open import Theory
open import Categories.Category using (Category)
open import Categories.Category.CartesianClosed

module Soundness {o ℓ e}
  (𝒞 : Category o ℓ e)
  (CC : CartesianClosed 𝒞)
  {ℓ₁ ℓ₂ ℓ₃}
  (Th : Theory ℓ₁ ℓ₂ ℓ₃)
  where

  open Theory.Theory Th
  open import Semantics 𝒞 CC Sg
  open import Syntax
  open Term Sg

  open import Categories.Category.Cartesian 𝒞
  open import Categories.Category.BinaryProducts 𝒞
  open import Categories.Object.Product 𝒞
  open import Categories.Object.Terminal 𝒞 using (Terminal)

  open Category 𝒞
  open CartesianClosed CC
  open Cartesian cartesian
  open BinaryProducts products
  module T = Terminal terminal

  open import Data.Product using (Σ; Σ-syntax; proj₁; proj₂)

  module _ (M : Model 𝒞 CC Th) where
    open Structure (proj₁ M)
    open HomReasoning

    soundness : forall {Γ A} {e₁ e₂ : Γ ⊢ A}
      -> Γ ⊢ e₁ ≡ e₂
      -> ⟦ e₁ ⟧ ≈ ⟦ e₂ ⟧
    soundness-sub : forall {Γ Γ′} {γ₁ γ₂ : Γ ⊨ Γ′}
      -> Γ ⊨ γ₁ ≡ γ₂
      -> ⟦ γ₁ ⟧S ≈ ⟦ γ₂ ⟧S

    soundness (ax x) = proj₂ M x
    soundness refl = Equiv.refl
    soundness (sym D) = Equiv.sym (soundness D)
    soundness (trans D D₁) = Equiv.trans (soundness D) (soundness D₁)
    soundness sub/id = identityʳ
    soundness sub/∙ = sym-assoc
    soundness (eta/Unit e) = T.!-unique ⟦ e ⟧
    soundness (beta/*₁ _ e₂) = project₁
    soundness (beta/*₂ e₁ _) = project₂
    soundness (eta/* _) = g-η
    soundness (beta/=> e e′) =
      begin
        ⟦ app (abs e) e′ ⟧
      ≈˘⟨ ∘-resp-≈ʳ (Equiv.trans ⁂∘⟨⟩ (⟨⟩-cong₂ identityʳ identityˡ)) ⟩
        eval′ ∘ (λg ⟦ e ⟧ ⁂ Category.id 𝒞) ∘ ⟨ Category.id 𝒞 , ⟦ e′ ⟧ ⟩
      ≈⟨ Equiv.trans sym-assoc (∘-resp-≈ˡ β′) ⟩
        ⟦ e [ ext Term.id e′ ] ⟧
      ∎
    soundness (eta/=> e) =
      begin
        ⟦ abs (app (e [ weaken ]) var) ⟧
      ≈˘⟨ λ-cong (∘-resp-≈ʳ (⟨⟩-cong₂ Equiv.refl identityˡ)) ⟩
        λg (eval′ ∘ ⟨ ⟦ e ⟧ ∘ π₁ , Category.id 𝒞 ∘ π₂ ⟩)
      ≈˘⟨ λ-cong (∘-resp-≈ʳ ⁂∘⟨⟩) ⟩
        λg (eval′ ∘ (⟦ e ⟧ ⁂ Category.id 𝒞) ∘ ⟨ π₁ , π₂ ⟩)
      ≈⟨ λ-cong (∘-resp-≈ʳ (∘-resp-≈ʳ η)) ⟩
        λg (eval′ ∘ (⟦ e ⟧ ⁂ Category.id 𝒞) ∘ Category.id 𝒞)
      ≈⟨ λ-cong (∘-resp-≈ʳ identityʳ) ⟩
        λg (eval′ ∘ (⟦ e ⟧ ⁂ Category.id 𝒞))
      ≈⟨ η-exp′ ⟩
        ⟦ e ⟧
      ∎
    soundness (comm/func _ Γ′ γ f e) = assoc
    soundness (comm/unit _ Γ′ γ) = Equiv.sym (T.!-unique (T.! ∘ ⟦ γ ⟧S))
    soundness comm/pair = Product.∘-distribʳ-⟨⟩ product
    soundness comm/fst = assoc
    soundness comm/snd = assoc
    soundness (comm/abs {γ = γ} {e = e}) =
      begin
        λg ⟦ e ⟧ ∘ ⟦ γ ⟧S
      ≈⟨ exp.subst product product ⟩
        λg (⟦ e ⟧ ∘ (⟦ γ ⟧S ⁂ Category.id 𝒞))
      ≈˘⟨ λ-cong (∘-resp-≈ʳ (Equiv.trans (∘-resp-≈ʳ η) identityʳ)) ⟩
        λg (⟦ e ⟧ ∘ (⟦ γ ⟧S ⁂ Category.id 𝒞) ∘ ⟨ π₁ , π₂ ⟩)
      ≈⟨ λ-cong (∘-resp-≈ʳ (⁂∘⟨⟩)) ⟩
        λg (⟦ e ⟧ ∘ ⟨ ⟦ γ ⟧S ∘ π₁ , Category.id 𝒞 ∘ π₂ ⟩)
      ≈⟨ λ-cong (∘-resp-≈ʳ (⟨⟩-cong₂ Equiv.refl identityˡ)) ⟩
        λg (⟦ e ⟧ ∘ ⟨ ⟦ γ ⟧S ∘ π₁ , π₂ ⟩ )
      ∎
    soundness comm/app = Equiv.trans assoc (∘-resp-≈ʳ ⟨⟩∘)
    soundness (var/ext γ _) = project₂
    soundness (cong/sub D D′) = ∘-resp-≈ (soundness D′) (soundness-sub D)
    soundness (cong/pair D D₁) = ⟨⟩-cong₂ (soundness D) (soundness D₁)
    soundness (cong/fst D) = ∘-resp-≈ʳ (soundness D)
    soundness (cong/snd D) = ∘-resp-≈ʳ (soundness D)
    soundness (cong/app D D₁) = ∘-resp-≈ʳ (⟨⟩-cong₂ (soundness D) (soundness D₁))
    soundness (cong/abs D) = λ-cong (soundness D)
    soundness (cong/func D) = ∘-resp-≈ Equiv.refl (soundness D)

    soundness-sub refl = Equiv.refl
    soundness-sub (sym D) = Equiv.sym (soundness-sub D)
    soundness-sub (trans D D₁) = Equiv.trans (soundness-sub D) (soundness-sub D₁)
    soundness-sub (!-unique {γ = γ}) = T.!-unique ⟦ γ ⟧S
    soundness-sub η-pair =
      begin
        ⟨ π₁ , π₂ ⟩
      ≈⟨ Product.η product ⟩
        Category.id 𝒞
      ∎
    soundness-sub ext∙ = ⟨⟩∘
    soundness-sub (cong/ext D D′) = ⟨⟩-cong₂ (soundness-sub D) (soundness D′)
    soundness-sub weaken/ext = project₁
    soundness-sub (cong/∙ D D₁) = ∘-resp-≈ (soundness-sub D) (soundness-sub D₁)
    soundness-sub id∙ˡ = identityˡ
    soundness-sub id∙ʳ = identityʳ
    soundness-sub assoc∙ = assoc


module hott.topology.theorems where

open import hott.topology
open import hott.topology.loopspace.theorems public


{-# OPTIONS --rewriting --confluence-check #-}

open import Agda.Builtin.Nat using (Nat; zero; suc)
open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

variable
  k l m n : Nat

postulate
  max : Nat → Nat → Nat
  max-0l : max 0 n ≡ n
  max-0r : max m 0 ≡ m
  max-diag : max m m ≡ m
  max-ss : max (suc m) (suc n) ≡ suc (max m n)
  max-assoc : max (max k l) m ≡ max k (max l m)

{-# REWRITE max-0l #-}
{-# REWRITE max-0r #-}
{-# REWRITE max-diag #-}
{-# REWRITE max-ss #-}
{-# REWRITE max-assoc #-} -- not confluent!


-- The previous error was:
-- Auto in hole `?0` raises a typing error:
--   (zero ∷ L) != L of type (List ℕ)
--   when checking that the expression x₁ has type (foo L)

open import Agda.Builtin.List
open import Agda.Builtin.Nat

data ⊥ : Set where

foo : List Nat → Set
foo []          = ⊥
foo (zero ∷ L)  = foo L
foo (suc N ∷ L) = foo (suc N ∷ L)

bar : (L : List Nat) → (foo L) → List Nat
bar [] x = []
bar (zero ∷ L) x₁ = bar L {!!}
bar (suc x ∷ L) x₁ = {!!}


------------------------------------------------------------------------
-- Full β-reduction in Fω with interval kinds
------------------------------------------------------------------------

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

module FOmegaInt.Reduction.Full where

open import Data.Fin using (suc; zero)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Data.List using ([]; _∷_)
open import Data.Sum using ([_,_])
open import Data.Product using (_,_; ∃; _×_)
open import Function using (flip; _∘_)
open import Relation.Binary using (Setoid; Preorder)
import Relation.Binary.Construct.Closure.Equivalence as EqClos
open import Relation.Binary.Construct.Closure.ReflexiveTransitive
  using (ε; _◅_; gmap)
import Relation.Binary.Construct.Closure.Symmetric as SymClos
open import Relation.Binary.PropositionalEquality as P using (_≡_; refl)
open import Relation.Binary.Reduction
import Function.Equivalence as Equiv

open import FOmegaInt.Syntax

open Syntax
open Substitution using (_[_]; weaken)

----------------------------------------------------------------------
-- Full β-reduction and equality relations

infixl 9  _·₁_ _·₂_ _⊡₁_ _⊡₂_
infixr 7  _⇒₁_ _⇒₂_
infix  6  _⋯₁_ _⋯₂_
infix  5  _→β_ _Kd→β_

mutual

  -- The compatible closure of a binary term relation.

  data Compat (_∼_ : TRel Term) {n} : Term n → Term n → Set where
    ⌈_⌉  : ∀ {a₁ a₂} → a₁ ∼ a₂                  → Compat _∼_ a₁ a₂
    Π₁   : ∀ {k₁ k₂} → KdCompat _∼_ k₁ k₂ → ∀ a → Compat _∼_ (Π k₁ a) (Π k₂ a)
    Π₂   : ∀ {a₁ a₂} k → Compat _∼_ a₁ a₂       → Compat _∼_ (Π k a₁) (Π k a₂)
    _⇒₁_ : ∀ {a₁ a₂} → Compat _∼_ a₁ a₂   → ∀ b → Compat _∼_ (a₁ ⇒ b) (a₂ ⇒ b)
    _⇒₂_ : ∀ {b₁ b₂} a → Compat _∼_ b₁ b₂       → Compat _∼_ (a ⇒ b₁) (a ⇒ b₂)
    Λ₁   : ∀ {k₁ k₂} → KdCompat _∼_ k₁ k₂ → ∀ a → Compat _∼_ (Λ k₁ a) (Λ k₂ a)
    Λ₂   : ∀ {a₁ a₂} k → Compat _∼_ a₁ a₂       → Compat _∼_ (Λ k a₁) (Λ k a₂)
    ƛ₁   : ∀ {a₁ a₂} → Compat _∼_ a₁ a₂   → ∀ b → Compat _∼_ (ƛ a₁ b) (ƛ a₂ b)
    ƛ₂   : ∀ {b₁ b₂} a → Compat _∼_ b₁ b₂       → Compat _∼_ (ƛ a b₁) (ƛ a b₂)
    _·₁_ : ∀ {a₁ a₂} → Compat _∼_ a₁ a₂   → ∀ b → Compat _∼_ (a₁ · b) (a₂ · b)
    _·₂_ : ∀ {b₁ b₂} a → Compat _∼_ b₁ b₂       → Compat _∼_ (a · b₁) (a · b₂)
    _⊡₁_ : ∀ {a₁ a₂} → Compat _∼_ a₁ a₂   → ∀ b → Compat _∼_ (a₁ ⊡ b) (a₂ ⊡ b)
    _⊡₂_ : ∀ {b₁ b₂} a → Compat _∼_ b₁ b₂       → Compat _∼_ (a ⊡ b₁) (a ⊡ b₂)

  data KdCompat (_∼_ : TRel Term) {n} : Kind Term n → Kind Term n → Set where
    _⋯₁_ : ∀ {a₁ a₂} → Compat _∼_ a₁ a₂ → ∀ b   → KdCompat _∼_ (a₁ ⋯ b) (a₂ ⋯ b)
    _⋯₂_ : ∀ {b₁ b₂} a → Compat _∼_ b₁ b₂       → KdCompat _∼_ (a ⋯ b₁) (a ⋯ b₂)
    Π₁   : ∀ {j₁ j₂} → KdCompat _∼_ j₁ j₂ → ∀ b → KdCompat _∼_ (Π j₁ b) (Π j₂ b)
    Π₂   : ∀ {k₁ k₂} k → KdCompat _∼_ k₁ k₂     → KdCompat _∼_ (Π k k₁) (Π k k₂)

-- β-contraction.
data BetaCont {n} : Term n → Term n → Set where
  cont-Tp· : ∀ k a b → BetaCont ((Λ k a) · b) (a [ b ])
  cont-Tm· : ∀ a b c → BetaCont ((ƛ a b) · c) (b [ c ])
  cont-⊡   : ∀ k a b → BetaCont ((Λ k a) ⊡ b) (a [ b ])

-- One-step β-reduction.

_→β_ : TRel Term
_→β_ = Compat BetaCont

_Kd→β_ : TRel (Kind Term)
_Kd→β_ = KdCompat BetaCont

-- Full β-reduction and equality.

β-reduction : Reduction Term
β-reduction = record { _→1_ = _→β_ }

β-reductionKind : Reduction (Kind Term)
β-reductionKind = record { _→1_ = _Kd→β_ }

open Reduction β-reduction public hiding (_→1_)
  renaming (_→*_ to _→β*_; _↔_ to _≡β_)

open Reduction β-reductionKind public hiding (_→1_)
  renaming (_→*_ to _Kd→β*_; _↔_ to _Kd≡β_)

----------------------------------------------------------------------
-- Simple properties of the β-reductions/equalities

-- Inclusions.

→β⇒→β* = →1⇒→* β-reduction
→β*⇒≡β = →*⇒↔  β-reduction
→β⇒≡β  = →1⇒↔  β-reduction

-- Reduction is a preorders.

→β*-preorder   = →*-preorder β-reduction
Kd→β*-preorder = →*-preorder β-reductionKind

-- Preorder reasoning for reduction.

module →β*-Reasoning    = →*-Reasoning β-reduction
module Kd→β*-Reasoning  = →*-Reasoning β-reductionKind

-- Raw terms and kinds together with β-equality form setoids.

≡β-setoid   = ↔-setoid β-reduction
Kd≡β-setoid = ↔-setoid β-reductionKind

-- Equational reasoning for the equality.

module ≡β-Reasoning   = ↔-Reasoning β-reduction
module Kd≡β-Reasoning = ↔-Reasoning β-reductionKind

-- Multistep and equality congruence lemmas.

module CongLemmas (_∼_ : TRel Term) where

  private
    reduction : Reduction Term
    reduction = record { _→1_ = Compat _∼_ }

    reductionKd : Reduction (Kind Term)
    reductionKd = record { _→1_ = KdCompat _∼_ }

    module O  {n} = Preorder (→*-preorder reduction   n)
    module S  {n} = Setoid   (↔-setoid    reduction   n)
    module OK {n} = Preorder (→*-preorder reductionKd n)
    module SK {n} = Setoid   (↔-setoid    reductionKd n)

  open Reduction reduction
  open Reduction reductionKd using () renaming (_→*_ to _Kd→*_; _↔_ to _Kd↔_)

  -- A Congruence lemma for _⌞∙⌟_.

  →1-⌞∙⌟₁ : ∀ {n} {a₁ a₂ : Term n} → a₁ →1 a₂ → ∀ bs → a₁ ⌞∙⌟ bs →1 a₂ ⌞∙⌟ bs
  →1-⌞∙⌟₁ a₁∼a₂ []       = a₁∼a₂
  →1-⌞∙⌟₁ a₁∼a₂ (b ∷ bs) = →1-⌞∙⌟₁ (a₁∼a₂ ·₁ b) bs

  -- Multistep congruence lemmas for transitive closures.

  →*-Π : ∀ {n} {k₁ k₂ : Kind Term n} {a₁ a₂} →
         k₁ Kd→* k₂ → a₁ →* a₂ → Π k₁ a₁ →* Π k₂ a₂
  →*-Π {a₁ = a₁} k₁→*k₂ a₁→*a₂ =
    O.trans (gmap (flip Π a₁) (λ j→k → Π₁ j→k a₁) k₁→*k₂)
            (gmap (Π _) (Π₂ _) a₁→*a₂)

  →*-⇒ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
         a₁ →* a₂ → b₁ →* b₂ → a₁ ⇒ b₁ →* a₂ ⇒ b₂
  →*-⇒ {b₁ = b₁} a₁→*a₂ b₁→*b₂ =
    O.trans (gmap (_⇒ b₁) (_⇒₁ b₁) a₁→*a₂) (gmap (_ ⇒_) (_ ⇒₂_) b₁→*b₂)

  →*-Λ : ∀ {n} {k₁ k₂ : Kind Term n} {a₁ a₂} →
         k₁ Kd→* k₂ → a₁ →* a₂ → Λ k₁ a₁ →* Λ k₂ a₂
  →*-Λ {a₁ = a₁} k₁→*k₂ a₁→*a₂ =
    O.trans (gmap (flip Λ a₁) (λ j→k → Λ₁ j→k a₁) k₁→*k₂)
            (gmap (Λ _) (Λ₂ _) a₁→*a₂)

  →*-ƛ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
         a₁ →* a₂ → b₁ →* b₂ → ƛ a₁ b₁ →* ƛ a₂ b₂
  →*-ƛ {b₁ = b₁} a₁→*a₂ b₁→*b₂ =
    O.trans (gmap (flip ƛ b₁) (flip ƛ₁ b₁) a₁→*a₂) (gmap (ƛ _) (ƛ₂ _) b₁→*b₂)

  →*-· : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
         a₁ →* a₂ → b₁ →* b₂ → a₁ · b₁ →* a₂ · b₂
  →*-· {b₁ = b₁} a₁→*a₂ b₁→*b₂ =
    O.trans (gmap (_· b₁) (_·₁ b₁) a₁→*a₂) (gmap (_ ·_) (_ ·₂_) b₁→*b₂)

  →*-⊡ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
         a₁ →* a₂ → b₁ →* b₂ → a₁ ⊡ b₁ →* a₂ ⊡ b₂
  →*-⊡ {b₁ = b₁} a₁→*a₂ b₁→*b₂ =
    O.trans (gmap (_⊡ b₁) (_⊡₁ b₁) a₁→*a₂) (gmap (_ ⊡_) (_ ⊡₂_) b₁→*b₂)

  Kd→*-⋯ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
         a₁ →* a₂ → b₁ →* b₂ → a₁ ⋯ b₁ Kd→* a₂ ⋯ b₂
  Kd→*-⋯ {b₁ = b₁} a₁→*a₂ b₁→*b₂ =
    OK.trans (gmap (_⋯ b₁) (_⋯₁ b₁) a₁→*a₂) (gmap (_ ⋯_) (_ ⋯₂_) b₁→*b₂)

  Kd→*-Π : ∀ {n} {j₁ j₂ : Kind Term n} {k₁ k₂} →
         j₁ Kd→* j₂ → k₁ Kd→* k₂ → Π j₁ k₁ Kd→* Π j₂ k₂
  Kd→*-Π {k₁ = k₁} j₁→*j₂ k₁→*k₂ =
    OK.trans (gmap (flip Π k₁) (λ j→k → Π₁ j→k k₁) j₁→*j₂)
             (gmap (Π _) (Π₂ _) k₁→*k₂)

  →*-⌞∙⌟₁ : ∀ {n} {a₁ a₂ : Term n} → a₁ →* a₂ → ∀ bs → a₁ ⌞∙⌟ bs →* a₂ ⌞∙⌟ bs
  →*-⌞∙⌟₁ a₁→*a₂ bs = gmap (_⌞∙⌟ bs) (flip →1-⌞∙⌟₁ bs) a₁→*a₂

  -- Congruence lemmas for equivalences closures.

  ↔-Π : ∀ {n} {k₁ k₂ : Kind Term n} {a₁ a₂} →
        k₁ Kd↔ k₂ → a₁ ↔ a₂ → Π k₁ a₁ ↔ Π k₂ a₂
  ↔-Π {a₁ = a₁} k₁↔k₂ a₁↔a₂ =
    S.trans (EqClos.gmap (flip Π a₁) (λ j→k → Π₁ j→k a₁) k₁↔k₂)
            (EqClos.gmap (Π _)       (Π₂ _)              a₁↔a₂)

  ↔-⇒ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
        a₁ ↔ a₂ → b₁ ↔ b₂ → a₁ ⇒ b₁ ↔ a₂ ⇒ b₂
  ↔-⇒ {b₁ = b₁} a₁↔a₂ b₁↔b₂ =
    S.trans (EqClos.gmap (_⇒ b₁) (_⇒₁ b₁) a₁↔a₂)
            (EqClos.gmap (_ ⇒_)  (_ ⇒₂_)  b₁↔b₂)

  ↔-Λ : ∀ {n} {k₁ k₂ : Kind Term n} {a₁ a₂} →
        k₁ Kd↔ k₂ → a₁ ↔ a₂ → Λ k₁ a₁ ↔ Λ k₂ a₂
  ↔-Λ {a₁ = a₁} k₁↔k₂ a₁↔a₂ =
    S.trans (EqClos.gmap (flip Λ a₁) (λ j→k → Λ₁ j→k a₁) k₁↔k₂)
            (EqClos.gmap (Λ _)       (Λ₂ _)              a₁↔a₂)

  ↔-ƛ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
        a₁ ↔ a₂ → b₁ ↔ b₂ → ƛ a₁ b₁ ↔ ƛ a₂ b₂
  ↔-ƛ {b₁ = b₁} a₁↔a₂ b₁↔b₂ =
    S.trans (EqClos.gmap (flip ƛ b₁) (flip ƛ₁ b₁) a₁↔a₂)
            (EqClos.gmap (ƛ _)       (ƛ₂ _)       b₁↔b₂)

  ↔-· : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
        a₁ ↔ a₂ → b₁ ↔ b₂ → a₁ · b₁ ↔ a₂ · b₂
  ↔-· {b₁ = b₁} a₁↔a₂ b₁↔b₂ =
    S.trans (EqClos.gmap (_· b₁) (_·₁ b₁) a₁↔a₂)
            (EqClos.gmap (_ ·_)  (_ ·₂_)  b₁↔b₂)

  ↔-⊡ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
        a₁ ↔ a₂ → b₁ ↔ b₂ → a₁ ⊡ b₁ ↔ a₂ ⊡ b₂
  ↔-⊡ {b₁ = b₁} a₁↔a₂ b₁↔b₂ =
    S.trans (EqClos.gmap (_⊡ b₁) (_⊡₁ b₁) a₁↔a₂)
            (EqClos.gmap (_ ⊡_)  (_ ⊡₂_)  b₁↔b₂)

  Kd↔-⋯ : ∀ {n} {a₁ a₂ : Term n} {b₁ b₂} →
          a₁ ↔ a₂ → b₁ ↔ b₂ → a₁ ⋯ b₁ Kd↔ a₂ ⋯ b₂
  Kd↔-⋯ {b₁ = b₁} a₁↔a₂ b₁↔b₂ =
    SK.trans (EqClos.gmap (_⋯ b₁) (_⋯₁ b₁) a₁↔a₂)
             (EqClos.gmap (_ ⋯_)  (_ ⋯₂_)  b₁↔b₂)

  Kd↔-Π : ∀ {n} {j₁ j₂ : Kind Term n} {k₁ k₂} →
          j₁ Kd↔ j₂ → k₁ Kd↔ k₂ → Π j₁ k₁ Kd↔ Π j₂ k₂
  Kd↔-Π {k₁ = k₁} j₁↔j₂ k₁↔k₂ =
    SK.trans (EqClos.gmap (flip Π k₁) (λ j→k → Π₁ j→k k₁) j₁↔j₂)
             (EqClos.gmap (Π _)       (Π₂ _)              k₁↔k₂)

  ↔-⌞∙⌟₁ : ∀ {n} {a₁ a₂ : Term n} → a₁ ↔ a₂ → ∀ bs → a₁ ⌞∙⌟ bs ↔ a₂ ⌞∙⌟ bs
  ↔-⌞∙⌟₁ a₁↔a₂ bs = EqClos.gmap (_⌞∙⌟ bs) (flip →1-⌞∙⌟₁ bs) a₁↔a₂

open CongLemmas BetaCont public renaming
  ( →1-⌞∙⌟₁ to →β-⌞∙⌟₁
  ; →*-Π    to →β*-Π
  ; →*-⇒    to →β*-⇒
  ; →*-Λ    to →β*-Λ
  ; →*-ƛ    to →β*-ƛ
  ; →*-·    to →β*-·
  ; →*-⊡    to →β*-⊡
  ; Kd→*-⋯  to Kd→β*-⋯
  ; Kd→*-Π  to Kd→β*-Π
  ; →*-⌞∙⌟₁ to →β*-⌞∙⌟₁
  ; ↔-Π     to ≡β-Π
  ; ↔-⇒     to ≡β-⇒
  ; ↔-Λ     to ≡β-Λ
  ; ↔-ƛ     to ≡β-ƛ
  ; ↔-·     to ≡β-·
  ; ↔-⊡     to ≡β-⊡
  ; Kd↔-⋯   to Kd≡β-⋯
  ; Kd↔-Π   to Kd≡β-Π
  ; ↔-⌞∙⌟₁  to ≡β-⌞∙⌟₁
  )


module _ where

open import Common.Prelude
open import Common.Reflection

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x _ = x

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

first : Tactic
first = give (def (quote const) [])

second : Tactic
second = give (def (quote const) (arg (argInfo visible relevant) (def (quote id) []) ∷ []))

number : Nat
number = unquote first 6 false

boolean : Bool
boolean = unquote second 5 true


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

module Light.Implementation.Relation.Decidable where

open import Light.Variable.Levels
open import Light.Variable.Sets
open import Light.Library.Relation.Decidable using (Library ; Dependencies)
open import Light.Library.Data.Empty as Empty using (Empty)
open import Light.Library.Data.Unit as Unit using (Unit ; unit)
open import Light.Library.Data.Both as Both using (Both)
import Light.Library.Data.Product as Product
open import Light.Library.Data.These as These using (These)
import Light.Implementation.Data.Empty
import Light.Implementation.Data.Unit
import Light.Implementation.Data.Product
import Light.Implementation.Data.These
import Light.Package

instance dependencies : Dependencies
dependencies = record {}

instance library : Library dependencies
library = record
      {
            Implementation ;
            to‐witness = λ ⦃ a ⦄ → Implementation.to‐witness a ;
            to‐false‐witness = λ ⦃ a ⦄ → Implementation.to‐false‐witness a ;
            from‐witness = λ ⦃ a ⦄ → Implementation.from‐witness a ;
            from‐false‐witness = λ ⦃ a ⦄ → Implementation.from‐false‐witness a
      }
      where
      module Implementation where
            open import Light.Implementation.Relation.Sets using (base) public

            data Decidable (𝕒 : Set ℓ) : Set ℓ where
                  yes : 𝕒 → Decidable 𝕒
                  no : (𝕒 → Empty) → Decidable 𝕒

            module Style where
                  true : Decidable Unit
                  true = yes unit

                  false : Decidable Empty
                  false = no λ a → a

                  ¬_ : Decidable 𝕒 → Decidable (𝕒 → Empty)
                  ¬ yes a = no λ f → f a
                  ¬ no a = yes a

                  _∧_ : ∀ {𝕒 : Set aℓ} {𝕓 : Set bℓ} (a? : Decidable 𝕒) (b? : Decidable 𝕓) → Decidable (Both 𝕒 𝕓)
                  yes a ∧ yes b = yes (Both.both a b)
                  no f ∧ _ = no λ both → f (Both.first both)
                  _ ∧ no f = no λ both → f (Both.second both)

                  _∨_ : ∀ {𝕒 : Set aℓ} {𝕓 : Set bℓ} (a? : Decidable 𝕒) (b? : Decidable 𝕓) → Decidable (These 𝕒 𝕓)
                  no af ∨ no bf = no {!!}
                  yes a ∨ yes b = yes (These.these a b)
                  yes a ∨ no _ = yes (These.this a)
                  no _ ∨ yes b = yes (These.that b)

                  _⇢_ : ∀ {𝕒 : Set aℓ} {𝕓 : Set bℓ} (a? : Decidable 𝕒) (b? : Decidable 𝕓) → Decidable (𝕒 → 𝕓)
                  _ ⇢ yes b = yes λ _ → b
                  no af ⇢ _ = yes λ a → Empty.eliminate (af a)
                  yes a ⇢ no bf = no λ f → bf (f a)

                  True False : Decidable 𝕒 → Set

                  True (yes _) = Unit
                  True (no _) = Empty
                  False a? = True (¬ a?)

            style = record { Style }

            if′_then_else_ : Decidable 𝕒 → 𝕓 → 𝕓 → 𝕓
            if′ yes _ then a else _ = a
            if′ no _ then _ else a = a

            if_then_else_ :
                  ∀ (a : Decidable 𝕒)
                  → (∀ ⦃ witness : 𝕒 ⦄ → 𝕓)
                  → (∀ ⦃ witness : 𝕒 → Empty ⦄ → 𝕓)
                  → 𝕓
            if yes w then a else _ = a ⦃ witness = w ⦄
            if no w then _ else a = a ⦃ witness = w ⦄

            to‐witness : ∀ {a? : Decidable 𝕒} → Style.True a? → 𝕒
            to‐false‐witness : ∀ {a? : Decidable 𝕒} → Style.False a? → 𝕒 → Empty

            from‐witness : ∀ {a? : Decidable 𝕒} → 𝕒 → Style.True a?
            from‐false‐witness : ∀ {a? : Decidable 𝕒} → (𝕒 → Empty) → Style.False a?

            to‐witness {a? = yes a} _ = a
            to‐false‐witness {a? = no f} _ = f

            from‐witness {a? = yes a} _ = _
            from‐witness {a? = no f} w = f w
            from‐false‐witness {a? = no f} _ = _
            from‐false‐witness {a? = yes a} w = w a


module TelescopingLet3 where

module Star where
  ★ : Set₁
  ★ = Set

  ★₁ : Set₂
  ★₁ = Set₁

module MEndo (open Star) (A : ★) where
  Endo = A → A

-- at this point, ★ should no longer be in scope

data D3 (open Star using (★₁)) : ★₁ where
  c : (A : ★) → D3
-- ★₁ is in scope
-- ★ is not in scope since it was not brought in scope
-- (not included in the using ())


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

module TypeEquivEquiv where

open import Equiv
  using (refl∼; sym∼; trans∼; sym≃;
    _⊎≃_; id≃; _≃_; _●_; _×≃_; qinv; gg;
    β⊎₁; β⊎₂; β₁; β₂; cong∘l; cong∘r; cong₂∘; β×₁; β×₂)
open import TypeEquiv
  using (unite₊equiv; uniti₊equiv; unite₊′equiv; uniti₊′equiv;
    assocr₊equiv; assocl₊equiv; swap₊equiv;
    unite⋆equiv; uniti⋆equiv; unite⋆′equiv; uniti⋆′equiv;
    assocr⋆equiv; assocl⋆equiv; swap⋆equiv;
    distlequiv; factorlequiv; distequiv; factorequiv;
    distzrequiv; factorzrequiv; distzequiv; factorzequiv)
open import EquivEquiv

open import Data.Empty using (⊥)
open import Data.Unit using (⊤)
open import Data.Sum using (_⊎_)
open import Data.Product using (_,_; _×_; proj₁)
open import Function using (_∘_)

open import Data.Sum.Properties2
  using (id⊎id∼id; ⊎∘∼∘⊎; _⊎∼_;
    unite₊-coh; uniti₊-coh; unite₊′-coh; uniti₊′-coh;
    assocr₊-wf; assocl₊-wf;
    triangle⊎-left; triangle⊎-right;
    pentagon⊎-right; pentagon⊎-left;
    swap₊-coh; unite₊-swap-coh-left; unite₊-swap-coh-right;
    hexagon⊎-right; hexagon⊎-left)

open import Data.Product.Properties2
  using (id×id∼id; ×∘∼∘×; _×∼_;
    unite⋆-coh; uniti⋆-coh; unite⋆′-coh; uniti⋆′-coh;
    assocr⋆-wf; assocl⋆-wf;
    triangle×-left; triangle×-right;
    pentagon×-right; pentagon×-left;
    swap⋆-coh;  unite⋆-swap-coh-left; unite⋆-swap-coh-right;
    hexagon×-right; hexagon×-left)

open import Data.SumProd.Properties -- TODO: list them

-- some local abbreviations to make life nicer
infixr 10 _⊙_

private
  _⊙_ = trans∼
  !_ = sym∼

-- we define all the equivalences-between-equivalences that hold
-- between type equivalences.

-- TODO: quite possibly, everything here should be abstract, as
-- it shouldn't be useful to look into the structure of the proofs,
-- but just that they do, indeed exist.  That and the proofs are in
-- fact rather boring, consisting of explicit sequences of
-- unveil --> delegate to lower level -> veil
-- operations.
----
-- equivalences for the ⊎ structure

[id,id]≋id : ∀ {A B : Set} → id≃ {A = A} ⊎≃ id≃ {A = B} ≋ id≃
[id,id]≋id = eq (β⊎₁ ⊙ id⊎id∼id) (β⊎₂ ⊙ id⊎id∼id)

-- ● and ⊎≃ commute.

⊎●≋●⊎ : {A B C D E F : Set} →
  {f : A ≃ C} {g : B ≃ D} {h : C ≃ E} {i : D ≃ F} →
  (h ● f) ⊎≃ (i ● g) ≋ (h ⊎≃ i) ● (f ⊎≃ g)
⊎●≋●⊎ =
  eq (β⊎₁ ⊙ β₁ ⊎∼ β₁ ⊙ ⊎∘∼∘⊎ ⊙ ! cong₂∘ β⊎₁ β⊎₁ ⊙ ! β₁)
     (β⊎₂ ⊙ β₂ ⊎∼ β₂ ⊙ ⊎∘∼∘⊎ ⊙ ! cong₂∘ β⊎₂ β⊎₂ ⊙ ! β₂)

-- ≋ has, predictably, an additive structure as well

_⊎≋_ : {A B C D : Set} {f h : A ≃ B} {g i : C ≃ D} → f ≋ h → g ≋ i →
  f ⊎≃ g ≋ h ⊎≃ i
f≋h ⊎≋ g≋i =
  eq (β⊎₁ ⊙ (f≡ f≋h) ⊎∼ (f≡ g≋i) ⊙ ! β⊎₁)
     (β⊎₂ ⊙ (g≡ f≋h) ⊎∼ (g≡ g≋i) ⊙ ! β⊎₂)
  where open _≋_

-- strangely, this is not needed by Rig Category.  However, it
-- belongs to the structure of a Monoidal Groupoid (I think!  Should
-- be checked), and is quite useful on its own.

sym≃-distrib⊎ : ∀ {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  sym≃ (f ⊎≃ g) ≋ sym≃ f ⊎≃ sym≃ g
sym≃-distrib⊎ = -- note how the proof mixes ₁ and ₂ !
  eq (β⊎₂ ⊙ ! β⊎₁) (β⊎₁ ⊙ ! β⊎₂)

-- Use '-nat' to signify that operation induces a
-- natural transformation, and that the induced operation
-- satisfies the naturality condition thus encoded

unite₊-nat : ∀ {A B} {f : A ≃ B} {g : ⊥ ≃ ⊥} →
  unite₊equiv ● (g ⊎≃ f) ≋ f ● unite₊equiv
unite₊-nat {g = g} =
  eq (β₁ ⊙ cong∘l (proj₁ unite₊equiv) β⊎₁ ⊙ unite₊-coh ⊙ ! β₁)
       (β₂ ⊙ cong∘r (gg unite₊equiv) β⊎₂ ⊙ uniti₊-coh {g = gg g} ⊙ ! β₂)

uniti₊-nat : ∀ {A B} {f : A ≃ B} {g : ⊥ ≃ ⊥} →
  uniti₊equiv ● f ≋ (g ⊎≃ f) ● uniti₊equiv
uniti₊-nat {g = g} =
  eq (β₁ ⊙ ! uniti₊-coh {g = proj₁ g} ⊙ ! cong∘r (proj₁ uniti₊equiv) β⊎₁ ⊙ ! β₁)
       (β₂ ⊙ ! unite₊-coh ⊙ ! cong∘l (gg uniti₊equiv) β⊎₂ ⊙ ! β₂)

unite₊′-nat : ∀ {A B} {f : A ≃ B} {g : ⊥ ≃ ⊥} →
  unite₊′equiv ● (f ⊎≃ g) ≋ f ● unite₊′equiv
unite₊′-nat {g = g} =
  eq (β₁ ⊙ cong∘l (proj₁ unite₊′equiv) β⊎₁ ⊙ unite₊′-coh ⊙ ! β₁)
     (β₂ ⊙ cong∘r (gg unite₊′equiv) β⊎₂ ⊙ uniti₊′-coh {g = gg g} ⊙ ! β₂)

uniti₊′-nat : ∀ {A B} {f : A ≃ B} {g : ⊥ ≃ ⊥} →
  uniti₊′equiv ● f ≋ (f ⊎≃ g) ● uniti₊′equiv
uniti₊′-nat {g = g} =
  eq (β₁ ⊙ ! uniti₊′-coh {g = proj₁ g} ⊙ ! cong∘r (proj₁ uniti₊′equiv) β⊎₁ ⊙ ! β₁)
       (β₂ ⊙ ! unite₊′-coh ⊙ ! cong∘l (gg uniti₊′equiv) β⊎₂ ⊙ ! β₂)

assocr₊-nat : ∀ {A B C D E F : Set} →
  {f₀ : A ≃ D} {f₁ : B ≃ E} {f₂ : C ≃ F} →
  assocr₊equiv ● ((f₀ ⊎≃ f₁) ⊎≃ f₂) ≋ (f₀ ⊎≃ (f₁ ⊎≃ f₂)) ● assocr₊equiv
assocr₊-nat {A} {B} {C} {D} {E} {F} {f₀} {f₁} {f₂} =
  let assocrDEF = proj₁ (assocr₊equiv {D} {E} {F}) in
  let assocrABC = proj₁ (assocr₊equiv {A} {B} {C}) in
  let assoclDEF = gg (assocr₊equiv {D} {E} {F}) in
  let assoclABC = gg (assocr₊equiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l assocrDEF (β⊎₁ ⊙ (β⊎₁ ⊎∼ refl∼)) ⊙
           assocr₊-wf ⊙
           ! cong∘r assocrABC (refl∼ ⊎∼ β⊎₁) ⊙
           ! cong∘r assocrABC β⊎₁ ⊙ ! β₁)
     (β₂ ⊙ cong∘r assoclDEF (β⊎₂ {f = f₀ ⊎≃ f₁} {f₂}) ⊙
           cong∘r assoclDEF (β⊎₂ ⊎∼ refl∼) ⊙
           assocl₊-wf ⊙
          ! cong∘l assoclABC (refl∼ ⊎∼ β⊎₂) ⊙
          ! cong∘l assoclABC (β⊎₂ {f = f₀} {f₁ ⊎≃ f₂}) ⊙ ! β₂)

assocl₊-nat : ∀ {A B C D E F : Set} →
  {f₀ : A ≃ D} {f₁ : B ≃ E} {f₂ : C ≃ F} →
  assocl₊equiv ● (f₀ ⊎≃ (f₁ ⊎≃ f₂)) ≋ ((f₀ ⊎≃ f₁) ⊎≃ f₂) ● assocl₊equiv
assocl₊-nat {A} {B} {C} {D} {E} {F} {f₀} {f₁} {f₂} =
  let assoclDEF = proj₁ (assocl₊equiv {D} {E} {F}) in
  let assoclABC = proj₁ (assocl₊equiv {A} {B} {C}) in
  let assocrDEF = gg (assocl₊equiv {D} {E} {F}) in
  let assocrABC = gg (assocl₊equiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l assoclDEF β⊎₁ ⊙
           cong∘l assoclDEF (refl∼ ⊎∼ β⊎₁) ⊙
           ! assocl₊-wf ⊙
           ! cong∘r assoclABC (β⊎₁ ⊎∼ refl∼) ⊙
           ! cong∘r assoclABC β⊎₁ ⊙ ! β₁)
     (β₂ ⊙ cong∘r assocrDEF (β⊎₂ {f = f₀} {f₁ ⊎≃ f₂}) ⊙
           cong∘r assocrDEF (refl∼ ⊎∼ β⊎₂) ⊙
           ! assocr₊-wf ⊙
           ! cong∘l assocrABC (β⊎₂ ⊎∼ refl∼) ⊙
           ! cong∘l assocrABC (β⊎₂ {f = f₀ ⊎≃ f₁} {f₂}) ⊙ ! β₂)

-- often called 'triangle'
unite-assocr₊-coh : ∀ {A B : Set} →
  unite₊′equiv ⊎≃ id≃ ≋ (id≃ ⊎≃ unite₊equiv) ● assocr₊equiv {A} {⊥} {B}
unite-assocr₊-coh = -- eq triangle⊎-right triangle⊎-left
  eq (β⊎₁ ⊙ triangle⊎-right ⊙ ! (β₁ ⊙ cong∘r (proj₁ assocr₊equiv) β⊎₁))
     (β⊎₂ ⊙ triangle⊎-left ⊙ ! (β₂ ⊙ cong∘l (gg assocr₊equiv) β⊎₂))

-- often called 'pentagon'
assocr₊-coh : ∀ {A B C D : Set} →
  assocr₊equiv {A} {B} {C ⊎ D} ● assocr₊equiv ≋
  (id≃ ⊎≃ assocr₊equiv) ● assocr₊equiv ● (assocr₊equiv ⊎≃ id≃)
assocr₊-coh = -- eq pentagon⊎-right pentagon⊎-left
 eq (β₁ ⊙ pentagon⊎-right ⊙
     ! (β₁ ⊙ cong₂∘ β⊎₁ β₁ ⊙
        cong∘l ((proj₁ id≃ ⊎→ proj₁ assocr₊equiv) ∘ proj₁ assocr₊equiv) β⊎₁))
    (β₂ ⊙ pentagon⊎-left ⊙
     ! (β₂ ⊙ cong₂∘ β₂ β⊎₂ ⊙
        cong∘r (gg assocr₊equiv ∘ (gg id≃ ⊎→ gg assocr₊equiv)) β⊎₂))

swap₊-nat : {A B C D : Set} {f : A ≃ C} {g : B ≃ D} →
  swap₊equiv ● (f ⊎≃ g) ≋ (g ⊎≃ f) ● swap₊equiv
swap₊-nat =
  eq (β₁ ⊙ cong∘l (proj₁ swap₊equiv) β⊎₁ ⊙ swap₊-coh ⊙
        ! (β₁ ⊙ cong∘r (proj₁ swap₊equiv) β⊎₁))
     (β₂ ⊙ cong∘r (gg swap₊equiv) β⊎₂ ⊙ sym∼ swap₊-coh ⊙
        ! (β₂ ⊙ cong∘l (gg swap₊equiv) β⊎₂))

-- also called 'triangle', but better to call it 'unit coherence'
unite₊l-coh : {A : Set} →
  unite₊equiv {A} ≋ unite₊′equiv ● swap₊equiv
unite₊l-coh =
  eq (unite₊-swap-coh-right ⊙ ! β₁) (unite₊-swap-coh-left ⊙ ! β₂)

-- often called 'hexagon'
assocr₊-swap₊-coh : ∀ {A B C : Set} →
  assocr₊equiv {B} {C} {A} ● swap₊equiv ● assocr₊equiv {A} {B} {C} ≋
  id≃ ⊎≃ swap₊equiv ● assocr₊equiv {B} {A} {C} ● swap₊equiv ⊎≃ id≃
assocr₊-swap₊-coh {A} {B} {C} = -- eq hexagon⊎-right hexagon⊎-left
  let assocrBCA = proj₁ (assocr₊equiv {B} {C} {A}) in
  let assocrABC = proj₁ (assocr₊equiv {A} {B} {C}) in
  let assocrBAC = proj₁ (assocr₊equiv {B} {A} {C}) in
  let swapAC = proj₁ id≃ ⊎→ proj₁ (swap₊equiv {A} {C}) in
  let assoclBCA = gg (assocr₊equiv {B} {C} {A}) in
  let assoclABC = gg (assocr₊equiv {A} {B} {C}) in
  let assoclBAC = gg (assocr₊equiv {B} {A} {C}) in
  let swapCA = gg id≃ ⊎→ gg (swap₊equiv {A} {C}) in
  eq (β₁ ⊙ cong∘l assocrBCA β₁ ⊙ hexagon⊎-right ⊙
      ! (β₁ ⊙ cong₂∘ β⊎₁ β₁ ⊙ cong∘l (swapAC ∘ assocrBAC) β⊎₁))
     (β₂ ⊙ cong∘r assoclBCA β₂ ⊙ hexagon⊎-left ⊙
      ! (β₂ ⊙ cong₂∘ β₂ β⊎₂ ⊙ cong∘r (assoclBAC ∘ swapCA) β⊎₂))

-- and in the opposite direction

assocl₊-swap₊-coh : ∀ {A B C : Set} →
  assocl₊equiv {A} {B} {C} ● swap₊equiv ● assocl₊equiv {B} {C} {A} ≋
  swap₊equiv ⊎≃ id≃ ● assocl₊equiv {B} {A} {C} ● id≃ ⊎≃ swap₊equiv
assocl₊-swap₊-coh {A} {B} {C} = -- eq hexagon⊎-left hexagon⊎-right
  let assoclBCA = proj₁ (assocl₊equiv {B} {C} {A}) in
  let assoclABC = proj₁ (assocl₊equiv {A} {B} {C}) in
  let assoclBAC = proj₁ (assocl₊equiv {B} {A} {C}) in
  let swapBA = proj₁ (swap₊equiv {B} {A}) ⊎→ proj₁ id≃ in
  let assocrBCA = gg (assocl₊equiv {B} {C} {A}) in
  let assocrABC = gg (assocl₊equiv {A} {B} {C}) in
  let assocrBAC = gg (assocl₊equiv {B} {A} {C}) in
  let swapAB = gg (swap₊equiv {B} {A}) ⊎→ proj₁ id≃ in
  eq (β₁ ⊙ (cong∘l assoclABC β₁ ⊙ hexagon⊎-left) ⊙
      ! (β₁ ⊙ cong₂∘ β⊎₁ β₁ ⊙ cong∘l (swapBA ∘ assoclBAC) β⊎₁))
     (β₂ ⊙ cong∘r assocrABC β₂ ⊙ hexagon⊎-right ⊙
      ! (β₂ ⊙ cong₂∘ β₂ β⊎₂ ⊙ cong∘r (assocrBAC ∘ swapAB) β⊎₂))

-- equivalences for the × structure

id×id≋id : ∀ {A B : Set} → id≃ {A = A} ×≃ id≃ {A = B} ≋ id≃
id×id≋id = eq (β×₁ ⊙ id×id∼id) (β×₂ ⊙ id×id∼id)

×●≋●× : {A B C D E F : Set} →
  {f : A ≃ C} {g : B ≃ D} {h : C ≃ E} {i : D ≃ F} →
  (h ● f) ×≃ (i ● g) ≋ (h ×≃ i) ● (f ×≃ g)
×●≋●× {f = f , qinv f⁻¹ _ _} {g , qinv g⁻¹ _ _} {h , qinv h⁻¹ _ _} {i , qinv i⁻¹ _ _} =
  eq (β×₁ ⊙ β₁ ×∼ β₁ ⊙ (×∘∼∘× {f = f} {g} {h} {i}) ⊙ ! cong₂∘ β×₁ β×₁ ⊙ ! β₁)
     (β×₂ ⊙ β₂ ×∼ β₂ ⊙ (×∘∼∘× {f = h⁻¹} {i⁻¹} {f⁻¹} {g⁻¹}) ⊙ ! cong₂∘ β×₂ β×₂ ⊙ ! β₂)

_×≋_ :  ∀ {A B C D : Set} {f g : A ≃ B} {h i : C ≃ D} →
  f ≋ g → h ≋ i → f ×≃ h ≋ g ×≃ i
e₁ ×≋ e₂ = eq (β×₁ ⊙ (f≡ e₁) ×∼ (f≡ e₂) ⊙ ! β×₁)
              (β×₂ ⊙ (g≡ e₁) ×∼ (g≡ e₂) ⊙ ! β×₂)
  where open _≋_

sym≃-distrib× : ∀ {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  sym≃ (f ×≃ g) ≋ sym≃ f ×≃ sym≃ g
sym≃-distrib× = -- note how the proof mixes ₁ and ₂ !
  eq (β×₂ ⊙ ! β×₁) (β×₁ ⊙ ! β×₂)

unite⋆-nat : ∀ {A B} {f : A ≃ B} {g : ⊤ ≃ ⊤} →
  unite⋆equiv ● (g ×≃ f) ≋ f ● unite⋆equiv
unite⋆-nat = -- eq unite⋆-coh uniti⋆-coh
  eq (β₁ ⊙ cong∘l (proj₁ unite⋆equiv) β×₁ ⊙ unite⋆-coh ⊙ ! β₁)
     (β₂ ⊙ cong∘r (gg unite⋆equiv) β×₂ ⊙ uniti⋆-coh ⊙ ! β₂)

uniti⋆-nat : ∀ {A B} {f : A ≃ B} {g : ⊤ ≃ ⊤} →
  uniti⋆equiv ● f ≋ (g ×≃ f) ● uniti⋆equiv
uniti⋆-nat = -- flip-sym≋ unite⋆-nat
  eq (β₁ ⊙ ! uniti⋆-coh ⊙ ! cong∘r (proj₁ uniti⋆equiv) β×₁ ⊙ ! β₁)
     (β₂ ⊙ ! unite⋆-coh ⊙ ! cong∘l (gg uniti⋆equiv) β×₂ ⊙ ! β₂)

unite⋆′-nat : ∀ {A B} {f : A ≃ B} {g : ⊤ ≃ ⊤} →
  unite⋆′equiv ● (f ×≃ g) ≋ f ● unite⋆′equiv
unite⋆′-nat = -- eq unite⋆′-coh uniti⋆′-coh
  eq (β₁ ⊙ cong∘l (proj₁ unite⋆′equiv) β×₁ ⊙ unite⋆′-coh ⊙ ! β₁)
     (β₂ ⊙ cong∘r (gg unite⋆′equiv) β×₂ ⊙ uniti⋆′-coh ⊙ ! β₂)

uniti⋆′-nat : ∀ {A B} {f : A ≃ B} {g : ⊤ ≃ ⊤} →
  uniti⋆′equiv ● f ≋ (f ×≃ g) ● uniti⋆′equiv
uniti⋆′-nat = -- flip-sym≋ unite⋆′-nat
  eq (β₁ ⊙ ! uniti⋆′-coh ⊙ ! cong∘r (proj₁ uniti⋆′equiv) β×₁ ⊙ ! β₁)
     (β₂ ⊙ ! unite⋆′-coh ⊙ ! cong∘l (gg uniti⋆′equiv) β×₂ ⊙ ! β₂)

assocr⋆-nat : ∀ {A B C D E F : Set} →
  {f₀ : A ≃ D} {f₁ : B ≃ E} {f₂ : C ≃ F} →
  assocr⋆equiv ● ((f₀ ×≃ f₁) ×≃ f₂) ≋ (f₀ ×≃ (f₁ ×≃ f₂)) ● assocr⋆equiv
assocr⋆-nat {A} {B} {C} {D} {E} {F} {f₀} {f₁} {f₂} = -- eq assocr⋆-wf assocl⋆-wf
  let assocrDEF = proj₁ (assocr⋆equiv {D} {E} {F}) in
  let assocrABC = proj₁ (assocr⋆equiv {A} {B} {C}) in
  let assoclDEF = gg (assocr⋆equiv {D} {E} {F}) in
  let assoclABC = gg (assocr⋆equiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l assocrDEF β×₁ ⊙
           cong∘l assocrDEF (β×₁ ×∼ refl∼) ⊙
           assocr⋆-wf ⊙
           ! cong∘r assocrABC (refl∼ ×∼ β×₁) ⊙
           ! cong∘r assocrABC β×₁ ⊙ ! β₁)
     (β₂ ⊙ cong∘r assoclDEF (β×₂ {f = f₀ ×≃ f₁} {f₂}) ⊙
           cong∘r assoclDEF (β×₂ ×∼ refl∼) ⊙
           assocl⋆-wf ⊙
          ! cong∘l assoclABC (refl∼ ×∼ β×₂) ⊙
          ! cong∘l assoclABC (β×₂ {f = f₀} {f₁ ×≃ f₂}) ⊙ ! β₂)
assocl⋆-nat : ∀ {A B C D E F : Set} →
  {f₀ : A ≃ D} {f₁ : B ≃ E} {f₂ : C ≃ F} →
  assocl⋆equiv ● (f₀ ×≃ (f₁ ×≃ f₂)) ≋ ((f₀ ×≃ f₁) ×≃ f₂) ● assocl⋆equiv
assocl⋆-nat {A} {B} {C} {D} {E} {F} {f₀} {f₁} {f₂}  = -- flip-sym≋ assocr⋆-nat
  let assoclDEF = proj₁ (assocl⋆equiv {D} {E} {F}) in
  let assoclABC = proj₁ (assocl⋆equiv {A} {B} {C}) in
  let assocrDEF = gg (assocl⋆equiv {D} {E} {F}) in
  let assocrABC = gg (assocl⋆equiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l assoclDEF β×₁ ⊙
           cong∘l assoclDEF (refl∼ ×∼ β×₁) ⊙
           ! assocl⋆-wf ⊙
           ! cong∘r assoclABC (β×₁ ×∼ refl∼) ⊙
           ! cong∘r assoclABC β×₁ ⊙ ! β₁)
     (β₂ ⊙ cong∘r assocrDEF (β×₂ {f = f₀} {f₁ ×≃ f₂}) ⊙
           cong∘r assocrDEF (refl∼ ×∼ β×₂) ⊙
           ! assocr⋆-wf ⊙
           ! cong∘l assocrABC (β×₂ ×∼ refl∼) ⊙
           ! cong∘l assocrABC (β×₂ {f = f₀ ×≃ f₁} {f₂}) ⊙ ! β₂)

-- often called 'triangle'

unite-assocr⋆-coh : ∀ {A B : Set} →
  unite⋆′equiv ×≃ id≃ ≋ (id≃ ×≃ unite⋆equiv) ● assocr⋆equiv {A} {⊤} {B}
unite-assocr⋆-coh =
  eq (β×₁ ⊙ triangle×-right ⊙ ! (β₁ ⊙ cong∘r (proj₁ assocr⋆equiv) β×₁))
     (β×₂ ⊙ triangle×-left ⊙ ! (β₂ ⊙ cong∘l (gg assocr⋆equiv) β×₂))

-- often called 'pentagon'

assocr⋆-coh : ∀ {A B C D : Set} →
  assocr⋆equiv {A} {B} {C × D} ● assocr⋆equiv ≋
  (id≃ ×≃ assocr⋆equiv) ● assocr⋆equiv ● (assocr⋆equiv ×≃ id≃)
assocr⋆-coh =
 eq (β₁ ⊙ pentagon×-right ⊙
     ! (β₁ ⊙ cong₂∘ β×₁ β₁ ⊙
        cong∘l ((proj₁ id≃ ×→ proj₁ assocr⋆equiv) ∘ proj₁ assocr⋆equiv) β×₁))
    (β₂ ⊙ pentagon×-left ⊙
     ! (β₂ ⊙ cong₂∘ β₂ β×₂ ⊙
        cong∘r (gg assocr⋆equiv ∘ (gg id≃ ×→ gg assocr⋆equiv)) β×₂))

swap⋆-nat : {A B C D : Set} {f : A ≃ C} {g : B ≃ D} →
  swap⋆equiv ● (f ×≃ g) ≋ (g ×≃ f) ● swap⋆equiv
swap⋆-nat =
  eq (β₁ ⊙ cong∘l (proj₁ swap⋆equiv) β×₁ ⊙ swap⋆-coh ⊙
        ! (β₁ ⊙ cong∘r (proj₁ swap⋆equiv) β×₁))
     (β₂ ⊙ cong∘r (gg swap⋆equiv) β×₂ ⊙ sym∼ swap⋆-coh ⊙
        ! (β₂ ⊙ cong∘l (gg swap⋆equiv) β×₂))

-- also called 'triangle', but better to call it 'unit coherence'
unite⋆l-coh : {A : Set} →
  unite⋆equiv {A} ≋ unite⋆′equiv ● swap⋆equiv
unite⋆l-coh =
  eq (unite⋆-swap-coh-right ⊙ ! β₁) (unite⋆-swap-coh-left ⊙ ! β₂)

-- often called 'hexagon'

assocr⋆-swap⋆-coh : ∀ {A B C : Set} →
  assocr⋆equiv {B} {C} {A} ● swap⋆equiv ● assocr⋆equiv {A} {B} {C} ≋
  id≃ ×≃ swap⋆equiv ● assocr⋆equiv {B} {A} {C} ● swap⋆equiv ×≃ id≃
assocr⋆-swap⋆-coh {A} {B} {C} =
  let assocrBCA = proj₁ (assocr⋆equiv {B} {C} {A}) in
  let assocrABC = proj₁ (assocr⋆equiv {A} {B} {C}) in
  let assocrBAC = proj₁ (assocr⋆equiv {B} {A} {C}) in
  let swapAC = proj₁ id≃ ×→ proj₁ (swap⋆equiv {A} {C}) in
  let assoclBCA = gg (assocr⋆equiv {B} {C} {A}) in
  let assoclABC = gg (assocr⋆equiv {A} {B} {C}) in
  let assoclBAC = gg (assocr⋆equiv {B} {A} {C}) in
  let swapCA = gg id≃ ×→ gg (swap⋆equiv {A} {C}) in
  eq (β₁ ⊙ cong∘l assocrBCA β₁ ⊙ hexagon×-right ⊙
      ! (β₁ ⊙ cong₂∘ β×₁ β₁ ⊙ cong∘l (swapAC ∘ assocrBAC) β×₁))
     (β₂ ⊙ cong∘r assoclBCA β₂ ⊙ hexagon×-left ⊙
      ! (β₂ ⊙ cong₂∘ β₂ β×₂ ⊙ cong∘r (assoclBAC ∘ swapCA) β×₂))

-- and in the opposite direction

assocl⋆-swap⋆-coh : ∀ {A B C : Set} →
  assocl⋆equiv {A} {B} {C} ● swap⋆equiv ● assocl⋆equiv {B} {C} {A} ≋
  swap⋆equiv ×≃ id≃ ● assocl⋆equiv {B} {A} {C} ● id≃ ×≃ swap⋆equiv
assocl⋆-swap⋆-coh {A} {B} {C} =
  let assoclBCA = proj₁ (assocl⋆equiv {B} {C} {A}) in
  let assoclABC = proj₁ (assocl⋆equiv {A} {B} {C}) in
  let assoclBAC = proj₁ (assocl⋆equiv {B} {A} {C}) in
  let swapBA = proj₁ (swap⋆equiv {B} {A}) ×→ proj₁ id≃ in
  let assocrBCA = gg (assocl⋆equiv {B} {C} {A}) in
  let assocrABC = gg (assocl⋆equiv {A} {B} {C}) in
  let assocrBAC = gg (assocl⋆equiv {B} {A} {C}) in
  let swapAB = gg (swap⋆equiv {B} {A}) ×→ proj₁ id≃ in
  eq (β₁ ⊙ (cong∘l assoclABC β₁ ⊙ hexagon×-left) ⊙
      ! (β₁ ⊙ cong₂∘ β×₁ β₁ ⊙ cong∘l (swapBA ∘ assoclBAC) β×₁))
     (β₂ ⊙ cong∘r assocrABC β₂ ⊙ hexagon×-right ⊙
      ! (β₂ ⊙ cong₂∘ β₂ β×₂ ⊙ cong∘r (assocrBAC ∘ swapAB) β×₂))

-- distributivity

distl-nat : {A B C D E F : Set} →
  {f : A ≃ D} {g : B ≃ E} {h : C ≃ F} →
  distlequiv ● (f ×≃ (g ⊎≃ h)) ≋ ((f ×≃ g) ⊎≃ (f ×≃ h)) ● distlequiv
distl-nat {A} {B} {C} {D} {E} {F} {f} {g} {h} = -- eq distl-coh factorl-coh
  let distlDEF = proj₁ (distlequiv {D} {E} {F}) in
  let distlABC = proj₁ (distlequiv {A} {B} {C}) in
  let factorlDEF = gg (distlequiv {D} {E} {F}) in
  let factorlABC = gg (distlequiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l distlDEF (β×₁ ⊙ (refl∼ ×∼ β⊎₁)) ⊙
      distl-coh ⊙
      ! (β₁ ⊙ cong∘r distlABC (β⊎₁ ⊙ (β×₁ ⊎∼ β×₁))))
      --
     (β₂ ⊙ cong∘r factorlDEF (β×₂ {f = f} {g ⊎≃ h} ⊙ (refl∼ ×∼ β⊎₂)) ⊙
      factorl-coh ⊙
      ! (β₂ ⊙ cong∘l factorlABC (β⊎₂ {f = f ×≃ g} {f ×≃ h} ⊙ (β×₂ ⊎∼ β×₂))))

factorl-nat : {A B C D E F : Set} →
  {f : A ≃ D} {g : B ≃ E} {h : C ≃ F} →
   factorlequiv ● ((f ×≃ g) ⊎≃ (f ×≃ h)) ≋ (f ×≃ (g ⊎≃ h)) ● factorlequiv
factorl-nat {A} {B} {C} {D} {E} {F} {f} {g} {h} = -- flip-sym≋ distl-nat
  let factorlDEF = proj₁ (factorlequiv {D} {E} {F}) in
  let factorlABC = proj₁ (factorlequiv {A} {B} {C}) in
  let distlDEF = gg (factorlequiv {D} {E} {F}) in
  let distlABC = gg (factorlequiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l factorlDEF (β⊎₁ ⊙ (β×₁ ⊎∼ β×₁)) ⊙
      sym∼ factorl-coh ⊙
      ! (β₁ ⊙ cong∘r factorlABC (β×₁ ⊙ (refl∼ ×∼ β⊎₁)) ))
     --
     (β₂ ⊙ cong∘r distlDEF (β⊎₂ {f = f ×≃ g} {f ×≃ h} ⊙ (β×₂ ⊎∼ β×₂)) ⊙
     sym∼ distl-coh ⊙
     ! (β₂ ⊙ cong∘l distlABC (β×₂ {f = f} {g ⊎≃ h} ⊙ (refl∼ ×∼ β⊎₂))))

dist-nat : {A B C D E F : Set} →
  {f : A ≃ D} {g : B ≃ E} {h : C ≃ F} →
  distequiv ● ((f ⊎≃ g) ×≃ h) ≋ ((f ×≃ h) ⊎≃ (g ×≃ h)) ● distequiv
dist-nat {A} {B} {C} {D} {E} {F} {f} {g} {h} = -- eq dist-coh factor-coh
  let distDEF = proj₁ (distequiv {D} {E} {F}) in
  let distABC = proj₁ (distequiv {A} {B} {C}) in
  let factorDEF = gg (distequiv {D} {E} {F}) in
  let factorABC = gg (distequiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l distDEF (β×₁ ⊙ (β⊎₁ ×∼ refl∼)) ⊙
      dist-coh ⊙
      ! (β₁ ⊙ cong∘r distABC (β⊎₁ ⊙ (β×₁ ⊎∼ β×₁))))
      --
     (β₂ ⊙ cong∘r factorDEF (β×₂ {f = f ⊎≃ g} {h} ⊙ (β⊎₂ ×∼ refl∼)) ⊙
      factor-coh ⊙
      ! (β₂ ⊙ cong∘l factorABC (β⊎₂ {f = f ×≃ h} {g ×≃ h} ⊙ (β×₂ ⊎∼ β×₂))))

factor-nat : {A B C D E F : Set} →
  {f : A ≃ D} {g : B ≃ E} {h : C ≃ F} →
  factorequiv ● ((f ×≃ h) ⊎≃ (g ×≃ h)) ≋ ((f ⊎≃ g) ×≃ h) ● factorequiv
factor-nat {A} {B} {C} {D} {E} {F} {f} {g} {h} = -- flip-sym≋ dist-nat
  let factorDEF = proj₁ (factorequiv {D} {E} {F}) in
  let factorABC = proj₁ (factorequiv {A} {B} {C}) in
  let distDEF = gg (factorequiv {D} {E} {F}) in
  let distABC = gg (factorequiv {A} {B} {C}) in
  eq (β₁ ⊙ cong∘l factorDEF (β⊎₁ ⊙ (β×₁ ⊎∼ β×₁)) ⊙
      sym∼ factor-coh ⊙
      ! (β₁ ⊙ cong∘r factorABC (β×₁ ⊙ (β⊎₁ ×∼ refl∼)) ))
     --
     (β₂ ⊙ cong∘r distDEF (β⊎₂ {f = f ×≃ h} {g ×≃ h} ⊙ (β×₂ ⊎∼ β×₂)) ⊙
     sym∼ dist-coh ⊙
     ! (β₂ ⊙ cong∘l distABC (β×₂ {f = f ⊎≃ g} {h} ⊙ (β⊎₂ ×∼ refl∼))))

-- note how we don't use id≃ but an arbitrary ⊥ ≃ ⊥.
-- because this law under-specifies f and g, we need to
-- be explicit in our calls

distzr-nat : {A B : Set} → {f : A ≃ B} → {g : ⊥ ≃ ⊥} →
  distzrequiv ● (f ×≃ g) ≋ g ● distzrequiv
distzr-nat {f = (f , qinv h _ _)} {(_ , qinv g _ _)} =
  -- eq (distzr-coh {f = f}) (factorzr-coh {f = h} {g})
  eq (β₁ ⊙ cong∘l (proj₁ distzrequiv) β×₁ ⊙ distzr-coh {f = f} ⊙ ! β₁)
     (β₂ ⊙ cong∘r (gg distzrequiv) β×₂ ⊙ factorzr-coh {f = h} {g} ⊙ ! β₂)

factorzr-nat : {A B : Set} → {f : A ≃ B} → {g : ⊥ ≃ ⊥} →
  factorzrequiv ● g ≋ (f ×≃ g) ● factorzrequiv
factorzr-nat {f = f , qinv f⁻¹ _ _} {g , _} = -- flip-sym≋ (distzr-nat {f = sym≃ f})
  eq (β₁ ⊙ sym∼ (factorzr-coh {f = f} {g}) ⊙
     ! (β₁ ⊙ cong∘r (proj₁ factorzrequiv) β×₁) )
     --
     (β₂ ⊙ sym∼ (distzr-coh {f = f⁻¹}) ⊙
     ! (β₂ ⊙ cong∘l (gg factorzrequiv) β×₂))

-- same comment as above

distz-nat : {A B : Set} → {f : A ≃ B} → {g : ⊥ ≃ ⊥} →
  distzequiv ● (g ×≃ f) ≋ g ● distzequiv
distz-nat {f = (f , qinv h _ _)} {(_ , qinv g _ _)} =
  eq (β₁ ⊙ cong∘l (proj₁ distzequiv) β×₁ ⊙ distz-coh {f = f} ⊙ ! β₁)
     (β₂ ⊙ cong∘r (gg distzequiv) β×₂ ⊙ factorz-coh {f = h} {g} ⊙ ! β₂)

factorz-nat : {A B : Set} → {f : A ≃ B} → {g : ⊥ ≃ ⊥} →
  factorzequiv ● g ≋ (g ×≃ f) ● factorzequiv
factorz-nat {f = (f , qinv f⁻¹ _ _)} {g , _} =
  eq (β₁ ⊙ (sym∼ (factorz-coh {f = f} {g})) ⊙
        ! (β₁ ⊙ cong∘r (proj₁ factorzequiv) β×₁))
     (β₂ ⊙ (sym∼ (distz-coh {f = f⁻¹})) ⊙ ! (β₂ ⊙ cong∘l (gg factorzequiv) β×₂))

-- some equivalences for which there are two 'obvious'
-- programs, but are in fact equivalent.  Named after
-- the types which are witnessed to be equivalent.

A×[B⊎C]≃[A×C]⊎[A×B] : {A B C : Set} →
  distlequiv ● (id≃ {A = A} ×≃ swap₊equiv {B} {C}) ≋ swap₊equiv ● distlequiv
A×[B⊎C]≃[A×C]⊎[A×B] = -- eq A×[B⊎C]→[A×C]⊎[A×B] [A×C]⊎[A×B]→A×[B⊎C]
  eq (β₁ ⊙ cong∘l (proj₁ distlequiv) β×₁ ⊙ A×[B⊎C]→[A×C]⊎[A×B] ⊙ ! β₁)
     (β₂ ⊙ cong∘r (gg distlequiv) β×₂ ⊙ [A×C]⊎[A×B]→A×[B⊎C] ⊙ ! β₂)

[A⊎B]×C≃[C×A]⊎[C×B] : {A B C : Set} →
  (swap⋆equiv ⊎≃ swap⋆equiv) ● distequiv ≋ distlequiv ● swap⋆equiv {A ⊎ B} {C}
[A⊎B]×C≃[C×A]⊎[C×B] = -- eq [A⊎B]×C→[C×A]⊎[C×B] [C×A]⊎[C×B]→[A⊎B]×C
  eq (β₁ ⊙ cong∘r (proj₁ distequiv) β⊎₁ ⊙ [A⊎B]×C→[C×A]⊎[C×B] ⊙ ! β₁)
     (β₂ ⊙ cong∘l (gg distequiv) β⊎₂ ⊙ [C×A]⊎[C×B]→[A⊎B]×C ⊙ ! β₂)

[A⊎B⊎C]×D≃[A×D⊎B×D]⊎C×D : {A B C D : Set} →
  (distequiv ⊎≃ id≃) ● distequiv ● (assocl₊equiv {A} {B} {C} ×≃ id≃ {A = D}) ≋
  assocl₊equiv ● (id≃ ⊎≃ distequiv) ● distequiv
[A⊎B⊎C]×D≃[A×D⊎B×D]⊎C×D = -- eq [A⊎B⊎C]×D→[A×D⊎B×D]⊎C×D [A×D⊎B×D]⊎C×D→[A⊎B⊎C]×D
  eq (β₁ ⊙ cong₂∘ β⊎₁ (β₁ ⊙ cong∘l (proj₁ distequiv) β×₁) ⊙
      [A⊎B⊎C]×D→[A×D⊎B×D]⊎C×D ⊙
      ! (β₁ ⊙ cong∘l (proj₁ assocl₊equiv) (β₁ ⊙ cong∘r (proj₁ distequiv) β⊎₁)))
      --
     (β₂ ⊙ cong₂∘ (β₂ ⊙ cong∘r (gg distequiv) β×₂) β⊎₂ ⊙
      [A×D⊎B×D]⊎C×D→[A⊎B⊎C]×D ⊙
      ! (β₂ ⊙ cong∘r (gg assocl₊equiv) (β₂ ⊙ cong∘l (gg distequiv) β⊎₂)))

A×B×[C⊎D]≃[A×B]×C⊎[A×B]×D : {A B C D : Set} →
  distlequiv ● assocl⋆equiv {A} {B} {C ⊎ D} ≋
  (assocl⋆equiv ⊎≃ assocl⋆equiv) ● distlequiv ● (id≃ ×≃ distlequiv)
A×B×[C⊎D]≃[A×B]×C⊎[A×B]×D =
  eq (β₁ ⊙ A×B×[C⊎D]→[A×B]×C⊎[A×B]×D ⊙
      ! (β₁ ⊙ cong₂∘ β⊎₁ (β₁ ⊙ cong∘l (proj₁ distlequiv) β×₁)))
     (β₂ ⊙ [A×B]×C⊎[A×B]×D→A×B×[C⊎D] ⊙
      ! (β₂ ⊙ cong₂∘ (β₂ ⊙ cong∘r (gg distlequiv) β×₂) β⊎₂))

0×0≃0 : distzequiv ≋ distzrequiv
0×0≃0 = eq 0×0→0 0→0×0

0×[A⊎B]≃0 : {A B : Set} →
  distzequiv ≋ unite₊equiv ● (distzequiv ⊎≃ distzequiv) ● distlequiv {⊥} {A} {B}
0×[A⊎B]≃0 =
  eq (0×[A⊎B]→0 ⊙
      ! (β₁ ⊙ cong∘l (proj₁ unite₊equiv) (β₁ ⊙ cong∘r (proj₁ distlequiv) β⊎₁)))
     (0→0×[A⊎B] ⊙
     ! (β₂ ⊙ cong∘r (gg unite₊equiv) (β₂ ⊙ cong∘l (gg distlequiv) β⊎₂)))

0×1≃0 : unite⋆′equiv  ≋ distzequiv
0×1≃0 = eq 0×1→0 0→0×1

A×0≃0 : {A : Set} → distzrequiv {A} ≋ distzequiv ● swap⋆equiv
A×0≃0 = eq (A×0→0 ⊙ ! β₁) (0→A×0 ⊙ ! β₂)

0×A×B≃0 : {A B : Set} →
  distzequiv ≋ distzequiv ● (distzequiv ×≃ id≃) ● assocl⋆equiv {⊥} {A} {B}
0×A×B≃0 =
  let distzB = proj₁ distzequiv in
  let factorzA = gg distzequiv in
  eq (0×A×B→0 ⊙
      ! (β₁ ⊙ cong∘l distzB (β₁ ⊙ cong∘r (proj₁ assocl⋆equiv) β×₁)))
     (0→0×A×B ⊙
       ! (β₂ ⊙ cong∘r factorzA (β₂ ⊙ cong∘l (gg assocl⋆equiv) β×₂)))

A×0×B≃0 : {A B : Set} →
  distzrequiv ● (id≃ ×≃ distzequiv)  ≋
  distzequiv ● (distzrequiv ×≃ id≃) ● assocl⋆equiv {A} {⊥} {B}
A×0×B≃0 =
  eq (β₁ ⊙ cong∘l (proj₁ distzrequiv) β×₁ ⊙ A×0×B→0 ⊙
      ! (β₁ ⊙ cong∘l (proj₁ distzequiv)
                     (β₁ ⊙ cong∘r (proj₁ assocl⋆equiv) β×₁)))
     (β₂ ⊙ cong∘r (gg distzrequiv) β×₂ ⊙  0→A×0×B ⊙
      ! (β₂ ⊙ cong∘r (gg distzequiv)
                      (β₂ ⊙ cong∘l (gg assocl⋆equiv) β×₂)))

A×[0+B]≃A×B : {A B : Set} →
  (id≃ {A = A} ×≃ unite₊equiv {B}) ≋ unite₊equiv ● (distzrequiv ⊎≃ id≃) ● distlequiv
A×[0+B]≃A×B =
  eq (β×₁ ⊙ A×[0+B]→A×B ⊙
      ! (β₁ ⊙ cong∘l (proj₁ unite₊equiv) (β₁ ⊙ cong∘r (proj₁ distlequiv) β⊎₁)))
     (β×₂ ⊙ A×B→A×[0+B] ⊙
      ! (β₂ ⊙ cong∘r (gg unite₊equiv) (β₂ ⊙ cong∘l (gg distlequiv) β⊎₂)))

1×[A⊎B]≃A⊎B : {A B : Set} →
  unite⋆equiv ≋ (unite⋆equiv ⊎≃ unite⋆equiv) ● distlequiv {⊤} {A} {B}
1×[A⊎B]≃A⊎B =
  eq (1×[A⊎B]→A⊎B ⊙ ! (β₁ ⊙ cong∘r (proj₁ distlequiv) β⊎₁))
     (A⊎B→1×[A⊎B] ⊙ ! (β₂ ⊙ cong∘l (gg distlequiv) β⊎₂))

[A⊎B]×[C⊎D]≃[[A×C⊎B×C]⊎A×D]⊎B×D : {A B C D : Set} →
  assocl₊equiv ● (distequiv ⊎≃ distequiv) ● distlequiv ≋
  (assocl₊equiv ⊎≃ id≃) ● ((id≃ ⊎≃ swap₊equiv) ⊎≃ id≃) ●
     (assocr₊equiv ⊎≃ id≃) ● assocl₊equiv ●
        (distlequiv ⊎≃ distlequiv) ● distequiv {A} {B} {C ⊎ D}
[A⊎B]×[C⊎D]≃[[A×C⊎B×C]⊎A×D]⊎B×D =
  eq (β₁ ⊙ cong∘l (proj₁ assocl₊equiv)
                  (β₁ ⊙ cong∘r (proj₁ distlequiv) β⊎₁) ⊙
      [A⊎B]×[C⊎D]→[[A×C⊎B×C]⊎A×D]⊎B×D ⊙
      ! (β₁ ⊙ cong₂∘ β⊎₁ (β₁ ⊙ cong₂∘ (β⊎₁ ⊙ (β⊎₁ ⊎∼ refl∼))
              (β₁ ⊙ cong₂∘ β⊎₁ (β₁ ⊙ cong∘l (proj₁ assocl₊equiv)
                    (β₁ ⊙ cong∘r (proj₁ distequiv) β⊎₁))))))
      --
     (β₂ ⊙ cong∘r (gg assocl₊equiv) (β₂ ⊙ cong∘l (gg distlequiv) β⊎₂) ⊙
      [[A×C⊎B×C]⊎A×D]⊎B×D→[A⊎B]×[C⊎D] ⊙
      ! (β₂ ⊙ cong₂∘
          (β₂ ⊙ cong₂∘
            (β₂ ⊙ cong₂∘
              (β₂ ⊙ cong∘r (gg assocl₊equiv) (β₂ ⊙ cong∘l (gg distequiv) β⊎₂))
              β⊎₂)
            (β⊎₂ {f = id≃ ⊎≃ swap₊equiv} ⊙ (β⊎₂ ⊎∼ refl∼)))
          β⊎₂))

------------------------------------------------------------------------------
-- also useful

[g+1]●[1+f]≋g+f : {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  (g ⊎≃ id≃) ● (id≃ ⊎≃ f) ≋ g ⊎≃ f
[g+1]●[1+f]≋g+f {f = f} {g} = begin (
  (g ⊎≃ id≃) ● (id≃ ⊎≃ f)
    ≋⟨ sym≋ ⊎●≋●⊎ ⟩
  (g ● id≃) ⊎≃ (id≃ ● f)
    ≋⟨ rid≋ ⊎≋ lid≋ ⟩
  g ⊎≃ f ∎)
  where open ≋-Reasoning

-- same proof as above, just written compactly

[1+f]●[g+1]≋g+f : {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  (id≃ ⊎≃ f) ● (g ⊎≃ id≃) ≋ g ⊎≃ f
[1+f]●[g+1]≋g+f = trans≋ (sym≋ ⊎●≋●⊎) (lid≋ ⊎≋ rid≋)

-- put then together

[g+1]●[1+f]≋[1+f]●[g+1] : {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  (g ⊎≃ id≃) ● (id≃ ⊎≃ f) ≋ (id≃ ⊎≃ f) ● (g ⊎≃ id≃)
[g+1]●[1+f]≋[1+f]●[g+1] = trans≋ [g+1]●[1+f]≋g+f (sym≋ [1+f]●[g+1]≋g+f)

--

[g*1]●[1*f]≋g*f : {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  (g ×≃ id≃) ● (id≃ ×≃ f) ≋ g ×≃ f
[g*1]●[1*f]≋g*f {f = f} {g} = begin (
  (g ×≃ id≃) ● (id≃ ×≃ f)
    ≋⟨ sym≋ ×●≋●× ⟩
  (g ● id≃) ×≃ (id≃ ● f)
    ≋⟨ rid≋ ×≋ lid≋ ⟩
  g ×≃ f ∎)
  where open ≋-Reasoning

[1*f]●[g*1]≋g*f : {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  (id≃ ×≃ f) ● (g ×≃ id≃) ≋ g ×≃ f
[1*f]●[g*1]≋g*f = trans≋ (sym≋ ×●≋●×) (lid≋ ×≋ rid≋)

[g*1]●[1*f]≋[1*f]●[g*1] : {A B C D : Set} {f : A ≃ B} {g : C ≃ D} →
  (g ×≃ id≃) ● (id≃ ×≃ f) ≋ (id≃ ×≃ f) ● (g ×≃ id≃)
[g*1]●[1*f]≋[1*f]●[g*1] = trans≋ [g*1]●[1*f]≋g*f (sym≋ [1*f]●[g*1]≋g*f)

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


-- MIT License

-- Copyright (c) 2021 Luca Ciccone and Luca Padovani

-- Permission is hereby granted, free of charge, to any person
-- obtaining a copy of this software and associated documentation
-- files (the "Software"), to deal in the Software without
-- restriction, including without limitation the rights to use,
-- copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the
-- Software is furnished to do so, subject to the following
-- conditions:

-- The above copyright notice and this permission notice shall be
-- included in all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
-- OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-- HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-- WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
-- FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
-- OTHER DEALINGS IN THE SOFTWARE.

{-# OPTIONS --guardedness #-}

open import Data.Empty using (⊥-elim)
open import Data.Product
open import Data.Sum

open import Relation.Nullary
open import Relation.Unary using (_∈_)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; trans; sym; subst)
open import Relation.Binary.Construct.Closure.ReflexiveTransitive using (ε; _◅_)

open import Function.Base using (case_of_)

open import Common

module Compliance {ℙ : Set} (message : Message ℙ)
  where

open import Action message
open import SessionType message
open import Transitions message
open import Session message
open import Progress message

data   Compliance : Session -> Set
record ∞Compliance (S : Session) : Set where
  constructor delay_
  coinductive
  field force : Compliance S
open ∞Compliance public

data Compliance where
  win#def : ∀{T S} (w : Win T) (def : Defined S) -> Compliance (T # S)
  out#inp : ∀{f g} (W : Witness f) (F : ∀{x} (!x : x ∈ dom f) -> ∞Compliance (f x .force # g x .force)) -> Compliance (out f # inp g)
  inp#out : ∀{f g} (W : Witness g) (F : ∀{x} (!x : x ∈ dom g) -> ∞Compliance (f x .force # g x .force)) -> Compliance (inp f # out g)

subject-reduction : ∀{S S'} -> Compliance S -> Reduction S S' -> ∞Compliance S'
force (subject-reduction (win#def (out U) def) (sync {I _} (out !x) s)) = ⊥-elim (U _ !x)
force (subject-reduction (inp#out _ F) (sync inp (out !x))) = F !x .force
force (subject-reduction (out#inp _ F) (sync (out !x) inp)) = F !x .force

subject-reduction* : ∀{S S'} -> Compliance S -> Reductions S S' -> ∞Compliance S'
force (subject-reduction* comp ε) = comp
subject-reduction* comp (red ◅ reds) = subject-reduction* (subject-reduction comp red .force) reds

compliance->progress : ∀{S} -> Compliance S -> Progress S
compliance->progress (win#def w def) = win#def w def
compliance->progress (out#inp W F) = out#inp W
compliance->progress (inp#out W F) = inp#out W

compliance->defined : ∀{T S} -> Compliance (T # S) -> Defined T × Defined S
compliance->defined (win#def (out _) def) = out , def
compliance->defined (out#inp _ _)         = out , inp
compliance->defined (inp#out _ _)         = inp , out

compliance-sound : ∀{S} -> Compliance S -> ComplianceS S
compliance-sound comp reds = progress-sound (compliance->progress (subject-reduction* comp reds .force))

compliance-complete : ∀{S} -> ComplianceS S -> ∞Compliance S
force (compliance-complete {T # S} spec) with spec ε
... | inj₁ (win#def w def) = win#def w def
... | inj₂ (_ , sync inp (out !x)) =
  inp#out (_ , !x) λ !x -> compliance-complete λ reds -> spec (sync inp (out !x) ◅ reds)
... | inj₂ (_ , sync (out !x) inp) =
  out#inp (_ , !x) λ !x -> compliance-complete λ reds -> spec (sync (out !x) inp ◅ reds)


-- Andreas, 2013-05-02 This ain't a bug, it is a feature.
-- {-# OPTIONS -v scope.name:10 #-}
module Issue836 where

open import Common.Equality

module M where

  record R : Set₁ where
    field
      X : Set

open M using (R)

X : R → Set
X = R.X

-- The open directive did not mention the /module/ R, so (I think
-- that) the code above should be rejected.

-- NO, it is a feature that projections can also be accessed via
-- the record /type/.

-- The following directive is (and should be) rejected:

-- open R

-- Bug.agda:19,6-7
-- No such module R
-- when scope checking the declaration
--   open R

module N where

  data D : Set₁ where
    c : Set → D

open N using (D) renaming (module D to MD)

twoWaysToQualify : D.c ≡ MD.c
twoWaysToQualify = refl


{-# OPTIONS --safe #-}

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Substitution.Introductions.Pair {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening as T hiding (wk; wkTerm; wkEqTerm)
open import Definition.Typed.RedSteps
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Weakening
open import Definition.LogicalRelation.Properties
open import Definition.LogicalRelation.Application
open import Definition.LogicalRelation.Substitution
open import Definition.LogicalRelation.Substitution.Properties
open import Definition.LogicalRelation.Substitution.Reflexivity
open import Definition.LogicalRelation.Substitution.Introductions.Sigma
open import Definition.LogicalRelation.Substitution.Introductions.Pi
open import Definition.LogicalRelation.Substitution.Introductions.SingleSubst

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Valid pair construction.
⦅⦆ᵛ : ∀ {F G l∃ t u Γ l}
       ([Γ] : ⊩ᵛ Γ)
       ([F] : Γ ⊩ᵛ⟨ l ⟩ F ^ [ % , ι l∃ ] / [Γ])
       ([G] : Γ ∙ F ^ [ % , ι l∃ ] ⊩ᵛ⟨ l ⟩ G ^ [ % , ι l∃ ] / [Γ] ∙ [F])
       ([t] : Γ ⊩ᵛ⟨ l ⟩ t ∷ F ^ [ % , ι l∃ ] / [Γ] / [F])
       ([u] : Γ ⊩ᵛ⟨ l ⟩ u ∷ G [ t ] ^ [ % , ι l∃ ] / [Γ] / substS {F} {G} {t} [Γ] [F] [G] [t])
          → Γ ⊩ᵛ⟨ l ⟩ ⦅ G , t , u ⦆ ∷ ∃ F ▹ G ^ [ % , ι l∃ ] / [Γ] / ∃ᵛ {F} {G} [Γ] [F] [G]
⦅⦆ᵛ {F} {G} {l∃} {t} {u} {Γ} {l} [Γ] [F] [G] [t] [u] {Δ = Δ} {σ = σ} ⊢Δ [σ] =
  let [G[t]] = substS {F} {G} {t} [Γ] [F] [G] [t]
      [ΠFG] = Πᵛ {F = F} {G = G} (≡is≤ PE.refl) (≡is≤ PE.refl) [Γ] [F] [G]
      [σF] = proj₁ ([F] ⊢Δ [σ])
      ⊢F = escape [σF]
      [σG] = proj₁ ([G] (⊢Δ ∙ ⊢F) (liftSubstS {F = F} [Γ] ⊢Δ [F] [σ]))
      ⊢G = escape [σG]
      [σt] = proj₁ ([t] (⊢Δ) [σ])
      ⊢t = escapeTerm [σF] [σt]
      [σu] = proj₁ ([u] (⊢Δ) [σ])
      [σG[t]] = proj₁ ([G[t]] ⊢Δ [σ])
      [σΠFG] = proj₁ ([ΠFG] ⊢Δ [σ])
      [σG[t]]′ = irrelevance′ (singleSubstLift G t) [σG[t]]
      [σu]′ = irrelevanceTerm′ (singleSubstLift G t) PE.refl PE.refl [σG[t]] [σG[t]]′ [σu]
      ⊢u = escapeTerm [σG[t]]′ [σu]′
      ⦅t,u⦆ⱼ = ⦅_,_,_,_⦆ⱼ {F = subst σ F} {G = subst (liftSubst σ) G} {t = subst σ t} {u = subst σ u}
                      ⊢F ⊢G ⊢t ⊢u
  in ⦅t,u⦆ⱼ , λ {σ′} [σ′] [σ≡σ′] →
            ⦅t,u⦆ⱼ ,
            let ⊢Γ = wfTerm ⊢t
                [σt′] = proj₁ ([t] ⊢Δ [σ′])
                [σt≡σt′] = proj₂ ([t] ⊢Δ [σ]) [σ′] [σ≡σ′]
                [σF′] = proj₁ ([F] ⊢Δ [σ′])
                ⊢F′ = escape [σF′]
                ⊢t′ = escapeTerm [σF′] [σt′]
                [σG′] = proj₁ ([G] {σ = liftSubst σ′} (⊢Δ ∙ ⊢F′) (liftSubstS {F = F} [Γ] ⊢Δ [F] [σ′]))
                ⊢G′ = escape [σG′]
                _ , Πᵣ _ _ _  _ _ F′ G′ D′ _ _  A≡A′ [F]₁ [G]₁ G-ext =
                  extractMaybeEmb (Π-elim (proj₁ ([ΠFG] ⊢Δ [σ′])))
                [σ′u] = proj₁ ([u] ⊢Δ [σ′])
                [σ′G[t]] = proj₁ ([G[t]] ⊢Δ [σ′])
                [σ′G[t]]′ = irrelevance′ (singleSubstLift G t) [σ′G[t]]
                [σ′u]′ = irrelevanceTerm′ (singleSubstLift G t) PE.refl PE.refl [σ′G[t]] [σ′G[t]]′ [σ′u]
                ⊢u′ = escapeTerm [σ′G[t]]′ [σ′u]′
                pair' =  ⦅_,_,_,_⦆ⱼ {F = subst σ′ F} {G = subst (liftSubst σ′) G} {t = subst σ′ t}
                                  {u = subst σ′ u} ⊢F′ ⊢G′ ⊢t′ ⊢u′
                [σ′≡σ]  = symS [Γ] ⊢Δ [σ] [σ′] [σ≡σ′]
                [σF′≡σF] = proj₂ ([F] ⊢Δ [σ′]) [σ] [σ′≡σ]
                σF′≡σF = escapeEq [σF′] [σF′≡σF]
                [liftσ] = liftSubstS {F = F} [Γ] ⊢Δ [F] [σ]
                [wk1σ′] = wk1SubstS [Γ] ⊢Δ ⊢F′ [σ′]
                [wk1σ] = wk1SubstS [Γ] ⊢Δ ⊢F′ [σ]
                foo = proj₁ ([F] (⊢Δ ∙ ⊢F′) [wk1σ′])
                [liftσ′] : (Δ ∙ subst σ′ F ^ [ % , ι l∃ ]) ⊩ˢ liftSubst σ ∷
                           Γ ∙ F ^ [ % , ι l∃ ] / [Γ] ∙ [F] / (⊢Δ ∙ escape (proj₁ ([F] ⊢Δ [σ′])))
                [liftσ′] =   let ⊢F = escape (proj₁ ([F] ⊢Δ [σ]))
                                 [tailσ] = wk1SubstS {F = subst σ′ F} [Γ] ⊢Δ (escape (proj₁ ([F] ⊢Δ [σ′]))) [σ]
                                 var0′ : (Δ ∙ subst σ′ F ^ [ % , ι l∃ ]) ⊢ var 0 ∷ subst (wk1Subst σ′) F ^ [ % , ι l∃ ]
                                 var0′ = var (⊢Δ ∙ ⊢F′) (PE.subst (λ x → 0 ∷ x ^ _ ∈ (Δ ∙ subst σ′ F ^ _))
                                             (wk-subst F) here)
                                 var0 = conv var0′ (≅-eq (escapeEq (proj₁ ([F] (⊢Δ ∙ ⊢F′) [wk1σ′])) (proj₂ ([F] (⊢Δ ∙ ⊢F′) [wk1σ′]) [wk1σ]
                                                            (wk1SubstSEq [Γ] ⊢Δ ⊢F′ [σ′] [σ′≡σ]))))
                             in  [tailσ] , neuTerm (proj₁ ([F] (⊢Δ ∙ ⊢F′) [tailσ])) (var 0)
                                 var0 (~-var var0)
                [σG′≡σG] = proj₂ ([G] (⊢Δ ∙ ⊢F′) (liftSubstS {F = F} [Γ] ⊢Δ [F] [σ′] )) [liftσ′]
                                 (liftSubstSEq {F = F} [Γ] ⊢Δ [F] [σ′] (symS [Γ] ⊢Δ [σ] [σ′] [σ≡σ′]))
                σG′≡σG = escapeEq [σG′] [σG′≡σG]
             in conv pair' (univ (∃-cong ⊢F′ (un-univ≡ (≅-eq σF′≡σF)) (un-univ≡ (≅-eq σG′≡σG))) )


module WrongHidingInLHS where

f : Set -> Set
f {x} = x


open import Relation.Binary.Core

module PLRTree.Drop.Permutation {A : Set}
                     (_≤_ : A → A → Set)
                     (tot≤ : Total _≤_) where

open import Data.List hiding (drop)
open import Data.Sum
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A
open import PLRTree {A}
open import PLRTree.Complete {A}
open import PLRTree.Compound {A}
open import PLRTree.Drop _≤_ tot≤
open import PLRTree.Drop.Complete _≤_ tot≤
open import PLRTree.DropLast.Complete _≤_ tot≤
open import PLRTree.DropLast.Permutation _≤_ tot≤
open import PLRTree.Equality {A}
open import PLRTree.Order.Properties {A}
open import PLRTree.Push.Permutation _≤_ tot≤

lemma-drop-++ : {t : Tag}{x : A}{l r : PLRTree} → Complete (node t x l r) → flatten (drop (node t x l r)) ∼ (flatten l ++ flatten r)
lemma-drop-++ (perfect {leaf} {leaf} x leaf leaf ≃lf) = ∼[]
lemma-drop-++ (perfect {node perfect x' l' r'} {node perfect x'' l'' r''} x cl cr (≃nd .x' .x'' l'≃r' l''≃r'' l'≃l'')) =
                 let _l = node perfect x' l' r' ;
                      _r = node perfect x'' l'' r'' ;
                      _l≃r = ≃nd x' x'' l'≃r' l''≃r'' l'≃l'' ;
                      cxlr = perfect x cl cr _l≃r ;
                      z = last (node perfect x _l _r) compound ;
                      t' = dropLast (node perfect x _l _r) ;
                      ct' = right x cl (lemma-dropLast-complete cr) (lemma-dropLast-≃ _l≃r compound)
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))) (lemma-dropLast-∼ cxlr)
lemma-drop-++ (left {l} {r} x cl cr l⋘r)
    with l | r | l⋘r | lemma-dropLast-⋘ l⋘r
... | leaf | _ | () | _
... | node perfect x' l' r' | _ | () | _
... | node left x' l' r' | node perfect x'' l'' r'' | l⋘ .x' .x'' l'⋘r' l''≃r'' r'≃l'' | inj₁ ld⋘r
    with dropLast (node left x' l' r') | ld⋘r | lemma-dropLast-complete cl | lemma-dropLast-∼ (left x cl cr (l⋘ x' x'' l'⋘r' l''≃r'' r'≃l''))
... | leaf | () | _ | _
... | node perfect _ _ _ | () | _ | _
... | node left x''' l''' r''' | ld⋘r' | cld | fzt'∼flfr =
                 let z = last (node left x (node left x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = node left x (node left x''' l''' r''') (node perfect x'' l'' r'') ;
                      ct' = left x cld cr ld⋘r'
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))) fzt'∼flfr
... | node right x''' l''' r''' | ld⋘r' | cld | fzt'∼flfr =
                 let z = last (node left x (node left x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = node left x (node right x''' l''' r''') (node perfect x'' l'' r'') ;
                      ct' = left x cld cr ld⋘r'
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))) fzt'∼flfr
lemma-drop-++ (left x cl cr l⋘r) | node left x' l' r' | node perfect x'' l'' r'' | l⋘ .x' .x'' l'⋘r' l''≃r'' r'≃l'' | inj₂ ld≃r
    with dropLast (node left x' l' r') | ld≃r | lemma-dropLast-complete cl | lemma-dropLast-∼ (left x cl cr (l⋘ x' x'' l'⋘r' l''≃r'' r'≃l''))
... | leaf | () | _ | _
... | node perfect x''' l''' r''' | ld≃r' | cld | fzt'∼flfr =
                 let z = last (node left x (node left x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = node perfect x (node perfect x''' l''' r''') (node perfect x'' l'' r'') ;
                      ct' = perfect x cld cr ld≃r'
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))) fzt'∼flfr
... | node left _ _ _ | () | _ | _
... | node right _ _ _ | () | _ | _
lemma-drop-++ (left x cl cr l⋘r) | node right x' l' r' | leaf | () | _
lemma-drop-++ (left x cl cr l⋘r) | node right x' (node perfect x'' leaf leaf) leaf | node perfect x''' leaf leaf | x⋘ .x' .x'' .x''' | inj₁ ()
lemma-drop-++ (left x cl cr l⋘r) | node right x' (node perfect x'' leaf leaf) leaf | node perfect x''' leaf leaf | x⋘ .x' .x'' .x''' | inj₂ x'≃x''' =
                 let z = last (node left x (node right x' (node perfect x'' leaf leaf) leaf) (node perfect x''' leaf leaf)) compound ;
                      t' = dropLast (node left x (node right x' (node perfect x'' leaf leaf) leaf) (node perfect x''' leaf leaf)) ;
                      ct' = perfect x (perfect x' leaf leaf ≃lf) cr x'≃x''' ;
                      fzt'∼flfr = lemma-dropLast-∼ (left x cl cr (x⋘ x' x'' x'''))
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
lemma-drop-++ (left x cl cr l⋘r) | node right x' l' r' | node perfect x'' l'' r'' | r⋘ .x' .x'' l⋙r l''≃r'' l'⋗l'' | inj₁ ld⋘r
    with dropLast (node right x' l' r') | ld⋘r | lemma-dropLast-complete cl | lemma-dropLast-∼ (left x cl cr (r⋘ x' x'' l⋙r l''≃r'' l'⋗l''))
... | leaf | () | _ | _
... | node perfect _ _ _ | () | _ | _
... | node left x''' l''' r''' | ld⋘r' | cld | fzt'∼flfr =
                 let z = last (node left x (node right x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = node left x (node left x''' l''' r''') (node perfect x'' l'' r'') ;
                      ct' = left x cld cr ld⋘r'
                  in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
... | node right x''' l''' r''' | ld⋘r' | cld | fzt'∼flfr =
                 let z = last (node left x (node right x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = node left x (node right x''' l''' r''') (node perfect x'' l'' r'') ;
                      ct' = left x cld cr ld⋘r'
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
lemma-drop-++ (left x cl cr l⋘r) | node right x' l' r' | node perfect x'' l'' r'' | r⋘ .x' .x'' l⋙r l''≃r'' l'⋗l'' | inj₂ ld≃r
    with dropLast (node right x' l' r') | ld≃r | lemma-dropLast-complete cl | lemma-dropLast-∼ (left x cl cr (r⋘ x' x'' l⋙r l''≃r'' l'⋗l''))
... | leaf | () | _ | _
... | node perfect x''' l''' r''' | ld≃r' | cld | fzt'∼flfr =
                 let z = last (node left x (node right x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = node perfect x (node perfect x''' l''' r''') (node perfect x'' l'' r'') ;
                      ct' = perfect x cld cr ld≃r'
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
... | node left _ _ _ | () | _ | _
... | node right _ _ _ | () | _ | _
lemma-drop-++ (left x cl cr l⋘r) | node right x' l' r' | node left x'' l'' r'' | () | _
lemma-drop-++ (left x cl cr l⋘r) | node right x' l' r' | node right x'' l'' r'' | () | _
lemma-drop-++ (right {l} {r} x cl cr l⋙r)
    with l | r | l⋙r | lemma-dropLast-⋙ l⋙r
... | leaf | leaf | ⋙p () | _
... | node perfect x' leaf leaf | leaf | ⋙p (⋗lf .x') | _ = ∼x /head /head ∼[]
... | node perfect _ _ (node _ _ _ _) | leaf | ⋙p () | _
... | node perfect _ (node _ _ _ _) _ | leaf | ⋙p () | _
... | node left _ _ _ | leaf | ⋙p () | _
... | node right _ _ _ | leaf | ⋙p () | _
... | leaf | node perfect _ _ _ | ⋙p () | _
... | node perfect x' l' r' | node perfect x'' l'' r'' | ⋙p (⋗nd .x' .x'' l'≃r' l''≃r'' l'⋗l'') | _ =
                 let z = last (node right x (node perfect x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = dropLast (node right x (node perfect x' l' r') (node perfect x'' l'' r'')) ;
                      ct' = left x (lemma-dropLast-complete cl) cr (lemma-dropLast-⋗ (⋗nd x' x'' l'≃r' l''≃r'' l'⋗l'') compound) ;
                      fzt'∼flfr = lemma-dropLast-∼ (right x cl cr (⋙p (⋗nd x' x'' l'≃r' l''≃r'' l'⋗l'')))
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
... | node left _ _ _ | node perfect _ _ _ | ⋙p () | _
... | node right _ _ _ | node perfect _ _ _ | ⋙p () | _
... | leaf | node left _ _ _ | ⋙p () | _
... | node perfect x' l' r' | node left x'' l'' r'' | _l⋙r | inj₁ l⋙rd =
                 let z = last (node right x (node perfect x' l' r') (node left x'' l'' r'')) compound ;
                      t' = dropLast (node right x (node perfect x' l' r') (node left x'' l'' r'')) ;
                      ct' = right x cl (lemma-dropLast-complete cr) l⋙rd ;
                      fzt'∼flfr = lemma-dropLast-∼ (right x cl cr _l⋙r)
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
... | node perfect _ _ _ | node left _ _ _ | _  | inj₂ ()
... | node left _ _ _ | node left _ _ _ | ⋙p () | _
... | node right _ _ _ | node left _ _ _ | ⋙p () | _
... | leaf | node right _ _ _ | ⋙p () | _
... | node perfect x' l' r' | node right x'' l'' r'' | _l⋙r | inj₁ l⋙rd =
                 let z = last (node right x (node perfect x' l' r') (node right x'' l'' r'')) compound ;
                      t' = dropLast (node right x (node perfect x' l' r') (node right x'' l'' r'')) ;
                      ct' = right x cl (lemma-dropLast-complete cr) l⋙rd ;
                      fzt'∼flfr = lemma-dropLast-∼ (right x cl cr _l⋙r)
                 in trans∼ (lemma-push-∼ (lemma-setRoot-complete z ct') (≺-wf (setRoot z t')))  fzt'∼flfr
... | node perfect _ _ _ | node right _ _ _ | _ | inj₂ ()
... | node left _ _ _ | node right _ _ _ | ⋙p () | _
... | node right _ _ _ | node right _ _ _ | ⋙p () | _

lemma-drop-∼ : {t : Tag}{x : A}{l r : PLRTree} → Complete (node t x l r) → (x ∷ flatten (drop (node t x l r))) ∼ flatten (node t x l r)
lemma-drop-∼ (perfect x cl cr l≃r) = ∼x /head /head (lemma-drop-++ (perfect x cl cr l≃r))
lemma-drop-∼ (left x cl cr l⋘r) = ∼x /head /head (lemma-drop-++ (left x cl cr l⋘r))
lemma-drop-∼ (right x cl cr l⋙r) = ∼x /head /head (lemma-drop-++ (right x cl cr l⋙r))


{-# OPTIONS --rewriting --confluence-check #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

postulate
  A : Set
  a b : A
  f : (A → A) → A
  g : A → A

  rewf₁ : f (λ x → g x) ≡ a
  rewf₂ : f (λ x → a) ≡ b

  rewg : (x : A) → g x ≡ a

{-# REWRITE rewf₁ rewf₂ rewg #-}


{- Byzantine Fault Tolerant Consensus Verification in Agda, version 0.9.

   Copyright (c) 2020, 2021 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Base.PKCS
open import LibraBFT.Base.Types
import      LibraBFT.Yasm.Base as LYB

-- This module provides some definitions and properties that facilitate
-- proofs of properties about a distributed system modeled by Yasm.System
-- paramaterized by some SystemParameters.

module LibraBFT.Yasm.Properties
   (ℓ-EC        : Level)
   (EpochConfig : Set ℓ-EC)
   (epochId     : EpochConfig → EpochId)
   (authorsN    : EpochConfig → ℕ)
   (parms       : LYB.SystemParameters ℓ-EC EpochConfig epochId authorsN)
   -- In addition to the parameters used by the rest of the system model, this module
   -- needs to relate Members to PKs and PeerIds, so that StepPeerState-AllValidParts
   -- can be defined.  This enables the application to prove that honest peers sign
   -- new messages only for their own public key.  The system model does not know that
   -- directly.
   (senderPKOK  : (ec : EpochConfig) → PK → LYB.SystemParameters.PeerId parms → Set)
  where
 open LYB.SystemParameters parms
 open import LibraBFT.Yasm.AvailableEpochs PeerId ℓ-EC EpochConfig epochId authorsN
             using (AvailableEpochs) renaming (lookup'' to EC-lookup)
 import      LibraBFT.Yasm.AvailableEpochs PeerId ℓ-EC EpochConfig epochId authorsN
             as AE
 open import LibraBFT.Yasm.Base   ℓ-EC EpochConfig epochId authorsN
 open import LibraBFT.Yasm.System ℓ-EC EpochConfig epochId authorsN parms
 open import Util.FunctionOverride PeerId _≟PeerId_

 -- A ValidPartForPK collects the assumptions about what a /part/ in the outputs of an honest verifier
 -- satisfies: (i) the epoch field is consistent with the existent epochs and (ii) the verifier is
 -- a member of the associated epoch config, and (iii) has the given PK in that epoch.
 record ValidSenderForPK {e}(𝓔s : AvailableEpochs e)(part : Part)(sender : PeerId)(pk : PK) : Set ℓ-EC where
   constructor mkValidSenderForPK
   field
     vp-epoch           : part-epoch part < e
     vp-ec              : EpochConfig
     vp-ec-≡            : AE.lookup'' 𝓔s vp-epoch ≡ vp-ec
     vp-sender-ok       : senderPKOK vp-ec pk sender
 open ValidSenderForPK public

 -- A valid part remains valid when new epochs are added
 ValidSenderForPK-stable-epoch : ∀{e part α pk}{𝓔s : AvailableEpochs e}(𝓔 : EpochConfigFor e)
                               → ValidSenderForPK 𝓔s part α pk
                               → ValidSenderForPK (AE.append 𝓔 𝓔s) part α pk
 ValidSenderForPK-stable-epoch {pk = pk} {𝓔s = 𝓔s} 𝓔 (mkValidSenderForPK e ec refl vpk) = record
   { vp-epoch           = ≤-step e
   ; vp-ec              = ec
   ; vp-ec-≡            = AE.lookup''-≤-step-lemma 𝓔s 𝓔 e
   ; vp-sender-ok       = vpk
   }

 -- A valid part remains valid
 ValidSenderForPK-stable : ∀{e e' α}{st : SystemState e}{st' : SystemState e'}
                    → Step* st st' → ∀{part pk}
                    → ValidSenderForPK (availEpochs st) part α pk
                    → ValidSenderForPK (availEpochs st') part α pk
 ValidSenderForPK-stable step-0 v = v
 ValidSenderForPK-stable (step-s st (step-epoch 𝓔)) v
   = ValidSenderForPK-stable-epoch 𝓔 (ValidSenderForPK-stable st v)
 ValidSenderForPK-stable (step-s st (step-peer _)) v
   = ValidSenderForPK-stable st v

 sameEpoch⇒sameEC : ∀ {e p1 p2 α1 α2 pk1 pk2}{𝓔s : AvailableEpochs e}
                    → (vp1 : ValidSenderForPK 𝓔s p1 α1 pk1)
                    → (vp2 : ValidSenderForPK 𝓔s p2 α2 pk2)
                    → part-epoch p1 ≡ part-epoch p2
                    → vp-ec vp1 ≡ vp-ec vp2
 sameEpoch⇒sameEC {𝓔s = 𝓔s} vp1 vp2 parts≡ =
   trans (sym (vp-ec-≡ vp1))
         (trans (AE.lookup-𝓔s-injective 𝓔s (vp-epoch vp1) (vp-epoch vp2) parts≡)
                (vp-ec-≡ vp2))

 -- TODO-1 : prove it
 postulate
   ValidSenderForPK⇒ep≡ : ∀ {e p1 p2 α1 pk} {𝓔s : AvailableEpochs e}
                        → WithVerSig pk p1 → WithVerSig pk p2
                        → part-epoch p1 ≡ part-epoch p2
                        → ValidSenderForPK 𝓔s p1 α1 pk
                        → ValidSenderForPK 𝓔s p2 α1 pk

 -- We say that an implementation produces only valid parts iff all parts of every message in the
 -- output of a 'StepPeerState' are either: (i) a valid new part (i.e., the part is valid and no
 -- message with the same signature has been sent previously), or (ii) a message has been sent
 -- with the same signature.
 StepPeerState-AllValidParts : Set ℓ-EC
 StepPeerState-AllValidParts = ∀{e s m part pk initd' outs}{α}{𝓔s : AvailableEpochs e}{st : SystemState e}
   → (r : ReachableSystemState st)
   → Meta-Honest-PK pk
   → StepPeerState α 𝓔s (msgPool st) (initialised st) (peerStates st α) initd' (s , outs)
   → m ∈ outs → part ⊂Msg m → (ver : WithVerSig pk part)
   → (ValidSenderForPK 𝓔s part α pk × ¬ (MsgWithSig∈ pk (ver-signature ver) (msgPool st)))
   ⊎ MsgWithSig∈ pk (ver-signature ver) (msgPool st)

 -- A /part/ was introduced by a specific step when:
 IsValidNewPart : ∀{e e'}{pre : SystemState e}{post : SystemState e'} → Signature → PK → Step pre post → Set ℓ-EC
 IsValidNewPart _ _ (step-epoch _) = Lift (ℓ-EC) ⊥
 -- said step is a /step-peer/ and
 IsValidNewPart {pre = pre} sig pk (step-peer {pid = pid} pstep)
    -- the part has never been seen before
    = ReachableSystemState pre
    × ¬ (MsgWithSig∈ pk sig (msgPool pre))
    × Σ (MsgWithSig∈ pk sig (msgPool (StepPeer-post pstep)))
        (λ m → ValidSenderForPK (availEpochs pre) (msgPart m) (msgSender m) pk)

 -- When we can prove that the implementation provided by 'parms' at the
 -- top of this module satisfies 'StepPeerState-AllValidParts', we can
 -- prove a number of useful structural properties:

 -- TODO-2: Refactor into a file (LibraBFT.Yasm.Properties.Structural) later on
 -- if this grows too large.
 module Structural (sps-avp      : StepPeerState-AllValidParts) where

     -- We can unwind the state and highlight the step where a part was
     -- originally sent. This 'unwind' function combined with Any-Step-elim
     -- enables a powerful form of reasoning. The 'honestVoteEpoch' below
     -- exemplifies this well.
     unwind : ∀{e}{st : SystemState e}(tr : ReachableSystemState st)
            → ∀{p m σ pk} → Meta-Honest-PK pk
            → p ⊂Msg m → (σ , m) ∈ msgPool st → (ver : WithVerSig pk p)
            → Any-Step (IsValidNewPart (ver-signature ver) pk) tr
     unwind (step-s tr (step-epoch _))    hpk p⊂m m∈sm sig
       = step-there (unwind tr hpk p⊂m m∈sm sig)
     unwind (step-s tr (step-peer {pid = β} {outs = outs} {pre = pre} sp)) hpk p⊂m m∈sm sig
       with Any-++⁻ (List-map (β ,_) outs) {msgPool pre} m∈sm
     ...| inj₂ furtherBack = step-there (unwind tr hpk p⊂m furtherBack sig)
     ...| inj₁ thisStep
       with sp
     ...| step-cheat fm isCheat
       with thisStep
     ...| here refl
       with isCheat p⊂m sig
     ...| inj₁ abs    = ⊥-elim (hpk abs)
     ...| inj₂ sentb4
       with unwind tr {p = msgPart sentb4} hpk (msg⊆ sentb4) (msg∈pool sentb4) (msgSigned sentb4)
     ...| res rewrite msgSameSig sentb4 = step-there res
     unwind (step-s tr (step-peer {pid = β} {outs = outs} {pre = pre} sp)) hpk p⊂m m∈sm sig
        | inj₁ thisStep
        | step-honest x
       with Any-satisfied-∈ (Any-map⁻ thisStep)
     ...| (m , refl , m∈outs)
       with sps-avp tr hpk x m∈outs p⊂m sig
     ...| inj₂ sentb4 with unwind tr {p = msgPart sentb4} hpk (msg⊆ sentb4) (msg∈pool sentb4) (msgSigned sentb4)
     ...| res rewrite msgSameSig sentb4 = step-there res
     unwind (step-s tr (step-peer {pid = β} {outs = outs} {pre = pre} sp)) {p} hpk p⊂m m∈sm sig
        | inj₁ thisStep
        | step-honest x
        | (m , refl , m∈outs)
        | inj₁ (valid-part , notBefore) =
               step-here tr (tr , notBefore , MsgWithSig∈-++ˡ (mkMsgWithSig∈ _ _ p⊂m β thisStep sig refl)
                                       , valid-part)

     -- Unwind is inconvenient to use by itself because we have to do
     -- induction on Any-Step-elim. The 'honestPartValid' property below
     -- provides a fairly general result conveniently: for every part
     -- verifiable with an honest PK, there is a msg with the same
     -- signature that is valid for some pid.

     honestPartValid : ∀ {e st} → ReachableSystemState {e} st → ∀ {pk nm v sender}
                     → Meta-Honest-PK pk
                     → v ⊂Msg nm → (sender , nm) ∈ msgPool st → (ver : WithVerSig pk v)
                     → Σ (MsgWithSig∈ pk (ver-signature ver) (msgPool st))
                         (λ msg → (ValidSenderForPK (availEpochs st) (msgPart msg) (msgSender msg) pk))
     honestPartValid {e} {st} r {pk = pk} hpk v⊂m m∈pool ver
     -- We extract two pieces of important information from the place where the part 'v'
     -- was first sent: (a) there is a message with the same signature /in the current pool/
     -- and (b) its epoch is less than e.
        = Any-Step-elim (λ { {st = step-epoch _} ()
                           ; {st = step-peer {pid = pid} ps} (_ , _ , new , valid) tr
                             →  MsgWithSig∈-Step* tr new
                                , ValidSenderForPK-stable tr (subst (λ P → ValidSenderForPK _ P (msgSender (MsgWithSig∈-Step* tr new)) pk)
                                                                         (MsgWithSig∈-Step*-part tr new)
                                                                         (subst (λ sndr → ValidSenderForPK _ _ sndr pk)
                                                                                (MsgWithSig∈-Step*-sender tr new)
                                                                                valid))
                           })
                        (unwind r hpk v⊂m m∈pool ver)

     -- Unforgeability is also an important property stating that every part that is
     -- verified with an honest public key has either been sent by α or is a replay
     -- of another message sent before.
     ext-unforgeability'
       : ∀{e α m part pk}{st : SystemState e} → ReachableSystemState st
       -- If a message m has been sent by α, containing part
       → (α , m) ∈ msgPool st → part ⊂Msg m
       -- And the part can be verified with an honest public key,
       → (sig : WithVerSig pk part) → Meta-Honest-PK pk
       -- then either the part is a valid part by α (meaning that α can
       -- sign the part itself) or a message with the same signature has
       -- been sent previously.
       → ValidSenderForPK (availEpochs st) part α pk
       ⊎ MsgWithSig∈ pk (ver-signature sig) (msgPool st)
     ext-unforgeability' (step-s st (step-epoch 𝓔)) m∈sm p⊆m sig hpk
       = ⊎-map (ValidSenderForPK-stable-epoch 𝓔) id (ext-unforgeability' st m∈sm p⊆m sig hpk)
     ext-unforgeability' {part = part} (step-s st (step-peer {pid = β} {outs = outs} {pre = pre} sp)) m∈sm p⊆m sig hpk
       with Any-++⁻ (List-map (β ,_) outs) {msgPool pre} m∈sm
     ...| inj₂ furtherBack = MsgWithSig∈-++ʳ <⊎$> (ext-unforgeability' st furtherBack p⊆m sig hpk)
     ...| inj₁ thisStep
       with sp
     ...| step-cheat fm isCheat
       with thisStep
     ...| here refl
       with isCheat p⊆m sig
     ...| inj₁ abs    = ⊥-elim (hpk abs)
     ...| inj₂ sentb4 = inj₂ (MsgWithSig∈-++ʳ sentb4)
     ext-unforgeability' {α = α} {m = m} {part = part} (step-s st (step-peer {pid = β} {outs = outs} {pre = pre} sp)) m∈sm p⊆m sig hpk
        | inj₁ thisStep
        | step-honest x
       with Any-satisfied-∈ (Any-map⁻ thisStep)
     ...| (m , refl , m∈outs) = ⊎-map proj₁ MsgWithSig∈-++ʳ (sps-avp st hpk x m∈outs p⊆m sig)

     -- The ext-unforgeability' property can be collapsed in a single clause.

     -- TODO-2: so far, ext-unforgeability is used only to get a MsgWithSig∈ that is passed to
     -- msgWithSigSentByAuthor, which duplicates some of the reasoning in the proof of
     -- ext-unforgeability'; should these properties possibly be combined into one simpler proof?
     ext-unforgeability
       : ∀{e α₀ m part pk}{st : SystemState e} → ReachableSystemState st
       → (α₀ , m) ∈ msgPool st → part ⊂Msg m
       → (sig : WithVerSig pk part) → Meta-Honest-PK pk
       → MsgWithSig∈ pk (ver-signature sig) (msgPool st)
     ext-unforgeability {_} {α₀} {m} {st = st} rst m∈sm p⊂m sig hpk
       with ext-unforgeability' rst m∈sm p⊂m sig hpk
     ...| inj₁ p
        = mkMsgWithSig∈ _ _ p⊂m α₀ m∈sm sig refl
     ...| inj₂ sentb4 = sentb4

     ¬cheatForgeNew : ∀ {e pid pk vsig mst outs m}{st : SystemState e}
                    → (sp : StepPeer st pid mst outs)
                    → outs ≡ m ∷ []
                    → (ic : isCheat sp)
                    → Meta-Honest-PK pk
                    → MsgWithSig∈ pk vsig ((pid , m) ∷ msgPool st)
                    → MsgWithSig∈ pk vsig (msgPool st)
     ¬cheatForgeNew sc@(step-cheat fm isCheat) refl _ hpk mws
        with msg∈pool mws
     ...| there m∈pool = mkMsgWithSig∈ (msgWhole mws) (msgPart mws) (msg⊆ mws) (msgSender mws) m∈pool (msgSigned mws) (msgSameSig mws)
     ...| here m∈pool
        with isCheat (subst (msgPart mws ⊂Msg_) (cong proj₂ m∈pool) (msg⊆ mws)) (msgSigned mws)
     ...| inj₁ dis = ⊥-elim (hpk dis)
     ...| inj₂ mws' rewrite msgSameSig mws = mws'

     msgWithSigSentByAuthor : ∀ {e pk sig}{st : SystemState e}
                            → ReachableSystemState st
                            → Meta-Honest-PK pk
                            → MsgWithSig∈ pk sig (msgPool st)
                            → Σ (MsgWithSig∈ pk sig (msgPool st))
                                λ mws → ValidSenderForPK (availEpochs st) (msgPart mws) (msgSender mws) pk
     msgWithSigSentByAuthor step-0 _ ()
     msgWithSigSentByAuthor (step-s {pre = pre} preach (step-epoch 𝓔)) hpk mws
       rewrite step-epoch-does-not-send pre 𝓔
          with msgWithSigSentByAuthor preach hpk mws
     ...| mws' , vpb =  mws' , ValidSenderForPK-stable {st = pre} (step-s step-0 (step-epoch 𝓔)) vpb
     msgWithSigSentByAuthor {pk = pk} (step-s {pre = pre} preach (step-peer theStep@(step-cheat fm cheatCons))) hpk mws
        with (¬cheatForgeNew theStep refl unit hpk mws)
     ...| mws'
        with msgWithSigSentByAuthor preach hpk mws'
     ...| mws'' , vpb'' = MsgWithSig∈-++ʳ mws'' , vpb''
     msgWithSigSentByAuthor {e} (step-s {pre = pre} preach (step-peer {pid = pid} {outs = outs} (step-honest sps))) hpk mws
       with Any-++⁻ (List-map (pid ,_) outs) {msgPool pre} (msg∈pool mws)
     ...| inj₂ furtherBack
       with msgWithSigSentByAuthor preach hpk (MsgWithSig∈-transp mws furtherBack)
     ...| mws' , vpb' =  MsgWithSig∈-++ʳ mws' , vpb'

     msgWithSigSentByAuthor {e} (step-s {pre = pre} preach (step-peer {pid = pid} {outs = outs} (step-honest sps))) hpk mws
        | inj₁ thisStep
        with Any-satisfied-∈ (Any-map⁻ thisStep)
     ...| (m' , refl , m∈outs)
        with sps-avp preach hpk sps m∈outs (msg⊆ mws) (msgSigned mws)
     ...| inj₁ (vpbα₀ , _) = mws , vpbα₀
     ...| inj₂ mws'
        with msgWithSigSentByAuthor preach hpk mws'
     ...| mws'' , vpb'' rewrite sym (msgSameSig mws) = MsgWithSig∈-++ʳ mws'' , vpb''

     newMsg⊎msgSentB4 :  ∀ {e pk v m pid sndr st' outs} {st : SystemState e}
                   → (r : ReachableSystemState st)
                   → (stP : StepPeer st pid st' outs)
                   → Meta-Honest-PK pk → (sig : WithVerSig pk v)
                   → v ⊂Msg m → (sndr , m) ∈ msgPool (StepPeer-post stP)
                   → (m ∈ outs × ValidSenderForPK (availEpochs st) v pid pk
                      × ¬ (MsgWithSig∈ pk (ver-signature sig) (msgPool st)))
                     ⊎ MsgWithSig∈ pk (ver-signature sig) (msgPool st)
     newMsg⊎msgSentB4 {e} {pk} {v} {m} {pid} {sndr} {_} {outs} {st} r stP pkH sig v⊂m m∈post
        with Any-++⁻ (List-map (pid ,_) outs) m∈post
     ...| inj₂ m∈preSt = inj₂ (mkMsgWithSig∈ m v v⊂m sndr m∈preSt sig refl)
     ...| inj₁ nm∈outs
        with Any-map (cong proj₂) (Any-map⁻ nm∈outs)
     ...| m∈outs
        with stP
     ...| step-honest stH
        with sps-avp r pkH stH m∈outs v⊂m sig
     ...| inj₁ newVote = inj₁ (m∈outs , newVote)
     ...| inj₂ msb4    = inj₂ msb4
     newMsg⊎msgSentB4 {e} {pk} {v} {m} {pid} {sndr} {_} {outs} {st} r stP pkH sig v⊂m m∈post
        | inj₁ nm∈outs
        | here refl
        | step-cheat fm ic
          = let mws = mkMsgWithSig∈ m v v⊂m pid (here refl) sig refl
            in inj₂ (¬cheatForgeNew {st = st} (step-cheat fm ic) refl unit pkH mws)

 -- This could potentially be more general, for example covering the whole SystemState, rather than
 -- just one peer's state.  However, this would put more burden on the user and is not required so
 -- far.
 CarrierProp : Set₁
 CarrierProp = Part → PeerState → Set

 module _ (P   : CarrierProp) where

  record PropCarrier (pk : PK) (sig : Signature) {e} (st : SystemState e) : Set (ℓ-EC ℓ⊔ (ℓ+1 0ℓ)) where
    constructor mkCarrier
    field
      carrStReach : ReachableSystemState st -- Enables use of invariants when proving that steps preserve carrProp
      carrSent    : MsgWithSig∈ pk sig (msgPool st)
      carrValid   : ValidSenderForPK (availEpochs st) (msgPart carrSent) (msgSender carrSent) pk
      carrProp    : P (msgPart carrSent) (peerStates st (msgSender carrSent))
  open PropCarrier public

  PeerStepPreserves : Set (ℓ+1 ℓ0 ℓ⊔ ℓ-EC)
  PeerStepPreserves = ∀ {e initd' ps' outs pk sig}{pre : SystemState e}
                      → (r : ReachableSystemState pre)
                      → (pc : PropCarrier pk sig {e} pre)
                      → (sps : StepPeerState {e} (msgSender (carrSent pc))
                                                 (availEpochs pre)
                                                 (msgPool pre)
                                                 (initialised pre)
                                                 (peerStates pre (msgSender (carrSent pc)))
                                                 initd'
                                                 (ps' , outs))
                      → P (msgPart (carrSent pc)) ps'

  module _ (PSP : PeerStepPreserves) where

    Carrier-transp : ∀ {e' e'' pk sig} {pre : SystemState e'}{post : SystemState e''}
                   → (theStep : Step pre post)
                   → PropCarrier pk sig pre
                   → PropCarrier pk sig post
    Carrier-transp {pre = pre} {post} (step-epoch ec) (mkCarrier r mws vpk lvr) =
       mkCarrier (step-s r (step-epoch ec)) mws (ValidSenderForPK-stable-epoch ec vpk) lvr
    Carrier-transp {e' = e'} {pre = pre} {post} theStep@(step-peer {pid = pid} {st'} {pre = .pre} sps) pc@(mkCarrier r mws vpk prop)
       with step-s r theStep
    ...| postReach
       with sps
    ...| step-cheat fm isch = mkCarrier postReach (MsgWithSig∈-++ʳ mws) vpk
           (subst (λ ps → P (msgPart mws) (ps (msgSender mws))) (sym (cheatStepDNMPeerStates {pre = pre} (step-cheat fm isch) unit)) prop)
    -- PeerStates not changed by cheat steps
    ...| step-honest {st = st} sps'
       with msgSender mws ≟PeerId pid
    ...| no neq   = mkCarrier postReach (MsgWithSig∈-++ʳ mws) vpk
                              (subst (λ ps → P (msgPart mws) ps) (override-target-≢ {f = peerStates pre} neq) prop)
    ...| yes refl = mkCarrier postReach (MsgWithSig∈-++ʳ mws) vpk
                              (subst (λ ps → P (msgPart mws) ps) (sym override-target-≡) (PSP r pc sps'))


-- WARNING: This file was generated automatically by Vehicle
-- and should not be modified manually!
-- Metadata
--  - Agda version: 2.6.2
--  - AISEC version: 0.1.0.1
--  - Time generated: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Data.Unit
open import Data.Empty
open import Data.Product
open import Data.Nat as ℕ using (ℕ)
open import Data.Fin as Fin using (Fin; #_)
open import Data.List
open import Data.List.Relation.Unary.All as List
open import Relation.Binary.PropositionalEquality

module simple-let-temp-output where

abstract
  e1 : let x = ⊤ in let y = ⊥ in x × y
  e1 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

abstract
  e2 : let y = # 1 in y Fin.≥ # 2
  e2 = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

e3 : ℕ
e3 = let y = 1 ℕ.+ 1 in y

lamLet : ℕ → ℕ
lamLet x = let y = x in y

abstract
  forallLet : ∀ (x : Fin 2) → let y = x in y ≡ # 1
  forallLet = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

abstract
  letForall : let y = # 1 in ∀ (x : Fin 2) → y ≡ x
  letForall = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

abstract
  forallInLet : List.All (λ (x : Fin 2) → let y = x in y ≡ # 1) (# 1 ∷ [])
  forallInLet = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }

abstract
  letForallIn : let y = # 1 in List.All (λ (x : Fin 2) → y ≡ x) (# 1 ∷ [])
  letForallIn = checkSpecification record
    { proofCache   = "/home/matthew/Code/AISEC/vehicle/proofcache.vclp"
    }


module Logic where

open import Type renaming (Type to Stmt ; Typeω to Stmtω) public


------------------------------------------------------------------------
-- Pretty-printing (documents and document combinators)
------------------------------------------------------------------------

{-# OPTIONS --guardedness #-}

module Pretty where

open import Data.Bool
open import Data.Char
open import Data.List hiding ([_])
open import Data.List.NonEmpty using (List⁺; _∷_; _∷⁺_)
open import Data.List.Properties
open import Data.Maybe hiding (_>>=_)
open import Data.Nat
open import Data.Product
open import Data.Unit
open import Function
open import Relation.Binary.PropositionalEquality using (_≡_; refl)
open import Tactic.MonoidSolver

open import Grammar.Infinite as G
  hiding (_<$>_; _<$_; _⊛_; _<⊛_; _⊛>_; token; tok; if-true; sat;
          tok-sat; symbol; list; list⁺)

------------------------------------------------------------------------
-- Pretty-printers

mutual

  -- Pretty-printer documents, indexed by grammars and corresponding
  -- values.
  --
  -- For convenience I have chosen to parametrise Doc by "extended"
  -- grammars rather than basic ones.

  infixr 20 _◇_

  data Doc : ∀ {A} → Grammar A → A → Set₁ where

    -- Concatenation.

    _◇_   : ∀ {c₁ c₂ A B x y}
              {g₁ : ∞Grammar c₁ A} {g₂ : A → ∞Grammar c₂ B} →
            Doc (♭? g₁) x → Doc (♭? (g₂ x)) y → Doc (g₁ >>= g₂) y

    -- A string. Note that I do /not/ enforce Wadler's convention
    -- that the string does not contain newline characters.

    text  : ∀ {s} → Doc (string s) s

    -- One or more whitespace characters.

    line  : Doc (tt G.<$ whitespace +) tt

    -- Grouping construct.

    group : ∀ {A x} {g : Grammar A} → Doc g x → Doc g x

    -- Increases the nesting level. (Whatever this means. Renderers
    -- are free to ignore group and nest, see ugly-renderer below.)

    nest  : ∀ {A x} {g : Grammar A} → ℕ → Doc g x → Doc g x

    -- Embedding operator: Documents for one grammar/result also
    -- work for other grammars/results, given that the semantics
    -- are, in a certain sense, compatible.

    emb   : ∀ {A B x y} {g₁ : Grammar A} {g₂ : Grammar B} →
            (∀ {s} → x ∈ g₁ · s → y ∈ g₂ · s) →
            Doc g₁ x → Doc g₂ y

    -- Fill operator.

    fill  : ∀ {A xs} {g : Grammar A} →
            Docs g xs → Doc (g sep-by whitespace +) xs

  -- Sequences of documents, all based on the same grammar.

  infixr 5 _∷_

  data Docs {A} (g : Grammar A) : List⁺ A → Set₁ where
    [_] : ∀ {x} → Doc g x → Docs g (x ∷ [])
    _∷_ : ∀ {x xs} → Doc g x → Docs g xs → Docs g (x ∷⁺ xs)

-- Pretty-printers. A pretty-printer is a function that for every
-- value constructs a matching document.

Pretty-printer : {A : Set} → Grammar A → Set₁
Pretty-printer g = ∀ x → Doc g x

Pretty-printer-for : {A : Set} → Grammar-for A → Set₁
Pretty-printer-for g = ∀ x → Doc (g x) (x , refl)

------------------------------------------------------------------------
-- Derived document combinators

-- A "smart" variant of emb. Can be used to avoid long chains of emb
-- constructors.

embed : ∀ {A B} {g₁ : Grammar A} {g₂ : Grammar B} {x y} →
        (∀ {s} → x ∈ g₁ · s → y ∈ g₂ · s) → Doc g₁ x → Doc g₂ y
embed f (emb g d) = emb (f ∘ g) d
embed f d         = emb f d

-- A document for the empty string.

nil : ∀ {A} {x : A} → Doc (return x) x
nil = embed lemma text
  where
  lemma : ∀ {x s} → [] ∈ string [] · s → x ∈ return x · s
  lemma return-sem = return-sem

-- A document for the given character.

token : ∀ {t} → Doc G.token t
token {t} = embed lemma text
  where
  lemma′ : ∀ {x s} → x ∈ string (t ∷ []) · s → x ≡ t ∷ [] →
           t ∈ G.token · s
  lemma′ (⊛-sem (<$>-sem tok-sem) return-sem) refl = token-sem

  lemma : ∀ {s} → t ∷ [] ∈ string (t ∷ []) · s → t ∈ G.token · s
  lemma t∈ = lemma′ t∈ refl

-- A document for the given character.

tok : ∀ {t} → Doc (G.tok t) t
tok {t} = embed lemma token
  where
  lemma : ∀ {s} → t ∈ G.token · s → t ∈ G.tok t · s
  lemma token-sem = tok-sem

-- Some mapping combinators.

infix 21 <$>_ <$_

<$>_ : ∀ {c A B} {f : A → B} {x} {g : ∞Grammar c A} →
       Doc (♭? g) x → Doc (f G.<$> g) (f x)
<$> d = embed <$>-sem d

<$_ : ∀ {c A B} {x : A} {y} {g : ∞Grammar c B} →
      Doc (♭? g) y → Doc (x G.<$ g) x
<$ d = embed <$-sem d

-- Some sequencing combinators.

infixl 20 _⊛_ _<⊛_ _⊛>_ _<⊛-tt_ _tt-⊛>_

_⊛_ : ∀ {c₁ c₂ A B f x}
        {g₁ : ∞Grammar c₁ (A → B)} {g₂ : ∞Grammar c₂ A} →
      Doc (♭? g₁) f → Doc (♭? g₂) x → Doc (g₁ G.⊛ g₂) (f x)
_⊛_ {g₁ = g₁} {g₂} d₁ d₂ = embed lemma (d₁ ◇ <$> d₂)
  where
  lemma : ∀ {x s} →
          x ∈ (g₁ >>= λ f → f G.<$> g₂) · s → x ∈ g₁ G.⊛ g₂ · s
  lemma (>>=-sem f∈ (<$>-sem x∈)) = ⊛-sem f∈ x∈

_<⊛_ : ∀ {c₁ c₂ A B x y} {g₁ : ∞Grammar c₁ A} {g₂ : ∞Grammar c₂ B} →
       Doc (♭? g₁) x → Doc (♭? g₂) y → Doc (g₁ G.<⊛ g₂) x
_<⊛_ {g₁ = g₁} {g₂} d₁ d₂ = embed lemma (d₁ ◇ <$ d₂)
  where
  lemma : ∀ {x s} →
          x ∈ (g₁ >>= λ x → x G.<$ g₂) · s → x ∈ g₁ G.<⊛ g₂ · s
  lemma (>>=-sem x∈ (<$-sem y∈)) = <⊛-sem x∈ y∈

_⊛>_ : ∀ {c₁ c₂ A B x y} {g₁ : ∞Grammar c₁ A} {g₂ : ∞Grammar c₂ B} →
       Doc (♭? g₁) x → Doc (♭? g₂) y → Doc (g₁ G.⊛> g₂) y
_⊛>_ {g₁ = g₁} {g₂} d₁ d₂ = embed lemma (d₁ ◇ d₂)
  where
  lemma : ∀ {y s} →
          y ∈ (g₁ >>= λ _ → g₂) · s → y ∈ g₁ G.⊛> g₂ · s
  lemma (>>=-sem x∈ y∈) = ⊛>-sem x∈ y∈

_<⊛-tt_ : ∀ {c₁ c₂ A B x} {g₁ : ∞Grammar c₁ A} {g₂ : ∞Grammar c₂ B} →
          Doc (♭? g₁) x → Doc (tt G.<$ g₂) tt → Doc (g₁ G.<⊛ g₂) x
_<⊛-tt_ {g₁ = g₁} {g₂} d₁ d₂ = embed lemma (d₁ <⊛ d₂)
  where
  lemma : ∀ {x s} → x ∈ g₁ G.<⊛ (tt G.<$ g₂) · s → x ∈ g₁ G.<⊛ g₂ · s
  lemma (<⊛-sem x∈ (<$-sem y∈)) = <⊛-sem x∈ y∈

_tt-⊛>_ : ∀ {c₁ c₂ A B x} {g₁ : ∞Grammar c₁ A} {g₂ : ∞Grammar c₂ B} →
          Doc (tt G.<$ g₁) tt → Doc (♭? g₂) x → Doc (g₁ G.⊛> g₂) x
_tt-⊛>_ {g₁ = g₁} {g₂} d₁ d₂ = embed lemma (d₁ ⊛> d₂)
  where
  lemma : ∀ {x s} → x ∈ (tt G.<$ g₁) G.⊛> g₂ · s → x ∈ g₁ G.⊛> g₂ · s
  lemma (⊛>-sem (<$-sem x∈) y∈) = ⊛>-sem x∈ y∈

-- Document combinators for choices.

left : ∀ {c₁ c₂ A x} {g₁ : ∞Grammar c₁ A} {g₂ : ∞Grammar c₂ A} →
       Doc (♭? g₁) x → Doc (g₁ ∣ g₂) x
left d = embed left-sem d

right : ∀ {c₁ c₂ A x} {g₁ : ∞Grammar c₁ A} {g₂ : ∞Grammar c₂ A} →
        Doc (♭? g₂) x → Doc (g₁ ∣ g₂) x
right d = embed right-sem d

-- Some Kleene star and plus combinators.

nil-⋆ : ∀ {c A} {g : ∞Grammar c A} → Doc (g ⋆) []
nil-⋆ {A = A} {g} = embed lemma nil
  where
  lemma : ∀ {s} → [] ∈ return {A = List A} [] · s → [] ∈ g ⋆ · s
  lemma return-sem = ⋆-[]-sem

cons-⋆+ : ∀ {c A} {g : ∞Grammar c A} {x xs} →
          Doc (♭? g) x → Doc (g ⋆) xs → Doc (g +) (x ∷ xs)
cons-⋆+ d₁ d₂ = <$> d₁ ⊛ d₂

cons-⋆ : ∀ {c A} {g : ∞Grammar c A} {x xs} →
         Doc (♭? g) x → Doc (g ⋆) xs → Doc (g ⋆) (x ∷ xs)
cons-⋆ d₁ d₂ = embed ⋆-+-sem (cons-⋆+ d₁ d₂)

-- A document for the empty string.

if-true : ∀ b → Pretty-printer (G.if-true b)
if-true true  _  = nil
if-true false ()

-- Documents for the given character.

sat : (p : Char → Bool) → Pretty-printer (G.sat p)
sat p (t , proof) = token ◇ <$> if-true (p t) proof

tok-sat : {p : Char → Bool} → Pretty-printer-for (G.tok-sat p)
tok-sat _ = <$ tok

-- A single space character.

space : Doc (whitespace ⋆) (' ' ∷ [])
space = embed lemma tok
  where
  lemma : ∀ {s} →
          ' ' ∈ G.tok ' ' · s →
          (' ' ∷ []) ∈ whitespace ⋆ · s
  lemma tok-sem = ⋆-+-sem single-space-sem

-- A variant of line (with _⋆ instead of _+ in the grammar).

line⋆ : Doc (tt G.<$ whitespace ⋆) tt
line⋆ = embed lemma line
  where
  lemma : ∀ {s} →
          tt ∈ tt G.<$ whitespace + · s →
          tt ∈ tt G.<$ whitespace ⋆ · s
  lemma (<$-sem w+) = <$-sem (⋆-+-sem w+)

-- Combinators that add a final "line" to the document, nested i
-- steps. (The grammars have to satisfy certain predicates.)

final-line′ : ∀ {A} {g : Grammar A} {x} →
              Trailing-whitespace g → Doc g x → (i : ℕ) → Doc g x
final-line′ trailing d i = embed trailing (d <⊛-tt nest i line⋆)

final-line : ∀ {A} {g : Grammar A} {x} (n : ℕ)
             {trailing : T (is-just (trailing-whitespace n g))} →
             Doc g x → (i : ℕ) → Doc g x
final-line n {trailing} =
  final-line′ (to-witness-T (trailing-whitespace n _) trailing)

-- Trailing-whitespace never holds for grammars of the form g ⋆, but
-- if the list to be pretty-printed has at least one element, then
-- final-line may still work.

final-line-+⋆ : ∀ {c A} {g : ∞Grammar c A} {x xs} (n : ℕ)
                {trailing : T (is-just (trailing-whitespace n (g +)))} →
                Doc (g +) (x ∷ xs) → (i : ℕ) → Doc (g ⋆) (x ∷ xs)
final-line-+⋆ n {trailing} d i =
  embed ⋆-+-sem (final-line n {trailing} d i)

-- A document for the given symbol (and no following whitespace).

symbol : ∀ {s} → Doc (G.symbol s) s
symbol = text <⊛ nil-⋆

-- A document for the given symbol plus a "line".

symbol-line : ∀ {s} → Doc (G.symbol s) s
symbol-line = final-line 1 symbol 0

-- A document for the given symbol plus a space character.

symbol-space : ∀ {s} → Doc (G.symbol s) s
symbol-space = text <⊛ space

-- A combinator for bracketed output, based on one in Wadler's "A
-- prettier printer".

bracket : ∀ {c A x s₁ s₂} {g : ∞Grammar c A} (n : ℕ) →
          {trailing : T (is-just (trailing-whitespace n (♭? g)))} →
          Doc (♭? g) x → Doc (G.symbol s₁ G.⊛> g G.<⊛ G.symbol s₂) x
bracket n {trailing} d =
  group (nest 2 symbol-line
           ⊛>
         final-line n {trailing = trailing} (nest 2 d) 0
           <⊛
         symbol)

mutual

  -- Conversion of pretty-printers for elements into pretty-printers
  -- for lists.

  map⋆ : ∀ {c A} {g : ∞Grammar c A} →
         Pretty-printer (♭? g) → Pretty-printer (g ⋆)
  map⋆ p []       = nil-⋆
  map⋆ p (x ∷ xs) = embed ⋆-+-sem (map+ p (x ∷ xs))

  map+ : ∀ {c A} {g : ∞Grammar c A} →
         Pretty-printer (♭? g) → Pretty-printer (g +)
  map+ p (x ∷ xs) = cons-⋆+ (p x) (map⋆ p xs)

mutual

  -- Conversion of pretty-printers for specific elements into
  -- pretty-printers for specific lists.

  list : ∀ {A} {elem : Grammar-for A} →
         Pretty-printer-for elem →
         Pretty-printer-for (G.list elem)
  list e []       = nil
  list e (x ∷ xs) = <$> (list⁺ e (x ∷ xs))

  list⁺ : ∀ {A} {elem : Grammar-for A} →
          Pretty-printer-for elem →
          Pretty-printer-for (G.list⁺ elem)
  list⁺ e (x ∷ xs) = <$> (e x) ⊛ list e xs

-- A variant of fill. (The grammar has to satisfy a certain
-- predicate.)

fill+ : ∀ {c A} {g : ∞Grammar c A} (n : ℕ)
        {trailing : T (is-just (trailing-whitespace n (♭? g)))} →
        ∀ {xs} → Docs (♭? g) xs → Doc (g +) xs
fill+ {g = g} n {trailing} ds = embed lemma (fill ds)
  where
  trailing! = to-witness-T (trailing-whitespace n (♭? g)) trailing

  lemma′ : ∀ {x xs s₁ s₂} →
           x ∈ ♭? g · s₁ → xs ∈ ♭? g prec-by whitespace + · s₂ →
           x ∷ xs ∈ g + · s₁ ++ s₂
  lemma′           x∈ ⋆-[]-sem = +-sem x∈ ⋆-[]-sem
  lemma′ {s₁ = s₁} x∈ (⋆-+-sem (⊛-sem (<$>-sem (⊛>-sem w+ x′∈)) xs∈)) =
    cast lemma″
         (+-∷-sem (trailing! (<⊛-sem x∈ (⋆-+-sem w+))) (lemma′ x′∈ xs∈))
    where
    lemma″ :
      ∀ {s₂ s₃ s₄} → (s₁ ++ s₂) ++ s₃ ++ s₄ ≡ s₁ ++ (s₂ ++ s₃) ++ s₄
    lemma″ = solve (++-monoid Char)

  lemma : ∀ {s xs} → xs ∈ ♭? g sep-by whitespace + · s → xs ∈ g + · s
  lemma (⊛-sem (<$>-sem x∈) xs∈) = lemma′ x∈ xs∈

-- Variants of map+/map⋆ that use fill. (The grammars have to satisfy
-- a certain predicate.)

map+-fill : ∀ {c A} {g : ∞Grammar c A} (n : ℕ)
            {trailing : T (is-just (trailing-whitespace n (♭? g)))} →
            Pretty-printer (♭? g) →
            Pretty-printer (g +)
map+-fill {g = g} n {trailing} p (x ∷ xs) =
  fill+ n {trailing = trailing} (to-docs x xs)
  where
  to-docs : ∀ x xs → Docs (♭? g) (x ∷ xs)
  to-docs x []        = [ p x ]
  to-docs x (x′ ∷ xs) = p x ∷ to-docs x′ xs

map⋆-fill : ∀ {c A} {g : ∞Grammar c A} (n : ℕ)
            {trailing : T (is-just (trailing-whitespace n (♭? g)))} →
            Pretty-printer (♭? g) →
            Pretty-printer (g ⋆)
map⋆-fill n            p []       = nil-⋆
map⋆-fill n {trailing} p (x ∷ xs) =
  embed ⋆-+-sem (map+-fill n {trailing = trailing} p (x ∷ xs))


module Human.Unit where

-- Do I need a record and the built-in ⊤? Why?
data Unit : Set where
  unit : Unit