Avoid local function (fix #1).

Avoid local function (fix #1).

This fixes an error about hidden vs. visible types in the type of a
local function. The error was introduced by switching to Agda 2.4.0. I
don't understand the error. It seems that the local function was
introduced to be able to use rewrite, so I rewrote the proof with subst
instead. This avoids the local function, and thus the error.

The ilc-agda project now type checks with current Agda. Tested versions:

agda/agda-stdlib@517d842ed43d0684e31b2e3e1f45ec9dda703761

agda/agda@b21f32a35f1a1b584538e3aaec3f62c9b4463aff (2_4_0)
agda/agda@70c8a575c46f6a568c7518150a1a64fcd03aa437

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Logical relation for erasure (Def. 3.8 and Lemma 3.9)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity
import Parametric.Change.Specification as Specification
import Parametric.Change.Type as ChangeType
import Parametric.Change.Value as ChangeValue
import Parametric.Change.Derive as Derive

module Parametric.Change.Implementation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (validity-structure : Validity.Structure ⟦_⟧Base)
    (specification-structure : Specification.Structure
       Const ⟦_⟧Base ⟦_⟧Const validity-structure)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
    (derive-const : Derive.Structure Const ΔBase)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base validity-structure
open Specification.Structure
  Const ⟦_⟧Base ⟦_⟧Const validity-structure specification-structure
open ChangeType.Structure Base ΔBase
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧
open Derive.Structure Const ΔBase derive-const

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality

record Structure : Set₁ where

  ----------------
  -- Parameters --
  ----------------

  field
    -- Extension point 1: Logical relation on base types.
    --
    -- In the paper, we assume that the logical relation is equality on base types
    -- (see Def. 3.8a). Here, we only require that plugins define what the logical
    -- relation is on base types, and provide proofs for the two extension points
    -- below.
    implements-base : ∀ ι {v : ⟦ ι ⟧Base} → Δ₍ ι ₎ v → ⟦ ΔBase ι ⟧Base → Set

    -- Extension point 2: Differences on base types are logically related.
    u⊟v≈u⊝v-base : ∀ ι {u v : ⟦ ι ⟧Base} →
      implements-base ι (u ⊟₍ ι ₎ v) (⟦diff-base⟧ ι u v)

    -- Extension point 3: Lemma 3.1 for base types.
    carry-over-base : ∀ {ι}
      {v : ⟦ ι ⟧Base}
      (Δv : Δ₍ ι ₎ v)
      {Δv′ : ⟦ ΔBase ι ⟧Base} (Δv≈Δv′ : implements-base ι Δv Δv′) →
        v ⊞₍ base ι ₎ Δv ≡ v ⟦⊕₍ base ι ₎⟧ Δv′

  ------------------------
  -- Logical relation ≈ --
  ------------------------

  infix 4 implements
  syntax implements τ u v = u ≈₍ τ ₎ v
  implements : ∀ τ {v} → Δ₍ τ ₎ v → ⟦ ΔType τ ⟧ → Set

  implements (base ι) Δf Δf′ = implements-base ι Δf Δf′
  implements (σ ⇒ τ) {f} Δf Δf′ =
    (w : ⟦ σ ⟧) (Δw : Δ₍ σ ₎ w)
    (Δw′ : ⟦ ΔType σ ⟧) (Δw≈Δw′ : implements σ {w} Δw Δw′) →
    implements τ {f w} (call-change {σ} {τ} Δf w Δw) (Δf′ w Δw′)

  infix 4 _≈_
  _≈_ : ∀ {τ v} → Δ₍ τ ₎ v → ⟦ ΔType τ ⟧ → Set
  _≈_ {τ} {v} = implements τ {v}

  data implements-env : ∀ Γ → {ρ : ⟦ Γ ⟧} (dρ : Δ₍ Γ ₎ ρ) → ⟦ mapContext ΔType Γ ⟧ → Set where
    ∅ : implements-env ∅ {∅} ∅ ∅
    _•_ : ∀ {τ Γ v ρ dv dρ v′ ρ′} →
      (dv≈v′ : implements τ {v} dv v′) →
      (dρ≈ρ′ : implements-env Γ {ρ} dρ ρ′) →
      implements-env (τ • Γ) {v • ρ} (dv • dρ) (v′ • ρ′)

  ----------------
  -- carry-over --
  ----------------

  -- This is lemma 3.10.
  carry-over : ∀ {τ}
    {v : ⟦ τ ⟧}
    (Δv : Δ₍ τ ₎ v)
    {Δv′ : ⟦ ΔType τ ⟧} (Δv≈Δv′ : Δv ≈₍ τ ₎ Δv′) →
      after₍ τ ₎ Δv ≡ before₍ τ ₎ Δv ⟦⊕₍ τ ₎⟧ Δv′

  u⊟v≈u⊝v : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    u ⊟₍ τ ₎ v ≈₍ τ ₎ u ⟦⊝₍ τ ₎⟧ v

  u⊟v≈u⊝v {base ι} {u} {v} = u⊟v≈u⊝v-base ι {u} {v}
  u⊟v≈u⊝v {σ ⇒ τ} {g} {f} w Δw Δw′ Δw≈Δw′ =
    subst
      (λ □ → (g □ ⊟₍ τ ₎ f (before₍ σ ₎ Δw)) ≈₍ τ ₎ g (before₍ σ ₎ Δw ⟦⊕₍ σ ₎⟧ Δw′) ⟦⊝₍ τ ₎⟧ f (before₍ σ ₎ Δw))
      (sym (carry-over {σ} Δw Δw≈Δw′))
      (u⊟v≈u⊝v {τ} {g (before₍ σ ₎ Δw ⟦⊕₍ σ ₎⟧ Δw′)} {f (before₍ σ ₎ Δw)})

  carry-over {base ι} Δv Δv≈Δv′ = carry-over-base Δv Δv≈Δv′
  carry-over {σ ⇒ τ} {f} Δf {Δf′} Δf≈Δf′ =
    ext (λ v →
      carry-over {τ} {f v} (call-change {σ} {τ} Δf v (nil₍ σ ₎ v))
        {Δf′ v (v ⟦⊝₍ σ ₎⟧ v)}
        (Δf≈Δf′ v (nil₍ σ ₎ v) (v ⟦⊝₍ σ ₎⟧ v) ( u⊟v≈u⊝v {σ} {v} {v})))

  -- A property relating `alternate` and the subcontext relation Γ≼ΔΓ
  ⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧) (dρ : ⟦ mapContext ΔType Γ ⟧) →
    ρ ≡ ⟦ Γ≼ΔΓ ⟧ (alternate ρ dρ)
  ⟦Γ≼ΔΓ⟧ ∅ ∅ = refl
  ⟦Γ≼ΔΓ⟧ (v • ρ) (dv • dρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ)

  -- A specialization of the soundness of weakening
  ⟦fit⟧ : ∀ {τ Γ} (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ⟦ mapContext ΔType Γ ⟧) →
    ⟦ t ⟧ ρ ≡ ⟦ fit t ⟧ (alternate ρ dρ)
  ⟦fit⟧ t ρ dρ =
    trans (cong ⟦ t ⟧ (⟦Γ≼ΔΓ⟧ ρ dρ)) (sym (weaken-sound t _))

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Logical relation for erasure (Def. 3.8 and Lemma 3.9)
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Change.Validity as Validity
import Parametric.Change.Specification as Specification
import Parametric.Change.Type as ChangeType
import Parametric.Change.Value as ChangeValue
import Parametric.Change.Derive as Derive

module Parametric.Change.Implementation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ΔBase : ChangeType.Structure Base)
    (validity-structure : Validity.Structure ⟦_⟧Base)
    (specification-structure : Specification.Structure
       Const ⟦_⟧Base ⟦_⟧Const validity-structure)
    (⟦apply-base⟧ : ChangeValue.ApplyStructure Const ⟦_⟧Base ΔBase)
    (⟦diff-base⟧ : ChangeValue.DiffStructure Const ⟦_⟧Base ΔBase)
    (derive-const : Derive.Structure Const ΔBase)
  where

open Type.Structure Base
open Term.Structure Base Const
open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open Validity.Structure ⟦_⟧Base validity-structure
open Specification.Structure
  Const ⟦_⟧Base ⟦_⟧Const validity-structure specification-structure
open ChangeType.Structure Base ΔBase
open ChangeValue.Structure Const ⟦_⟧Base ΔBase ⟦apply-base⟧ ⟦diff-base⟧
open Derive.Structure Const ΔBase derive-const

open import Base.Denotation.Notation

open import Relation.Binary.PropositionalEquality
open import Postulate.Extensionality

record Structure : Set₁ where

  ----------------
  -- Parameters --
  ----------------

  field
    -- Extension point 1: Logical relation on base types.
    --
    -- In the paper, we assume that the logical relation is equality on base types
    -- (see Def. 3.8a). Here, we only require that plugins define what the logical
    -- relation is on base types, and provide proofs for the two extension points
    -- below.
    implements-base : ∀ ι {v : ⟦ ι ⟧Base} → Δ₍ ι ₎ v → ⟦ ΔBase ι ⟧Base → Set

    -- Extension point 2: Differences on base types are logically related.
    u⊟v≈u⊝v-base : ∀ ι {u v : ⟦ ι ⟧Base} →
      implements-base ι (u ⊟₍ ι ₎ v) (⟦diff-base⟧ ι u v)

    -- Extension point 3: Lemma 3.1 for base types.
    carry-over-base : ∀ {ι}
      {v : ⟦ ι ⟧Base}
      (Δv : Δ₍ ι ₎ v)
      {Δv′ : ⟦ ΔBase ι ⟧Base} (Δv≈Δv′ : implements-base ι Δv Δv′) →
        v ⊞₍ base ι ₎ Δv ≡ v ⟦⊕₍ base ι ₎⟧ Δv′

  ------------------------
  -- Logical relation ≈ --
  ------------------------

  infix 4 implements
  syntax implements τ u v = u ≈₍ τ ₎ v
  implements : ∀ τ {v} → Δ₍ τ ₎ v → ⟦ ΔType τ ⟧ → Set

  implements (base ι) Δf Δf′ = implements-base ι Δf Δf′
  implements (σ ⇒ τ) {f} Δf Δf′ =
    (w : ⟦ σ ⟧) (Δw : Δ₍ σ ₎ w)
    (Δw′ : ⟦ ΔType σ ⟧) (Δw≈Δw′ : implements σ {w} Δw Δw′) →
    implements τ {f w} (call-change {σ} {τ} Δf w Δw) (Δf′ w Δw′)

  infix 4 _≈_
  _≈_ : ∀ {τ v} → Δ₍ τ ₎ v → ⟦ ΔType τ ⟧ → Set
  _≈_ {τ} {v} = implements τ {v}

  data implements-env : ∀ Γ → {ρ : ⟦ Γ ⟧} (dρ : Δ₍ Γ ₎ ρ) → ⟦ mapContext ΔType Γ ⟧ → Set where
    ∅ : implements-env ∅ {∅} ∅ ∅
    _•_ : ∀ {τ Γ v ρ dv dρ v′ ρ′} →
      (dv≈v′ : implements τ {v} dv v′) →
      (dρ≈ρ′ : implements-env Γ {ρ} dρ ρ′) →
      implements-env (τ • Γ) {v • ρ} (dv • dρ) (v′ • ρ′)

  ----------------
  -- carry-over --
  ----------------

  -- This is lemma 3.10.
  carry-over : ∀ {τ}
    {v : ⟦ τ ⟧}
    (Δv : Δ₍ τ ₎ v)
    {Δv′ : ⟦ ΔType τ ⟧} (Δv≈Δv′ : Δv ≈₍ τ ₎ Δv′) →
      after₍ τ ₎ Δv ≡ before₍ τ ₎ Δv ⟦⊕₍ τ ₎⟧ Δv′

  u⊟v≈u⊝v : ∀ {τ : Type} {u v : ⟦ τ ⟧} →
    u ⊟₍ τ ₎ v ≈₍ τ ₎ u ⟦⊝₍ τ ₎⟧ v

  u⊟v≈u⊝v {base ι} {u} {v} = u⊟v≈u⊝v-base ι {u} {v}
  u⊟v≈u⊝v {σ ⇒ τ} {g} {f} = result where
    result : (w : ⟦ σ ⟧) (Δw : Δ₍ σ ₎ w) →
      (Δw′ : ⟦ ΔType σ ⟧) → Δw ≈₍ σ ₎ Δw′ →
        (g (after₍ σ ₎ Δw) ⊟₍ τ ₎ f (before₍ σ ₎ Δw)) ≈₍ τ ₎ g (before₍ σ ₎ Δw ⟦⊕₍ σ ₎⟧ Δw′) ⟦⊝₍ τ ₎⟧ f (before₍ σ ₎ Δw)
    result w Δw Δw′ Δw≈Δw′
      rewrite carry-over {σ} Δw Δw≈Δw′ =
      u⊟v≈u⊝v {τ} {g (before₍ σ ₎ Δw ⟦⊕₍ σ ₎⟧ Δw′)} {f (before₍ σ ₎ Δw)}

  carry-over {base ι} Δv Δv≈Δv′ = carry-over-base Δv Δv≈Δv′
  carry-over {σ ⇒ τ} {f} Δf {Δf′} Δf≈Δf′ =
    ext (λ v →
      carry-over {τ} {f v} (call-change {σ} {τ} Δf v (nil₍ σ ₎ v))
        {Δf′ v (v ⟦⊝₍ σ ₎⟧ v)}
        (Δf≈Δf′ v (nil₍ σ ₎ v) (v ⟦⊝₍ σ ₎⟧ v) ( u⊟v≈u⊝v {σ} {v} {v})))

  -- A property relating `alternate` and the subcontext relation Γ≼ΔΓ
  ⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧) (dρ : ⟦ mapContext ΔType Γ ⟧) →
    ρ ≡ ⟦ Γ≼ΔΓ ⟧ (alternate ρ dρ)
  ⟦Γ≼ΔΓ⟧ ∅ ∅ = refl
  ⟦Γ≼ΔΓ⟧ (v • ρ) (dv • dρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ)

  -- A specialization of the soundness of weakening
  ⟦fit⟧ : ∀ {τ Γ} (t : Term Γ τ) (ρ : ⟦ Γ ⟧) (dρ : ⟦ mapContext ΔType Γ ⟧) →
    ⟦ t ⟧ ρ ≡ ⟦ fit t ⟧ (alternate ρ dρ)
  ⟦fit⟧ t ρ dρ =
    trans (cong ⟦ t ⟧ (⟦Γ≼ΔΓ⟧ ρ dρ)) (sym (weaken-sound t _))


