Atlas: add primitives `lookup`, `fold` and various improvements

Improvements:

- speed up derivative of zip

- less verbose term constructors for constants

- remove need to support conjunction and union directly

Future work:

- elimination forms: if-then-else, if-nonempty

Old-commit-hash: 9aafd0c2835ff027b57e44ed2930f4f57147e0de

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

open import Syntax.Language.Calculus

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

data Atlas-const : Set where

  true  : Atlas-const
  false : Atlas-const
  xor   : Atlas-const

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
  update : ∀ {κ ι : Atlas-type} → Atlas-const
  lookup : ∀ {κ ι : Atlas-type} → Atlas-const
  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const
  fold   : ∀ {κ a b : Atlas-type} → Atlas-const

Atlas-lookup : Atlas-const → Type Atlas-type

Atlas-lookup true  = base Bool
Atlas-lookup false = base Bool
Atlas-lookup xor   = base Bool ⇒ base Bool ⇒ base Bool

Atlas-lookup (empty {κ} {ι}) = base (Map κ ι)

-- `update key val my-map` would
-- - insert if `key` is not present in `my-map`
-- - delete if `val` is the neutral element
-- - make an update otherwise
Atlas-lookup (update {κ} {ι}) =
  base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι)

Atlas-lookup (lookup {κ} {ι}) =
  base κ ⇒ base (Map κ ι) ⇒ base ι

-- Model of zip = Haskell Data.List.zipWith
--
-- zipWith :: (a → b → c) → [a] → [b] → [c]
--
-- Behavioral difference: all key-value pairs present
-- in *either* (m₁ : Map κ a) *or* (m₂ : Map κ b) will
-- be iterated over. Neutral element of type `a` or `b`
-- will be supplied if the key is missing in the
-- corresponding map.
Atlas-lookup (zip {κ} {a} {b} {c}) =
  (base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
  base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c)

-- Model of fold = Haskell Data.Map.foldWithKey
--
-- foldWithKey :: (k → a → b → b) → b → Map k a → b
--
Atlas-lookup (fold {κ} {a} {b}) =
  (base κ ⇒ base a ⇒ base b ⇒ base b) ⇒
  base b ⇒ base (Map κ a) ⇒ base b

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type Atlas-type → Type Atlas-type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

Atlas-context : Set
Atlas-context = Context {Type Atlas-type}

Atlas-term : Atlas-context → Type Atlas-type → Set
Atlas-term = Term {Atlas-type} {Atlas-const} {Atlas-lookup}

-- Shorthands of constants
--
-- There's probably a uniform way to lift constants
-- into term constructors.

update! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base (Map κ ι))
update! = app₃ (const update)

lookup! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base ι)
lookup! = app₂ (const lookup)

zip! : ∀ {κ a b c Γ} →
  Atlas-term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Atlas-term Γ (base (Map κ a)) → Atlas-term Γ (base (Map κ b)) →
  Atlas-term Γ (base (Map κ c))
zip! = app₃ (const zip)

fold! : ∀ {κ a b Γ} →
  Atlas-term Γ (base κ ⇒ base a ⇒ base b ⇒ base b) →
  Atlas-term Γ (base b) → Atlas-term Γ (base (Map κ a)) →
  Atlas-term Γ (base b)
fold! = app₃ (const fold)

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Atlas-term Γ (base ι)
neutral-term {Bool}   = const (neutral {Bool})
neutral-term {Map κ ι} = const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Atlas-term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Nonfunctional products can be encoded.
-- The incremental behavior of products thus encoded is weird:
-- Δ(α × β) = α × Δβ
Pair : Atlas-type → Atlas-type → Atlas-type
Pair α β = Map α β

pair : ∀ {α β Γ} →
  Atlas-term Γ (base α) → Atlas-term Γ (base β) →
  Atlas-term Γ (base (Pair α β))
pair s t = update! s t (const empty)

pair-term : ∀ {α β Γ} →
  Atlas-term Γ (base α ⇒ base β ⇒ base (Pair α β))
pair-term = abs (abs (pair (var (that this)) (var this)))

uncurry : ∀ {α β γ Γ} →
  Atlas-term Γ (base α ⇒ base β ⇒ base γ) →
  Atlas-term Γ (base (Pair α β)) →
  Atlas-term Γ (base γ)
uncurry f p =
  let
    a = var (that (that this))
    b = var (that this)
    g = abs (abs (abs (app₂ (weaken₃ f) a b)))
  in
    fold! g neutral-term p

zip-pair : ∀ {κ a b Γ} →
  Atlas-term Γ (base (Map κ a)) → Atlas-term Γ (base (Map κ b)) →
  Atlas-term Γ (base (Map κ (Pair a b)))
zip-pair = zip! (abs pair-term)

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Atlas-term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = const xor
Atlas-diff {Map κ ι} = app (const zip) (abs Atlas-diff)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Atlas-term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = const xor
Atlas-apply {Map κ ι} = app (const zip) (abs Atlas-apply)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Atlas-term Γ τ → Atlas-term Γ τ →
  Atlas-term Γ (Atlas-Δtype τ)
diff = app₂ (lift-diff Atlas-diff Atlas-apply)

apply : ∀ {τ Γ} →
  Atlas-term Γ (Atlas-Δtype τ) → Atlas-term Γ τ →
  Atlas-term Γ τ
apply = app₂ (lift-apply Atlas-diff Atlas-apply)

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

insert : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  -- last argument is the change accumulator
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Atlas-term Γ (base ι)
  in
    Atlas-term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

-- zip₄ f m₁ m₂ m₃ m₄ =
-- zip (λ k p₁₂ p₃₄ → uncurry (λ v₁ v₂ → uncurry (λ v₃ v₄ →
--       f k v₁ v₂ v₃ v₄)
--       p₃₄) p₁₂)
--     (zip-pair m₁ m₂) (zip-pair m₃ m₄)

zip4! f m₁ m₂ m₃ m₄ =
  let
    f′ = weaken₃ (weaken₃ (weaken₁ f))
    k = var (that (that (that (that (that (that this))))))
    p₁₂ = var (that this)
    p₃₄ = var (that (that this))
    v₁ = var (that (that (that this)))
    v₂ = var (that (that this))
    v₃ = var (that this)
    v₄ = var this
    g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
        (app₅ f′ k v₁ v₂ v₃ v₄)))
        p₃₄))) p₁₂)))
  in
    zip! g (zip-pair m₁ m₂) (zip-pair m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ} → (c : Atlas-const) →
  Atlas-term Γ (Atlas-Δtype (Atlas-lookup c))

Atlas-Δconst true  = const false
Atlas-Δconst false = const false

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (app₂ (const xor) Δx Δy))))

Atlas-Δconst empty = const empty

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δlookup k Δk m Δm | true? (k ⊕ Δk ≡ k)
-- ... | true  = lookup k Δm
-- ... | false =
--   (lookup (k ⊕ Δk) m ⊕ lookup (k ⊕ Δk) Δm)
--     ⊝ lookup k m
--
-- Only the false-branch is implemented.
Atlas-Δconst lookup =
  let
    k  = var (that (that (that this)))
    Δk = var (that (that this))
    m  = var (that this)
    Δm = var this
    k′ = apply Δk k
  in
    abs (abs (abs (abs
      (diff (apply (lookup! k′ Δm) (lookup! k′ m))
            (lookup! k m)))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app₂ (weaken₁ Δf) (var this) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

-- Δfold f Δf z Δz m Δm = proj₂
--   (fold (λ k [a,Δa] [b,Δb] →
--           uncurry (λ a Δa → uncurry (λ b Δb →
--             pair (f k a b) (Δf k nil a Δa b Δb))
--             [b,Δb]) [a,Δa])
--        (pair z Δz)
--        (zip-pair m Δm))
--
-- Δfold is efficient only if evaluation is lazy and Δf is
-- self-maintainable: it doesn't look at the argument
-- (b = fold f k a b₀) at all.
Atlas-Δconst (fold {κ} {α} {β}) =
    let -- TODO (tedius): write weaken₇
      f  = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that (that this))))))))
      Δf = weaken₃ (weaken₃ (weaken₁
        (var (that (that (that (that this)))))))
      z  = var (that (that (that this)))
      Δz = var (that (that this))
      m  = var (that this)
      Δm = var this
      k = weaken₃ (weaken₁ (var (that (that this))))
      [a,Δa] = var (that this)
      [b,Δb] = var this
      a  = var (that (that (that this)))
      Δa = var (that (that this))
      b  = var (that this)
      Δb = var this
      g = abs (abs (abs (uncurry (abs (abs (uncurry (abs (abs
            (pair (app₃ f k a b)
                  (app₆ Δf k nil-term a Δa b Δb))))
            (weaken₂ [b,Δb])))) [a,Δa])))
      proj₂ = uncurry (abs (abs (var this)))
    in
      abs (abs (abs (abs (abs (abs
        (proj₂ (fold! g (pair z Δz) (zip-pair m Δm))))))))

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-lookup
  Atlas-Δtype
  Atlas-Δconst

module Syntax.Language.Atlas where

-- Base types of the calculus Atlas
-- to be used with Plotkin-style language description
--
-- Atlas supports maps with neutral elements. The change type to
-- `Map κ ι` is `Map κ Δι`, where Δι is the change type of the
-- ground type ι. Such a change to maps can support insertions
-- and deletions as well: Inserting `k -> v` means mapping `k` to
-- the change from the neutral element to `v`, and deleting
-- `k -> v` means mapping `k` to the change from `v` to the
-- neutral element.

open import Syntax.Language.Calculus

data Atlas-type : Set where
  Bool : Atlas-type
  Map : (κ : Atlas-type) (ι : Atlas-type) → Atlas-type