Added tailS.

Added tailS.

Ignore-this: f8c3a1c756aff5692726c70d02433824

darcs-hash:20110730172619-3bd4e-8ac339efc4e78dfcdd270f2cd26b2497b39c4bf3.gz

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

module FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base

open import FOTC.Base.PropertiesATP

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

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

postulate tailS : ∀ {x xs} → Stream (x ∷ xs) → Stream xs
{-# ATP prove tailS #-}

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs
  {-# ATP definition P₁ #-}

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs
  {-# ATP definition P₂ #-}

  postulate
    helper₁ : ∀ {ws} → P₁ ws →
              ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ P₁ ws'))
  {-# ATP prove helper₁ #-}

  postulate
    helper₂ : ∀ {zs} → P₂ zs →
              ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ P₂ zs'))
  {-# ATP prove helper₂ #-}

------------------------------------------------------------------------------
-- Streams properties
------------------------------------------------------------------------------

module FOTC.Data.Stream.PropertiesATP where

open import FOTC.Base

open import FOTC.Base.PropertiesATP

open import FOTC.Data.Stream.Type

open import FOTC.Relation.Binary.Bisimilarity

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

≈→Stream : ∀ {xs ys} → xs ≈ ys → Stream xs ∧ Stream ys
≈→Stream {xs} {ys} xs≈ys = Stream-gfp₂ P₁ helper₁ (ys , xs≈ys)
                         , Stream-gfp₂ P₂ helper₂ (xs , xs≈ys)
  where
  P₁ : D → Set
  P₁ ws = ∃ λ zs → ws ≈ zs
  {-# ATP definition P₁ #-}

  P₂ : D → Set
  P₂ zs = ∃ λ ws → ws ≈ zs
  {-# ATP definition P₂ #-}

  postulate
    helper₁ : ∀ {ws} → P₁ ws →
              ∃ (λ w' → ∃ (λ ws' → ws ≡ w' ∷ ws' ∧ P₁ ws'))
  {-# ATP prove helper₁ #-}

  postulate
    helper₂ : ∀ {zs} → P₂ zs →
              ∃ (λ z' → ∃ (λ zs' → zs ≡ z' ∷ zs' ∧ P₂ zs'))
  {-# ATP prove helper₂ #-}


Fixed doc.

Fixed doc.

Ignore-this: 50b6461ccb5bd7b956e03cae0ed535da

darcs-hash:20110402162139-3bd4e-30f7fb20d91dca52965210f6fa7687e4370efcb5.gz

module Draft.FOTC.Data.Nat.AddTotality where

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

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → N i → P i → P (succ i)
    ih {i} Ni Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : (x : D) →
                N (zero + x) →
                (∀ {n} → N n → N (n + x) → N (succ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(p,x) → app₁(p,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
{-# ATP prove +-N₂ indN #-}

module Draft.FOTC.Data.Nat.AddTotality where

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

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

-- Interactive proof using the induction principle for natural numbers.
+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = indN P P0 ih Nm
  where
    P : D → Set
    P = λ i → N (i + n)

    P0 : P zero
    P0 = subst N (sym (+-0x n)) Nn

    ih : ∀ {i} → N i → P i → P (succ i)
    ih {i} Ni Pi = subst N (sym (+-Sx i n)) (sN Pi)

-- Combined proof using an instance of the induction principle.
indN-instance : (x : D) →
                N (zero + x) →
                (∀ {n} → N n → N (n + x) → N (succ n + x)) →
                ∀ {n} → N n → N (n + x)
indN-instance x = indN (λ i → N (i + x))

postulate
  +-N₁ : ∀ {m n} → N m → N n → N (m + n)
{-# ATP prove +-N₁ indN-instance #-}

-- Combined proof using the induction principle.

-- The translation is
-- ∀ p. app₁(p,zero) →
--      (∀ x. app₁(n,x) → app₁(n,x) → app₁(n,appFn(succ,x))) →   -- indN
--      (∀ x. app₁(n,x) → app₁(p,x))
----------------------------------------------------------------
-- ∀ x y. app₁(n,x) → app₁(n,y) → app₁(n,appFn(appFn(+,x),y))    -- +-N₂

postulate
  +-N₂ : ∀ {m n} → N m → N n → N (m + n)
-- The ATPs could not prove this postulate.
{-# ATP prove +-N₂ indN #-}


Cosmetic change.

Cosmetic change.

Ignore-this: 4cb7c429d7aabe9ac4be5cc0acb31552

darcs-hash:20120519135448-3bd4e-301a535b796fb0130b2cc51ef323c1879532647f.gz

------------------------------------------------------------------------------
-- Arithmetic properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module LTC-PCF.Data.Nat.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning
open import Common.Function

open import LTC-PCF.Base
open import LTC-PCF.Base.Properties
open import LTC-PCF.Data.Nat
open import LTC-PCF.Data.Nat.Rec
open import LTC-PCF.Data.Nat.Rec.EquationsI

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

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong refl = refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong refl = refl

∸-leftCong : ∀ {m n o} → m ≡ n → m ∸ o ≡ n ∸ o
∸-leftCong refl = refl

∸-rightCong : ∀ {m n o} → n ≡ o → m ∸ n ≡ m ∸ o
∸-rightCong refl = refl

*-leftCong : ∀ {m n o} → m ≡ n → m * o ≡ n * o
*-leftCong refl = refl

*-rightCong : ∀ {m n o} → n ≡ o → m * n ≡ m * o
*-rightCong refl = refl

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

+-0x : ∀ n → zero + n ≡ n
+-0x n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

+-Sx : ∀ m n → succ₁ m + n ≡ succ₁ (m + n)
+-Sx m n =
  rec (succ₁ m) n (lam (λ x → lam (λ y → succ₁ y)))
    ≡⟨ rec-S m n (lam (λ x → lam (λ y → succ₁ y))) ⟩
  (lam (λ x → lam (λ y → succ₁ y))) · m · (m + n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → succ₁ y)) m) ⟩
  (λ x → lam (λ y → succ₁ y)) m · (m + n)
    ≡⟨ refl ⟩
  lam succ₁ · (m + n)
    ≡⟨ beta succ₁ (m + n) ⟩
  succ₁ (m + n) ∎

∸-x0 : ∀ n → n ∸ zero ≡ n
∸-x0 n = rec zero n _ ≡⟨ rec-0 n ⟩
         n            ∎

∸-0S : ∀ {n} → N n → zero ∸ succ₁ n ≡ zero
∸-0S zN =
  rec (succ₁ zero) zero (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S zero zero (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · zero · (zero ∸ zero)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) zero) ⟩
  (λ x → lam (λ y → pred₁ y)) zero · (zero ∸ zero)
    ≡⟨ refl ⟩
  lam pred₁ · (zero ∸ zero)
    ≡⟨ beta pred₁ (zero ∸ zero) ⟩
  pred₁ (zero ∸ zero)
    ≡⟨ cong pred₁ (∸-x0 zero) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0S (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) zero (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) zero (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y))  (succ₁ n) · (zero ∸ (succ₁ n))
    ≡⟨ refl ⟩
  lam pred₁ · (zero ∸ (succ₁ n))
    ≡⟨ beta pred₁ (zero ∸ (succ₁ n)) ⟩
  pred₁ (zero ∸ (succ₁ n))
    ≡⟨ cong pred₁ (∸-0S Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero ∎

∸-0x : ∀ {n} → N n → zero ∸ n ≡ zero
∸-0x zN      = ∸-x0 zero
∸-0x (sN Nn) = ∸-0S Nn

∸-SS : ∀ {m n} → N m → N n → succ₁ m ∸ succ₁ n ≡ m ∸ n
∸-SS {m} _ zN =
  rec (succ₁ zero) (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S zero (succ₁ m) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y))  · zero · (succ₁ m ∸ zero)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) zero) ⟩
  (λ x → lam (λ y → pred₁ y)) zero · (succ₁ m ∸ zero)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ m ∸ zero)
    ≡⟨ beta pred₁ (succ₁ m ∸ zero) ⟩
  pred₁ (succ₁ m ∸ zero)
    ≡⟨ cong pred₁ (∸-x0 (succ₁ m)) ⟩
  pred₁ (succ₁ m)
    ≡⟨ pred-S m ⟩
  m
    ≡⟨ sym $ ∸-x0 m ⟩
  m ∸ zero ∎

∸-SS zN (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ zero) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) (succ₁ zero) (lam (λ x → lam (λ y → pred₁ y)))  ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y)) (succ₁ n) · (succ₁ zero ∸ succ₁ n)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ zero ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ zero ∸ succ₁ n) ⟩
  pred₁ (succ₁ zero ∸ succ₁ n)
    ≡⟨ cong pred₁ (∸-SS zN Nn) ⟩
  pred₁ (zero ∸ n)
    ≡⟨ cong pred₁ (∸-0x Nn) ⟩
  pred₁ zero
    ≡⟨ pred-0 ⟩
  zero
    ≡⟨ sym $ ∸-0S Nn ⟩
  zero ∸ succ₁ n ∎

∸-SS (sN {m} Nm) (sN {n} Nn) =
  rec (succ₁ (succ₁ n)) (succ₁ (succ₁ m)) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ rec-S (succ₁ n) (succ₁ (succ₁ m)) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  lam (λ x → lam (λ y → pred₁ y)) · (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ ·-leftCong (beta (λ x → lam (λ y → pred₁ y)) (succ₁ n)) ⟩
  (λ x → lam (λ y → pred₁ y)) (succ₁ n) · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ refl ⟩
  lam pred₁ · (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ beta pred₁ (succ₁ (succ₁ m) ∸ succ₁ n) ⟩
  pred₁ (succ₁ (succ₁ m) ∸ succ₁ n)
    ≡⟨ cong pred₁ (∸-SS (sN Nm) Nn) ⟩
  pred₁ (succ₁ m ∸ n)
    ≡⟨ sym $ beta pred₁ (succ₁ m ∸ n) ⟩
  lam pred₁ · (succ₁ m ∸ n)
    ≡⟨ refl ⟩
  (λ x → lam (λ y → pred₁ y)) n · (succ₁ m ∸ n)
    ≡⟨ ·-leftCong (sym $ beta (λ x → lam (λ y → pred₁ y)) n) ⟩
  (lam (λ x → lam (λ y → pred₁ y))) · n · (succ₁ m ∸ n)
    ≡⟨ sym $ rec-S n (succ₁ m) (lam (λ x → lam (λ y → pred₁ y))) ⟩
  rec (succ₁ n) (succ₁ m) (lam (λ x → lam (λ y → pred₁ y)))
    ≡⟨ refl ⟩
  succ₁ m ∸ succ₁ n ∎

*-0x : ∀ n → zero * n ≡ zero
*-0x n = rec zero zero (lam (λ _ → lam (λ y → n + y))) ≡⟨ rec-0 zero ⟩
         zero                                          ∎

*-Sx : ∀ m n → succ₁ m * n ≡ n + m * n
*-Sx m n =
  rec (succ₁ m) zero (lam (λ _ → lam (λ y → n + y)))
    ≡⟨ rec-S m zero (lam (λ _ → lam (λ y → n + y))) ⟩
  (lam (λ _ → lam (λ y → n + y))) · m · (m * n)
    ≡⟨ ·-leftCong (beta (λ _ → lam (λ y → n + y)) m) ⟩
  (λ _ → lam (λ y → n + y)) m · (m * n)
    ≡⟨ refl ⟩
  lam (λ y → n + y) · (m * n)
    ≡⟨ beta (λ y → n + y) (m * n) ⟩
  (λ y → n + y) (m * n)
    ≡⟨ refl ⟩
  n + (m * n) ∎

∸-N : ∀ {m n} → N m → N n → N (m ∸ n)
∸-N {m} Nm       zN     = subst N (sym $ ∸-x0 m) Nm
∸-N     zN      (sN Nn) = subst N (sym $ ∸-0S Nn) zN
∸-N     (sN Nm) (sN Nn) = subst N (sym $ ∸-SS Nm Nn) (∸-N Nm Nn)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity = +-0x

+-rightIdentity : ∀ {n} → N n → n + zero ≡ n
+-rightIdentity zN          = +-leftIdentity zero
+-rightIdentity (sN {n} Nn) =
  trans (+-Sx n zero)
        (subst (λ t → succ₁ (n + zero) ≡ succ₁ t) (+-rightIdentity Nn) refl)

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {n = n} zN          Nn = subst N (sym $ +-leftIdentity n) Nn
+-N {n = n} (sN {m} Nm) Nn = subst N (sym $ +-Sx m n) (sN (+-N Nm Nn))

+-assoc : ∀ {m} → N m →  ∀ n o → m + n + o ≡ m + (n + o)
+-assoc zN n o =
  zero + n + o   ≡⟨ subst (λ t → zero + n + o ≡ t + o) (+-leftIdentity n) refl ⟩
  n + o          ≡⟨ sym $ +-leftIdentity (n + o) ⟩
  zero + (n + o) ∎

+-assoc (sN {m} Nm) n o =
  succ₁ m + n + o
    ≡⟨ subst (λ t → succ₁ m + n + o ≡ t + o) (+-Sx m n) refl ⟩
  succ₁ (m + n) + o
    ≡⟨ +-Sx (m + n) o ⟩
  succ₁ (m + n + o)
    ≡⟨ subst (λ t → succ₁ (m + n + o) ≡ succ₁ t) (+-assoc Nm n o) refl ⟩
  succ₁ (m + (n + o))
    ≡⟨ sym $ +-Sx m (n + o) ⟩
  succ₁ m + (n + o) ∎

x+Sy≡S[x+y] : ∀ {m} → N m → ∀ n → m + succ₁ n ≡ succ₁ (m + n)
x+Sy≡S[x+y] zN n =
  zero + succ₁ n ≡⟨ +-0x (succ₁ n) ⟩
  succ₁ n ≡⟨ subst (λ t → succ₁ n ≡ succ₁ t) (sym $ +-leftIdentity n) refl ⟩
  succ₁ (zero + n) ∎

x+Sy≡S[x+y] (sN {m} Nm) n =
  succ₁ m + succ₁ n
    ≡⟨ +-Sx m (succ₁ n) ⟩
  succ₁ (m + succ₁ n)
    ≡⟨ subst (λ t → succ₁ (m + succ₁ n) ≡ succ₁ t) (x+Sy≡S[x+y] Nm n) refl ⟩
  succ₁ (succ₁ (m + n))
    ≡⟨ subst (λ t → succ₁ (succ₁ (m + n)) ≡ succ₁ t) (sym $ +-Sx m n) refl ⟩
  succ₁ (succ₁ m + n) ∎

[x+y]∸[x+z]≡y∸z : ∀ {m n o} → N m → N n → N o → (m + n) ∸ (m + o) ≡ n ∸ o
[x+y]∸[x+z]≡y∸z {n = n} {o} zN _ _ =
  (zero + n) ∸ (zero + o)
    ≡⟨ subst (λ t → (zero + n) ∸ (zero + o) ≡ t ∸ (zero + o)) (+-0x n) refl ⟩
    n ∸ (zero + o)
      ≡⟨ subst (λ t → n ∸ (zero + o) ≡ n ∸ t) (+-0x o) refl ⟩
    n ∸ o ∎

[x+y]∸[x+z]≡y∸z {n = n} {o} (sN {m} Nm) Nn No =
  (succ₁ m + n) ∸ (succ₁ m + o)
    ≡⟨ subst (λ t → succ₁ m + n ∸ (succ₁ m + o) ≡ t ∸ (succ₁ m + o))
             (+-Sx m n)
             refl
    ⟩
  succ₁ (m + n) ∸ (succ₁ m + o)
    ≡⟨ subst (λ t → succ₁ (m + n) ∸ (succ₁ m + o) ≡ succ₁ (m + n) ∸ t)
             (+-Sx m o)
             refl
    ⟩
  succ₁ (m + n) ∸ succ₁ (m + o)
    ≡⟨ ∸-SS (+-N Nm Nn) (+-N Nm No) ⟩
  (m + n) ∸ (m + o)
    ≡⟨ [x+y]∸[x+z]≡y∸z Nm Nn No ⟩
  n ∸ o ∎

+-comm : ∀ {m n} → N m → N n → m + n ≡ n + m
+-comm {n = n} zN Nn =
  zero + n ≡⟨ +-leftIdentity n ⟩
  n        ≡⟨ sym $ +-rightIdentity Nn ⟩
  n + zero ∎

+-comm {n = n} (sN {m} Nm) Nn =
  succ₁ m + n   ≡⟨ +-Sx m n ⟩
  succ₁ (m + n) ≡⟨ cong succ₁ (+-comm Nm Nn) ⟩
  succ₁ (n + m) ≡⟨ sym $ x+Sy≡S[x+y] Nn m ⟩
  n + succ₁ m   ∎

*-leftZero : ∀ n → zero * n ≡ zero
*-leftZero = *-0x

*-N : ∀ {m n} → N m → N n → N (m * n)
*-N {n = n} zN          _  = subst N (sym $ *-leftZero n) zN
*-N {n = n} (sN {m} Nm) Nn = subst N (sym $ *-Sx m n) (+-N Nn (*-N Nm Nn))

*-rightZero : ∀ {n} → N n → n * zero ≡ zero
*-rightZero zN          = *-leftZero zero
*-rightZero (sN {n} Nn) =
  trans (*-Sx n zero)
        (trans (+-leftIdentity (n * zero)) (*-rightZero Nn))

*-leftIdentity : ∀ {n} → N n → succ₁ zero * n ≡ n
*-leftIdentity {n} Nn =
  succ₁ zero * n ≡⟨ *-Sx zero n ⟩
  n + zero * n   ≡⟨ subst (λ t → n + zero * n ≡ n + t) (*-leftZero n) refl ⟩
  n + zero       ≡⟨ +-rightIdentity Nn ⟩
  n              ∎

x*Sy≡x+xy : ∀ {m n} → N m → N n → m * succ₁ n ≡ m + m * n
x*Sy≡x+xy {n = n} zN _ = sym
  ( zero + zero * n
      ≡⟨ subst (λ t → zero + zero * n ≡ zero + t) (*-leftZero n) refl ⟩
    zero + zero
      ≡⟨ +-leftIdentity zero ⟩
    zero
      ≡⟨ sym $ *-leftZero (succ₁ n) ⟩
    zero * succ₁ n ∎
  )

x*Sy≡x+xy {n = n} (sN {m} Nm) Nn =
  succ₁ m * succ₁ n
    ≡⟨ *-Sx m (succ₁ n) ⟩
  succ₁ n + m * succ₁ n
    ≡⟨ subst (λ t → succ₁ n + m * succ₁ n ≡ succ₁ n + t)
             (x*Sy≡x+xy Nm Nn)
             refl
    ⟩
  succ₁ n + (m + m * n)
    ≡⟨ +-Sx n (m + m * n) ⟩
  succ₁ (n + (m + m * n))
    ≡⟨ subst (λ t → succ₁ (n + (m + m * n)) ≡ succ₁ t)
             (sym $ +-assoc Nn m (m * n))
             refl
    ⟩
  succ₁ (n + m + m * n)
    ≡⟨ subst (λ t → succ₁ (n + m + m * n) ≡ succ₁ (t + m * n))
             (+-comm Nn Nm)
             refl
    ⟩
  succ₁ (m + n + m * n)
    ≡⟨ subst (λ t → succ₁ (m + n + m * n) ≡ succ₁ t)
             (+-assoc Nm n (m * n))
             refl
    ⟩
  succ₁ (m + (n + m * n))
    ≡⟨ sym $ +-Sx m (n + m * n) ⟩
  succ₁ m + (n + m * n)
    ≡⟨ subst (λ t → succ₁ m + (n + m * n) ≡ succ₁ m + t)
             (sym $ *-Sx m n)
             refl
    ⟩
  succ₁ m + succ₁ m * n ∎

*-comm : ∀ {m n} → N m → N n → m * n ≡ n * m
*-comm {n = n} zN Nn          = trans (*-leftZero n) (sym $ *-rightZero Nn)
*-comm {n = n} (sN {m} Nm) Nn =
  succ₁ m * n  ≡⟨ *-Sx m n ⟩
  n + m * n    ≡⟨ subst (λ t → n + m * n ≡ n + t) (*-comm Nm Nn) refl ⟩
  n + n * m    ≡⟨ sym $ x*Sy≡x+xy Nn Nm ⟩
  n * succ₁ m  ∎

*∸-leftDistributive : ∀ {m n o} → N m → N n → N o → (m ∸ n) * o ≡ m * o ∸ n * o
*∸-leftDistributive {m} {o = o} _ zN _ =
  (m ∸ zero) * o   ≡⟨ subst (λ t → (m ∸ zero) * o ≡ t * o) (∸-x0 m) refl ⟩
  m * o            ≡⟨ sym $ ∸-x0 (m * o) ⟩
  m * o ∸ zero     ≡⟨ subst (λ t → m * o ∸ zero ≡ m * o ∸ t) (sym $ *-0x o) refl ⟩
  m * o ∸ zero * o ∎

*∸-leftDistributive {o = o} zN (sN {n} Nn) No =
  (zero ∸ succ₁ n) * o
    ≡⟨ subst (λ t → (zero ∸ succ₁ n) * o ≡ t * o) (∸-0S Nn) refl ⟩
  zero * o
    ≡⟨ *-0x o ⟩
  zero
    ≡⟨ sym $ ∸-0x (*-N (sN Nn) No) ⟩
  zero ∸ succ₁ n * o
    ≡⟨ subst (λ t → zero ∸ succ₁ n * o ≡ t ∸ succ₁ n * o)
             (sym $ *-0x o)
             refl
    ⟩
  zero * o ∸ succ₁ n * o ∎

*∸-leftDistributive (sN {m} Nm) (sN {n} Nn) zN =
  (succ₁ m ∸ succ₁ n) * zero
    ≡⟨ *-comm (∸-N (sN Nm) (sN Nn)) zN ⟩
  zero * (succ₁ m ∸ succ₁ n)
    ≡⟨ *-0x (succ₁ m ∸ succ₁ n) ⟩
  zero
    ≡⟨ sym $ ∸-0x (*-N (sN Nn) zN) ⟩
  zero ∸ succ₁ n * zero
    ≡⟨ subst (λ t → zero ∸ succ₁ n * zero ≡ t ∸ succ₁ n * zero)
             (sym $ *-0x (succ₁ m))
             refl
    ⟩
  zero * succ₁ m ∸ succ₁ n * zero
    ≡⟨ subst (λ t → zero * succ₁ m ∸ succ₁ n * zero ≡ t ∸ succ₁ n * zero)
             (*-comm zN (sN Nm))
             refl
    ⟩
  succ₁ m * zero ∸ succ₁ n * zero ∎

*∸-leftDistributive (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  (succ₁ m ∸ succ₁ n) * succ₁ o
    ≡⟨ subst (λ t → (succ₁ m ∸ succ₁ n) * succ₁ o ≡ t * succ₁ o)
             (∸-SS Nm Nn)
             refl
    ⟩
  (m ∸ n) * succ₁ o
    ≡⟨ *∸-leftDistributive Nm Nn (sN No) ⟩
  m * succ₁ o ∸ n * succ₁ o
    ≡⟨ sym $ [x+y]∸[x+z]≡y∸z (sN No) (*-N Nm (sN No)) (*-N Nn (sN No)) ⟩
  (succ₁ o + m * succ₁ o) ∸ (succ₁ o + n * succ₁ o)
    ≡⟨ subst (λ t → (succ₁ o + m * succ₁ o) ∸ (succ₁ o + n * succ₁ o) ≡
                    t ∸ (succ₁ o + n * succ₁ o))
             (sym $ *-Sx m (succ₁ o))
             refl
    ⟩
  (succ₁ m * succ₁ o) ∸ (succ₁ o + n * succ₁ o)
    ≡⟨ subst (λ t → (succ₁ m * succ₁ o) ∸ (succ₁ o + n * succ₁ o) ≡
                    (succ₁ m * succ₁ o) ∸ t)
             (sym $ *-Sx n (succ₁ o))
             refl
    ⟩
  (succ₁ m * succ₁ o) ∸ (succ₁ n * succ₁ o) ∎

*+-leftDistributive : ∀ {m n o} → N m → N n → N o → (m + n) * o ≡ m * o + n * o
*+-leftDistributive {m} {n} Nm Nn zN =
  (m + n) * zero       ≡⟨ *-comm (+-N Nm Nn) zN ⟩
  zero * (m + n)       ≡⟨ *-0x (m + n) ⟩
  zero                 ≡⟨ sym $ *-0x m ⟩
  zero * m             ≡⟨ *-comm zN Nm ⟩
  m * zero             ≡⟨ sym $ +-rightIdentity (*-N Nm zN) ⟩
  m * zero + zero      ≡⟨ subst (λ t → m * zero + zero ≡ m * zero + t)
                                (trans (sym $ *-0x n) (*-comm zN Nn))
                                  refl
                       ⟩
  m * zero + n * zero  ∎

*+-leftDistributive {n = n} zN Nn (sN {o} No) =
  (zero + n) * succ₁ o
    ≡⟨ subst (λ t → (zero + n) * succ₁ o ≡ t * succ₁ o)
             (+-leftIdentity n)
             refl
    ⟩
  n * succ₁ o
    ≡⟨ sym $ +-leftIdentity (n * succ₁ o) ⟩
  zero + n * succ₁ o
    ≡⟨ subst (λ t → zero + n * succ₁ o ≡ t +  n * succ₁ o)
             (sym $ *-0x (succ₁ o))
             refl
    ⟩
  zero * succ₁ o + n * succ₁ o ∎

*+-leftDistributive (sN {m} Nm) zN (sN {o} No) =
  (succ₁ m + zero) * succ₁ o
    ≡⟨ subst (λ t → (succ₁ m + zero) * succ₁ o ≡ t * succ₁ o)
             (+-rightIdentity (sN Nm))
             refl
    ⟩
  succ₁ m * succ₁ o
    ≡⟨ sym $ +-rightIdentity (*-N (sN Nm) (sN No)) ⟩
  succ₁ m * succ₁ o + zero
    ≡⟨ subst (λ t → succ₁ m * succ₁ o + zero ≡ succ₁ m * succ₁ o + t)
             (sym $ *-leftZero (succ₁ o))
             refl
    ⟩
    succ₁ m * succ₁ o + zero * succ₁ o ∎

*+-leftDistributive (sN {m} Nm) (sN {n} Nn) (sN {o} No) =
  (succ₁ m + succ₁ n) * succ₁ o
    ≡⟨ subst (λ t → (succ₁ m + succ₁ n) * succ₁ o ≡ t * succ₁ o)
             (+-Sx m (succ₁ n))
             refl
    ⟩
  succ₁ (m + succ₁ n) * succ₁ o
    ≡⟨ *-Sx (m + succ₁ n) (succ₁ o) ⟩
  succ₁ o + (m + succ₁ n) * succ₁ o
    ≡⟨ subst (λ t → succ₁ o + (m + succ₁ n) * succ₁ o ≡ succ₁ o + t)
             (*+-leftDistributive Nm (sN Nn) (sN No))
             refl
    ⟩
  succ₁ o + (m * succ₁ o + succ₁ n * succ₁ o)
    ≡⟨ sym $ +-assoc (sN No) (m * succ₁ o) (succ₁ n * succ₁ o) ⟩
  succ₁ o + m * succ₁ o + succ₁ n * succ₁ o
    ≡⟨ subst (λ t → succ₁ o + m * succ₁ o + succ₁ n * succ₁ o ≡
                    t + succ₁ n * succ₁ o)
             (sym $ *-Sx m (succ₁ o))
             refl
    ⟩
  succ₁ m * succ₁ o + succ₁ n * succ₁ o ∎


Defined uncurry.

Defined uncurry.

-----------------------------------------------------------------------
-- This file defines DC₂(Sets) and its SMC structure.              --
-----------------------------------------------------------------------
module DC2Sets where

open import prelude

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (U → X → Set))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , α) (V , Y , β) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , α)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , α)}{(V , Y , β)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , α}{V , Y , β}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , α}{V , Y , β}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , α}{V , Y , β}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , α}
         {V , Y , β}
         {W , Z , γ}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , α}{V , Y , β}{W , Z , γ}{S , T , ι}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _}{V , Y , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _}{V , Y , _}{f , F , _} = refl , refl

-----------------------------------------------------------------------
-- DC₂(Sets) is a SMC                                              --
-----------------------------------------------------------------------

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , α) ⊗ₒ (V , Y , β) = ((U × V) , (X × Y) , α ⊗ᵣ β)

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

-- The unit for tensor:
ι : ⊤ → ⊤ → Set
ι triv triv = ⊤

I : Obj
I = (⊤ , ⊤ , ι)

J : Obj
J = (⊤ , ⊤ , (λ x y → ⊥))

-- The left-unitor:
λ⊗-p : ∀{U X α}{u : Σ ⊤ (λ x → U)} {y : X} → (ι ⊗ᵣ α) u (triv , y) → α (snd u) y
λ⊗-p {U}{X}{α}{(triv , u)}{x} = snd

λ⊗ : ∀{A : Obj} → Hom (I ⊗ₒ A) A
λ⊗ {(U , X , α)} = snd , (λ _ x → triv , x) , λ⊗-p

λ⊗-inv : ∀{A : Obj} → Hom A (I ⊗ₒ A)
λ⊗-inv {(U , X , α)} = (λ u → triv , u) , (λ _ r → snd r) , λ⊗-inv-p
 where
  λ⊗-inv-p : ∀{U X α}{u : U} {y : Σ ⊤ (λ x → X)} → α u (snd y) → (ι ⊗ᵣ α) (triv , u) y
  λ⊗-inv-p {U}{X}{α}{u}{triv , x} p = triv , p