data Atlas-const : Set where

  true  : Atlas-const
  false : Atlas-const
  xor   : Atlas-const

  empty  : ∀ {κ ι : Atlas-type} → Atlas-const
  update : ∀ {κ ι : Atlas-type} → Atlas-const
  zip    : ∀ {κ a b c : Atlas-type} → Atlas-const

Atlas-lookup : Atlas-const → Type Atlas-type

Atlas-lookup true  = base Bool
Atlas-lookup false = base Bool
Atlas-lookup xor   = base Bool ⇒ base Bool ⇒ base Bool

Atlas-lookup (empty {κ} {ι}) = base (Map κ ι)

-- `update key val my-map` would
-- - insert if `key` is not present in `my-map`
-- - delete if `val` is the neutral element
-- - make an update otherwise
Atlas-lookup (update {κ} {ι}) =
  base κ ⇒ base ι ⇒ base (Map κ ι) ⇒ base (Map κ ι)

-- Model of zip = Haskell Data.List.zipWith
-- zipWith :: (a → b → c) → [a] → [b] → [c]
Atlas-lookup (zip {κ} {a} {b} {c}) =
  (base κ ⇒ base a ⇒ base b ⇒ base c) ⇒
  base (Map κ a) ⇒ base (Map κ b) ⇒ base (Map κ c)

Atlas-Δbase : Atlas-type → Atlas-type
-- change to a boolean is a xor-rand
Atlas-Δbase Bool = Bool
-- change to a map is change to its values
Atlas-Δbase (Map key val) = (Map key (Atlas-Δbase val))

Atlas-Δtype : Type Atlas-type → Type Atlas-type
Atlas-Δtype = lift-Δtype₀ Atlas-Δbase

Atlas-context : Set
Atlas-context = Context {Type Atlas-type}

Atlas-term : Atlas-context → Type Atlas-type → Set
Atlas-term = Term {Atlas-type} {Atlas-const} {Atlas-lookup}

-- Every base type has a known nil-change.
-- The nil-change of ι is also the neutral element of Map κ Δι.

neutral : ∀ {ι : Atlas-type} → Atlas-const
neutral {Bool} = false
neutral {Map κ ι} = empty {κ} {ι}

neutral-term : ∀ {ι Γ} → Atlas-term Γ (base ι)
neutral-term {Bool}   = const (neutral {Bool})
neutral-term {Map κ ι} = const (neutral {Map κ ι})

nil-const : ∀ {ι : Atlas-type} → Atlas-const
nil-const {ι} = neutral {Atlas-Δbase ι}

nil-term : ∀ {ι Γ} → Atlas-term Γ (base (Atlas-Δbase ι))
nil-term {Bool}   = const (nil-const {Bool})
nil-term {Map κ ι} = const (nil-const {Map κ ι})

-- Shorthands of constants
--
-- There's probably a uniform way to lift constants
-- into term constructors.
--
-- TODO: write this and call it Syntax.Term.Plotkin.lift-term

zip! : ∀ {κ a b c Γ} →
  Atlas-term Γ (base κ ⇒ base a ⇒ base b ⇒ base c) →
  Atlas-term Γ (base (Map κ a)) → Atlas-term Γ (base (Map κ b)) →
  Atlas-term Γ (base (Map κ c))

zip! f m₁ m₂ = app (app (app (const zip) f) m₁) m₂

lookup! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base ι)

lookup! = {!!} -- TODO: add constant `lookup`

-- diff-term and apply-term

-- b₀ ⊝ b₁ = b₀ xor b₁
-- m₀ ⊝ m₁ = zip _⊝_ m₀ m₁

Atlas-diff : ∀ {ι Γ} →
  Atlas-term Γ (base ι ⇒ base ι ⇒ Atlas-Δtype (base ι))
Atlas-diff {Bool} = const xor
Atlas-diff {Map κ ι} = app (const zip) (abs Atlas-diff)

-- b ⊕ Δb = b xor Δb
-- m ⊕ Δm = zip _⊕_ m Δm

Atlas-apply : ∀ {ι Γ} →
  Atlas-term Γ (Atlas-Δtype (base ι) ⇒ base ι ⇒ base ι)
Atlas-apply {Bool} = const xor
Atlas-apply {Map κ ι} = app (const zip) (abs Atlas-apply)

-- Shorthands for working with diff-term and apply-term

diff : ∀ {τ Γ} →
  Atlas-term Γ τ → Atlas-term Γ τ →
  Atlas-term Γ (Atlas-Δtype τ)
diff s t = app (app (lift-diff Atlas-diff Atlas-apply) s) t

apply : ∀ {τ Γ} →
  Atlas-term Γ (Atlas-Δtype τ) → Atlas-term Γ τ →
  Atlas-term Γ τ
apply s t = app (app (lift-apply Atlas-diff Atlas-apply) s) t

-- Shorthands for creating changes corresponding to
-- insertion/deletion.

update! : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base (Map κ ι)) →
  Atlas-term Γ (base (Map κ ι))

update! k v m = app (app (app (const update) k) v) m

insert : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  -- last argument is the change accumulator
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

delete : ∀ {κ ι Γ} →
  Atlas-term Γ (base κ) → Atlas-term Γ (base ι) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι))) →
  Atlas-term Γ (Atlas-Δtype (base (Map κ ι)))

insert k v acc = update! k (diff v neutral-term) acc
delete k v acc = update! k (diff neutral-term v) acc

-- union s t should be:
-- 1. equal to t if s is neutral
-- 2. equal to s if t is neutral
-- 3. equal to s if s == t
-- 4. whatever it wants to be otherwise
--
-- On Booleans, only conjunction can be union.
--
-- TODO (later): support conjunction, probably by Boolean
-- elimination form if-then-else

postulate
  and! : ∀ {Γ} →
    Atlas-term Γ (base Bool) → Atlas-term Γ (base Bool) →
    Atlas-term Γ (base Bool)

union : ∀ {ι Γ} →
  Atlas-term Γ (base ι) → Atlas-term Γ (base ι) →
  Atlas-term Γ (base ι)
union {Bool} s t = and! s t
union {Map κ ι} s t =
  let
    union-term = abs (abs (union (var (that this)) (var this)))
  in
    zip! (abs union-term) s t

-- Shorthand for 4-way zip
zip4! : ∀ {κ a b c d e Γ} →
  let
    t:_ = λ ι → Atlas-term Γ (base ι)
  in
    Atlas-term Γ
      (base κ ⇒ base a ⇒ base b ⇒ base c ⇒ base d ⇒ base e) →
    t: Map κ a → t: Map κ b → t: Map κ c → t: Map κ d → t: Map κ e

zip4! f m₁ m₂ m₃ m₄ =
  let
    v₁ = var (that this)
    v₂ = var this
    v₃ = var (that this)
    v₄ = var this
    k₁₂ = var (that (that this))
    k₃₄ = var (that (that this))
    f₁₂ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₁₂) v₁) v₂)
      (lookup! k₁₂ (weaken₃ m₃))) (lookup! k₁₂ (weaken₃ m₄)))))
    f₃₄ = abs (abs (abs (app (app (app (app (app
      (weaken₃ f) k₃₄)
      (lookup! k₃₄ (weaken₃ m₁)))
      (lookup! k₃₄ (weaken₃ m₂))) v₃) v₄)))
  in
    -- A correct but inefficient implementation.
    -- May want to speed it up after constants are finalized.
    union (zip! f₁₂ m₁ m₂) (zip! f₃₄ m₃ m₄)

-- Type signature of Atlas-Δconst is boilerplate.
Atlas-Δconst : ∀ {Γ} → (c : Atlas-const) →
  Atlas-term Γ (Atlas-Δtype (Atlas-lookup c))

Atlas-Δconst true  = const false
Atlas-Δconst false = const false

-- Δxor = λ x Δx y Δy → Δx xor Δy
Atlas-Δconst xor =
  let
    Δx = var (that (that this))
    Δy = var this
  in abs (abs (abs (abs (app (app (const xor) Δx) Δy))))

Atlas-Δconst empty = const empty

-- If k ⊕ Δk ≡ k, then
--   Δupdate k Δk v Δv m Δm = update k Δv Δm
-- else it is a deletion followed by insertion:
--   Δupdate k Δk v Δv m Δm =
--     insert (k ⊕ Δk) (v ⊕ Δv) (delete k v Δm)
--
-- We implement the else-branch only for the moment.
Atlas-Δconst update =
  let
    k  = var (that (that (that (that (that this)))))
    Δk = var (that (that (that (that this))))
    v  = var (that (that (that this)))
    Δv = var (that (that this))
    -- m = var (that this) -- unused parameter
    Δm = var this
  in
    abs (abs (abs (abs (abs (abs
      (insert (apply Δk k) (apply Δv v)
        (delete k v Δm)))))))

-- Δzip f Δf m₁ Δm₁ m₂ Δm₂ | true? (f ⊕ Δf ≡ f)
--
-- ... | true =
--   zip (λ k Δv₁ Δv₂ → Δf (lookup k m₁) Δv₁ (lookup k m₂) Δv₂)
--       Δm₁ Δm₂
--
-- ... | false = zip₄ Δf m₁ Δm₁ m₂ Δm₂
--
-- we implement the false-branch for the moment.
Atlas-Δconst zip =
  let
    Δf = var (that (that (that (that this))))
    m₁  = var (that (that (that this)))
    Δm₁ = var (that (that this))
    m₂  = var (that this)
    Δm₂ = var this
    g = abs (app (app (weaken₁ Δf) (var this)) nil-term)
  in
    abs (abs (abs (abs (abs (abs (zip4! g m₁ Δm₁ m₂ Δm₂))))))