-- The right-unitor:
ρ⊗ : ∀{A : Obj} → Hom (A ⊗ₒ I) A
ρ⊗ {(U , X , α)} = fst , (λ r x → x , triv) , ρ⊗-p
 where
  ρ⊗-p : ∀{U X α}{u : Σ U (λ x → ⊤)} {y : X} → (α ⊗ᵣ ι) u (y , triv) → α (fst u) y
  ρ⊗-p {U}{X}{α}{(u , _)}{x} (p , _) = p

ρ⊗-inv : ∀{A : Obj} → Hom A (A ⊗ₒ I)
ρ⊗-inv {(U , X , α)} = (λ u → u , triv) , (λ u r → fst r) , ρ⊗-p-inv
 where
  ρ⊗-p-inv : ∀{U X α}{u : U} {y : Σ X (λ x → ⊤)} → α u (fst y) → (α ⊗ᵣ ι) (u , triv) y
  ρ⊗-p-inv {U}{X}{α}{u}{x , triv} p = p , triv

-- Symmetry:
β⊗ : ∀{A B : Obj} → Hom (A ⊗ₒ B) (B ⊗ₒ A)
β⊗ {(U , X , α)}{(V , Y , β)} = twist-× , (λ r₁ r₂ → twist-× r₂) , β⊗-p
 where
   β⊗-p : ∀{U V Y X α β}{u : Σ U (λ x → V)} {y : Σ Y (λ x → X)} → (α ⊗ᵣ β) u (twist-× y) → (β ⊗ᵣ α) (twist-× u) y
   β⊗-p {U}{V}{Y}{X}{α}{β}{u , v}{y , x} = twist-×

-- The associator:
Fα-inv : ∀{ℓ}{U V W X Y Z : Set ℓ} → (U × (V × W)) → ((X × Y) × Z) → (X × (Y × Z))
Fα-inv (u , (v , w)) ((x , y) , z) = x , y , z

α⊗-inv : ∀{A B C : Obj} → Hom (A ⊗ₒ (B ⊗ₒ C)) ((A ⊗ₒ B) ⊗ₒ C)
α⊗-inv {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = rl-assoc-× , Fα-inv , α-inv-cond
 where
   α-inv-cond : {u : Σ U (λ x → Σ V (λ x₁ → W))}{y : Σ (Σ X (λ x → Y)) (λ x → Z)}
     → (α ⊗ᵣ (β ⊗ᵣ γ)) u (Fα-inv u y)
     → ((α ⊗ᵣ β) ⊗ᵣ γ) (rl-assoc-× u) y
   α-inv-cond {u , (v , w)}{(x , y) , z} (p₁ , (p₂ , p₃)) = (p₁ , p₂) , p₃

Fα : ∀{V W X Y U Z : Set} → ((U × V) × W) → (X × (Y × Z)) → ((X × Y) × Z)
Fα {V}{W}{X}{Y}{U}{Z} ((u , v) , w) (x , (y , z)) = (x , y) , z

α⊗ : ∀{A B C : Obj} → Hom ((A ⊗ₒ B) ⊗ₒ C) (A ⊗ₒ (B ⊗ₒ C))
α⊗ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = (lr-assoc-× , Fα , α-cond)
 where
  α-cond : {u : Σ (Σ U (λ x → V)) (λ x → W)}
      {y : Σ X (λ x → Σ Y (λ x₁ → Z))} →
      ((α ⊗ᵣ β) ⊗ᵣ γ) u (Fα u y) → (α ⊗ᵣ (β ⊗ᵣ γ)) (lr-assoc-× u) y
  α-cond {(u , v) , w}{x , (y , z)} ((p₁ , p₂) , p₃) = p₁ , p₂ , p₃

α⊗-id₁ : ∀{A B C} → (α⊗ {A}{B}{C}) ○ α⊗-inv ≡h id
α⊗-id₁ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ (Σ U (λ x → V)) (λ x → W)} → rl-assoc-× (lr-assoc-× a) ≡ a
   aux {(u , v) , w} = refl

   aux' : {a : Σ (Σ U (λ x → V)) (λ x → W)} → (λ z → Fα {V}{W}{X}{Y}{U}{Z} a (Fα-inv (lr-assoc-× a) z)) ≡ (λ y → y)
   aux' {(u , v), w} = ext-set aux''
    where
      aux'' : {a : Σ (Σ X (λ x → Y)) (λ x → Z)} → Fα ((u , v) , w) (Fα-inv (u , v , w) a) ≡ a
      aux'' {(x , y) , z} = refl

α⊗-id₂ : ∀{A B C} → (α⊗-inv {A}{B}{C}) ○ α⊗ ≡h id
α⊗-id₂ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ U (λ x → Σ V (λ x₁ → W))} → lr-assoc-× (rl-assoc-× a) ≡ a
   aux {u , (v , w)} = refl
   aux' : {a : Σ U (λ x → Σ V (λ x₁ → W))} → (λ z → Fα-inv {_}{U}{V}{W}{X}{Y}{Z} a (Fα (rl-assoc-× a) z)) ≡ (λ y → y)
   aux' {u , (v , w)} = ext-set aux''
    where
      aux'' : {a : Σ X (λ x → Σ Y (λ x₁ → Z))} → Fα-inv (u , v , w) (Fα ((u , v) , w) a) ≡ a
      aux'' {x , (y , z)} = refl

-- Internal hom:
⊸-cond : ∀{U V X Y : Set}{α : U → X → Set}{β : V → Y → Set}
  → Σ (U → V) (λ x → U → Y → X)
  → Σ U (λ x → Y)
  → Set
⊸-cond {α = α}{β} (f , F) (u , y) = α u (F u y) → β (f u) y

_⊸ₒ_ : Obj → Obj → Obj
(U , X , α) ⊸ₒ (V , Y , β) = ((U → V) × (U → Y → X)) , ((U × Y) , ⊸-cond {α = α}{β})

_⊸ₐ_ : {A B C D : Obj} → Hom C A → Hom B D → Hom (A ⊸ₒ B) (C ⊸ₒ D)
_⊸ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) =
  h , H , cond
 where
  h : Σ (U → V) (λ x → U → Y → X) → Σ (W → S) (λ x → W → T → Z)
  h (i , I) = (λ w → g (i (f w))) , (λ w t → F w (I (f w) (G (i (f w)) t)))
  H : Σ (U → V) (λ x → U → Y → X) → Σ W (λ x → T) → Σ U (λ x → Y)
  H (i , I) (w , t) = f w , G (i (f w)) t
  cond : {u : Σ (U → V) (λ x → U → Y → X)} {y : Σ W (λ x → T)} → ⊸-cond {α = α}{β} u (H u y) → ⊸-cond {α = γ}{δ} (h u) y
  cond {i , I}{w , y} p₃ p₄ = p₂ (p₃ (p₁ p₄))

cur : {A B C : Obj}
  → Hom (A ⊗ₒ B) C
  → Hom A (B ⊸ₒ C)
cur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ u → (λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) , (λ u r → fst (F (u , (fst r)) (snd r))) , cond
 where
   cond : {u : U} {y : Σ V (λ x → Z)}
     → α u (fst (F (u , fst y) (snd y)))
     → ⊸-cond {α = β}{γ} ((λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) y
   cond {u}{v , z} p₂ p₃ with (p₁ {u , v}{z})
   ... | p₄ with F (u , v) z
   ... | (x , y) = p₄ (p₂ , p₃)

cur-≡h : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C}
  → f₁ ≡h f₂
  → cur f₁ ≡h cur f₂
cur-≡h {U , X , α}{V , Y , β}{W , Z , γ}
       {f₁ , F₁ , p₁}{f₂ , F₂ , p₂} (p₃ , p₄)
       rewrite p₃ | p₄ = refl , refl

cur-cong : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C} → f₁ ≡h f₂ → cur f₁ ≡h cur f₂
cur-cong {(U , X , α)} {(V , Y , β)} {(W , Z , γ)}{f₁ , F₁ , _}{f₂ , F₂ , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

uncur : {A B C : Obj}
  → Hom A (B ⊸ₒ C)
  → Hom (A ⊗ₒ B) C
uncur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = h , (H , cond)
  where
  h : Σ U (λ x → V) → W
  h (u , v) with f u
  ... | i , I = i v
  H : Σ U (λ x → V) → Z → Σ X (λ x → Y)
  H (u , v) z with f u
  ... | i , I = F u (v , z) , I v z
  cond : {u : Σ U (λ x → V)} {z : Z} → (α ⊗ᵣ β) u (H u z) → γ (h u) z
  cond {u , v}{z} r with (p₁ {u}{v , z})
  ... | p₄ with f u
  ... | i , I with r
  ... | p₂ , p₃ = p₄ p₂ p₃

{-
cur-uncur-bij₁ : ∀{A B C}{f : Hom (A ⊗ₒ B) C}
  → uncur (cur f) ≡h f
cur-uncur-bij₁ {U , X , α}{V , Y , β}{W , Z , γ}{f , F , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : Σ U (λ x → V)} → f (fst a , snd a) ≡ f a
   aux₁ {u , v} = refl

   aux₂ : {a : Z} → ((λ v → fst (F a) v) , (λ u → snd (F a) u)) ≡ F a
   aux₂ {z} with F z
   ... | j₁ , j₂ = refl

cur-uncur-bij₂ : ∀{A B C}{g : Hom A (B ⊸ₒ C)}
  → cur (uncur g) ≡h g
cur-uncur-bij₂ {U , X , α}{V , Y , β}{W , Z , γ}{g , G , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : U} → ((λ v → fst (g a) v) , (λ z → snd (g a) z)) ≡ g a
   aux₁ {u} with g u
   ... | (j₁ , j₂) = refl

   aux₂ : {a : Σ V (λ x → Z)} → G (fst a , snd a) ≡ G a
   aux₂ {v , z} = refl

-- The of-course exponential:
!ₒ-cond : ∀{U X : Set}
  → (U → X → Set)
  → U
  → (U → X *)
  → Set
!ₒ-cond α u f = all-pred (α u) (f u)

!ₒ : Obj → Obj
!ₒ (U , X , α) = U , (U → X *) , !ₒ-cond α

!-cta : {V Y U X : Set}
  → (Y → X)
  → (U → V)
  → (V → Y *)
  → (U → X *)
!-cta F f g = λ u → list-funct F (g (f u))

!ₐ-cond : ∀{U V Y X : Set}{F : Y → X}{f : U → V}
  → (α : U → X → Set)
  → (β : V → Y → Set)
  → (p : {u : U} {y : Y} → α u (F y) → β (f u) y)
    {u : U}{l : Y *}
  → all-pred (α u) (list-funct F l)
  → all-pred (β (f u)) l
!ₐ-cond _ _ _ {l = []} _ = triv
!ₐ-cond α β p {u}{x :: xs} (p' , p'') = p p' , !ₐ-cond α β p p''

!ₐ : {A B : Obj} → Hom A B → Hom (!ₒ A) (!ₒ B)
!ₐ {U , X , α}{V , Y , β} (f , F , p) = f , !-cta F f , !ₐ-cond α β p

-- Of-course is a comonad:
ε : ∀{A} → Hom (!ₒ A) A
ε {U , X , α} = id-set , (λ x y → [ x ]) , fst

δ-cta : {U X : Set} → (U → 𝕃 (U → 𝕃 X)) → U → 𝕃 X
δ-cta g u = foldr (λ f rest → (f u) ++ rest) [] (g u)

δ : ∀{A} → Hom (!ₒ A) (!ₒ (!ₒ A))
δ {U , X , α} = id-set , δ-cta , δ-cond
  where
   δ-cond : {u : U} {l : 𝕃 (U → 𝕃 X)}
     → all-pred (α u) (foldr (λ f → _++_ (f u)) [] l)
     → all-pred (λ f
     → all-pred (α u) (f u)) l
   δ-cond {l = []} _ = triv
   δ-cond {u}{l = x :: l'} p with
     all-pred-append {X}{α u}
                     {x u}
                     {foldr (λ f → _++_ (f u)) [] l'}
                     ∧-unit ∧-assoc
   ... | p' rewrite p' = fst p , δ-cond {u} {l'} (snd p)

-- These diagrams can be found on page 22 of the report.
comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (!ₐ (δ {A})) ≡h (δ {A}) ○ (δ { !ₒ A})
comonand-diag₁ {U , X , α} =
  refl , ext-set (λ {a} → ext-set (λ {a₁} → aux {a₁}{a a₁}))
 where
   aux : ∀{a₁ : U}{l : 𝕃 (U → 𝕃 (U → 𝕃 X))} →
      foldr (λ f → _++_ (f a₁)) []
      (map (λ g u → foldr (λ f → _++_ (f u)) [] (g u)) l)
      ≡
      foldr (λ f → _++_ (f a₁)) [] (foldr (λ f → _++_ (f a₁)) [] l)
   aux {a}{[]} = refl
   aux {a}{x :: l} rewrite
     sym (foldr-append {l₁ = x a}{foldr (λ f → _++_ (f a)) [] l}{a})
     = cong2 {a = foldr (λ f → _++_ (f a)) [] (x a)}
             _++_
             refl
             (aux {a}{l})

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { !ₒ A}) ≡h (δ {A}) ○ (!ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {f} → ext-set (λ {a} → aux {a}{f a}))
 where
  aux : ∀{a : U}{l : X *}
    → l ++ [] ≡ foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x y → x :: []) l)
  aux {a}{[]} = refl
  aux {a}{x :: l} with aux {a}{l}
  ... | IH rewrite ++[] l =
    cong2 {a = x} {x} {l}
          {foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x₁ y → x₁ :: []) l)} _::_ refl
          IH

module Cartesian where
  π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (U , X , α))
  π₁ {U}{X}{V}{Y}{α}{β} = fst , (λ f → (λ v u → f u) , (λ u v → [])) , π₁-cond
    where
      π₁-cond : ∀{u : Σ U (λ x → V)} {y : U → 𝕃 X} →
        ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
        (λ u₁ f → all-pred (β u₁) (f u₁)))
        u ((λ v u₁ → y u₁) , (λ u₁ v → [])) →
        all-pred (α (fst u)) (y (fst u))
      π₁-cond {u , v}{f} (p₁ , p₂) = p₁

  π₂ : {U X V Y : Set}
      → {α : U → X → Set}
      → {β : V → Y → Set}
      → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (V , Y , β))
  π₂ {U}{X}{V}{Y}{α}{β} = snd , (λ f → (λ v u → []) , (λ u v → f v)) , π₂-cond
      where
        π₂-cond : ∀{u : Σ U (λ x → V)} {y : V → 𝕃 Y} →
          ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
            (λ u₁ f → all-pred (β u₁) (f u₁)))
              u ((λ v u₁ → []) , (λ u₁ v → y v)) →
            all-pred (β (snd u)) (y (snd u))
        π₂-cond {u , v}{f} (p₁ , p₂) = p₂

  cart-ar-crt : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y) → W → 𝕃 Z
  cart-ar-crt  (f , F , p₁) (g , G , p₂) (j₁ , j₂) w = F (j₁ (g w)) w ++ G (j₂ (f w)) w

  cart-ar : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Hom (!ₒ (W , Z , γ)) ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))
  cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ} (f , F , p₁) (g , G , p₂)
    = (λ w → f w , g w) , cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) , cart-ar-cond
      where
        cart-ar-cond : ∀{u : W} {y : Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y)} →
          all-pred (γ u) (cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) y u) →
          ((λ u₁ f₁ → all-pred (α u₁) (f₁ u₁)) ⊗ᵣ
          (λ u₁ f₁ → all-pred (β u₁) (f₁ u₁)))
          (f u , g u) y
        cart-ar-cond {w}{j₁ , j₂} p
          rewrite
            all-pred-append {f = γ w}{F (j₁ (g w)) w}{G (j₂ (f w)) w} ∧-unit ∧-assoc with p
        ... | (a , b) = p₁ a , p₂ b

  cart-diag₁ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (U , X , α)}
      (!ₐ {W , Z , γ}{U , X , α} f)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (U , X , α)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₁)
  cart-diag₁ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → sym (++[] (map F (j (f w))))))

  cart-diag₂ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (V , Y , β)}
      (!ₐ {W , Z , γ}{V , Y , β} g)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (V , Y , β)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₂)
  cart-diag₂ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → refl))