Atlas = calculus-with
  Atlas-type
  Atlas-const
  Atlas-lookup
  Atlas-Δtype
  Atlas-Δconst


s/Mu/μ and s/Nu/ν.

s/Mu/μ and s/Nu/ν.

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

module Functors where

-- The carrier of the initial algebra is (up to isomorphism) a
-- fixed-point of the functor (Vene 2000, p).

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

data Bool : Set where
  false true : Bool

data _⊎_  (A B : Set) : Set where
  inl : A → A ⊎ B
  inr : B → A ⊎ B

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

-- The terminal object.
data One : Set where
   one : One

postulate
  -- The least fixed-point.

  -- Haskell definitions:

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  μ    : (Set → Set) → Set
  In   : {F : Set → Set} → F (μ F) → μ F
  unIn : {F : Set → Set} → μ F → F (μ F)

postulate
  -- The greatest fixed-point.

  -- Haskell definitions:

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  ν    : (Set → Set) → Set
  Wrap : {F : Set → Set} → F (ν F) → ν F
  out  : {F : Set → Set} → ν F → F (ν F)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = One ⊎ X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = One ⊎ (A × X)

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = μ IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = μ NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl one)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = μ (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl one)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = ν IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conaturals type is a greatest fixed-point.
Conat : Set
Conat = ν NatF