-}

-----------------------------------------------------------------------
-- This file defines DC₂(Sets) and its SMC structure.              --
-----------------------------------------------------------------------
module DC2Sets where

open import prelude

-- The objects:
Obj : Set₁
Obj = Σ[ U ∈ Set ] (Σ[ X ∈ Set ] (U → X → Set))

-- The morphisms:
Hom : Obj → Obj → Set
Hom (U , X , α) (V , Y , β) =
  Σ[ f ∈ (U → V) ]
    (Σ[ F ∈ (U → Y → X) ] (∀{u : U}{y : Y} → α u (F u y) → β (f u) y))

-- Composition:
comp : {A B C : Obj} → Hom A B → Hom B C → Hom A C
comp {(U , X , α)} {(V , Y , β)} {(W , Z , γ)} (f , F , p₁) (g , G , p₂) =
  (g ∘ f , (λ u z → F u (G (f u) z)), (λ {u} {y} p₃ → p₂ (p₁ p₃)))

infixl 5 _○_

_○_ = comp

-- The contravariant hom-functor:
Homₐ :  {A' A B B' : Obj} → Hom A' A → Hom B B' → Hom A B → Hom A' B'
Homₐ f h g = comp f (comp g h)

-- The identity function:
id : {A : Obj} → Hom A A
id {(U , V , α)} = (id-set , curry snd , id-set)

-- In this formalization we will only worry about proving that the
-- data of morphisms are equivalent, and not worry about the morphism
-- conditions.  This will make proofs shorter and faster.
--
-- If we have parallel morphisms (f,F) and (g,G) in which we know that
-- f = g and F = G, then the condition for (f,F) will imply the
-- condition of (g,G) and vice versa.  Thus, we can safely ignore it.
infix 4 _≡h_

_≡h_ : {A B : Obj} → (f g : Hom A B) → Set
_≡h_ {(U , X , α)}{(V , Y , β)} (f , F , p₁) (g , G , p₂) = f ≡ g × F ≡ G

≡h-refl : {A B : Obj}{f : Hom A B} → f ≡h f
≡h-refl {U , X , α}{V , Y , β}{f , F , _} = refl , refl

≡h-trans : ∀{A B}{f g h : Hom A B} → f ≡h g → g ≡h h → f ≡h h
≡h-trans {U , X , α}{V , Y , β}{f , F , _}{g , G , _}{h , H , _} (p₁ , p₂) (p₃ , p₄) rewrite p₁ | p₂ | p₃ | p₄ = refl , refl

≡h-sym : ∀{A B}{f g : Hom A B} → f ≡h g → g ≡h f
≡h-sym {U , X , α}{V , Y , β}{f , F , _}{g , G , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

≡h-subst-○ : ∀{A B C}{f₁ f₂ : Hom A B}{g₁ g₂ : Hom B C}{j : Hom A C}
  → f₁ ≡h f₂
  → g₁ ≡h g₂
  → f₂ ○ g₂ ≡h j
  → f₁ ○ g₁ ≡h j
≡h-subst-○ {U , X , α}
         {V , Y , β}
         {W , Z , γ}
         {f₁ , F₁ , _}
         {f₂ , F₂ , _}
         {g₁ , G₁ , _}
         {g₂ , G₂ , _}
         {j , J , _}
         (p₅ , p₆) (p₇ , p₈) (p₉ , p₁₀) rewrite p₅ | p₆ | p₇ | p₈ | p₉ | p₁₀ = refl , refl

○-assoc : ∀{A B C D}{f : Hom A B}{g : Hom B C}{h : Hom C D}
  → f ○ (g ○ h) ≡h (f ○ g) ○ h
○-assoc {U , X , α}{V , Y , β}{W , Z , γ}{S , T , ι}
        {f , F , _}{g , G , _}{h , H , _} = refl , refl

○-idl : ∀{A B}{f : Hom A B} → id ○ f ≡h f
○-idl {U , X , _}{V , Y , _}{f , F , _} = refl , refl

○-idr : ∀{A B}{f : Hom A B} → f ○ id ≡h f
○-idr {U , X , _}{V , Y , _}{f , F , _} = refl , refl

-----------------------------------------------------------------------
-- DC₂(Sets) is a SMC                                              --
-----------------------------------------------------------------------

-- The tensor functor: ⊗
_⊗ᵣ_ : ∀{U X V Y : Set} → (U → X → Set) → (V → Y → Set) → ((U × V) → (X × Y) → Set)
_⊗ᵣ_ α β (u , v) (x , y) = (α u x) × (β v y)

_⊗ₒ_ : (A B : Obj) → Obj
(U , X , α) ⊗ₒ (V , Y , β) = ((U × V) , (X × Y) , α ⊗ᵣ β)

F⊗ : ∀{Z T V X U Y : Set}{F : U → Z → X}{G : V → T → Y} → (U × V) → (Z × T) → (X × Y)
F⊗ {F = F}{G} (u , v) (z , t) = F u z , G v t

_⊗ₐ_ : {A B C D : Obj} → Hom A C → Hom B D → Hom (A ⊗ₒ B) (C ⊗ₒ D)
_⊗ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) = ⟨ f , g ⟩ , F⊗ {F = F}{G} , p⊗
 where
  p⊗ : {u : Σ U (λ x → V)} {y : Σ Z (λ x → T)} → (α ⊗ᵣ β) u (F⊗ {F = F}{G} u y) → (γ ⊗ᵣ δ) (⟨ f , g ⟩ u) y
  p⊗ {u , v}{z , t} (p₃ , p₄) = p₁  p₃ , p₂ p₄

-- The unit for tensor:
ι : ⊤ → ⊤ → Set
ι triv triv = ⊤

I : Obj
I = (⊤ , ⊤ , ι)

J : Obj
J = (⊤ , ⊤ , (λ x y → ⊥))

-- The left-unitor:
λ⊗-p : ∀{U X α}{u : Σ ⊤ (λ x → U)} {y : X} → (ι ⊗ᵣ α) u (triv , y) → α (snd u) y
λ⊗-p {U}{X}{α}{(triv , u)}{x} = snd

λ⊗ : ∀{A : Obj} → Hom (I ⊗ₒ A) A
λ⊗ {(U , X , α)} = snd , (λ _ x → triv , x) , λ⊗-p

λ⊗-inv : ∀{A : Obj} → Hom A (I ⊗ₒ A)
λ⊗-inv {(U , X , α)} = (λ u → triv , u) , (λ _ r → snd r) , λ⊗-inv-p
 where
  λ⊗-inv-p : ∀{U X α}{u : U} {y : Σ ⊤ (λ x → X)} → α u (snd y) → (ι ⊗ᵣ α) (triv , u) y
  λ⊗-inv-p {U}{X}{α}{u}{triv , x} p = triv , p

-- The right-unitor:
ρ⊗ : ∀{A : Obj} → Hom (A ⊗ₒ I) A
ρ⊗ {(U , X , α)} = fst , (λ r x → x , triv) , ρ⊗-p
 where
  ρ⊗-p : ∀{U X α}{u : Σ U (λ x → ⊤)} {y : X} → (α ⊗ᵣ ι) u (y , triv) → α (fst u) y
  ρ⊗-p {U}{X}{α}{(u , _)}{x} (p , _) = p

ρ⊗-inv : ∀{A : Obj} → Hom A (A ⊗ₒ I)
ρ⊗-inv {(U , X , α)} = (λ u → u , triv) , (λ u r → fst r) , ρ⊗-p-inv
 where
  ρ⊗-p-inv : ∀{U X α}{u : U} {y : Σ X (λ x → ⊤)} → α u (fst y) → (α ⊗ᵣ ι) (u , triv) y
  ρ⊗-p-inv {U}{X}{α}{u}{x , triv} p = p , triv

-- Symmetry:
β⊗ : ∀{A B : Obj} → Hom (A ⊗ₒ B) (B ⊗ₒ A)
β⊗ {(U , X , α)}{(V , Y , β)} = twist-× , (λ r₁ r₂ → twist-× r₂) , β⊗-p
 where
   β⊗-p : ∀{U V Y X α β}{u : Σ U (λ x → V)} {y : Σ Y (λ x → X)} → (α ⊗ᵣ β) u (twist-× y) → (β ⊗ᵣ α) (twist-× u) y
   β⊗-p {U}{V}{Y}{X}{α}{β}{u , v}{y , x} = twist-×

-- The associator:
Fα-inv : ∀{ℓ}{U V W X Y Z : Set ℓ} → (U × (V × W)) → ((X × Y) × Z) → (X × (Y × Z))
Fα-inv (u , (v , w)) ((x , y) , z) = x , y , z

α⊗-inv : ∀{A B C : Obj} → Hom (A ⊗ₒ (B ⊗ₒ C)) ((A ⊗ₒ B) ⊗ₒ C)
α⊗-inv {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = rl-assoc-× , Fα-inv , α-inv-cond
 where
   α-inv-cond : {u : Σ U (λ x → Σ V (λ x₁ → W))}{y : Σ (Σ X (λ x → Y)) (λ x → Z)}
     → (α ⊗ᵣ (β ⊗ᵣ γ)) u (Fα-inv u y)
     → ((α ⊗ᵣ β) ⊗ᵣ γ) (rl-assoc-× u) y
   α-inv-cond {u , (v , w)}{(x , y) , z} (p₁ , (p₂ , p₃)) = (p₁ , p₂) , p₃

Fα : ∀{V W X Y U Z : Set} → ((U × V) × W) → (X × (Y × Z)) → ((X × Y) × Z)
Fα {V}{W}{X}{Y}{U}{Z} ((u , v) , w) (x , (y , z)) = (x , y) , z

α⊗ : ∀{A B C : Obj} → Hom ((A ⊗ₒ B) ⊗ₒ C) (A ⊗ₒ (B ⊗ₒ C))
α⊗ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)} = (lr-assoc-× , Fα , α-cond)
 where
  α-cond : {u : Σ (Σ U (λ x → V)) (λ x → W)}
      {y : Σ X (λ x → Σ Y (λ x₁ → Z))} →
      ((α ⊗ᵣ β) ⊗ᵣ γ) u (Fα u y) → (α ⊗ᵣ (β ⊗ᵣ γ)) (lr-assoc-× u) y
  α-cond {(u , v) , w}{x , (y , z)} ((p₁ , p₂) , p₃) = p₁ , p₂ , p₃

α⊗-id₁ : ∀{A B C} → (α⊗ {A}{B}{C}) ○ α⊗-inv ≡h id
α⊗-id₁ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ (Σ U (λ x → V)) (λ x → W)} → rl-assoc-× (lr-assoc-× a) ≡ a
   aux {(u , v) , w} = refl

   aux' : {a : Σ (Σ U (λ x → V)) (λ x → W)} → (λ z → Fα {V}{W}{X}{Y}{U}{Z} a (Fα-inv (lr-assoc-× a) z)) ≡ (λ y → y)
   aux' {(u , v), w} = ext-set aux''
    where
      aux'' : {a : Σ (Σ X (λ x → Y)) (λ x → Z)} → Fα ((u , v) , w) (Fα-inv (u , v , w) a) ≡ a
      aux'' {(x , y) , z} = refl

α⊗-id₂ : ∀{A B C} → (α⊗-inv {A}{B}{C}) ○ α⊗ ≡h id
α⊗-id₂ {U , X , α}{V , Y , β}{W , Z , γ} = ext-set aux , ext-set aux'
 where
   aux : {a : Σ U (λ x → Σ V (λ x₁ → W))} → lr-assoc-× (rl-assoc-× a) ≡ a
   aux {u , (v , w)} = refl
   aux' : {a : Σ U (λ x → Σ V (λ x₁ → W))} → (λ z → Fα-inv {_}{U}{V}{W}{X}{Y}{Z} a (Fα (rl-assoc-× a) z)) ≡ (λ y → y)
   aux' {u , (v , w)} = ext-set aux''
    where
      aux'' : {a : Σ X (λ x → Σ Y (λ x₁ → Z))} → Fα-inv (u , v , w) (Fα ((u , v) , w) a) ≡ a
      aux'' {x , (y , z)} = refl

-- Internal hom:
⊸-cond : ∀{U V X Y : Set}{α : U → X → Set}{β : V → Y → Set}
  → Σ (U → V) (λ x → U → Y → X)
  → Σ U (λ x → Y)
  → Set
⊸-cond {α = α}{β} (f , F) (u , y) = α u (F u y) → β (f u) y

_⊸ₒ_ : Obj → Obj → Obj
(U , X , α) ⊸ₒ (V , Y , β) = ((U → V) × (U → Y → X)) , ((U × Y) , ⊸-cond {α = α}{β})

_⊸ₐ_ : {A B C D : Obj} → Hom C A → Hom B D → Hom (A ⊸ₒ B) (C ⊸ₒ D)
_⊸ₐ_ {(U , X , α)}{(V , Y , β)}{(W , Z , γ)}{(S , T , δ)} (f , F , p₁) (g , G , p₂) =
  h , H , cond
 where
  h : Σ (U → V) (λ x → U → Y → X) → Σ (W → S) (λ x → W → T → Z)
  h (i , I) = (λ w → g (i (f w))) , (λ w t → F w (I (f w) (G (i (f w)) t)))
  H : Σ (U → V) (λ x → U → Y → X) → Σ W (λ x → T) → Σ U (λ x → Y)
  H (i , I) (w , t) = f w , G (i (f w)) t
  cond : {u : Σ (U → V) (λ x → U → Y → X)} {y : Σ W (λ x → T)} → ⊸-cond {α = α}{β} u (H u y) → ⊸-cond {α = γ}{δ} (h u) y
  cond {i , I}{w , y} p₃ p₄ = p₂ (p₃ (p₁ p₄))

cur : {A B C : Obj}
  → Hom (A ⊗ₒ B) C
  → Hom A (B ⊸ₒ C)
cur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ u → (λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) , (λ u r → fst (F (u , (fst r)) (snd r))) , cond
 where
   cond : {u : U} {y : Σ V (λ x → Z)}
     → α u (fst (F (u , fst y) (snd y)))
     → ⊸-cond {α = β}{γ} ((λ v → f (u , v)) , (λ v z → snd (F (u , v) z))) y
   cond {u}{v , z} p₂ p₃ with (p₁ {u , v}{z})
   ... | p₄ with F (u , v) z
   ... | (x , y) = p₄ (p₂ , p₃)

cur-≡h : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C}
  → f₁ ≡h f₂
  → cur f₁ ≡h cur f₂
cur-≡h {U , X , α}{V , Y , β}{W , Z , γ}
       {f₁ , F₁ , p₁}{f₂ , F₂ , p₂} (p₃ , p₄)
       rewrite p₃ | p₄ = refl , refl

cur-cong : ∀{A B C}{f₁ f₂ : Hom (A ⊗ₒ B) C} → f₁ ≡h f₂ → cur f₁ ≡h cur f₂
cur-cong {(U , X , α)} {(V , Y , β)} {(W , Z , γ)}{f₁ , F₁ , _}{f₂ , F₂ , _} (p₁ , p₂) rewrite p₁ | p₂ = refl , refl

{-
uncur : {A B C : Obj}
  → Hom A (B ⊸ₒ C)
  → Hom (A ⊗ₒ B) C
uncur {U , X , α}{V , Y , β}{W , Z , γ} (f , F , p₁)
  = (λ p → fst (f (fst p)) (snd p)) , (λ z → (λ v → F (v , z)) , (λ u → snd (f u) z)) , uncur-cond
  where
    uncur-cond : ∀{u : Σ U (λ x → V)} {y : Z}
      → (α ⊗ᵣ β) u ((λ v → F (v , y)) , (λ u₁ → snd (f u₁) y))
      → γ (fst (f (fst u)) (snd u)) y
    uncur-cond {u , v}{z} (p₂ , p₃) with p₁ {u}{v , z} p₂
    ... | p₁' with f u
    ... | (j₁ , j₂) = p₁' p₃

cur-uncur-bij₁ : ∀{A B C}{f : Hom (A ⊗ₒ B) C}
  → uncur (cur f) ≡h f
cur-uncur-bij₁ {U , X , α}{V , Y , β}{W , Z , γ}{f , F , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : Σ U (λ x → V)} → f (fst a , snd a) ≡ f a
   aux₁ {u , v} = refl

   aux₂ : {a : Z} → ((λ v → fst (F a) v) , (λ u → snd (F a) u)) ≡ F a
   aux₂ {z} with F z
   ... | j₁ , j₂ = refl

cur-uncur-bij₂ : ∀{A B C}{g : Hom A (B ⊸ₒ C)}
  → cur (uncur g) ≡h g
cur-uncur-bij₂ {U , X , α}{V , Y , β}{W , Z , γ}{g , G , p₁} = ext-set aux₁ , ext-set aux₂
 where
   aux₁ : {a : U} → ((λ v → fst (g a) v) , (λ z → snd (g a) z)) ≡ g a
   aux₁ {u} with g u
   ... | (j₁ , j₂) = refl

   aux₂ : {a : Σ V (λ x → Z)} → G (fst a , snd a) ≡ G a
   aux₂ {v , z} = refl

-- The of-course exponential:
!ₒ-cond : ∀{U X : Set}
  → (U → X → Set)
  → U
  → (U → X *)
  → Set
!ₒ-cond α u f = all-pred (α u) (f u)

!ₒ : Obj → Obj
!ₒ (U , X , α) = U , (U → X *) , !ₒ-cond α

!-cta : {V Y U X : Set}
  → (Y → X)
  → (U → V)
  → (V → Y *)
  → (U → X *)
!-cta F f g = λ u → list-funct F (g (f u))

!ₐ-cond : ∀{U V Y X : Set}{F : Y → X}{f : U → V}
  → (α : U → X → Set)
  → (β : V → Y → Set)
  → (p : {u : U} {y : Y} → α u (F y) → β (f u) y)
    {u : U}{l : Y *}
  → all-pred (α u) (list-funct F l)
  → all-pred (β (f u)) l
!ₐ-cond _ _ _ {l = []} _ = triv
!ₐ-cond α β p {u}{x :: xs} (p' , p'') = p p' , !ₐ-cond α β p p''

!ₐ : {A B : Obj} → Hom A B → Hom (!ₒ A) (!ₒ B)
!ₐ {U , X , α}{V , Y , β} (f , F , p) = f , !-cta F f , !ₐ-cond α β p

-- Of-course is a comonad:
ε : ∀{A} → Hom (!ₒ A) A
ε {U , X , α} = id-set , (λ x y → [ x ]) , fst

δ-cta : {U X : Set} → (U → 𝕃 (U → 𝕃 X)) → U → 𝕃 X
δ-cta g u = foldr (λ f rest → (f u) ++ rest) [] (g u)

δ : ∀{A} → Hom (!ₒ A) (!ₒ (!ₒ A))
δ {U , X , α} = id-set , δ-cta , δ-cond
  where
   δ-cond : {u : U} {l : 𝕃 (U → 𝕃 X)}
     → all-pred (α u) (foldr (λ f → _++_ (f u)) [] l)
     → all-pred (λ f
     → all-pred (α u) (f u)) l
   δ-cond {l = []} _ = triv
   δ-cond {u}{l = x :: l'} p with
     all-pred-append {X}{α u}
                     {x u}
                     {foldr (λ f → _++_ (f u)) [] l'}
                     ∧-unit ∧-assoc
   ... | p' rewrite p' = fst p , δ-cond {u} {l'} (snd p)

-- These diagrams can be found on page 22 of the report.
comonand-diag₁ : ∀{A}
  → (δ {A}) ○ (!ₐ (δ {A})) ≡h (δ {A}) ○ (δ { !ₒ A})
comonand-diag₁ {U , X , α} =
  refl , ext-set (λ {a} → ext-set (λ {a₁} → aux {a₁}{a a₁}))
 where
   aux : ∀{a₁ : U}{l : 𝕃 (U → 𝕃 (U → 𝕃 X))} →
      foldr (λ f → _++_ (f a₁)) []
      (map (λ g u → foldr (λ f → _++_ (f u)) [] (g u)) l)
      ≡
      foldr (λ f → _++_ (f a₁)) [] (foldr (λ f → _++_ (f a₁)) [] l)
   aux {a}{[]} = refl
   aux {a}{x :: l} rewrite
     sym (foldr-append {l₁ = x a}{foldr (λ f → _++_ (f a)) [] l}{a})
     = cong2 {a = foldr (λ f → _++_ (f a)) [] (x a)}
             _++_
             refl
             (aux {a}{l})

comonand-diag₂ : ∀{A}
  → (δ {A}) ○ (ε { !ₒ A}) ≡h (δ {A}) ○ (!ₐ (ε {A}))
comonand-diag₂ {U , X , α} =
  refl , ext-set (λ {f} → ext-set (λ {a} → aux {a}{f a}))
 where
  aux : ∀{a : U}{l : X *}
    → l ++ [] ≡ foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x y → x :: []) l)
  aux {a}{[]} = refl
  aux {a}{x :: l} with aux {a}{l}
  ... | IH rewrite ++[] l =
    cong2 {a = x} {x} {l}
          {foldr (λ f₁ → _++_ (f₁ a)) [] (map (λ x₁ y → x₁ :: []) l)} _::_ refl
          IH

module Cartesian where
  π₁ : {U X V Y : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (U , X , α))
  π₁ {U}{X}{V}{Y}{α}{β} = fst , (λ f → (λ v u → f u) , (λ u v → [])) , π₁-cond
    where
      π₁-cond : ∀{u : Σ U (λ x → V)} {y : U → 𝕃 X} →
        ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
        (λ u₁ f → all-pred (β u₁) (f u₁)))
        u ((λ v u₁ → y u₁) , (λ u₁ v → [])) →
        all-pred (α (fst u)) (y (fst u))
      π₁-cond {u , v}{f} (p₁ , p₂) = p₁

  π₂ : {U X V Y : Set}
      → {α : U → X → Set}
      → {β : V → Y → Set}
      → Hom ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β))) (!ₒ (V , Y , β))
  π₂ {U}{X}{V}{Y}{α}{β} = snd , (λ f → (λ v u → []) , (λ u v → f v)) , π₂-cond
      where
        π₂-cond : ∀{u : Σ U (λ x → V)} {y : V → 𝕃 Y} →
          ((λ u₁ f → all-pred (α u₁) (f u₁)) ⊗ᵣ
            (λ u₁ f → all-pred (β u₁) (f u₁)))
              u ((λ v u₁ → []) , (λ u₁ v → y v)) →
            all-pred (β (snd u)) (y (snd u))
        π₂-cond {u , v}{f} (p₁ , p₂) = p₂

  cart-ar-crt : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y) → W → 𝕃 Z
  cart-ar-crt  (f , F , p₁) (g , G , p₂) (j₁ , j₂) w = F (j₁ (g w)) w ++ G (j₂ (f w)) w

  cart-ar : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → Hom (!ₒ (W , Z , γ)) (!ₒ (U , X , α))
    → Hom (!ₒ (W , Z , γ)) (!ₒ (V , Y , β))
    → Hom (!ₒ (W , Z , γ)) ((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))
  cart-ar {U}{X}{V}{Y}{W}{Z}{α}{β}{γ} (f , F , p₁) (g , G , p₂)
    = (λ w → f w , g w) , cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) , cart-ar-cond
      where
        cart-ar-cond : ∀{u : W} {y : Σ (V → U → 𝕃 X) (λ x → U → V → 𝕃 Y)} →
          all-pred (γ u) (cart-ar-crt {α = α}{β} (f , F , p₁) (g , G , p₂) y u) →
          ((λ u₁ f₁ → all-pred (α u₁) (f₁ u₁)) ⊗ᵣ
          (λ u₁ f₁ → all-pred (β u₁) (f₁ u₁)))
          (f u , g u) y
        cart-ar-cond {w}{j₁ , j₂} p
          rewrite
            all-pred-append {f = γ w}{F (j₁ (g w)) w}{G (j₂ (f w)) w} ∧-unit ∧-assoc with p
        ... | (a , b) = p₁ a , p₂ b

  cart-diag₁ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (U , X , α)}
      (!ₐ {W , Z , γ}{U , X , α} f)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (U , X , α)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₁)
  cart-diag₁ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → sym (++[] (map F (j (f w))))))

  cart-diag₂ : {U X V Y W Z : Set}
    → {α : U → X → Set}
    → {β : V → Y → Set}
    → {γ : W → Z → Set}
    → {f : Hom (W , Z , γ) (U , X , α)}
    → {g : Hom (W , Z , γ) (V , Y , β)}
    → _≡h_ { !ₒ (W , Z , γ)}{ !ₒ (V , Y , β)}
      (!ₐ {W , Z , γ}{V , Y , β} g)
      (comp { !ₒ (W , Z , γ)}
            {((!ₒ (U , X , α)) ⊗ₒ (!ₒ (V , Y , β)))}
            { !ₒ (V , Y , β)}
            (cart-ar {α = α}{β}{γ} (!ₐ {W , Z , γ}{U , X , α} f) (!ₐ {W , Z , γ}{V , Y , β} g))
            π₂)
  cart-diag₂ {f = f , F , p₁}{g , G , p₂}
    = refl , ext-set (λ {j} → ext-set (λ {w} → refl))