zeroC : Conat
zeroC = Wrap (inl one)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- TODO: The conat destructor.
pred : Conat → One ⊎ Conat
pred cn with out cn
... | inl _ = inl one
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = ν (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl one)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = ν (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

------------------------------------------------------------------------------
-- References
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.

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

module Functors where

-- The carrier of the initial algebra is (up to isomorphism) a
-- fixed-point of the functor (Vene 2000, p).

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

data Bool : Set where
  false true : Bool

data _⊎_  (A B : Set) : Set where
  inl : A → A ⊎ B
  inr : B → A ⊎ B

data _×_ (A B : Set) : Set where
  _,_ : A → B → A × B

-- The terminal object.
data One : Set where
   one : One

postulate
  -- The least fixed-point.
  -- The names came from the Haskell definitions

  -- data Mu f = In (f (Mu f))

  -- unIn :: Mu f → f (Mu f)
  -- unIn (In x) = x

  Mu   : (Set → Set) → Set
  In   : {f : Set → Set} → f (Mu f) → Mu f
  unIn : {f : Set → Set} → Mu f → f (Mu f)

postulate
  -- The greatest fixed-point.
  -- The names came from the Haskell definitions

  -- data Nu f = Wrap (f (Nu f))

  -- out :: Nu f → (f (Nu f))
  -- out (Wrap x) = x

  Nu   : (Set → Set) → Set
  Wrap : {f : Set → Set} → f (Nu f) → Nu f
  out  : {f : Set → Set} → Nu f → f (Nu f)

------------------------------------------------------------------------------
-- Functors

--  The identity functor (the functor for the empty and unit types).
IdF : Set → Set
IdF X = X

-- The (co)natural numbers functor.
NatF : Set → Set
NatF X = One ⊎ X

-- The (co)list functor.
ListF : Set → Set → Set
ListF A X = One ⊎ (A × X)

-- The stream functor.
StreamF : Set → Set → Set
StreamF A X = A × X

------------------------------------------------------------------------------
-- Types as least fixed-points

-- The empty type is a least fixed-point.
⊥ : Set
⊥ = Mu IdF

-- The natural numbers type is a least fixed-point.
N : Set
N = Mu NatF

-- The data constructors for the natural numbers.
zero : N
zero = In (inl one)

succ : N → N
succ n = In (inr n)

-- The list type is a least fixed-point.
List : Set → Set
List A = Mu (ListF A)

-- The data constructors for List.
nil : {A : Set} → List A
nil = In (inl one)

cons : {A : Set} → A → List A → List A
cons x xs = In (inr (x , xs))

------------------------------------------------------------------------------
-- Types as greatest fixed-points

-- The unit type is a greatest fixed-point.
Unit : Set
Unit = Nu IdF

-- Non-structural recursion
-- unit : Nu IdF
-- unit = Wrap IdF {!unit!}

-- The conaturals type is a greatest fixed-point.
Conat : Set
Conat = Nu NatF

zeroC : Conat
zeroC = Wrap (inl one)

succC : Conat → Conat
succC cn = Wrap (inr cn)

-- Non-structural recursion for the definition of ∞C.
-- ∞C : Conat
-- ∞C = succC {!∞C!}

-- TODO: The conat destructor.
pred : Conat → One ⊎ Conat
pred cn with out cn
... | inl _ = inl one
... | inr x = inr x

-- The colist type is a greatest fixed-point.
Colist : Set → Set
Colist A = Nu (ListF A)

-- The colist data constructors.
nilCL : {A : Set} → Colist A
nilCL = Wrap (inl one)

consCL : {A : Set} → A → Colist A → Colist A
consCL x xs = Wrap (inr (x , xs))

-- The colist destructors.
nullCL : {A : Set} → Colist A → Bool
nullCL xs with out xs
... | inl _ = true
... | inr _ = false

-- headCL : {A : Set} → Colist A → A
-- headCL {A} xs with out (ListF A) xs
-- ... | inl t       =  -- Impossible
-- ... | inr (x , _) = x

-- tailCL : {A : Set} → Colist A → Colist A
-- tailCL {A} xs with out (ListF A) xs
-- ... | inl t         =  -- Impossible
-- ... | inr (_ , xs') = xs'

-- The stream type is a greatest fixed-point.
Stream : Set → Set
Stream A = Nu (StreamF A)

-- The stream data constructor.
consS : {A : Set} → A → Stream A → Stream A
consS x xs = Wrap (x , xs)

-- The stream destructors.
headS : {A : Set} → Stream A → A
headS xs with out xs
... | x , _ = x

tailS : {A : Set} → Stream A → Stream A
tailS xs with out xs
... | _ , xs' = xs'

------------------------------------------------------------------------------
-- References
--
-- Vene, Varmo (2000). Categorical programming with inductive and
-- coinductive types. PhD thesis. Faculty of Mathematics: University
-- of Tartu.


Implement apply-term and diff-term directly.

Before this commit: Mutual recursion of apply-term and diff-term encoded
explicitly via a product type. After this commit: Mutual recursion
expressed with Agda mutual recursion.

Old-commit-hash: 9a7571f8ef5cf6765629a001c46870e002f54d7e

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  diff-term : ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)
  apply-term : ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  diff-term {base ι} = diff-base
  diff-term {σ ⇒ τ} =
    (let
       _⊝τ_ = λ {Γ} s t  → app₂ (diff-term {τ} {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (apply-term {σ} {Γ}) Δt t
     in
       abs₄ (λ g f x Δx → app f (x ⊕σ Δx) ⊝τ app g x))

  apply-term {base ι} = apply-base
  apply-term {σ ⇒ τ} =
    (let
       _⊝σ_ = λ {Γ} s t  → app₂ (diff-term {σ} {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (apply-term {τ} {Γ}) Δt t
     in
       abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

  diff : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff = app₂ diff-term

  apply : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply = app₂ apply-term

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Change.Type as ChangeType

module Parametric.Change.Term
    {Base : Set}
    (Constant : Term.Structure Base)
    (ΔBase : ChangeType.Structure Base)
  where

-- Terms that operate on changes

open Type.Structure Base
open Term.Structure Base Constant
open ChangeType.Structure Base ΔBase

open import Data.Product

DiffStructure : Set
DiffStructure = ∀ {ι Γ} → Term Γ (base ι ⇒ base ι ⇒ base (ΔBase ι))

ApplyStructure : Set
ApplyStructure = ∀ {ι Γ} → Term Γ (ΔType (base ι) ⇒ base ι ⇒ base ι)

module Structure
    (diff-base : DiffStructure)
    (apply-base : ApplyStructure)
  where

  -- g ⊝ f  = λ x . λ Δx . g (x ⊕ Δx) ⊝ f x
  -- f ⊕ Δf = λ x . f x ⊕ Δf x (x ⊝ x)

  lift-diff-apply :
    ∀ {τ Γ} →
      Term Γ (τ ⇒ τ ⇒ ΔType τ) × Term Γ (ΔType τ ⇒ τ ⇒ τ)

  lift-diff-apply {base ι} = diff-base , apply-base
  lift-diff-apply {σ ⇒ τ} =
    (let
       diffτ  = λ {Γ} → proj₁ (lift-diff-apply {τ} {Γ})
       applyσ = λ {Γ} → proj₂ (lift-diff-apply {σ} {Γ})
       _⊝τ_ = λ {Γ} s t  → app₂ (diffτ {Γ}) s t
       _⊕σ_ = λ {Γ} t Δt → app₂ (applyσ {Γ}) Δt t
     in
       abs₄ (λ g f x Δx → app f (x ⊕σ Δx) ⊝τ app g x))
    ,
    (let
       diffσ  = λ {Γ} → proj₁ (lift-diff-apply {σ} {Γ})
       applyτ = λ {Γ} → proj₂ (lift-diff-apply {τ} {Γ})
       _⊝σ_ = λ {Γ} s t  → app₂ (diffσ {Γ}) s t
       _⊕τ_ = λ {Γ} t Δt → app₂ (applyτ {Γ}) Δt t
     in
       abs₃ (λ Δh h y → app h y ⊕τ app (app Δh y) (y ⊝σ y)))

  diff-term :
    ∀ {τ Γ} → Term Γ (τ ⇒ τ ⇒ ΔType τ)

  diff-term = λ {τ Γ} →
    proj₁ (lift-diff-apply {τ} {Γ})

  apply-term :
    ∀ {τ Γ} → Term Γ (ΔType τ ⇒ τ ⇒ τ)

  apply-term = λ {τ Γ} →
    proj₂ (lift-diff-apply {τ} {Γ})

  diff : ∀ {τ Γ} →
    Term Γ τ → Term Γ τ →
    Term Γ (ΔType τ)
  diff = app₂ diff-term

  apply : ∀ {τ Γ} →
    Term Γ (ΔType τ) → Term Γ τ →
    Term Γ τ
  apply = app₂ apply-term


Type.Identities: some more identities

Type.Identities: some more identities

{-# OPTIONS --without-K #-}
open import Type

open import Level.NP
open import HoTT
open import Function.NP
open import Function.Extensionality

open import Data.Maybe.NP using (Maybe ; just ; nothing ; maybe ; maybe′ ; just-injective)
open import Data.Zero using (𝟘 ; 𝟘-elim)
open import Data.One using (𝟙)
open import Data.Two using (𝟚 ; 0₂ ; 1₂ ; [0:_1:_]; twist)
open import Data.Fin as Fin using (Fin ; suc ; zero)
open import Data.Nat.NP as ℕ using (ℕ ; suc ; zero)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_ ; ap; coe; coe!; !_; _∙_; J ; inspect ; Reveal_is_ ; [_]; tr) renaming (refl to idp; cong₂ to ap₂; _≗_ to _∼_)

module Type.Identities where

open Equivalences

-- for use with ap₂ etc.
_⟶_ : ∀ {a b} → ★_ a → ★_ b → ★_ (b ⊔ a)
A ⟶ B = A → B

𝟚≃𝟙⊎𝟙 : 𝟚 ≃ (𝟙 ⊎ 𝟙)
𝟚≃𝟙⊎𝟙 = equiv [0: inl _ 1: inr _ ]
              [inl: const 0₂ ,inr: const 1₂ ]
              [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
              [0: idp 1: idp ]

𝟚≡𝟙⊎𝟙 : {{_ : UA}} → 𝟚 ≡ (𝟙 ⊎ 𝟙)
𝟚≡𝟙⊎𝟙 = ua 𝟚≃𝟙⊎𝟙

module _ {{_ : UA}}{A : ★}{B C : A → ★} where
    Σ⊎-split : (Σ A (λ x → B x ⊎ C x)) ≡ (Σ A B ⊎ Σ A C)
    Σ⊎-split = ua (equiv (λ { (x , inl y) → inl (x , y)
                            ; (x , inr y) → inr (x , y) })
                         (λ { (inl (x , y)) → x , inl y
                            ; (inr (x , y)) → x , inr y })
                         (λ { (inl (x , y)) → idp
                            ; (inr (x , y)) → idp })
                         (λ { (x , inl y) → idp
                            ; (x , inr y) → idp }))

module _ {{_ : UA}}{A B : ★}{C : A ⊎ B → ★} where
    dist-⊎-Σ-equiv : Σ (A ⊎ B) C ≃ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-Σ : Σ (A ⊎ B) C ≡ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ = ua dist-⊎-Σ-equiv

    module _{{_ : FunExt}} where
      dist-×-Π-equiv : Π (A ⊎ B) C ≃ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-Π : Π (A ⊎ B) C ≡ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π = ua dist-×-Π-equiv

module _ {{_ : UA}}{A B : ★}{C : A → ★}{D : B → ★} where
    dist-⊎-Σ[] : (Σ (A ⊎ B) [inl: C ,inr: D ]) ≡ (Σ A C ⊎ Σ B D)
    dist-⊎-Σ[] = dist-⊎-Σ

    module _{{_ : FunExt}} where
      dist-×-Π[] : (Π (A ⊎ B) [inl: C ,inr: D ]) ≡ (Π A C × Π B D)
      dist-×-Π[] = dist-×-Π

module _ {{_ : UA}}{A B C : ★} where
    dist-⊎-×-equiv : ((A ⊎ B) × C) ≃ (A × C ⊎ B × C)
    dist-⊎-×-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-× : ((A ⊎ B) × C) ≡ (A × C ⊎ B × C)
    dist-⊎-× = ua dist-⊎-×-equiv

    module _ {{_ : FunExt}} where
      dist-×-→-equiv : ((A ⊎ B) → C ) ≃ ((A → C) × (B → C))
      dist-×-→-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-→ : ((A ⊎ B) → C) ≡ ((A → C) × (B → C))
      dist-×-→ = ua dist-×-→-equiv

module _ {A : ★}{B : A → ★}{C : (x : A) → B x → ★} where
    Σ-assoc-equiv : (Σ A (λ x → Σ (B x) (C x))) ≃ (Σ (Σ A B) (uncurry C))
    Σ-assoc-equiv = equiv (λ x → (fst x , fst (snd x)) , snd (snd x))
                          (λ x → fst (fst x) , snd (fst x) , snd x)
                          (λ y → idp)
                          (λ y → idp)

    Σ-assoc : {{_ : UA}} → (Σ A (λ x → Σ (B x) (C x))) ≡ (Σ (Σ A B) (uncurry C))
    Σ-assoc = ua Σ-assoc-equiv

module _ {A B : ★} where
    ×-comm-equiv : (A × B) ≃ (B × A)
    ×-comm-equiv = equiv swap swap (λ y → idp) (λ x → idp)

    ×-comm : {{_ : UA}} → (A × B) ≡ (B × A)
    ×-comm = ua ×-comm-equiv

    ⊎-comm-equiv : (A ⊎ B) ≃ (B ⊎ A)
    ⊎-comm-equiv = equiv [inl: inr ,inr: inl ]
                         [inl: inr ,inr: inl ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]

    ⊎-comm : {{_ : UA}} → (A ⊎ B) ≡ (B ⊎ A)
    ⊎-comm = ua ⊎-comm-equiv

module _ {A B : ★}{C : A → B → ★} where
    ΠΠ-comm-equiv : ((x : A)(y : B) → C x y) ≃ ((y : B)(x : A) → C x y)
    ΠΠ-comm-equiv = equiv flip flip (λ _ → idp) (λ _ → idp)

    ΠΠ-comm : {{_ : UA}} → ((x : A)(y : B) → C x y) ≡ ((y : B)(x : A) → C x y)
    ΠΠ-comm = ua ΠΠ-comm-equiv

    ΣΣ-comm-equiv : (Σ A λ x → Σ B λ y → C x y) ≃ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm-equiv = equiv (λ { (x , y , z) → y , x , z })
                          (λ { (x , y , z) → y , x , z })
                          (λ _ → idp)
                          (λ _ → idp)

    ΣΣ-comm : {{_ : UA}} → (Σ A λ x → Σ B λ y → C x y) ≡ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm = ua ΣΣ-comm-equiv

module _ {A B C : ★} where
    ×-assoc : {{_ : UA}} → (A × (B × C)) ≡ ((A × B) × C)
    ×-assoc = Σ-assoc

    ⊎-assoc-equiv : (A ⊎ (B ⊎ C)) ≃ ((A ⊎ B) ⊎ C)
    ⊎-assoc-equiv = equiv [inl: inl ∘ inl ,inr: [inl: inl ∘ inr ,inr: inr ] ]
                          [inl: [inl: inl ,inr: inr ∘ inl ] ,inr: inr ∘ inr ]
                          [inl: [inl: (λ x → idp) ,inr: (λ x → idp) ] ,inr: (λ x → idp) ]
                          [inl: (λ x → idp) ,inr: [inl: (λ x → idp) ,inr: (λ x → idp) ] ]

    ⊎-assoc : {{_ : UA}} → (A ⊎ (B ⊎ C)) ≡ ((A ⊎ B) ⊎ C)
    ⊎-assoc = ua ⊎-assoc-equiv

module _ {{_ : UA}}{{_ : FunExt}}(A : 𝟘 → ★) where
    Π𝟘-uniq : Π 𝟘 A ≡ 𝟙
    Π𝟘-uniq = ua (equiv _ (λ _ ()) (λ _ → idp) (λ _ → λ= (λ())))

module _ {{_ : UA}}(A : 𝟙 → ★) where
    Π𝟙-uniq : Π 𝟙 A ≡ A _
    Π𝟙-uniq = ua (equiv (λ f → f _) (λ x _ → x) (λ _ → idp) (λ _ → idp))

module _ {{_ : UA}}(A : ★) where
    Π𝟙-uniq′ : (𝟙 → A) ≡ A
    Π𝟙-uniq′ = Π𝟙-uniq (λ _ → A)

module _ {{_ : UA}}{{_ : FunExt}}(A : ★) where
    Π𝟘-uniq′ : (𝟘 → A) ≡ 𝟙
    Π𝟘-uniq′ = Π𝟘-uniq (λ _ → A)

    𝟘→A↔𝟙 = Π𝟘-uniq′

module _ {{_ : FunExt}}(F G : 𝟘 → ★) where
    -- also by Π𝟘-uniq twice
    Π𝟘-uniq' : Π 𝟘 F ≡ Π 𝟘 G
    Π𝟘-uniq' = Π=′ 𝟘 (λ())

module _ {A : 𝟘 → ★} where
    Σ𝟘-fst-equiv : Σ 𝟘 A ≃ 𝟘
    Σ𝟘-fst-equiv = equiv fst (λ()) (λ()) (λ { (() , _) })

    Σ𝟘-fst : {{_ : UA}} → Σ 𝟘 A ≡ 𝟘
    Σ𝟘-fst = ua Σ𝟘-fst-equiv

module _ {A : 𝟙 → ★} where
    Σ𝟙-snd-equiv : Σ 𝟙 A ≃ A _
    Σ𝟙-snd-equiv = equiv snd (_,_ _) (λ _ → idp) (λ _ → idp)

    Σ𝟙-snd : {{_ : UA}} → Σ 𝟙 A ≡ A _
    Σ𝟙-snd = ua Σ𝟙-snd-equiv

module _ {A : ★} where
    ⊎𝟘-inl-equiv : A ≃ (A ⊎ 𝟘)
    ⊎𝟘-inl-equiv = equiv inl [inl: id ,inr: (λ()) ] [inl: (λ _ → idp) ,inr: (λ()) ] (λ _ → idp)

    ⊎𝟘-inl : {{_ : UA}} → A ≡ (A ⊎ 𝟘)
    ⊎𝟘-inl = ua ⊎𝟘-inl-equiv

    𝟙×-snd : {{_ : UA}} → (𝟙 × A) ≡ A
    𝟙×-snd = Σ𝟙-snd

    ×𝟙-fst : {{_ : UA}} → (A × 𝟙) ≡ A
    ×𝟙-fst = ×-comm ∙ 𝟙×-snd

    -- old names
    A×𝟙≡A = ×𝟙-fst
    𝟙×A≡A = 𝟙×-snd

module _ {A : ★}{B : A → ★}{C : Σ A B → ★} where
    -- AC: Dependent axiom of choice
    -- In Type Theory it happens to be neither an axiom nor to be choosing anything.
    ΠΣ-comm-equiv : (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≃ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm-equiv = equiv (λ H → fst ∘ H , snd ∘ H) (λ H → < fst H , snd H >) (λ H → idp) (λ H → idp)

    ΠΣ-comm : {{_ : UA}}
            → (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≡ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm = ua ΠΣ-comm-equiv

module _ {A : 𝟚 → ★}{{_ : UA}}{{_ : FunExt}} where
  Σ𝟚-⊎ : Σ 𝟚 A ≡ (A 0₂ ⊎ A 1₂)
  Σ𝟚-⊎ = Σ-first 𝟚≃𝟙⊎𝟙 ∙ dist-⊎-Σ ∙ ap₂ _⊎_ Σ𝟙-snd Σ𝟙-snd

  Π𝟚-× : Π 𝟚 A ≡ (A 0₂ × A 1₂)
  Π𝟚-× = Π-first 𝟚≃𝟙⊎𝟙 ∙ dist-×-Π ∙ ap₂ _×_ (Π𝟙-uniq _) (Π𝟙-uniq _)

  Π𝟚F↔F₀×F₁ = Π𝟚-×

module _ {A : ★}{{_ : UA}}{{_ : FunExt}} where
  Σ𝟚-⊎′ : 𝟚 × A ≡ (A ⊎ A)
  Σ𝟚-⊎′ = Σ𝟚-⊎

  𝟚→A↔A×A : (𝟚 → A) ↔ (A × A)
  𝟚→A↔A×A

module _ where

  private
    maybe-elim : {X : Set}(m : Maybe X) → m ≢ nothing → X
    maybe-elim {X} m = maybe {B = λ m' → m' ≢ _ → _} (λ x _ → x) (λ e → 𝟘-elim (e idp)) m

    maybe-elim-just : {X : Set}(m : Maybe X)(p : m ≢ nothing)
      → just (maybe-elim m p) ≡ m
    maybe-elim-just (just x) p = idp
    maybe-elim-just nothing p = 𝟘-elim (p idp)

    maybe-elim-cong : ∀ {X : Set}{m m' : Maybe X}{p p'} → m ≡ m'
      → maybe-elim m p ≡ maybe-elim m' p'
    maybe-elim-cong {m = just x} idp = idp
    maybe-elim-cong {m = nothing} {p = p} idp = 𝟘-elim (p idp)

    not-just : {X : Set}{x : X} → _≢_ {A = Maybe X} (just x) nothing
    not-just ()

    !!-p : ∀ {x}{X : Set x}{x y : X}(p : x ≡ y) → ! (! p) ≡ p
    !!-p idp = idp

    !∙ : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → ! p ∙ p ≡ idp
    !∙ idp = idp

    ∙! : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → p ∙ ! p ≡ idp
    ∙! idp = idp

    record PreservePoint {A B : Set}(eq : Maybe A ≡ Maybe B) : Set where
      field
        coe-p : ∀ x → coe eq (just x) ≢ nothing
        coe!-p : ∀ x → coe! eq (just x) ≢ nothing
    open PreservePoint

    nothing-to-nothing : {A B : Set}(eq : Maybe A ≡ Maybe B)
      → coe eq nothing ≡ nothing → PreservePoint eq
    nothing-to-nothing eq n2n = record { coe-p = λ x p → not-just (coe-inj eq (p ∙ ! n2n))
                                       ; coe!-p = λ x p → not-just (coe-same (! !∙ eq) (just x)
                                                 ∙ ! (coe∘coe eq (! eq) (just x)) ∙ ap (coe eq) p ∙ n2n) }

    !-PP : ∀ {A B : Set} {e : Maybe A ≡ Maybe B} → PreservePoint e → PreservePoint (! e)
    !-PP {e = e} e-pp = record { coe-p = coe!-p e-pp
                               ; coe!-p = λ x p → coe-p e-pp x ( ap (λ X → coe X (just x)) (! !!-p e ) ∙ p) }

    to : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → PreservePoint e → A → B
    to e e-pp x = maybe-elim (coe e (just x)) (coe-p e-pp x)

    module _{A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}{ep ep'}(e'∙e=id : e' ∙ e ≡ idp)(x : B) where
      to-to : to e ep (to e' ep' x) ≡ x
      to-to = just-injective (ap just (maybe-elim-cong
                                                {m = coe e (just (maybe-elim (coe e' (just x)) _))}
                                                {m' = coe e (coe e' (just x))}
                                                {p' = λ q → not-just (! p ∙ q)} (ap (coe e) (maybe-elim-just _ _)))
                                      ∙ maybe-elim-just (coe e (coe e' (just x))) (λ q → not-just (! p ∙ q))
                                      ∙ p)
        where
          p : coe e (coe e' (just x)) ≡ just x
          p = coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)

    cto : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → Maybe A → Maybe B
    cto e = maybe (maybe′ just (coe e nothing) ∘ coe e ∘ just) nothing

    module _ {A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}(e'∙e=id : e' ∙ e ≡ idp) where
      cto-cto : (x : Maybe B) → cto e (cto e' x) ≡ x
      cto-cto nothing = idp
      cto-cto (just x) with coe e' (just x) | coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)
      cto-cto (just x) | just x₁ | p = ap (maybe just (coe e nothing)) p
      cto-cto (just x) | nothing | p with coe e' nothing
                                        | coe∘coe e e' nothing ∙ coe-same e'∙e=id nothing
      cto-cto (just x) | nothing | p | just y  | q = ap (maybe just (coe e nothing)) q ∙ p
      cto-cto (just x) | nothing | p | nothing | q = ! q ∙ p

  module _ {A B : Set} where
    create-PP-≃ : Maybe A ≡ Maybe B → Maybe A ≃ Maybe B
    create-PP-≃ e = equiv (cto e)
                          (cto (! e))
                          (cto-cto {e = e} {e' = ! e} (!∙ e))
                          (cto-cto {e = ! e}{e' = e} (∙! e))

    create-PP : {{_ : UA}} → Maybe A ≡ Maybe B → Σ (Maybe A ≡ Maybe B) PreservePoint
    create-PP eq = ua (create-PP-≃ eq) , nothing-to-nothing _ (coe-β (create-PP-≃ eq) nothing)

    Maybe-injective-PP : {{_ : UA}} → (e : Maybe A ≡ Maybe B) → PreservePoint e
      → A ≡ B
    Maybe-injective-PP e e-pp = ua
      (equiv (to e e-pp)
             (to (! e) (!-PP e-pp))
             (to-to {e = e} { ! e} {e-pp}{ !-PP e-pp} (!∙ e))
             (to-to {e = ! e} {e} { !-PP e-pp} {e-pp} (∙! e)))

    Maybe-injective : ∀ {{_ : UA}} → Maybe A ≡ Maybe B → A ≡ B
    Maybe-injective e = let (e' , e'-pp) = create-PP e in Maybe-injective-PP e' e'-pp

module _ {a}{A : ★_ a} where
  Maybe≃𝟙⊎ : Maybe A ≃ (𝟙 ⊎ A)
  Maybe≃𝟙⊎ = equiv (maybe inr (inl _)) [inl: const nothing ,inr: just ]
     [inl: (λ x → idp) ,inr: (λ x → idp) ]
     (maybe (λ x → idp) idp)

  Maybe≡𝟙⊎ : ∀ {{_ : UA}}→ Maybe A ≡ (𝟙 ⊎ A)
  Maybe≡𝟙⊎ = ua Maybe≃𝟙⊎

module _ {{_ : UA}} where
    Fin0≡𝟘 : Fin 0 ≡ 𝟘
    Fin0≡𝟘 = ua (equiv (λ ()) (λ ()) (λ ()) (λ ()))

    Fin1≡𝟙 : Fin 1 ≡ 𝟙
    Fin1≡𝟙 = ua (equiv _ (λ _ → zero) (λ _ → idp) β)
      where β : (_ : Fin 1) → _
            β zero = idp
            β (suc ())

module _ where
  isZero? : ∀ {n}{A : Fin (suc n) → Set} → ((i : Fin n) → A (suc i)) → A zero
    → (i : Fin (suc n)) → A i
  isZero? f x zero = x
  isZero? f x (suc i) = f i

  Fin∘suc≃𝟙⊎Fin : ∀ {n} → Fin (suc n) ≃ (𝟙 ⊎ Fin n)
  Fin∘suc≃𝟙⊎Fin = equiv (isZero? inr (inl _)) [inl: (λ _ → zero) ,inr: suc ]
    [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
    (isZero? (λ _ → idp) idp)

  Fin∘suc≡𝟙⊎Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ (𝟙 ⊎ Fin n)
  Fin∘suc≡𝟙⊎Fin = ua Fin∘suc≃𝟙⊎Fin

Fin-⊎-+ : ∀ {{_ : UA}} {m n} → (Fin m ⊎ Fin n) ≡ Fin (m ℕ.+ n)
Fin-⊎-+ {zero} = ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm ∙ ! ⊎𝟘-inl
Fin-⊎-+ {suc m} = ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ap (_⊎_ 𝟙) Fin-⊎-+ ∙ ! Fin∘suc≡𝟙⊎Fin

Fin-×-* : ∀ {{_ : UA}} {m n} → (Fin m × Fin n) ≡ Fin (m ℕ.* n)
Fin-×-* {zero} = ap₂ _×_ Fin0≡𝟘 idp ∙ Σ𝟘-fst ∙ ! Fin0≡𝟘
Fin-×-* {suc m} = ap₂ _×_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-⊎-× ∙ ap₂ _⊎_ Σ𝟙-snd Fin-×-* ∙ Fin-⊎-+

Fin-→-^ : ∀ {{_ : UA}}{{_ : FunExt}}{m n} → (Fin m → Fin n) ≡ Fin (n ℕ.^ m)
Fin-→-^ {zero} = ap₂ _⟶_ Fin0≡𝟘 idp ∙ Π𝟘-uniq′ _ ∙ ⊎𝟘-inl ∙ ap (_⊎_ 𝟙) (! Fin0≡𝟘)
                  ∙ ! Fin∘suc≡𝟙⊎Fin
Fin-→-^ {suc m} = ap₂ _⟶_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-×-→ ∙ ap₂ _×_ (Π𝟙-uniq _) Fin-→-^ ∙ Fin-×-*

Fin∘suc≡Maybe∘Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ Maybe (Fin n)
Fin∘suc≡Maybe∘Fin = Fin∘suc≡𝟙⊎Fin ∙ ! Maybe≡𝟙⊎

Fin-injective : ∀ {{_ : UA}}{m n} → Fin m ≡ Fin n → m ≡ n
Fin-injective {zero} {zero} Finm≡Finn = idp
Fin-injective {zero} {suc n} Finm≡Finn = 𝟘-elim (coe (! Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {zero} Finm≡Finn = 𝟘-elim (coe (Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {suc n} Finm≡Finn
  = ap suc (Fin-injective (Maybe-injective
            (! Fin∘suc≡Maybe∘Fin ∙ Finm≡Finn ∙ Fin∘suc≡Maybe∘Fin)))

Fin⊎-injective : ∀ {{_ : UA}}{A B : Set} n → (Fin n ⊎ A) ≡ (Fin n ⊎ B) → A ≡ B
Fin⊎-injective zero    f = ⊎𝟘-inl ∙ ⊎-comm ∙  ap₂ _⊎_ (! Fin0≡𝟘) idp
                       ∙ f ∙ (ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm) ∙ ! ⊎𝟘-inl
Fin⊎-injective (suc n) f = Fin⊎-injective n (Maybe-injective
   (Maybe≡𝟙⊎ ∙ ⊎-assoc ∙ ap₂ _⊎_ (! Fin∘suc≡𝟙⊎Fin) idp ∙ f
   ∙ ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ! Maybe≡𝟙⊎))

module _ {{_ : UA}} where
    Lift≡id : ∀ {a} {A : ★_ a} → Lift {a} {a} A ≡ A
    Lift≡id = ua (equiv lower lift (λ _ → idp) (λ { (lift x) → idp }))

    Π𝟙F≡F : ∀ {ℓ} {F : 𝟙 → ★_ ℓ} → Π 𝟙 F ≡ F _
    Π𝟙F≡F = ua (equiv (λ x → x _) const (λ _ → idp) (λ _ → idp))

    𝟙→A≡A : ∀ {ℓ} {A : ★_ ℓ} → (𝟙 → A) ≡ A
    𝟙→A≡A = Π𝟙F≡F

    not-𝟚≡𝟚 : 𝟚 ≡ 𝟚
    not-𝟚≡𝟚 = twist

{-
TODO ?
Maybe𝟘↔𝟙 : Maybe 𝟘 ↔ 𝟙
Maybe𝟘↔𝟙 = A⊎𝟘↔A ∘ Maybe↔𝟙⊎

Maybe^𝟘↔Fin : ∀ n → Maybe^ n 𝟘 ↔ Fin n
Maybe^𝟘↔Fin zero    = sym Fin0↔𝟘
Maybe^𝟘↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^𝟘↔Fin n)

Maybe^𝟙↔Fin1+ : ∀ n → Maybe^ n 𝟙 ↔ Fin (suc n)
Maybe^𝟙↔Fin1+ n = Maybe^𝟘↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe𝟘↔𝟙)

Maybe-⊎ : ∀ {a} {A B : ★ a} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ {a} = sym Maybe↔Lift𝟙⊎ ∘ ⊎-CMon.assoc (Lift {_} {a} 𝟙) _ _ ∘ (Maybe↔Lift𝟙⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m 𝟘 ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = 𝟘⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎
-}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Type

open import Level.NP
open import HoTT
open import Function.NP
open import Function.Extensionality

open import Data.Maybe.NP using (Maybe ; just ; nothing ; maybe ; maybe′ ; just-injective)
open import Data.Zero using (𝟘 ; 𝟘-elim)
open import Data.One using (𝟙)
open import Data.Two using (𝟚 ; 0₂ ; 1₂ ; [0:_1:_])
open import Data.Fin as Fin using (Fin ; suc ; zero)
open import Data.Nat.NP as ℕ using (ℕ ; suc ; zero)
open import Data.Product.NP renaming (proj₁ to fst; proj₂ to snd)
open import Data.Sum using (_⊎_) renaming (inj₁ to inl; inj₂ to inr; [_,_] to [inl:_,inr:_])

import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≢_ ; ap; coe; coe!; !_; _∙_; J ; inspect ; Reveal_is_ ; [_]) renaming (subst to tr; refl to idp; cong₂ to ap₂; _≗_ to _∼_)

module Type.Identities where

open Equivalences

-- for use with ap₂ etc.
_⟶_ : ∀ {a b} → ★_ a → ★_ b → ★_ (b ⊔ a)
A ⟶ B = A → B

𝟚≃𝟙⊎𝟙 : 𝟚 ≃ (𝟙 ⊎ 𝟙)
𝟚≃𝟙⊎𝟙 = equiv [0: inl _ 1: inr _ ]
              [inl: const 0₂ ,inr: const 1₂ ]
              [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
              [0: idp 1: idp ]

𝟚≡𝟙⊎𝟙 : {{_ : UA}} → 𝟚 ≡ (𝟙 ⊎ 𝟙)
𝟚≡𝟙⊎𝟙 = ua 𝟚≃𝟙⊎𝟙

module _ {{_ : UA}}{A : ★}{B C : A → ★} where
    Σ⊎-split : (Σ A (λ x → B x ⊎ C x)) ≡ (Σ A B ⊎ Σ A C)
    Σ⊎-split = ua (equiv (λ { (x , inl y) → inl (x , y)
                            ; (x , inr y) → inr (x , y) })
                         (λ { (inl (x , y)) → x , inl y
                            ; (inr (x , y)) → x , inr y })
                         (λ { (inl (x , y)) → idp
                            ; (inr (x , y)) → idp })
                         (λ { (x , inl y) → idp
                            ; (x , inr y) → idp }))

module _ {{_ : UA}}{A B : ★}{C : A ⊎ B → ★} where
    dist-⊎-Σ-equiv : Σ (A ⊎ B) C ≃ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-Σ : Σ (A ⊎ B) C ≡ (Σ A (C ∘ inl) ⊎ Σ B (C ∘ inr))
    dist-⊎-Σ = ua dist-⊎-Σ-equiv

    module _{{_ : FunExt}} where
      dist-×-Π-equiv : Π (A ⊎ B) C ≃ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-Π : Π (A ⊎ B) C ≡ (Π A (C ∘ inl) × Π B (C ∘ inr))
      dist-×-Π = ua dist-×-Π-equiv

module _ {{_ : UA}}{A B : ★}{C : A → ★}{D : B → ★} where
    dist-⊎-Σ[] : (Σ (A ⊎ B) [inl: C ,inr: D ]) ≡ (Σ A C ⊎ Σ B D)
    dist-⊎-Σ[] = dist-⊎-Σ

    module _{{_ : FunExt}} where
      dist-×-Π[] : (Π (A ⊎ B) [inl: C ,inr: D ]) ≡ (Π A C × Π B D)
      dist-×-Π[] = dist-×-Π

module _ {{_ : UA}}{A B C : ★} where
    dist-⊎-×-equiv : ((A ⊎ B) × C) ≃ (A × C ⊎ B × C)
    dist-⊎-×-equiv = equiv (λ { (inl x , y) → inl (x , y)
                              ; (inr x , y) → inr (x , y) })
                           [inl: (λ x → inl (fst x) , snd x)
                           ,inr: (λ x → inr (fst x) , snd x) ]
                           [inl: (λ x → idp) ,inr: (λ x → idp) ]
                           (λ { (inl x , y) → idp
                              ; (inr x , y) → idp })

    dist-⊎-× : ((A ⊎ B) × C) ≡ (A × C ⊎ B × C)
    dist-⊎-× = ua dist-⊎-×-equiv

    module _ {{_ : FunExt}} where
      dist-×-→-equiv : ((A ⊎ B) → C ) ≃ ((A → C) × (B → C))
      dist-×-→-equiv = equiv (λ f → f ∘ inl , f ∘ inr) (λ fg → [inl: fst fg ,inr: snd fg ])
                             (λ _ → idp) (λ _ → λ= [inl: (λ _ → idp) ,inr: (λ _ → idp) ])

      dist-×-→ : ((A ⊎ B) → C) ≡ ((A → C) × (B → C))
      dist-×-→ = ua dist-×-→-equiv

module _ {A : ★}{B : A → ★}{C : (x : A) → B x → ★} where
    Σ-assoc-equiv : (Σ A (λ x → Σ (B x) (C x))) ≃ (Σ (Σ A B) (uncurry C))
    Σ-assoc-equiv = equiv (λ x → (fst x , fst (snd x)) , snd (snd x))
                          (λ x → fst (fst x) , snd (fst x) , snd x)
                          (λ y → idp)
                          (λ y → idp)

    Σ-assoc : {{_ : UA}} → (Σ A (λ x → Σ (B x) (C x))) ≡ (Σ (Σ A B) (uncurry C))
    Σ-assoc = ua Σ-assoc-equiv

module _ {A B : ★} where
    ×-comm-equiv : (A × B) ≃ (B × A)
    ×-comm-equiv = equiv swap swap (λ y → idp) (λ x → idp)

    ×-comm : {{_ : UA}} → (A × B) ≡ (B × A)
    ×-comm = ua ×-comm-equiv

    ⊎-comm-equiv : (A ⊎ B) ≃ (B ⊎ A)
    ⊎-comm-equiv = equiv [inl: inr ,inr: inl ]
                         [inl: inr ,inr: inl ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]
                         [inl: (λ x → idp) ,inr: (λ x → idp) ]

    ⊎-comm : {{_ : UA}} → (A ⊎ B) ≡ (B ⊎ A)
    ⊎-comm = ua ⊎-comm-equiv

module _ {A B : ★}{C : A → B → ★} where
    ΠΠ-comm-equiv : ((x : A)(y : B) → C x y) ≃ ((y : B)(x : A) → C x y)
    ΠΠ-comm-equiv = equiv flip flip (λ _ → idp) (λ _ → idp)

    ΠΠ-comm : {{_ : UA}} → ((x : A)(y : B) → C x y) ≡ ((y : B)(x : A) → C x y)
    ΠΠ-comm = ua ΠΠ-comm-equiv

    ΣΣ-comm-equiv : (Σ A λ x → Σ B λ y → C x y) ≃ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm-equiv = equiv (λ { (x , y , z) → y , x , z })
                          (λ { (x , y , z) → y , x , z })
                          (λ _ → idp)
                          (λ _ → idp)

    ΣΣ-comm : {{_ : UA}} → (Σ A λ x → Σ B λ y → C x y) ≡ (Σ B λ y → Σ A λ x → C x y)
    ΣΣ-comm = ua ΣΣ-comm-equiv

module _ {A B C : ★} where
    ×-assoc : {{_ : UA}} → (A × (B × C)) ≡ ((A × B) × C)
    ×-assoc = Σ-assoc

    ⊎-assoc-equiv : (A ⊎ (B ⊎ C)) ≃ ((A ⊎ B) ⊎ C)
    ⊎-assoc-equiv = equiv [inl: inl ∘ inl ,inr: [inl: inl ∘ inr ,inr: inr ] ]
                          [inl: [inl: inl ,inr: inr ∘ inl ] ,inr: inr ∘ inr ]
                          [inl: [inl: (λ x → idp) ,inr: (λ x → idp) ] ,inr: (λ x → idp) ]
                          [inl: (λ x → idp) ,inr: [inl: (λ x → idp) ,inr: (λ x → idp) ] ]

    ⊎-assoc : {{_ : UA}} → (A ⊎ (B ⊎ C)) ≡ ((A ⊎ B) ⊎ C)
    ⊎-assoc = ua ⊎-assoc-equiv

module _ {{_ : UA}}{{_ : FunExt}}(A : 𝟘 → ★) where
    Π𝟘-uniq : Π 𝟘 A ≡ 𝟙
    Π𝟘-uniq = ua (equiv _ (λ _ ()) (λ _ → idp) (λ _ → λ= (λ())))

module _ {{_ : UA}}(A : 𝟙 → ★) where
    Π𝟙-uniq : Π 𝟙 A ≡ A _
    Π𝟙-uniq = ua (equiv (λ f → f _) (λ x _ → x) (λ _ → idp) (λ _ → idp))

module _ {{_ : UA}}(A : ★) where
    Π𝟙-uniq′ : (𝟙 → A) ≡ A
    Π𝟙-uniq′ = Π𝟙-uniq (λ _ → A)

module _ {{_ : UA}}{{_ : FunExt}}(A : ★) where
    Π𝟘-uniq′ : (𝟘 → A) ≡ 𝟙
    Π𝟘-uniq′ = Π𝟘-uniq (λ _ → A)

module _ {{_ : FunExt}}(F G : 𝟘 → ★) where
    -- also by Π𝟘-uniq twice
    Π𝟘-uniq' : Π 𝟘 F ≡ Π 𝟘 G
    Π𝟘-uniq' = Π=′ 𝟘 (λ())

module _ {A : 𝟘 → ★} where
    Σ𝟘-fst-equiv : Σ 𝟘 A ≃ 𝟘
    Σ𝟘-fst-equiv = equiv fst (λ()) (λ()) (λ { (() , _) })

    Σ𝟘-fst : {{_ : UA}} → Σ 𝟘 A ≡ 𝟘
    Σ𝟘-fst = ua Σ𝟘-fst-equiv

module _ {A : 𝟙 → ★} where
    Σ𝟙-snd-equiv : Σ 𝟙 A ≃ A _
    Σ𝟙-snd-equiv = equiv snd (_,_ _) (λ _ → idp) (λ _ → idp)

    Σ𝟙-snd : {{_ : UA}} → Σ 𝟙 A ≡ A _
    Σ𝟙-snd = ua Σ𝟙-snd-equiv

module _ {A : ★} where
    ⊎𝟘-inl-equiv : A ≃ (A ⊎ 𝟘)
    ⊎𝟘-inl-equiv = equiv inl [inl: id ,inr: (λ()) ] [inl: (λ _ → idp) ,inr: (λ()) ] (λ _ → idp)

    ⊎𝟘-inl : {{_ : UA}} → A ≡ (A ⊎ 𝟘)
    ⊎𝟘-inl = ua ⊎𝟘-inl-equiv

    𝟙×-snd : {{_ : UA}} → (𝟙 × A) ≡ A
    𝟙×-snd = Σ𝟙-snd

    𝟙×-fst : {{_ : UA}} → (A × 𝟙) ≡ A
    𝟙×-fst = ×-comm ∙ 𝟙×-snd

module _ {A : ★}{B : A → ★}{C : Σ A B → ★} where
    -- AC: Dependent axiom of choice
    -- In Type Theory it happens to be neither an axiom nor to be choosing anything.
    ΠΣ-comm-equiv : (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≃ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm-equiv = equiv (λ H → fst ∘ H , snd ∘ H) (λ H → < fst H , snd H >) (λ H → idp) (λ H → idp)

    ΠΣ-comm : {{_ : UA}}
            → (∀ (x : A) → ∃ λ (y : B x) → C (x , y)) ≡ (∃ λ (f : Π A B) → ∀ (x : A) → C (x , f x))
    ΠΣ-comm = ua ΠΣ-comm-equiv

module _ {A : 𝟚 → ★} where
  Σ𝟚-⊎ : {{_ : UA}}{{_ : FunExt}} → Σ 𝟚 A ≡ (A 0₂ ⊎ A 1₂)
  Σ𝟚-⊎ = Σ-first 𝟚≃𝟙⊎𝟙 ∙ dist-⊎-Σ ∙ ap₂ _⊎_ Σ𝟙-snd Σ𝟙-snd

  Π𝟚-× : {{_ : UA}}{{_ : FunExt}} → Π 𝟚 A ≡ (A 0₂ × A 1₂)
  Π𝟚-× = Π-first 𝟚≃𝟙⊎𝟙 ∙ dist-×-Π ∙ ap₂ _×_ (Π𝟙-uniq _) (Π𝟙-uniq _)

module _ where

  private
    maybe-elim : {X : Set}(m : Maybe X) → m ≢ nothing → X
    maybe-elim {X} m = maybe {B = λ m' → m' ≢ _ → _} (λ x _ → x) (λ e → 𝟘-elim (e idp)) m

    maybe-elim-just : {X : Set}(m : Maybe X)(p : m ≢ nothing)
      → just (maybe-elim m p) ≡ m
    maybe-elim-just (just x) p = idp
    maybe-elim-just nothing p = 𝟘-elim (p idp)

    maybe-elim-cong : ∀ {X : Set}{m m' : Maybe X}{p p'} → m ≡ m'
      → maybe-elim m p ≡ maybe-elim m' p'
    maybe-elim-cong {m = just x} idp = idp
    maybe-elim-cong {m = nothing} {p = p} idp = 𝟘-elim (p idp)

    not-just : {X : Set}{x : X} → _≢_ {A = Maybe X} (just x) nothing
    not-just ()

    !!-p : ∀ {x}{X : Set x}{x y : X}(p : x ≡ y) → ! (! p) ≡ p
    !!-p idp = idp

    !∙ : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → ! p ∙ p ≡ idp
    !∙ idp = idp

    ∙! : ∀ {ℓ}{A : Set ℓ}{x y : A}(p : x ≡ y) → p ∙ ! p ≡ idp
    ∙! idp = idp

    record PreservePoint {A B : Set}(eq : Maybe A ≡ Maybe B) : Set where
      field
        coe-p : ∀ x → coe eq (just x) ≢ nothing
        coe!-p : ∀ x → coe! eq (just x) ≢ nothing
    open PreservePoint

    nothing-to-nothing : {A B : Set}(eq : Maybe A ≡ Maybe B)
      → coe eq nothing ≡ nothing → PreservePoint eq
    nothing-to-nothing eq n2n = record { coe-p = λ x p → not-just (coe-inj eq (p ∙ ! n2n))
                                       ; coe!-p = λ x p → not-just (coe-same (! !∙ eq) (just x)
                                                 ∙ ! (coe∘coe eq (! eq) (just x)) ∙ ap (coe eq) p ∙ n2n) }

    !-PP : ∀ {A B : Set} {e : Maybe A ≡ Maybe B} → PreservePoint e → PreservePoint (! e)
    !-PP {e = e} e-pp = record { coe-p = coe!-p e-pp
                               ; coe!-p = λ x p → coe-p e-pp x ( ap (λ X → coe X (just x)) (! !!-p e ) ∙ p) }

    to : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → PreservePoint e → A → B
    to e e-pp x = maybe-elim (coe e (just x)) (coe-p e-pp x)

    module _{A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}{ep ep'}(e'∙e=id : e' ∙ e ≡ idp)(x : B) where
      to-to : to e ep (to e' ep' x) ≡ x
      to-to = just-injective (ap just (maybe-elim-cong
                                                {m = coe e (just (maybe-elim (coe e' (just x)) _))}
                                                {m' = coe e (coe e' (just x))}
                                                {p' = λ q → not-just (! p ∙ q)} (ap (coe e) (maybe-elim-just _ _)))
                                      ∙ maybe-elim-just (coe e (coe e' (just x))) (λ q → not-just (! p ∙ q))
                                      ∙ p)
        where
          p : coe e (coe e' (just x)) ≡ just x
          p = coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)

    cto : ∀ {A B : Set}(e : Maybe A ≡ Maybe B) → Maybe A → Maybe B
    cto e = maybe (maybe′ just (coe e nothing) ∘ coe e ∘ just) nothing

    module _ {A B : Set}{e : Maybe A ≡ Maybe B}{e' : Maybe B ≡ Maybe A}(e'∙e=id : e' ∙ e ≡ idp) where
      cto-cto : (x : Maybe B) → cto e (cto e' x) ≡ x
      cto-cto nothing = idp
      cto-cto (just x) with coe e' (just x) | coe∘coe e e' (just x) ∙ coe-same e'∙e=id (just x)
      cto-cto (just x) | just x₁ | p = ap (maybe just (coe e nothing)) p
      cto-cto (just x) | nothing | p with coe e' nothing
                                        | coe∘coe e e' nothing ∙ coe-same e'∙e=id nothing
      cto-cto (just x) | nothing | p | just y  | q = ap (maybe just (coe e nothing)) q ∙ p
      cto-cto (just x) | nothing | p | nothing | q = ! q ∙ p

  module _ {A B : Set} where
    create-PP-≃ : Maybe A ≡ Maybe B → Maybe A ≃ Maybe B
    create-PP-≃ e = equiv (cto e)
                          (cto (! e))
                          (cto-cto {e = e} {e' = ! e} (!∙ e))
                          (cto-cto {e = ! e}{e' = e} (∙! e))

    create-PP : {{_ : UA}} → Maybe A ≡ Maybe B → Σ (Maybe A ≡ Maybe B) PreservePoint
    create-PP eq = ua (create-PP-≃ eq) , nothing-to-nothing _ (coe-β (create-PP-≃ eq) nothing)

    Maybe-injective-PP : {{_ : UA}} → (e : Maybe A ≡ Maybe B) → PreservePoint e
      → A ≡ B
    Maybe-injective-PP e e-pp = ua
      (equiv (to e e-pp)
             (to (! e) (!-PP e-pp))
             (to-to {e = e} { ! e} {e-pp}{ !-PP e-pp} (!∙ e))
             (to-to {e = ! e} {e} { !-PP e-pp} {e-pp} (∙! e)))

    Maybe-injective : ∀ {{_ : UA}} → Maybe A ≡ Maybe B → A ≡ B
    Maybe-injective e = let (e' , e'-pp) = create-PP e in Maybe-injective-PP e' e'-pp

module _ {a}{A : ★_ a} where
  Maybe≃𝟙⊎ : Maybe A ≃ (𝟙 ⊎ A)
  Maybe≃𝟙⊎ = equiv (maybe inr (inl _)) [inl: const nothing ,inr: just ]
     [inl: (λ x → idp) ,inr: (λ x → idp) ]
     (maybe (λ x → idp) idp)

  Maybe≡𝟙⊎ : ∀ {{_ : UA}}→ Maybe A ≡ (𝟙 ⊎ A)
  Maybe≡𝟙⊎ = ua Maybe≃𝟙⊎

Fin0≡𝟘 : {{_ : UA}} → Fin 0 ≡ 𝟘
Fin0≡𝟘 = ua (equiv (λ ()) (λ ()) (λ ()) (λ ()))

module _ where
  isZero? : ∀ {n}{A : Fin (suc n) → Set} → ((i : Fin n) → A (suc i)) → A zero
    → (i : Fin (suc n)) → A i
  isZero? f x zero = x
  isZero? f x (suc i) = f i

  Fin∘suc≃𝟙⊎Fin : ∀ {n} → Fin (suc n) ≃ (𝟙 ⊎ Fin n)
  Fin∘suc≃𝟙⊎Fin = equiv (isZero? inr (inl _)) [inl: (λ _ → zero) ,inr: suc ]
    [inl: (λ _ → idp) ,inr: (λ _ → idp) ]
    (isZero? (λ _ → idp) idp)

  Fin∘suc≡𝟙⊎Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ (𝟙 ⊎ Fin n)
  Fin∘suc≡𝟙⊎Fin = ua Fin∘suc≃𝟙⊎Fin

Fin-⊎-+ : ∀ {{_ : UA}} {m n} → (Fin m ⊎ Fin n) ≡ Fin (m ℕ.+ n)
Fin-⊎-+ {zero} = ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm ∙ ! ⊎𝟘-inl
Fin-⊎-+ {suc m} = ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ap (_⊎_ 𝟙) Fin-⊎-+ ∙ ! Fin∘suc≡𝟙⊎Fin

Fin-×-* : ∀ {{_ : UA}} {m n} → (Fin m × Fin n) ≡ Fin (m ℕ.* n)
Fin-×-* {zero} = ap₂ _×_ Fin0≡𝟘 idp ∙ Σ𝟘-fst ∙ ! Fin0≡𝟘
Fin-×-* {suc m} = ap₂ _×_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-⊎-× ∙ ap₂ _⊎_ Σ𝟙-snd Fin-×-* ∙ Fin-⊎-+

Fin-→-^ : ∀ {{_ : UA}}{{_ : FunExt}}{m n} → (Fin m → Fin n) ≡ Fin (n ℕ.^ m)
Fin-→-^ {zero} = ap₂ _⟶_ Fin0≡𝟘 idp ∙ Π𝟘-uniq′ _ ∙ ⊎𝟘-inl ∙ ap (_⊎_ 𝟙) (! Fin0≡𝟘)
                  ∙ ! Fin∘suc≡𝟙⊎Fin
Fin-→-^ {suc m} = ap₂ _⟶_ Fin∘suc≡𝟙⊎Fin idp ∙ dist-×-→ ∙ ap₂ _×_ (Π𝟙-uniq _) Fin-→-^ ∙ Fin-×-*

Fin∘suc≡Maybe∘Fin : ∀ {{_ : UA}}{n} → Fin (suc n) ≡ Maybe (Fin n)
Fin∘suc≡Maybe∘Fin = Fin∘suc≡𝟙⊎Fin ∙ ! Maybe≡𝟙⊎

Fin-injective : ∀ {{_ : UA}}{m n} → Fin m ≡ Fin n → m ≡ n
Fin-injective {zero} {zero} Finm≡Finn = idp
Fin-injective {zero} {suc n} Finm≡Finn = 𝟘-elim (coe (! Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {zero} Finm≡Finn = 𝟘-elim (coe (Finm≡Finn ∙ Fin0≡𝟘) zero)
Fin-injective {suc m} {suc n} Finm≡Finn
  = ap suc (Fin-injective (Maybe-injective
            (! Fin∘suc≡Maybe∘Fin ∙ Finm≡Finn ∙ Fin∘suc≡Maybe∘Fin)))

Fin⊎-injective : ∀ {{_ : UA}}{A B : Set} n → (Fin n ⊎ A) ≡ (Fin n ⊎ B) → A ≡ B
Fin⊎-injective zero    f = ⊎𝟘-inl ∙ ⊎-comm ∙  ap₂ _⊎_ (! Fin0≡𝟘) idp
                       ∙ f ∙ (ap₂ _⊎_ Fin0≡𝟘 idp ∙ ⊎-comm) ∙ ! ⊎𝟘-inl
Fin⊎-injective (suc n) f = Fin⊎-injective n (Maybe-injective
   (Maybe≡𝟙⊎ ∙ ⊎-assoc ∙ ap₂ _⊎_ (! Fin∘suc≡𝟙⊎Fin) idp ∙ f
   ∙ ap₂ _⊎_ Fin∘suc≡𝟙⊎Fin idp ∙ ! ⊎-assoc ∙ ! Maybe≡𝟙⊎))
-- -}
-- -}
-- -}
-- -}