-}


update the validity for the simulator

update the validity for the simulator

{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.One
open import Data.Two
open import Data.Maybe
open import Data.Product
open import Data.Nat
open import Data.Vec hiding (_>>=_ ; _∈_)
open import Data.List as L
open import Data.Fin as Fin using (Fin)
open import Relation.Binary.PropositionalEquality.NP as ≡
open import Control.Strategy renaming (map to mapS)
open import Control.Strategy.Utils
open import Game.Challenge
import Game.ReceiptFreeness
import Game.IND-CCA2-dagger
import Game.IND-CCA2-dagger.Valid
import Game.IND-CPA-utils

import Data.List.Any
open Data.List.Any using (here; there)
open Data.List.Any.Membership-≡ using (_∈_ ; _∉_)

import Game.ReceiptFreeness.Adversary
import Game.ReceiptFreeness.Valid
import Game.Transformation.ReceiptFreeness-CCA2d.Simulator

module Game.Transformation.ReceiptFreeness-CCA2d.Valid
  (PubKey    : ★)
  (CipherText : ★)

  (SerialNumber : ★)
  (Receipt : ★)
  (MarkedReceipt? : ★)
  (Ballot : ★)
  (Tally : ★)
--  (BB    : ★)
--  ([]    : BB)
--  (_∷_ : Receipt → BB → BB)
  (Rgb   : ★)
  (genBallot : PubKey → Rgb → Ballot)
  (tallyMarkedReceipt? : let CO = 𝟚 in CO → MarkedReceipt? → Tally)
  (0,0   : Tally)
  (1,1   : Tally)
  (_+,+_ : Tally → Tally → Tally)
  (receipts : SerialNumber ² → CipherText ² → Receipt ²)
  (enc-co : Receipt → CipherText)
  (r-sn   : Receipt → SerialNumber)
  (m?     : Receipt → MarkedReceipt?)
  (b-sn   : Ballot → SerialNumber)
  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₐ : ★)
  (#q : ℕ) (max#q : Fin #q)
  (Check    : let BB = List Receipt in BB → Receipt → 𝟚)
  where

_²' : ★ → ★
X ²' = X × X

CO = 𝟚
BB = List Receipt
all-sn : BB → List SerialNumber
all-sn = L.map r-sn

module RF  = Game.ReceiptFreeness.Adversary PubKey (SerialNumber ²) Rₐ Receipt Ballot Tally CO BB
module RFV = Game.ReceiptFreeness.Valid     PubKey SerialNumber Rₐ Receipt Ballot Tally CO BB
                                            CipherText enc-co r-sn b-sn

open Game.Transformation.ReceiptFreeness-CCA2d.Simulator
  PubKey CipherText (SerialNumber ²) Receipt MarkedReceipt? Ballot Tally BB [] _∷_ Rgb genBallot
  tallyMarkedReceipt? 0,0 1,1 _+,+_ receipts enc-co m? Rₐ #q max#q Check

module CCA2†V = Game.IND-CCA2-dagger.Valid PubKey Message CipherText Rₐ†

module Simulator-Valid (RFA : RF.Adversary)(RFA-Valid : RFV.Valid-Adversary RFA)
  (WRONG-HYP : ∀ r r' → enc-co r ≡ enc-co r' → r-sn r ≡ r-sn r')
  (CheckMem : ∀ bb r → ✓ (Check bb r) → r-sn r ∉ all-sn bb)
  where
  valid : CCA2†V.Valid-Adversary (Simulator.A† RFA)
  valid (rₐ , rgb) pk = Phase1 _ (RFA-Valid rₐ pk) where
     open CCA2†V.Valid-Adversary (rₐ , rgb) pk
     module RFVA = RFV.Valid-Adversary rₐ pk
     open RF
     open Simulator RFA
     open AdversaryParts rgb pk rₐ

     -- could refine r more
     -- {-
     Phase2 : ∀ RF {bb i ta r} → r-sn (r 0₂) ∈ all-sn bb → r-sn (r 1₂) ∈ all-sn bb → RFVA.Phase2-Valid r RF
            → Phase2-Valid (enc-co ∘ r) (mapS proj₁ (mitm-to-client-trans (MITM-phase 1₂ i bb ta) RF))
     Phase2 (ask REB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RBB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RTally cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask (RCO x) cont) r0 r1 ((r₀ , r₁) , RF-valid) = r₀ , r₁ , (λ r → Phase2 (cont _) r0 r1 (RF-valid _))
     Phase2 (ask (Vote x) cont) {bb} r0 r1 RF-valid with Check bb x | CheckMem bb x
     ... | 0₂ | _ = Phase2 (cont _) r0 r1 (RF-valid _)
     ... | 1₂ | not-in-bb = (λ eq → not-in-bb _ (subst (λ x₁ → x₁ ∈ all-sn bb) (WRONG-HYP _ _  eq) r0))
                            , (λ eq → not-in-bb _ (subst (λ x₁ → x₁ ∈ all-sn bb) (WRONG-HYP _ _ eq) r1))
                            , λ r → Phase2 (cont _) (there r0) (there r1) (RF-valid _)
                            --Phase2 (cont _) (there r0) (there r1) (RF-valid _)
     Phase2 (done x) r0 r1 RF-valid = RF-valid

     Phase1 : ∀ RF {sn i bb ta} → RFVA.Phase1-Valid sn RF
            → Phase1-Valid (mapS A†2 (mitm-to-client-trans (MITM-phase 0₂ i bb ta) RF))
     Phase1 (ask REB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RBB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RTally cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask (RCO x) cont) RF-valid r = Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) {bb = bb} RF-valid with Check bb x
     Phase1 (ask (Vote x) cont) RF-valid | 1₂ = λ r → Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) RF-valid | 0₂ = Phase1 _ (RF-valid _)
     Phase1 (done x) {bb = bb'}{ta} (sn₀∉sn , sn₁∉sn , RF-valid) cs
       = {!Phase2 (put-resp x (proj₂ (put-resp (hack-challenge x) cs))) (here refl) (there (here refl)) (RF-valid _)!}
       -- Phase2 (put-resp x (proj₂ (put-resp (hack-challenge x) cs) ))
       --     ? ? (RF-valid _)
    -- -}

-- -}

-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --copatterns #-}
open import Type
open import Function
open import Data.One
open import Data.Two
open import Data.Maybe
open import Data.Product
open import Data.Nat
open import Data.Vec hiding (_>>=_ ; _∈_)
open import Data.List as L
open import Data.Fin as Fin using (Fin)
open import Relation.Binary.PropositionalEquality.NP as ≡
open import Control.Strategy renaming (map to mapS)
open import Game.Challenge
import Game.ReceiptFreeness
import Game.IND-CCA2-dagger
import Game.IND-CPA-utils

import Data.List.Any
open Data.List.Any using (here; there)
open Data.List.Any.Membership-≡ using (_∈_ ; _∉_)

module Game.Transformation.ReceiptFreeness-CCA2d.Valid
  (PubKey    : ★)
  (SecKey    : ★)
  -- Message = 𝟚
  (CipherText : ★)

  (SerialNumber : ★)

  -- randomness supply for, encryption, key-generation, adversary, adversary state
  (Rₑ Rₖ Rₐ : ★)
  (#q : ℕ) (max#q : Fin #q)
  (KeyGen : Rₖ → PubKey × SecKey)
  (Enc    : let Message = 𝟚 in
            PubKey → Message → Rₑ → CipherText)
  (Dec    : let Message = 𝟚 in
            SecKey → CipherText → Message)
  (Check    : let open Game.ReceiptFreeness PubKey SecKey CipherText SerialNumber Rₑ Rₖ Rₐ #q max#q KeyGen Enc Dec
               in BB → Receipt → 𝟚)
  (CheckMem : ∀ bb r → ✓ (Check bb r) → proj₁ (proj₂ r) ∉ L.map (proj₁ ∘ proj₂) bb)
  -- (CheckEnc : ∀ pk m rₑ → Check (Enc pk m rₑ) ≡ 1₂)
  where

_²' : ★ → ★
X ²' = X × X

r-sn : Receipt → SerialNumber
r-sn (_ , sn , _) = sn

module Simulator-Valid (RFA : RF.Adversary)(RFA-Valid : RF.Valid-Adversary RFA)
  (WRONG-HYP : ∀ r r' → r-sn r ≡ r-sn r' → enc-co r ≡ enc-co r')
  where
  valid : CCA2†.Valid-Adversary (Simulator.A† RFA)
  valid (rₐ , rgb) pk = Phase1 _ (RFA-Valid rₐ pk) where
     open CCA2†.Valid-Adversary (rₐ , rgb) pk
     module RFA = RF.Valid-Adversary rₐ pk
     open Simulator RFA
     open AdversaryParts rgb pk rₐ

     -- could refine r more
     -- {-
     Phase2 : ∀ RF {bb i taA taB r} → r-sn (r 0₂) ∈ L.map r-sn bb → r-sn (r 1₂) ∈ L.map r-sn bb → RFA.Phase2-Valid r RF
            → Phase2-Valid (proj₂ ∘ proj₂ ∘ r) (mapS proj₁ (mitm-to-client-trans (MITM-phase 1₂ i bb (taA , taB)) RF))
     Phase2 (ask REB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RBB cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask RTally cont) r0 r1 RF-valid = Phase2 (cont _) r0 r1 (RF-valid _)
     Phase2 (ask (RCO x) cont) r0 r1 ((r₀ , r₁) , RF-valid) = r₀ , r₁ , (λ r → Phase2 (cont _) r0 r1 (RF-valid _))
     Phase2 (ask (Vote x) cont) {bb} r0 r1 RF-valid with Check bb x | CheckMem bb x
     ... | 0₂ | _ = Phase2 (cont _) r0 r1 (RF-valid _)
     ... | 1₂ | not-in-bb = (λ eq → not-in-bb _ {!subst (λ x → x ∈ L.map r-sn bb) eq!})
                            , {!!},
                            , λ r → Phase2 (cont _) (there r0) (there r1) (RF-valid _)
     Phase2 (done x) r0 r1 RF-valid = RF-valid

     Phase1 : ∀ RF {sn i bb taA taB} → RFA.Phase1-Valid sn RF
            → Phase1-Valid (mapS A†2 (mitm-to-client-trans (MITM-phase 0₂ i bb (taA , taB)) RF))
     Phase1 (ask REB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RBB cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask RTally cont) RF-valid = Phase1 _ (RF-valid _)
     Phase1 (ask (RCO x) cont) RF-valid r = Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) {bb = bb} RF-valid with Check bb x
     Phase1 (ask (Vote x) cont) RF-valid | 1₂ = λ r → Phase1 _ (RF-valid _)
     Phase1 (ask (Vote x) cont) RF-valid | 0₂ = Phase1 _ (RF-valid _)
     Phase1 (done x) (sn₀∉sn , sn₁∉sn , RF-valid) cs = Phase2 (put-resp x (proj₂ (put-resp (hack-challenge x) cs) ))
            (here refl) (there (here refl)) (RF-valid _)
    -- -}

-- -}

-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}