------------------------------------------------------------------------
-- Banker's queues (following Okasaki)
------------------------------------------------------------------------

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

open import Equality

module Queue.Bankers {c⁺} (eq : ∀ {a p} → Equality-with-J a p c⁺) where

open Derived-definitions-and-properties eq

open import Prelude

open import Bijection eq using (_↔_)
open import Erased.Without-box-cong eq as Erased hiding (map)
open import Function-universe eq hiding (id; _∘_)
open import List eq as L hiding (map)
open import Nat eq
open import Surjection eq using (_↠_)
open import Tactic.By.Parametrised eq

private
  variable
    a ℓ ℓ₁ ℓ₂ : Level
    A B       : Type a
    p q x     : A
    f         : A → B
    b         : Bool
    xs        : List A

------------------------------------------------------------------------
-- Queues

-- Queues.
--
-- Note that the invariant is erased.

record Queue (A : Type a) : Type a where
  field
    front rear               : List A
    length-front length-rear : ℕ
    @0 length-invariant      : length-rear ≤ length-front
    @0 length-front≡         : length-front ≡ length front
    @0 length-rear≡          : length-rear  ≡ length rear

open Queue public

------------------------------------------------------------------------
-- Conversion functions

-- Converts queues to lists.

to-List : Queue A → List A
to-List q = q .front ++ reverse (q .rear)

-- Converts lists to queues.

from-List : List A → Queue A
from-List xs = record
  { front            = xs
  ; rear             = []
  ; length-front     = length xs
  ; length-rear      = 0
  ; length-invariant = zero≤ _
  ; length-front≡    = refl _
  ; length-rear≡     = refl _
  }

-- The function from-List is a right inverse of to-List.

to-List-from-List : to-List (from-List xs) ≡ xs
to-List-from-List {xs = xs} =
  xs ++ []  ≡⟨ ++-right-identity _ ⟩∎
  xs        ∎

------------------------------------------------------------------------
-- Queues with broken invariants

private

  -- Queues where the invariant may have been broken (slightly).

  record Almost-queue (A : Type a) : Type a where
    field
      front rear               : List A
      length-front length-rear : ℕ
      @0 length-invariant      : length-rear ≤ suc length-front
      @0 length-front≡         : length-front ≡ length front
      @0 length-rear≡          : length-rear  ≡ length rear

  open Almost-queue

  -- Some conversion functions.

  from-Almost-queue : Almost-queue A → List A
  from-Almost-queue q = q .front ++ reverse (q .rear)

  to-Almost-queue : Queue A → Almost-queue A
  to-Almost-queue q = record
    { front            = q .front
    ; rear             = q .rear
    ; length-front     = q .length-front
    ; length-rear      = q .length-rear
    ; length-front≡    = q .length-front≡
    ; length-rear≡     = q .length-rear≡
    ; length-invariant = ≤-step (q .length-invariant)
    }

  -- Restores the invariant by rotating the queue, if necessary.

  rotate′ :
    (q : Almost-queue A) (b : Bool) →
    @0 T b ↔ suc (q .length-front) ≡ q .length-rear →
    Queue A
  rotate′ q true _ = record
    { front            = q .front ++ reverse (q .rear)
    ; rear             = []
    ; length-front     = q .length-front + q .length-rear
    ; length-rear      = 0
    ; length-invariant = zero≤ _
    ; length-rear≡     = refl _
    ; length-front≡    =
        ⟨ q .length-front ⟩ + q .length-rear                ≡⟨ ⟨by⟩ (q .length-front≡) ⟩
        length (q .front) + ⟨ q .length-rear ⟩              ≡⟨ ⟨by⟩ (q .length-rear≡) ⟩
        length (q .front) + ⟨ length (q .rear) ⟩            ≡⟨ ⟨by⟩ (length-reverse (q .rear)) ⟩
        ⟨ length (q .front) + length (reverse (q .rear)) ⟩  ≡⟨ ⟨by⟩ (length-++ (q .front)) ⟩∎
        length (q .front ++ reverse (q .rear))              ∎
    }
  rotate′ q false 1+f≢r = record
    { front            = q .front
    ; rear             = q .rear
    ; length-front     = q .length-front
    ; length-rear      = q .length-rear
    ; length-front≡    = q .length-front≡
    ; length-rear≡     = q .length-rear≡
    ; length-invariant = case ≤→<⊎≡ (q .length-invariant) of λ @0 where
        (inj₁ 1+r≤1+f) → suc≤suc⁻¹ 1+r≤1+f
        (inj₂ r≡1+f)   → ⊥-elim (_↔_.from 1+f≢r (sym r≡1+f))
    }

  rotate : Almost-queue A → Queue A
  rotate q =
    rotate′ q (suc (q .length-front) == q .length-rear) T[==]↔≡

  to-List-rotate′ :
    ∀ b {p} → to-List (rotate′ q b p) ≡ from-Almost-queue q
  to-List-rotate′         false = refl _
  to-List-rotate′ {q = q} true  =
    (q .front ++ reverse (q .rear)) ++ []  ≡⟨ ++-right-identity _ ⟩∎
    q .front ++ reverse (q .rear)          ∎

  to-List-rotate :
    (q : Almost-queue A) → to-List (rotate q) ≡ from-Almost-queue q
  to-List-rotate q =
    to-List-rotate′ (suc (q .length-front) == q .length-rear)

------------------------------------------------------------------------
-- Queue operations

-- Enqueues an element.

enqueue : A → Queue A → Queue A
enqueue x q =
  rotate (record (to-Almost-queue q)
    { rear             = x ∷ q .rear
    ; length-rear      = 1 + q .length-rear
    ; length-rear≡     = cong suc (q .length-rear≡)
    ; length-invariant = suc≤suc (q .length-invariant)
    })

to-List-enqueue : ∀ q → to-List (enqueue x q) ≡ to-List q ++ x ∷ []
to-List-enqueue {x = x} q =
  to-List (enqueue x q)                      ≡⟨ to-List-rotate (record
                                                  { length-invariant = suc≤suc (q .length-invariant)
                                                  }) ⟩
  q .front ++ ⟨ reverse (x ∷ q .rear) ⟩      ≡⟨ ⟨by⟩ (reverse-∷ (q .rear)) ⟩
  q .front ++ (reverse (q .rear) ++ x ∷ [])  ≡⟨ ++-associative (q .front) _ _ ⟩∎
  (q .front ++ reverse (q .rear)) ++ x ∷ []  ∎

-- Dequeues an element, if possible.

dequeue : Queue A → Maybe (A × Queue A)
dequeue (record { front = [] }) = nothing

dequeue q@(record { front        = x ∷ front
                  ; length-front = suc length-front
                  }) =
  just (x , rotate (record (to-Almost-queue q)
    { front            = front
    ; length-front     = length-front
    ; length-invariant = q .length-invariant
    ; length-front≡    = cancel-suc (q .length-front≡)
    }))

dequeue {A = A}
        q@(record { front        = x ∷ front
                  ; length-front = zero
                  }) =                $⟨ [ q .length-front≡ ] ⟩
  Erased (zero ≡ suc (length front))  ↝⟨ Erased.map 0≢+ ⟩
  Erased ⊥                            ↔⟨ Erased-⊥↔⊥ ⟩
  ⊥                                   ↝⟨ ⊥-elim ⟩□
  Maybe (A × Queue A)                 □

to-List-dequeue :
  (q : Queue A) →
  ⊎-map id (Σ-map id to-List) (dequeue q) ≡
  _↔_.to List↔Maybe[×List] (to-List q)
to-List-dequeue (record { front = []; rear = [] }) = refl _

to-List-dequeue q@(record { front = []; rear = _ ∷ _ }) =
                                             $⟨ [ q .length-invariant ] ⟩
  Erased (q .length-rear ≤ q .length-front)  ↝⟨ Erased.map (subst (_ ≤_) (q .length-front≡)) ⟩
  Erased (q .length-rear ≤ 0)                ↝⟨ Erased.map (subst (_≤ _) (q .length-rear≡)) ⟩
  Erased (suc _ ≤ 0)                         ↝⟨ Erased.map (≮0 _) ⟩
  Erased ⊥                                   ↔⟨ Erased-⊥↔⊥ ⟩
  ⊥                                          ↝⟨ ⊥-elim ⟩□
  _                                          □

to-List-dequeue q@(record { front        = x ∷ front
                          ; length-front = suc length-front
                          }) =
  cong (just ∘ (x ,_))
    (to-List-rotate (record { length-invariant = q .length-invariant }))

to-List-dequeue q@(record { front        = x ∷ front
                          ; length-front = zero
                  }) =                $⟨ [ q .length-front≡ ] ⟩
  Erased (zero ≡ suc (length front))  ↝⟨ Erased.map 0≢+ ⟩
  Erased ⊥                            ↔⟨ Erased-⊥↔⊥ ⟩
  ⊥                                   ↝⟨ ⊥-elim ⟩□
  _                                   □

-- The "inverse" of the dequeue operation.

dequeue⁻¹ : Maybe (A × Queue A) → Queue A
dequeue⁻¹ nothing        = from-List []
dequeue⁻¹ (just (x , q)) = record q
  { front            = x ∷ q .front
  ; length-front     = suc (q .length-front)
  ; length-invariant = ≤-step (q .length-invariant)
  ; length-front≡    = cong suc (q .length-front≡)
  }

to-List-dequeue⁻¹ :
  (x : Maybe (A × Queue A)) →
  to-List (dequeue⁻¹ x) ≡
  _↔_.from List↔Maybe[×List] (⊎-map id (Σ-map id to-List) x)
to-List-dequeue⁻¹ nothing  = refl _
to-List-dequeue⁻¹ (just _) = refl _

-- A map function.

map : (A → B) → Queue A → Queue B
map f q = record
  { front            = L.map f (q .front)
  ; rear             = L.map f (q .rear)
  ; length-front     = q .length-front
  ; length-rear      = q .length-rear
  ; length-invariant = q .length-invariant
  ; length-front≡    =
      q .length-front              ≡⟨ q .length-front≡ ⟩
      ⟨ length (q .front) ⟩        ≡⟨ ⟨by⟩ (length∘map _ (q .front)) ⟩∎
      length (L.map f (q .front))  ∎
  ; length-rear≡     =
      q .length-rear              ≡⟨ q .length-rear≡ ⟩
      ⟨ length (q .rear) ⟩        ≡⟨ ⟨by⟩ (length∘map _ (q .rear)) ⟩∎
      length (L.map f (q .rear))  ∎
  }

to-List-map : ∀ q → to-List (map f q) ≡ L.map f (to-List q)
to-List-map {f = f} q =
  L.map f (q .front) ++ ⟨ reverse (L.map f (q .rear)) ⟩  ≡⟨ ⟨by⟩ (map-reverse (q .rear)) ⟩
  L.map f (q .front) ++ L.map f (reverse (q .rear))      ≡⟨ sym $ map-++ _ (q .front) _ ⟩∎
  L.map f (q .front ++ reverse (q .rear))                ∎


-- {-# OPTIONS --no-forcing #-}
{-# OPTIONS --rewriting #-}
{-# OPTIONS --sized-types #-}

open import Agda.Builtin.Equality
open import Agda.Builtin.Size

{-# BUILTIN REWRITE _≡_ #-}

variable i j : Size

postulate ANY : ∀{A : Set} → A

data Ty : Set where
  bool : Ty

variable a b c d : Ty

infixl 5 _∘_
infixr 6 _∷_ _++_

mutual

  data Tm (c : Ty) : Set where
    tm : ∀{i a} (E : Stack i a c) → Tm c

  data Stack (i : Size) : (a c : Ty) → Set where
    ε    : ∀{c} → Stack i c c
    _∷_  : ∀{j : Size< i}{b} (u : Tm b) (E : Stack j b c) → Stack i bool c

  variable E E' E′ : Stack i a c

_++_ : ∀{a b c} → Stack ∞ a b → Stack ∞ b c → Stack ∞ a c
ε       ++ E′ = E′
(u ∷ E) ++ E′ = u ∷ (E ++ E′)

postulate
  _∘_ : ∀{a c} → Tm a → Stack ∞ a c → Tm c
  app-app : ∀{i j a b c}{t : Tm a} {E : Stack i a b} {E′ : Stack j b c} → t ∘ E ∘ E′ ≡ t ∘ E ++ E′

{-# REWRITE app-app #-}

infix 4 _↦_  _↦ₛ_

mutual

  data _↦_ {c} : (t t′ : Tm c) → Set where
    ↦E  : (r : E ↦ₛ E′) → tm E ↦ tm E′
    -- ↦E  : ∀{i a} {E E′ : Stack i a c} (r : E ↦ₛ E′) → tm E ↦ tm E′ -- no internal error

  data _↦ₛ_ {c} : ∀ {i a} (E E′ : Stack i a c) → Set where
    π     : ∀{i a u v} {E : Stack i a c} → (u ∷ v ∷ E) ↦ₛ ((u ∘ v ∷ ε) ∷ E)
    there : ∀{i a u} {E E′ : Stack i a c} (r : E ↦ₛ E′) → u ∷ E ↦ₛ u  ∷ E′

data SN {a} (t : Tm a) : Set where
  acc : (h : {t′ : Tm a} (r : t ↦ t′) → SN t′) → SN t

-- {-# TERMINATING #-}  -- removes internal error

test : {i : Size} {a c : Ty} {t : Tm a} {E : Stack i a c}
          (sntE : SN (t ∘ E))
          → SN (tm (t ∷ E))
test {i = i} {t = t} (acc sntE) = acc
  λ { (↦E (there r)) → test (sntE ANY)
    ; (↦E (π {i = j})) → test {i = j} (acc sntE)
    }


-- Andreas, 2015-08-27 use imported rewrite rule

{-# OPTIONS --rewriting #-}

open import Common.Nat
open import Common.Equality

open import Issue1550

x+0+0+0 : ∀{x} → ((x + 0) + 0) + 0 ≡ x
x+0+0+0 = refl


-- Generic term traversals
module Syntax.Substitution.Lemmas where

open import Syntax.Types
open import Syntax.Context
open import Syntax.Terms
open import Syntax.Substitution.Kits
open import Syntax.Substitution.Instances

open import Data.Sum
open import Relation.Binary.PropositionalEquality as ≡
    using (_≡_ ; refl ; sym ; cong ; subst)
open import Function using (id ; flip ; _∘_)
open ≡.≡-Reasoning

-- | Lemmas from substitutions
-- | Concrete instances of structural and substitution lemmas
-- | can be expressed as substituting traversals on terms

-- Weakening lemma
weakening : ∀{Γ Δ A} ->     Γ ⊆ Δ   ->   Γ ⊢ A
                           --------------------
                     ->           Δ ⊢ A
weakening s = substitute (weakₛ 𝒯ermₛ s)

-- Weakening lemma for computations
weakening′ : ∀{Γ Δ A} ->     Γ ⊆ Δ   ->   Γ ⊨ A
                           --------------------
                     ->           Δ ⊨ A
weakening′ s = substitute′ (weakₛ 𝒯ermₛ s)

-- Exchange lemma
exchange : ∀ Γ Γ′ Γ″ {A B C}
                     ->   Γ ⌊ A ⌋ Γ′ ⌊ B ⌋ Γ″ ⊢ C
                         ----------------------
                     ->   Γ ⌊ B ⌋ Γ′ ⌊ A ⌋ Γ″ ⊢ C
exchange Γ Γ′ Γ″ = substitute (exₛ 𝒯ermₛ Γ Γ′ Γ″)

-- Contraction lemma
contraction : ∀ Γ Γ′ Γ″ {A B}
                     ->   Γ ⌊ A ⌋ Γ′ ⌊ A ⌋ Γ″ ⊢ B
                         ----------------------
                     ->   Γ ⌊ A ⌋ Γ′ ⌊⌋ Γ″ ⊢ B
contraction Γ Γ′ Γ″ = substitute (contr-lₛ 𝒯ermₛ Γ Γ′ Γ″)

-- Substitution lemma
substitution : ∀ Γ Γ′ {A B}
                     ->  Γ ⌊⌋ Γ′ ⊢ A   ->   Γ ⌊ A ⌋ Γ′ ⊢ B
                        --------------------------------
                     ->           Γ ⌊⌋ Γ′ ⊢ B
substitution Γ Γ′ M = substitute (sub-midₛ 𝒯ermₛ Γ Γ′ M)

-- Substitution lemma for computational terms
substitution′ : ∀ Γ Γ′ {A B}
                     ->  Γ ⌊⌋ Γ′ ⊢ A   ->   Γ ⌊ A ⌋ Γ′ ⊨ B
                        --------------------------------
                     ->           Γ ⌊⌋ Γ′ ⊨ B
substitution′ Γ Γ′ M = substitute′ (sub-midₛ 𝒯ermₛ Γ Γ′ M)

-- Top substitution lemma
[_/] : ∀ {Γ A B}
                     ->  Γ ⊢ A   ->   Γ , A  ⊢ B
                        --------------------------
                     ->           Γ ⊢ B
[_/] M = substitute (sub-topₛ 𝒯ermₛ M)

-- Top substitution lemma for computational terms
[_/′] : ∀ {Γ A B}
                     ->  Γ ⊢ A   ->   Γ , A  ⊨ B
                        --------------------------
                     ->           Γ ⊨ B
[_/′] M = substitute′ (sub-topₛ 𝒯ermₛ M)

-- Top substitution of computation into a computation
⟨_/⟩ : ∀ {Γ A B}      ->  Γ ⊨ A now  ->   Γ ˢ , A now ⊨ B now
                        ------------------------------------
                     ->              Γ ⊨ B now
⟨ pure M               /⟩ D = substitute′ (sub-topˢₛ 𝒯ermₛ M) D
⟨ letSig S InC C       /⟩ D = letSig S InC ⟨ C /⟩ (substitute′ ((idₛ 𝒯erm) ⁺ 𝒯erm ↑ 𝒯erm) D)
⟨ (letEvt_In_ {Γ} E C) /⟩ D = letEvt E In  ⟨ C /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D)
⟨ select_↦_||_↦_||both↦_ {Γ} E₁ C₁ E₂ C₂ C₃ /⟩ D
                           = select E₁ ↦ ⟨ C₁ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D)
                                 || E₂ ↦ ⟨ C₂ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D)
                                 ||both↦ ⟨ C₃ /⟩ (substitute′ ((Γ ˢˢₛ 𝒯erm) ↑ 𝒯erm) D)


{- 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 Optics.All
open import LibraBFT.Prelude
open import LibraBFT.Lemmas
open import LibraBFT.Hash
open import LibraBFT.Base.ByteString
open import LibraBFT.Base.Encode
open import LibraBFT.Base.PKCS
open import LibraBFT.Impl.Consensus.Types.EpochIndep

-- This module postulates a collision-resistant cryptographic hash
-- function (we call it sha256 for concreteness, but it could be any
-- collision-resistant cryptographic hash function), and defines hash
-- functions used in (an earlier version of) LibraBFT, properties
-- about it, and how Votes and Blocks are signed.

module LibraBFT.Impl.Util.Crypto where
  -- Note that this is an abstraction of a collision-resistant hash function.  It could be any such
  -- hash function, not necessarily sha256.  We just call it sha256 for "concreteness", to remind
  -- ourselves it's modeling such a function.
  postulate -- valid assumption (collision-resistant hash function)
    sha256    : BitString → Hash
    sha256-cr : ∀{x y} → sha256 x ≡ sha256 y → Collision sha256 x y ⊎ x ≡ y

  open WithCryptoHash sha256 sha256-cr

  blockInfoBSList : BlockInfo → List ByteString
  blockInfoBSList (BlockInfo∙new epoch round id) = encode epoch ∷ encode round ∷ encode id ∷ []

  hashBI : BlockInfo → HashValue
  hashBI = sha256 ∘ bs-concat ∘ blockInfoBSList

  hashBI-inj : ∀ {bi1 bi2} → hashBI bi1 ≡ hashBI bi2 → NonInjective-≡ sha256 ⊎ bi1 ≡ bi2
  hashBI-inj {bi1} {bi2} hyp with sha256-cr hyp
  ...| inj₁ col = inj₁ (_ , col)
  ...| inj₂ res with bs-concat-inj (blockInfoBSList bi1) (blockInfoBSList bi2) res
  ...| final = inj₂ (BlockInfo-η (encode-inj (proj₁ (∷-injective final)))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective final)))))
                                 (encode-inj (proj₁ (∷-injective (proj₂ (∷-injective (proj₂ (∷-injective final))))))))

  voteDataHashList : VoteData → List Hash
  voteDataHashList (VoteData∙new proposed parent) =
    hProposed ∷ hParent ∷ []
   where
    hProposed = hashBI proposed
    hParent   = hashBI parent

  hashVD : VoteData → HashValue
  hashVD = hash-concat ∘ voteDataHashList

  VoteData-≢-eid : ∀ {vd1 vd2 : VoteData}
                 → vd1 ^∙ vdProposed ∙ biEpoch ≢ vd2 ^∙ vdProposed ∙ biEpoch
                 → vd1 ≢ vd2
  VoteData-≢-eid neq = λ x → neq (cong (_^∙ vdProposed ∙ biEpoch) x)

  VoteData-hb : ∀ {vd1 vd2 : VoteData}
              → vd1 ^∙ vdProposed ∙ biEpoch ≢ vd2 ^∙ vdProposed ∙ biEpoch
              → hashVD vd1 ≡ hashVD vd2
              → NonInjective-≡ sha256
  VoteData-hb {vd1} {vd2} neq hvd≡
    with hash-concat-inj {voteDataHashList vd1} {voteDataHashList vd2} hvd≡
  ...| inj₁ hb = hb
  ...| inj₂ xxx
     with cong head xxx
  ...| yyy
     with cong tail xxx
  ...| yyy'
     with cong head (just-injective yyy')
  ...| yyy''
     with just-injective yyy | just-injective yyy''
  ...| zzz | zzz'
     with hashBI-inj {vd1 ^∙ vdProposed} {vd2 ^∙ vdProposed} zzz |
          hashBI-inj {vd1 ^∙ vdParent}   {vd2 ^∙ vdParent}   zzz'
  ...| inj₁ hb  | _         = hb
  ...| inj₂ _   | inj₁ hb   = hb
  ...| inj₂ aaa | inj₂ aaa' = ⊥-elim (VoteData-≢-eid {vd1} {vd2} neq (VoteData-η aaa aaa'))

  hashVD-inj : ∀ {vd1 vd2} → hashVD vd1 ≡ hashVD vd2 → NonInjective-≡ sha256 ⊎ vd1 ≡ vd2
  hashVD-inj {vd1} {vd2} prf
    with hash-concat-inj {voteDataHashList vd1} {voteDataHashList vd2} prf
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ vdLists≡
     with hashBI-inj (proj₁ (∷-injective vdLists≡)) | hashBI-inj (proj₁ (∷-injective (proj₂ (∷-injective vdLists≡))))
  ...| inj₁ hb    | _         = inj₁ hb
  ...| inj₂ _     | inj₁ hb   = inj₁ hb
  ...| inj₂ prop≡ | inj₂ par≡ = inj₂ (VoteData-η prop≡ par≡)

  hashLI : LedgerInfo → HashValue
  hashLI (LedgerInfo∙new commitInfo consensusDataHash) =
    hash-concat (hashBI commitInfo ∷ consensusDataHash ∷ [])

  hashLI-inj : ∀ {li1 li2} → hashLI li1 ≡ hashLI li2 → NonInjective-≡ sha256 ⊎ li1 ≡ li2
  hashLI-inj {LedgerInfo∙new ci1 cd1} {LedgerInfo∙new ci2 cd2} prf
     with hash-concat-inj {hashBI ci1 ∷ cd1 ∷ []} {hashBI ci2 ∷ cd2 ∷ []} prf
  ...| inj₁ hb      = inj₁ hb
  ...| inj₂ li1≡li2
     with ∷-injective li1≡li2
  ...| ci≡ , rest≡
     with ∷-injective rest≡
  ...| cdh≡ , _
     with hashBI-inj ci≡
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ cis≡
     = inj₂ (LedgerInfo-η cis≡ cdh≡)

  constructLI : Vote → LedgerInfo
  constructLI v = LedgerInfo∙new (₋liCommitInfo (₋vLedgerInfo v)) (hashVD (₋vVoteData v))

  hashVote : Vote → HashValue
  hashVote = hashLI ∘ constructLI

  hashVote-inj1 : ∀ {v1 v2} → hashVote v1 ≡ hashVote v2
                → NonInjective-≡ sha256 ⊎ ₋vVoteData v1 ≡ ₋vVoteData v2
  hashVote-inj1 {v1} {v2} hyp with hashLI-inj {constructLI v1} {constructLI v2} hyp
  ...| inj₁ hb = inj₁ hb
  ...| inj₂ ok = hashVD-inj {₋vVoteData v1} {₋vVoteData v2} (cong ₋liConsensusDataHash ok)

  -- A vote is always signed; as seen by the 'Unit'
  -- in the definition of Signed.
  instance
    sig-Vote : WithSig Vote
    sig-Vote = record
       { Signed         = λ _ → Unit
       ; Signed-pi      = λ _ _ _ → Unit-pi
       ; isSigned?      = λ _ → yes unit
       ; signature      = λ v _ → ₋vSignature v
       ; signableFields = encodeH ∘ hashVote
       }

  -- Captures a proof that a vote was cast by α by recording that 'verify' returns true.
  VoteSigVerifies : PK → Vote → Set
  VoteSigVerifies pk v = T (verify (signableFields ⦃ sig-Vote ⦄ v) (₋vSignature v) pk)

  Signed-pi-Blk : (b : Block)
                → (is1 is2 : (Is-just ∘ ₋bSignature) b)
                → is1 ≡ is2
  Signed-pi-Blk (Block∙new _ _ .(just _)) (just _) (just _) = cong just refl

  -- A Block might carry a signature
  instance
    sig-Block : WithSig Block
    sig-Block = record
       { Signed         = Is-just ∘ ₋bSignature
       ; Signed-pi      = Signed-pi-Blk
       ; isSigned?      = λ b → Maybe-Any-dec (λ _ → yes tt) (b ^∙ bSignature)
       ; signature      = λ { _ prf → to-witness prf }
       ; signableFields = λ b → concat (encodeH (₋bId b) ∷ encode (b ^∙ bBlockData) ∷ [])
       }


open import Relation.Binary.Core

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

open import Data.Sum
open import PLRTree {A}
open import PLRTree.Complete {A}
open import PLRTree.Compound {A}
open import PLRTree.Drop _≤_ tot≤
open import PLRTree.DropLast.Complete _≤_ tot≤
open import PLRTree.Equality {A}
open import PLRTree.Order.Properties {A}
open import PLRTree.Push.Complete _≤_ tot≤

lemma-setRoot-complete : {t : PLRTree}(x : A) → Complete t → Complete (setRoot x t)
lemma-setRoot-complete x leaf = leaf
lemma-setRoot-complete x (perfect _ cl cr l≃r) = perfect x cl cr l≃r
lemma-setRoot-complete x (left _ cl cr l⋘r) = left x cl cr l⋘r
lemma-setRoot-complete x (right _ cl cr l⋙r) = right x cl cr l⋙r

lemma-drop-complete : {t : PLRTree} → Complete t → Complete (drop t)
lemma-drop-complete leaf = leaf
lemma-drop-complete (perfect _ _ _ ≃lf) = leaf
lemma-drop-complete (perfect {node perfect x' l' r'} {node perfect x'' l'' r''} x (perfect .x' cl' cr' _) (perfect .x'' cl'' cr'' _) (≃nd .x' .x'' l'≃r' l''≃r'' l'≃l'')) =
                 let z = last (node perfect x (node perfect x' l' r') (node perfect x'' l'' r'')) compound ;
                      t' = dropLast (node perfect x (node perfect x' l' r') (node perfect x'' l'' r'')) ;
                      ct' = right x (perfect x' cl' cr' l'≃r') (lemma-dropLast-complete (perfect x'' cl'' cr'' l''≃r'')) (lemma-dropLast-≃ (≃nd x' x'' l'≃r' l''≃r'' l'≃l'') compound)
                 in lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
lemma-drop-complete (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
... | leaf | () | _
... | node perfect _ _ _ | () | _
... | node left x''' l''' r''' | ld⋘r' | cld =
                 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 lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | node right x''' l''' r''' | ld⋘r' | cld =
                 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 lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
lemma-drop-complete (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
... | leaf | () | _
... | node perfect x''' l''' r''' | ld≃r' | cld =
                 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 lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | node left _ _ _ | () | _
... | node right _ _ _ | () | _
lemma-drop-complete (left x cl cr l⋘r) | node right x' l' r' | leaf | () | _
lemma-drop-complete (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-complete (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'''
                 in lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
lemma-drop-complete (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
... | leaf | () | _
... | node perfect _ _ _ | () | _
... | node left x''' l''' r''' | ld⋘r' | cld =
                 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 lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | node right x''' l''' r''' | ld⋘r' | cld =
                 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 lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
lemma-drop-complete (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
... | leaf | () | _
... | node perfect x''' l''' r''' | ld≃r' | cld =
                 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 lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | node left _ _ _ | () | _
... | node right _ _ _ | () | _
lemma-drop-complete (left x cl cr l⋘r) | node right x' l' r' | node left x'' l'' r'' | () | _
lemma-drop-complete (left x cl cr l⋘r) | node right x' l' r' | node right x'' l'' r'' | () | _
lemma-drop-complete (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') | _ = cl
... | 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)
                 in lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | node left _ _ _ | node perfect _ _ _ | ⋙p () | _
... | node right _ _ _ | node perfect _ _ _ | ⋙p () | _
... | leaf | node left _ _ _ | ⋙p () | _
... | node perfect x' l' r' | node left x'' 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
                 in lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | 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'' | _ | 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
                 in lemma-push-complete (lemma-setRoot-complete z ct') (≺-wf (setRoot z t'))
... | node perfect _ _ _ | node right _ _ _ | _ | inj₂ ()
... | node left _ _ _ | node right _ _ _ | ⋙p () | _
... | node right _ _ _ | node right _ _ _ | ⋙p () | _


------------------------------------------------------------------------
-- The Agda standard library
--
-- The unit type and the total relation on unit
------------------------------------------------------------------------

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

open import Agda.Builtin.Equality using (_≡_)

module Data.Unit.Base where

------------------------------------------------------------------------
-- A unit type defined as a record type

-- Note that by default the unit type is not universe polymorphic as it
-- often results in unsolved metas. See `Data.Unit.Polymorphic` for a
-- universe polymorphic variant.

-- Note also that the name of this type is "\top", not T.

open import Agda.Builtin.Unit public
  using (⊤; tt)

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.2

record _≤_ (x y : ⊤) : Set where
{-# WARNING_ON_USAGE _≤_
"Warning: _≤_ was deprecated in v1.2.
Please use _≡_ from Relation.Binary.PropositionalEquality instead."
#-}


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

open import Cubical.HITs.Wedge.Base public


-- Andreas, 2016-06-20, issue #1891

-- Computation of which variables are splittable was wrong
-- in the presence of a where-module.

-- {-# OPTIONS -v interaction.case:20 #-}

data D : Set where
  c : D

test : (x : D) → D
test x = {!x!}  -- C-c C-c
  where
   y = c

-- WAS:
-- Splitting on x reports:
-- Not a (splittable) variable: x
-- when checking that the expression ? has type D

-- Should work now.

-- Further tests:

record R (A : Set) : Set where
  testR : (x : D) → D
  testR x = {!x!}
    where B = A

module M (A : Set) where
  testM : (x : D) → D
  testM x = {!x!}
    where open R {A = A}


{-# OPTIONS --without-K --overlapping-instances #-}

open import lib.Basics
open import lib.types.Coproduct
open import lib.types.Truncation
open import lib.types.Sigma
open import lib.types.Empty
open import lib.types.Bool
open import lib.NConnected
open import lib.NType2

module Util.Misc where

transp-↓' : ∀ {k j} {A : Type k} (P : A → Type j) {a₁ a₂ : A}
  (p : a₁ == a₂) (y : P a₁) → y == transport P p y [ P ↓ p ]
transp-↓' P p y = from-transp P p idp

Σ-transp : ∀ {i j} {A : Type i} (B : A → Type j) {a a' : A} (p : a == a') (b : B a) →
           (a , b) == (a' , transport B p b)

Σ-transp B p b = pair= p (transp-↓' B p b)

equiv-prop : {i j : ULevel} {P : Type i} ⦃ P-prop : is-prop P ⦄ {Q : Type j} ⦃ Q-prop : is-prop Q ⦄ → (P → Q) →
             (Q → P) → (P ≃ Q)

equiv-prop f g = f , (record { g = g ; f-g = λ q → prop-has-all-paths (f (g q)) q
                             ; g-f = λ p → prop-has-all-paths (g (f p)) p
                             ; adj = λ p → prop-has-all-paths _ _ })

_↔_ : {i j : ULevel} (A : Type i) (B : Type j) → Type (lmax i j)
A ↔ B = (A → B) × (B → A)

prop-extensionality : {i : ULevel} {P Q : Type i} ⦃ P-prop : is-prop P ⦄ ⦃ Q-prop : is-prop Q ⦄ → (P ↔ Q) → (P == Q)
prop-extensionality e = ua (equiv-prop (fst e) (snd e))

{- Notation for propositional truncation. -}
∥_∥ : {j : ULevel} → (A : Type j) → Type j
∥_∥ = Trunc (-1)

{- This enables do notation for propositional truncation. It works well for any modality, but we will
   only need this special case. -}
_>>=_ : {i j : ULevel} {X : Type i} {Y : Type j} → (Trunc (-1) X) → (X → Trunc (-1) Y) → (Trunc (-1) Y)
x >>= f = Trunc-rec f x

{- We also add notation for 0 and 1 truncation -}
∥_∥₀ : {j : ULevel} → (A : Type j) → Type j
∥_∥₀ = Trunc 0

∥_∥₁ : {j : ULevel} → (A : Type j) → Type j
∥_∥₁ = Trunc 1

conn-to-path : {i : ULevel} {A : Type i} ⦃ conn : is-connected 0 A ⦄ → (a b : A) → ∥ a == b ∥
conn-to-path ⦃ conn ⦄ _ _ = contr-center (path-conn conn)

conn-to-inh : {i : ULevel} {A : Type i} ⦃ conn : is-connected 0 A ⦄ → ∥ A ∥
conn-to-inh ⦃ conn ⦄ = Trunc-rec ⦃ raise-level _ ⟨⟩ ⦄ [_] (contr-center conn)

inj-to-embed-allpaths : {i j : ULevel} {A : Type i} {B : Type j} ⦃ Bset : is-set B ⦄ (inc : A → B) (inc-inj : is-inj inc) → (b : B) → has-all-paths (hfiber inc b)
inj-to-embed-allpaths inc inc-inj b (a , p) (a' , q) = pair= (inc-inj _ _ (p ∙ ! q)) prop-has-all-paths-↓

inj-to-embed : {i j : ULevel} {A : Type i} {B : Type j} ⦃ Bset : is-set B ⦄ (inc : A → B) (inc-inj : is-inj inc) → (b : B) → is-prop (hfiber inc b)
inj-to-embed inc inc-inj b = all-paths-is-prop (inj-to-embed-allpaths inc inc-inj b)

dec-img-to-⊔ : {i j : ULevel} {A : Type i} {B : Type j} (inc : A → B) (inc-inj : is-inj inc) (dec-img : (b : B) → Dec (hfiber inc b)) → A ⊔ Σ B (λ b → ¬ (hfiber inc b)) ≃ B
dec-img-to-⊔ {A = A} {B = B} inc inc-inj dec-img = equiv f g f-g g-f
  where
    g-aux : (b : B) → (Dec (hfiber inc b)) → A ⊔ Σ B (λ b → ¬ (hfiber inc b))
    g-aux b (inl x) = inl (fst x)
    g-aux b (inr x) = inr (b , x)

    g : (b : B) → A ⊔ Σ B (λ b → ¬ (hfiber inc b))
    g b = g-aux b (dec-img b)

    f : A ⊔ Σ B (λ b → ¬ (hfiber inc b)) → B
    f (inl a) = inc a
    f (inr (b , p)) = b

    g-f-aux : (z : A ⊔ Σ B (λ b → ¬ (hfiber inc b))) (x : Dec (hfiber inc (f z))) → (g-aux (f z) x == z)
    g-f-aux (inl a) (inl x) = ap inl (inc-inj _ _ (snd x))
    g-f-aux (inl a) (inr x) = ⊥-rec (x (a , idp))
    g-f-aux (inr p) (inl x) = ⊥-rec (snd p x)
    g-f-aux (inr p) (inr x) = ap inr (pair= idp (λ= λ w → prop-has-all-paths _ _))

    g-f : (z : A ⊔ Σ B (λ b → ¬ (hfiber inc b))) → (g (f z) == z)
    g-f z = g-f-aux z (dec-img (f z))

    f-g-aux : (b : B) → (x : Dec (hfiber inc b)) → (f (g-aux b x) == b)
    f-g-aux b (inl x) = snd x
    f-g-aux b (inr x) = idp

    f-g : (b : B) → (f (g b) == b)
    f-g b = f-g-aux b (dec-img b)


-- Andreas, 2017-01-18, issue #57
-- reported by Nisse 2008-03-26

data Unit : Set where
  unit : Unit

foo : Unit → Unit
foo m with m
foo _ | x@unit with x
foo _ | x@unit | _ = x

test : Unit → Unit
test m with m
test _ | x@unit with x
... | _ = x


module Imports.Issue5198 (Y : Set₁) where

record R : Set₂ where
  constructor mkR
  field
    A : Set₁


module Issue784.Values where

open import Data.Bool using (Bool; true; false; not)
open import Data.String public using (String)
open import Data.String.Properties public using (_≟_)

open import Function public
open import Data.List using (List; []; _∷_; _++_; [_]; filterᵇ) renaming (map to mapL)
open import Data.List.Relation.Unary.Any public using (Any; here; there) renaming (map to mapA; any to anyA)
open import Data.Product public using (Σ; Σ-syntax; proj₁; proj₂; _,_; _×_) renaming (map to mapΣ)
open import Data.Unit public using (⊤)
open import Data.Unit.NonEta public using (Unit; unit)
open import Data.Empty public using (⊥; ⊥-elim)
open import Relation.Binary.Core hiding (_⇔_) public
open import Relation.Nullary hiding (Irrelevant) public
import Level

open import Relation.Binary.PropositionalEquality public hiding ([_]) renaming (cong to ≡-cong; cong₂ to ≡-cong₂)
open import Relation.Binary.PropositionalEquality.Core public renaming (sym to ≡-sym; trans to ≡-trans)
{-
≢-sym : ∀ {ℓ} {A : Set ℓ} {x y : A} → x ≢ y → y ≢ x
≢-sym x≢y = x≢y ∘ ≡-sym
-}
≡-elim : ∀ {ℓ} {X Y : Set ℓ} → X ≡ Y → X → Y
≡-elim refl p = p

≡-elim′ : ∀ {a ℓ} {A : Set a} {x y : A} → (P : A → Set ℓ) → x ≡ y → P x → P y
≡-elim′ P = ≡-elim ∘ (≡-cong P)

Named : ∀ {ℓ} (A : Set ℓ) → Set ℓ
Named A = String × A

NamedType : ∀ ℓ → Set (Level.suc ℓ)
NamedType ℓ = Named (Set ℓ)

NamedValue : ∀ ℓ → Set (Level.suc ℓ)
NamedValue ℓ = Named (Σ[ A ∈ Set ℓ ] A)

Names : Set
Names = List String

Types : ∀ ℓ → Set (Level.suc ℓ)
Types ℓ = List (NamedType ℓ)

Values : ∀ ℓ → Set (Level.suc ℓ)
Values ℓ = List (NamedValue ℓ)

names : ∀ {ℓ} {A : Set ℓ} → List (Named A) → Names
names = mapL proj₁

types : ∀ {ℓ} → Values ℓ → Types ℓ
types = mapL (mapΣ id proj₁)

infix 4 _∈_ _∉_

_∈_ : ∀ {ℓ} {A : Set ℓ} → A → List A → Set ℓ
x ∈ xs = Any (_≡_ x) xs

_∉_ : ∀ {ℓ} {A : Set ℓ} → A → List A → Set ℓ
x ∉ xs = ¬ x ∈ xs

x∉y∷l⇒x≢y : ∀ {ℓ} {A : Set ℓ} {x y : A} {l : List A} → x ∉ y ∷ l → x ≢ y
x∉y∷l⇒x≢y x∉y∷l x≡y = x∉y∷l $ here x≡y

x∉y∷l⇒x∉l : ∀ {ℓ} {A : Set ℓ} {x y : A} {l : List A} → x ∉ y ∷ l → x ∉ l
x∉y∷l⇒x∉l x∉y∷l x∈l = x∉y∷l $ there x∈l

x≢y⇒x∉l⇒x∉y∷l : ∀ {ℓ} {A : Set ℓ} {x y : A} {l : List A} → x ≢ y → x ∉ l → x ∉ y ∷ l
x≢y⇒x∉l⇒x∉y∷l x≢y x∉l (here x≡y) = x≢y x≡y
x≢y⇒x∉l⇒x∉y∷l x≢y x∉l (there x∈l) = x∉l x∈l

infix 5 _∋!_ _∈?_

_∈?_ : (s : String) (n : Names) → Dec (s ∈ n)
s ∈? [] = no λ()
s ∈? (h ∷ t) with s ≟ h
... | yes s≡h = yes $ here s≡h
... | no s≢h with s ∈? t
...        | yes s∈t = yes $ there s∈t
...        | no s∉t = no $ x≢y⇒x∉l⇒x∉y∷l s≢h s∉t

_∋!_ : Names → String → Bool
l ∋! e with e ∈? l
... | yes _ = true
... | no _ = false

infix 4 _⊆_ _⊈_

_⊆_ : ∀ {ℓ} {A : Set ℓ} → List A → List A → Set ℓ
xs ⊆ ys = ∀ {x} → x ∈ xs → x ∈ ys

_⊈_ : ∀ {ℓ} {A : Set ℓ} → List A → List A → Set ℓ
xs ⊈ ys = ¬ xs ⊆ ys

infixl 5 _∪_

_∪_ : ∀ {ℓ} {A : Set ℓ} → List A → List A → List A
_∪_ = _++_

infixl 6 _∩_

_∩_ : Names → Names → Names
x ∩ y = filterᵇ (_∋!_ y) x

infixl 6 _∖_ _∖∖_

_∖_ : Names → Names → Names
_∖_ x y = filterᵇ (not ∘ _∋!_ y) x

_∖∖_ : ∀ {ℓ} {A : Set ℓ} → List (Named A) → Names → List (Named A)
_∖∖_ l n = filterᵇ (not ∘ _∋!_ n ∘ proj₁) l

filter-∈ : ∀ {ℓ} {A : Set ℓ} → List (Named A) → Names → List (Named A)
filter-∈ l n = filterᵇ (_∋!_ n ∘ proj₁) l

infixr 5 _∷_

data NonRepetitive {ℓ} {A : Set ℓ} : List A → Set ℓ where
  [] : NonRepetitive []
  _∷_ : ∀ {x xs} → x ∉ xs → NonRepetitive xs → NonRepetitive (x ∷ xs)

infix 4 _≋_

data _≋_ {ℓ} {A : Set ℓ} : List A → List A → Set ℓ where
  refl : ∀ {l} → l ≋ l
  perm : ∀ {l} l₁ x₁ x₂ l₂ → l ≋ l₁ ++ x₂ ∷ x₁ ∷ l₂ → l ≋ l₁ ++ x₁ ∷ x₂ ∷ l₂

NonRepetitiveNames : ∀ {ℓ} {A : Set ℓ} → List (Named A) → Set
NonRepetitiveNames = NonRepetitive ∘ names

NonRepetitiveTypes : ∀ ℓ → Set (Level.suc ℓ)
NonRepetitiveTypes ℓ = Σ[ t ∈ Types ℓ ] NonRepetitiveNames t

-- lemmas

∪-assoc : ∀ {l} {A : Set l} (x y z : List A) → (x ∪ y) ∪ z ≡ x ∪ (y ∪ z)
∪-assoc [] y z = refl
∪-assoc (x ∷ xs) y z = ≡-elim′ (λ e → x ∷ e ≡ (x ∷ xs) ∪ (y ∪ z)) (≡-sym $ ∪-assoc xs y z) refl

≡⇒≋ : ∀ {ℓ} {A : Set ℓ} {x y : List A} → x ≡ y → x ≋ y
≡⇒≋ refl = refl

private
    ∈-perm : ∀ {ℓ} {A : Set ℓ} {x : A} (l₁ : List A) (e₁ : A) (e₂ : A) (l₂ : List A) → x ∈ l₁ ++ e₁ ∷ e₂ ∷ l₂ → x ∈ l₁ ++ e₂ ∷ e₁ ∷ l₂
    ∈-perm [] e₁ e₂ l₂ (here .{e₁} .{e₂ ∷ l₂} px) = there $ here px
    ∈-perm [] e₁ e₂ l₂ (there .{e₁} .{e₂ ∷ l₂} (here .{e₂} .{l₂} px)) = here px
    ∈-perm [] e₁ e₂ l₂ (there .{e₁} .{e₂ ∷ l₂} (there .{e₂} .{l₂} pxs)) = there $ there pxs
    ∈-perm (h₁ ∷ t₁) e₁ e₂ l₂ (here .{h₁} .{t₁ ++ e₁ ∷ e₂ ∷ l₂} px) = here px
    ∈-perm (h₁ ∷ t₁) e₁ e₂ l₂ (there .{h₁} .{t₁ ++ e₁ ∷ e₂ ∷ l₂} pxs) = there $ ∈-perm t₁ e₁ e₂ l₂ pxs

≋⇒⊆ : ∀ {ℓ} {A : Set ℓ} {x y : List A} → x ≋ y → x ⊆ y
≋⇒⊆ refl p = p
≋⇒⊆ {x = x} {y = .(l₁ ++ x₁ ∷ x₂ ∷ l₂)} (perm l₁ x₁ x₂ l₂ p) {e} e∈x = ∈-perm l₁ x₂ x₁ l₂ $ ≋⇒⊆ p e∈x

≋-trans : ∀ {l} {A : Set l} {x y z : List A} → x ≋ y → y ≋ z → x ≋ z
≋-trans p refl = p
≋-trans p₁ (perm l₁ x₁ x₂ l₂ p₂) = perm l₁ x₁ x₂ l₂ $ ≋-trans p₁ p₂

≋-sym : ∀ {l} {A : Set l} {x y : List A} → x ≋ y → y ≋ x
≋-sym refl = refl
≋-sym (perm l₁ x₁ x₂ l₂ p) = ≋-trans (perm l₁ x₂ x₁ l₂ refl) (≋-sym p)

≋-del-ins-r : ∀ {l} {A : Set l} (l₁ : List A) (x : A) (l₂ l₃ : List A) → (l₁ ++ x ∷ l₂ ++ l₃) ≋ (l₁ ++ l₂ ++ x ∷ l₃)
≋-del-ins-r l₁ x [] l₃ = refl
≋-del-ins-r l₁ x (h ∷ t) l₃ = ≋-trans p₀ p₅
  where p₀ : (l₁ ++ x ∷ h ∷ t ++ l₃) ≋ (l₁ ++ h ∷ x ∷ t ++ l₃)
        p₀ = perm l₁ h x (t ++ l₃) refl

        p₁ : ((l₁ ++ [ h ]) ++ x ∷ t ++ l₃) ≋ ((l₁ ++ [ h ]) ++ t ++ x ∷ l₃)
        p₁ = ≋-del-ins-r (l₁ ++ [ h ]) x t l₃

        p₂ : (l₁ ++ [ h ]) ++ t ++ x ∷ l₃ ≡ l₁ ++ h ∷ t ++ x ∷ l₃
        p₂ = ∪-assoc l₁ [ h ] (t ++ x ∷ l₃)

        p₃ : (l₁ ++ [ h ]) ++ x ∷ t ++ l₃ ≡ l₁ ++ h ∷ x ∷ t ++ l₃
        p₃ = ∪-assoc l₁ [ h ] (x ∷ t ++ l₃)

        p₄ : ((l₁ ++ [ h ]) ++ x ∷ t ++ l₃) ≋ (l₁ ++ h ∷ t ++ x ∷ l₃)
        p₄ = ≡-elim′ (λ y → ((l₁ ++ [ h ]) ++ x ∷ t ++ l₃) ≋ y) p₂ p₁

        p₅ : (l₁ ++ h ∷ x ∷ t ++ l₃) ≋ (l₁ ++ h ∷ t ++ x ∷ l₃)
        p₅ = ≡-elim′ (λ y → y ≋ (l₁ ++ h ∷ t ++ x ∷ l₃)) p₃ p₄

≋-del-ins-l : ∀ {l} {A : Set l} (l₁ l₂ : List A) (x : A) (l₃ : List A) → (l₁ ++ l₂ ++ x ∷ l₃) ≋ (l₁ ++ x ∷ l₂ ++ l₃)
≋-del-ins-l l₁ l₂ x l₃ = ≋-sym $ ≋-del-ins-r l₁ x l₂ l₃

x∪[]≡x : ∀ {ℓ} {A : Set ℓ} (x : List A) → x ∪ [] ≡ x
x∪[]≡x [] = refl
x∪[]≡x (h ∷ t) = ≡-trans p₀ p₁
  where p₀ : (h ∷ t) ++ [] ≡ h ∷ t ++ []
        p₀ = ∪-assoc [ h ] t []
        p₁ : h ∷ t ++ [] ≡ h ∷ t
        p₁ = ≡-cong (λ x → h ∷ x) (x∪[]≡x t)

x∖[]≡x : (x : Names) → x ∖ [] ≡ x
x∖[]≡x [] = refl
x∖[]≡x (h ∷ t) = ≡-cong (_∷_ h) (x∖[]≡x t)

t∖[]≡t : ∀ {ℓ} {A : Set ℓ} (t : List (Named A)) → t ∖∖ [] ≡ t
t∖[]≡t [] = refl
t∖[]≡t (h ∷ t) = ≡-cong (_∷_ h) (t∖[]≡t t)

e∷x≋e∷y : ∀ {ℓ} {A : Set ℓ} (e : A) {x y : List A} → x ≋ y → e ∷ x ≋ e ∷ y
e∷x≋e∷y _ refl = refl
e∷x≋e∷y x (perm l₁ e₁ e₂ l₂ p) = perm (x ∷ l₁) e₁ e₂ l₂ (e∷x≋e∷y x p)

∪-sym : ∀ {ℓ} {A : Set ℓ} (x y : List A) → x ∪ y ≋ y ∪ x
∪-sym [] y = ≡-elim′ (λ z → y ≋ z) (≡-sym $ x∪[]≡x y) refl
∪-sym x [] = ≡-elim′ (λ z → z ≋ x) (≡-sym $ x∪[]≡x x) refl
∪-sym x (y ∷ ys) = ≡-elim′ (λ z → x ++ (y ∷ ys) ≋ z) p₃ (≋-trans p₁ p₂) where
    p₁ : x ++ (y ∷ ys) ≋ y ∷ (x ++ ys)
    p₁ = ≋-del-ins-l [] x y ys
    p₂ : y ∷ (x ++ ys) ≋ y ∷ (ys ++ x)
    p₂ = e∷x≋e∷y y $ ∪-sym x ys
    p₃ : y ∷ (ys ++ x) ≡ (y ∷ ys) ++ x
    p₃ = ∪-assoc [ y ] ys x

y≋ỳ⇒x∪y≋x∪ỳ : ∀ {ℓ} {A : Set ℓ} (x : List A) {y ỳ : List A} → y ≋ ỳ → x ∪ y ≋ x ∪ ỳ
y≋ỳ⇒x∪y≋x∪ỳ [] p = p
y≋ỳ⇒x∪y≋x∪ỳ (h ∷ t) p = e∷x≋e∷y h (y≋ỳ⇒x∪y≋x∪ỳ t p)

x≋x̀⇒x∪y≋x̀∪y : ∀ {ℓ} {A : Set ℓ} {x x̀ : List A} → x ≋ x̀ → (y : List A) → x ∪ y ≋ x̀ ∪ y
x≋x̀⇒x∪y≋x̀∪y {x = x} {x̀ = x̀} p y = ≋-trans (∪-sym x y) $ ≋-trans (y≋ỳ⇒x∪y≋x∪ỳ y p) (∪-sym y x̀)

x⊆y≋z : ∀ {ℓ} {A : Set ℓ} {x y z : List A} → x ⊆ y → y ≋ z → x ⊆ z
x⊆y≋z x⊆y refl = x⊆y
x⊆y≋z {x = x} {y = y} {z = .(l₁ ++ x₁ ∷ x₂ ∷ l₂)} x⊆y (perm l₁ x₁ x₂ l₂ p) = ∈-perm l₁ x₂ x₁ l₂ ∘ x⊆y≋z x⊆y p

x≋y⊆z : ∀ {ℓ} {A : Set ℓ} {x y z : List A} → x ≋ y → x ⊆ z → y ⊆ z
x≋y⊆z refl x⊆z = x⊆z
x≋y⊆z {y = .(l₁ ++ x₁ ∷ x₂ ∷ l₂)} {z = z} (perm l₁ x₁ x₂ l₂ p) x⊆z = x≋y⊆z p x⊆z ∘ ∈-perm l₁ x₁ x₂ l₂

x⊆x∪y : ∀ {ℓ} {A : Set ℓ} (x y : List A) → x ⊆ x ∪ y
x⊆x∪y .(x ∷ xs) y (here  {x} {xs} px) = here px
x⊆x∪y .(x ∷ xs) y (there {x} {xs} pxs) = there $ x⊆x∪y xs y pxs

x∪y⊆z⇒x⊆z : ∀ {ℓ} {A : Set ℓ} (x y : List A) {z : List A} → x ∪ y ⊆ z → x ⊆ z
x∪y⊆z⇒x⊆z x y x∪y⊆z = x∪y⊆z ∘ x⊆x∪y x y

x∪y⊆z⇒y⊆z : ∀ {ℓ} {A : Set ℓ} (x y : List A) {z : List A} → x ∪ y ⊆ z → y ⊆ z
x∪y⊆z⇒y⊆z x y = x∪y⊆z⇒x⊆z y x ∘ x≋y⊆z (∪-sym x y)

n-x∪y : ∀ {ℓ} {A : Set ℓ} (x y : List (Named A)) → names (x ∪ y) ≡ names x ∪ names y
n-x∪y [] _ = refl
n-x∪y {ℓ} (x ∷ xs) y = ≡-trans p₁ p₂ where
    nx = [ proj₁ x ]
    nxs = names xs
    ny = names y
    p₁ : nx ∪ names (xs ∪ y) ≡ nx ∪ (nxs ∪ ny)
    p₁ = ≡-cong (λ z → nx ∪ z) (n-x∪y xs y)
    p₂ : nx ∪ (nxs ∪ ny) ≡ (nx ∪ nxs) ∪ ny
    p₂ = ≡-sym $ ∪-assoc nx nxs ny

t-x∪y : ∀ {ℓ} (x y : Values ℓ) → types (x ∪ y) ≡ types x ∪ types y
t-x∪y [] _ = refl
t-x∪y (x ∷ xs) y = ≡-trans p₁ p₂ where
    nx = types [ x ]
    nxs = types xs
    ny = types y
    p₁ : nx ∪ types (xs ∪ y) ≡ nx ∪ (nxs ∪ ny)
    p₁ = ≡-cong (λ z → nx ∪ z) (t-x∪y xs y)
    p₂ : nx ∪ (nxs ∪ ny) ≡ (nx ∪ nxs) ∪ ny
    p₂ = ≡-sym $ ∪-assoc nx nxs ny

n-x≋y : ∀ {ℓ} {A : Set ℓ} {x y : List (Named A)} → x ≋ y → names x ≋ names y
n-x≋y refl = refl
n-x≋y (perm {x} l₁ e₁ e₂ l₂ p) = p₃ where
    n-l₁e₁e₂l₂ : ∀ e₁ e₂ → names (l₁ ++ e₁ ∷ e₂ ∷ l₂) ≡ names l₁ ++ names [ e₁ ] ++ names [ e₂ ] ++ names l₂
    n-l₁e₁e₂l₂ e₁ e₂ = ≡-trans p₁ $ ≡-trans p₂ p₃ where
        p₁ : names (l₁ ++ e₁ ∷ e₂ ∷ l₂) ≡ names l₁ ++ names (e₁ ∷ e₂ ∷ l₂)
        p₁ = n-x∪y l₁ (e₁ ∷ e₂ ∷ l₂)
        p₂ : names l₁ ++ names (e₁ ∷ e₂ ∷ l₂) ≡ names l₁ ++ names [ e₁ ] ++ names (e₂ ∷ l₂)
        p₂ = ≡-cong (λ z → names l₁ ++ z) (n-x∪y [ e₁ ] (e₂ ∷ l₂))
        p₃ : names l₁ ++ names [ e₁ ] ++ names (e₂ ∷ l₂) ≡ names l₁ ++ names [ e₁ ] ++ names [ e₂ ] ++ names l₂
        p₃ = ≡-cong (λ z → names l₁ ++ names [ e₁ ] ++ z) (n-x∪y [ e₂ ] l₂)

    p₁ : names x ≋ names l₁ ++ proj₁ e₂ ∷ proj₁ e₁ ∷ names l₂
    p₁ = ≡-elim′ (λ z → names x ≋ z) (n-l₁e₁e₂l₂ e₂ e₁) (n-x≋y p)
    p₂ : names x ≋ names l₁ ++ proj₁ e₁ ∷ proj₁ e₂ ∷ names l₂
    p₂ = perm (names l₁) (proj₁ e₁) (proj₁ e₂) (names l₂) p₁

    p₃ : names x ≋ names (l₁ ++ e₁ ∷ e₂ ∷ l₂)
    p₃ = ≡-elim′ (λ z → names x ≋ z) (≡-sym $ n-l₁e₁e₂l₂ e₁ e₂) p₂

n-types : ∀ {ℓ} (x : Values ℓ) → names (types x) ≡ names x
n-types [] = refl
n-types (x ∷ xs) = ≡-cong (λ z → proj₁ x ∷ z) (n-types xs)

nr-x≋y : ∀ {ℓ} {A : Set ℓ} {x y : List A} → x ≋ y → NonRepetitive x → NonRepetitive y
nr-x≋y refl u = u
nr-x≋y {y = .(l₁ ++ e₁ ∷ e₂ ∷ l₂)} (perm l₁ e₁ e₂ l₂ p) u = ≋-step l₁ e₂ e₁ l₂ (nr-x≋y p u) where
    ∉-step : ∀ {ℓ} {A : Set ℓ} {x : A} (l₁ : List A) (e₁ : A) (e₂ : A) (l₂ : List A) → x ∉ l₁ ++ e₁ ∷ e₂ ∷ l₂ → x ∉ l₁ ++ e₂ ∷ e₁ ∷ l₂
    ∉-step l₁ e₁ e₂ l₂ x∉l x∈l = ⊥-elim $ x∉l $ ∈-perm l₁ e₂ e₁ l₂ x∈l

    ≋-step : ∀ {ℓ} {A : Set ℓ} (l₁ : List A) (e₁ : A) (e₂ : A) (l₂ : List A) → NonRepetitive (l₁ ++ e₁ ∷ e₂ ∷ l₂) → NonRepetitive (l₁ ++ e₂ ∷ e₁ ∷ l₂)
    ≋-step [] e₁ e₂ l₂ (_∷_ .{e₁} .{e₂ ∷ l₂} e₁∉e₂∷l₂ (_∷_ .{e₂} .{l₂} e₂∉l₂ pU)) = e₂∉e₁∷l₂ ∷ e₁∉l₂ ∷ pU where
        e₁∉l₂ = e₁ ∉ l₂ ∋ x∉y∷l⇒x∉l e₁∉e₂∷l₂
        e₂∉e₁∷l₂ = e₂ ∉ e₁ ∷ l₂ ∋ x≢y⇒x∉l⇒x∉y∷l (≢-sym $ x∉y∷l⇒x≢y e₁∉e₂∷l₂) e₂∉l₂
    ≋-step (h₁ ∷ t₁) e₁ e₂ l₂ (_∷_ .{h₁} .{t₁ ++ e₁ ∷ e₂ ∷ l₂} p∉ pU) = ∉-step t₁ e₁ e₂ l₂ p∉ ∷ ≋-step t₁ e₁ e₂ l₂ pU

nr-x⇒nr-t-x : ∀ {ℓ} {x : Values ℓ} → NonRepetitiveNames x → NonRepetitiveNames (types x)
nr-x⇒nr-t-x {x = x} = ≡-elim′ NonRepetitive (≡-sym $ n-types x)

n-x∖y : ∀ {ℓ} {A : Set ℓ} (x : List (Named A)) (y : Names) → names (x ∖∖ y) ≡ names x ∖ y
n-x∖y [] _ = refl
n-x∖y (x ∷ xs) ny with not $ ny ∋! proj₁ x
... | false = n-x∖y xs ny
... | true = ≡-trans p₁ p₂ where
        p₁ : names (x ∷ (xs ∖∖ ny)) ≡ proj₁ x ∷ names (xs ∖∖ ny)
        p₁ = n-x∪y [ x ] (xs ∖∖ ny)
        p₂ : proj₁ x ∷ names (xs ∖∖ ny) ≡ proj₁ x ∷ (names xs ∖ ny)
        p₂ = ≡-cong (λ z → proj₁ x ∷ z) (n-x∖y xs ny)

t-x∖y : ∀ {ℓ} (x : Values ℓ) (y : Names) → types (x ∖∖ y) ≡ types x ∖∖ y
t-x∖y [] _ = refl
t-x∖y (x ∷ xs) ny with not $ ny ∋! proj₁ x
... | false = t-x∖y xs ny
... | true = ≡-trans p₁ p₂ where
        x̀ = types [ x ]
        p₁ : types (x ∷ (xs ∖∖ ny)) ≡ x̀ ∪ types (xs ∖∖ ny)
        p₁ = t-x∪y [ x ] (xs ∖∖ ny)
        p₂ : x̀ ∪ types (xs ∖∖ ny) ≡ x̀ ∪ (types xs ∖∖ ny)
        p₂ = ≡-cong (λ z → x̀ ∪ z) (t-x∖y xs ny)

n-filter-∈ : ∀ {ℓ} {A : Set ℓ} (x : List (Named A)) (y : Names) → names (filter-∈ x y) ≡ names x ∩ y
n-filter-∈ [] _ = refl
n-filter-∈ (x ∷ xs) ny with ny ∋! proj₁ x
... | false = n-filter-∈ xs ny
... | true = ≡-trans p₁ p₂ where
        p₁ : names (x ∷ (filter-∈ xs ny)) ≡ proj₁ x ∷ names (filter-∈ xs ny)
        p₁ = n-x∪y [ x ] (filter-∈ xs ny)
        p₂ : proj₁ x ∷ names (filter-∈ xs ny) ≡ proj₁ x ∷ (names xs ∩ ny)
        p₂ = ≡-cong (λ z → proj₁ x ∷ z) (n-filter-∈ xs ny)

t-filter-∈ : ∀ {ℓ} (x : Values ℓ) (y : Names) → types (filter-∈ x y) ≡ filter-∈ (types x) y
t-filter-∈ [] _ = refl
t-filter-∈ (x ∷ xs) ny with ny ∋! proj₁ x
... | false = t-filter-∈ xs ny
... | true = ≡-trans p₁ p₂ where
        x̀ = types [ x ]
        p₁ : types (x ∷ filter-∈ xs ny) ≡ x̀ ∪ types (filter-∈ xs ny)
        p₁ = t-x∪y [ x ] (filter-∈ xs ny)
        p₂ : x̀ ∪ types (filter-∈ xs ny) ≡ x̀ ∪ filter-∈ (types xs) ny
        p₂ = ≡-cong (λ z → x̀ ∪ z) (t-filter-∈ xs ny)

[]⊆x : ∀ {ℓ} {A : Set ℓ} (x : List A) → [] ⊆ x
[]⊆x _ ()

∀x∉[] : ∀ {ℓ} {A : Set ℓ} {x : A} → x ∉ []
∀x∉[] ()

x⊆[]⇒x≡[] : ∀ {ℓ} {A : Set ℓ} {x : List A} → x ⊆ [] → x ≡ []
x⊆[]⇒x≡[] {x = []} _ = refl
x⊆[]⇒x≡[] {x = _ ∷ _} x⊆[] = ⊥-elim $ ∀x∉[] $ x⊆[] (here refl)

x∩y⊆x : ∀ {ℓ} {A : Set ℓ} (x : List (Named A)) (y : Names) → filter-∈ x y ⊆ x
x∩y⊆x [] _ = λ()
x∩y⊆x (h ∷ t) y with y ∋! proj₁ h
... | false = there ∘ x∩y⊆x t y
... | true = f where
             f : h ∷ filter-∈ t y ⊆ h ∷ t
             f (here {x = .h} p) = here p
             f (there {xs = .(filter-∈ t y)} p) = there $ x∩y⊆x t y p

e∈x⇒e∈y∪x : ∀ {ℓ} {A : Set ℓ} {e : A} {x : List A} (y : List A) → e ∈ x → e ∈ y ∪ x
e∈x⇒e∈y∪x [] = id
e∈x⇒e∈y∪x (h ∷ t) = there ∘ e∈x⇒e∈y∪x t

e∈x⇒e∈x∪y : ∀ {ℓ} {A : Set ℓ} {e : A} {x : List A} (y : List A) → e ∈ x → e ∈ x ∪ y
e∈x⇒e∈x∪y {e = e} {x = x} y e∈x = x⊆y≋z f (∪-sym y x) (e ∈ [ e ] ∋ here refl) where
    f : [ e ] ⊆ y ∪ x
    f {è} (here {x = .e} p) = ≡-elim′ (λ z → z ∈ y ∪ x) (≡-sym p) (e∈x⇒e∈y∪x y e∈x)
    f (there ())

x∪y⊆x̀∪ỳ : ∀ {ℓ} {A : Set ℓ} {x x̀ y ỳ : List A} → x ⊆ x̀ → y ⊆ ỳ → x ∪ y ⊆ x̀ ∪ ỳ
x∪y⊆x̀∪ỳ {x = []} {x̀ = []} _ y⊆ỳ = y⊆ỳ
x∪y⊆x̀∪ỳ {x = []} {x̀ = _ ∷ t̀} _ y⊆ỳ = there ∘ x∪y⊆x̀∪ỳ ([]⊆x t̀) y⊆ỳ
x∪y⊆x̀∪ỳ {x = h ∷ t} {x̀ = x̀} {y = y} {ỳ = ỳ} x⊆x̀ y⊆ỳ = f where
    f : (h ∷ t) ∪ y ⊆ x̀ ∪ ỳ
    f {e} (here {x = .h} e≡h) = e∈x⇒e∈x∪y ỳ (x⊆x̀ $ here e≡h)
    f {e} (there {xs = .(t ∪ y)} p) = x∪y⊆x̀∪ỳ (x∪y⊆z⇒y⊆z [ h ] t x⊆x̀) y⊆ỳ p

x∖y⊆x : (x y : Names) → x ∖ y ⊆ x
x∖y⊆x [] _ = λ()
x∖y⊆x (h ∷ t) y with y ∋! h
... | true = there ∘ x∖y⊆x t y
... | false = x∪y⊆x̀∪ỳ (≋⇒⊆ $ ≡⇒≋ $ refl {x = [ h ]}) (x∖y⊆x t y)

t≋t∖n∪t∩n : ∀ {ℓ} {A : Set ℓ} (t : List (Named A)) (n : Names) → t ≋ (t ∖∖ n) ∪ filter-∈ t n
t≋t∖n∪t∩n [] _ = refl
t≋t∖n∪t∩n (h ∷ t) n with n ∋! proj₁ h
... | false = e∷x≋e∷y h $ t≋t∖n∪t∩n t n
... | true = ≋-trans p₁ p₂ where
           p₁ : h ∷ t ≋ (h ∷ (t ∖∖ n)) ∪ filter-∈ t n
           p₁ = e∷x≋e∷y h $ t≋t∖n∪t∩n t n
           p₂ : (h ∷ (t ∖∖ n)) ∪ filter-∈ t n ≋ (t ∖∖ n) ∪ (h ∷ filter-∈ t n)
           p₂ = ≋-del-ins-r [] h (t ∖∖ n) (filter-∈ t n)

e₁∈x⇒e₂∉x⇒e≢e₂ : ∀ {ℓ} {A : Set ℓ} {e₁ e₂ : A} {x : List A} → e₁ ∈ x → e₂ ∉ x → e₁ ≢ e₂
e₁∈x⇒e₂∉x⇒e≢e₂ e₁∈x e₂∉x refl = e₂∉x e₁∈x

e₁∈e₂∷x⇒e₁≢e₂⇒e₁∈x : ∀ {ℓ} {A : Set ℓ} {e₁ e₂ : A} {x : List A} → e₁ ∈ e₂ ∷ x → e₁ ≢ e₂ → e₁ ∈ x
e₁∈e₂∷x⇒e₁≢e₂⇒e₁∈x (here e₁≡e₂) e₁≢e₂ = ⊥-elim $ e₁≢e₂ e₁≡e₂
e₁∈e₂∷x⇒e₁≢e₂⇒e₁∈x (there e₁∈x) _ = e₁∈x

x⊆e∷y⇒e∉x⇒x⊆y : ∀ {ℓ} {A : Set ℓ} {e : A} {x y : List A} → x ⊆ e ∷ y → e ∉ x → x ⊆ y
x⊆e∷y⇒e∉x⇒x⊆y {e = e} {x = x} {y = y} x⊆e∷y e∉x {è} è∈x = e₁∈e₂∷x⇒e₁≢e₂⇒e₁∈x (x⊆e∷y è∈x) (e₁∈x⇒e₂∉x⇒e≢e₂ è∈x e∉x)

n-e∉l⇒e∉l : ∀ {ℓ} {A : Set ℓ} {e : Named A} {l : List (Named A)} → proj₁ e ∉ names l → e ∉ l
n-e∉l⇒e∉l {e = e} n-e∉l (here {x = è} p) = ⊥-elim $ n-e∉l $ here $ ≡-cong proj₁ p
n-e∉l⇒e∉l n-e∉l (there p) = n-e∉l⇒e∉l (x∉y∷l⇒x∉l n-e∉l) p

nr-names⇒nr : ∀ {ℓ} {A : Set ℓ} {l : List (Named A)} → NonRepetitiveNames l → NonRepetitive l
nr-names⇒nr {l = []} [] = []
nr-names⇒nr {l = _ ∷ _} (nh∉nt ∷ nr-t) = n-e∉l⇒e∉l nh∉nt ∷ nr-names⇒nr nr-t

e∉x⇒e∉y⇒e∉x∪y : ∀ {ℓ} {A : Set ℓ} {e : A} {x y : List A} → e ∉ x → e ∉ y → e ∉ x ∪ y
e∉x⇒e∉y⇒e∉x∪y {x = []} _  e∉y e∈y = ⊥-elim $ e∉y e∈y
e∉x⇒e∉y⇒e∉x∪y {x = h ∷ t} e∉x e∉y (here e≡h) = ⊥-elim $ e∉x $ here e≡h
e∉x⇒e∉y⇒e∉x∪y {x = h ∷ t} e∉x e∉y (there e∈t∪y) = e∉x⇒e∉y⇒e∉x∪y (x∉y∷l⇒x∉l e∉x) e∉y e∈t∪y

nr-x∖y∪y : {x y : Names} → NonRepetitive x → NonRepetitive y → NonRepetitive (x ∖ y ∪ y)
nr-x∖y∪y {x = []} _ nr-y = nr-y
nr-x∖y∪y {x = x ∷ xs} {y = y} (x∉xs ∷ nr-xs) nr-y with x ∈? y
... | yes x∈y = nr-x∖y∪y nr-xs nr-y
... | no x∉y = e∉x⇒e∉y⇒e∉x∪y (⊥-elim ∘ x∉xs ∘ x∖y⊆x xs y) x∉y ∷ nr-x∖y∪y nr-xs nr-y

e∉l∖[e] : (e : String) (l : Names) → e ∉ l ∖ [ e ]
e∉l∖[e] _ [] = λ()
e∉l∖[e] e (h ∷ t) with h ≟ e
... | yes _ = e∉l∖[e] e t
... | no h≢e = x≢y⇒x∉l⇒x∉y∷l (≢-sym h≢e) (e∉l∖[e] e t)

e∉l⇒l∖e≡l : {e : String} {l : Names} → e ∉ l → l ∖ [ e ] ≡ l
e∉l⇒l∖e≡l {e = e} {l = []} _ = refl
e∉l⇒l∖e≡l {e = e} {l = h ∷ t} e∉l with h ∈? [ e ]
... | yes h∈e = ⊥-elim $ x≢y⇒x∉l⇒x∉y∷l (≢-sym $ x∉y∷l⇒x≢y e∉l) (λ()) h∈e
... | no h∉e = ≡-cong (_∷_ h) (e∉l⇒l∖e≡l $ x∉y∷l⇒x∉l e∉l)

e∈l⇒nr-l⇒l∖e∪e≋l : {e : String} {l : Names} → e ∈ l → NonRepetitive l → l ∖ [ e ] ∪ [ e ] ≋ l
e∈l⇒nr-l⇒l∖e∪e≋l {l = []} () _
e∈l⇒nr-l⇒l∖e∪e≋l {e = e} {l = h ∷ t} e∈h∷t (h∉t ∷ nr-t) with h ∈? [ e ]
... | yes (here h≡e) = ≋-trans (≡⇒≋ $ ≡-trans p₁ p₂) (∪-sym t [ h ]) where
          p₁ : t ∖ [ e ] ∪ [ e ] ≡ t ∖ [ h ] ∪ [ h ]
          p₁ = ≡-cong (λ x → t ∖ [ x ] ∪ [ x ]) (≡-sym h≡e)
          p₂ : t ∖ [ h ] ∪ [ h ] ≡ t ∪ [ h ]
          p₂ = ≡-cong (λ x → x ∪ [ h ]) (e∉l⇒l∖e≡l h∉t)
... | yes (there ())
... | no  h∉e with e∈h∷t
...      | here e≡h = ⊥-elim ∘ h∉e ∘ here ∘ ≡-sym $ e≡h
...      | there e∈t = e∷x≋e∷y _ $ e∈l⇒nr-l⇒l∖e∪e≋l e∈t nr-t

nr-x∖y : {x : Names} → NonRepetitive x → (y : Names) → NonRepetitive (x ∖ y)
nr-x∖y {x = []} _ _ = []
nr-x∖y {x = x ∷ xs} (x∉xs ∷ nr-xs) y with x ∈? y
... | yes x∈y = nr-x∖y nr-xs y
... | no  x∉y = ⊥-elim ∘ x∉xs ∘ x∖y⊆x xs y ∷ nr-x∖y nr-xs y

x⊆y⇒e∉y⇒e∉x : ∀ {ℓ} {A : Set ℓ} {e : A} {x y : List A} → x ⊆ y → e ∉ y → e ∉ x
x⊆y⇒e∉y⇒e∉x x⊆y e∉y e∈x = e∉y $ x⊆y e∈x

e∈n-l⇒∃è,n-è≡e×è∈l : ∀ {ℓ} {A : Set ℓ} {e : String} {l : List (Named A)} → e ∈ names l → Σ[ è ∈ Named A ] (e ≡ proj₁ è × è ∈ l)
e∈n-l⇒∃è,n-è≡e×è∈l {l = []} ()
e∈n-l⇒∃è,n-è≡e×è∈l {l = h ∷ t} (here e≡n-h) = h , e≡n-h , here refl
e∈n-l⇒∃è,n-è≡e×è∈l {l = h ∷ t} (there e∈n-t) with e∈n-l⇒∃è,n-è≡e×è∈l e∈n-t
... | è , n-è≡e , è∈l = è , n-è≡e , there è∈l

x⊆y⇒nx⊆ny : ∀ {ℓ} {A : Set ℓ} {x y : List (Named A)} → x ⊆ y → names x ⊆ names y
x⊆y⇒nx⊆ny {x = x} {y = y} x⊆y {e} e∈n-x with e ∈? names y
... | yes e∈n-y = e∈n-y
... | no  e∉n-y with e∈n-l⇒∃è,n-è≡e×è∈l e∈n-x
...              | è , e≡n-è , è∈x = ⊥-elim $ x⊆y⇒e∉y⇒e∉x x⊆y (n-e∉l⇒e∉l $ ≡-elim′ (λ z → z ∉ names y) e≡n-è e∉n-y) è∈x

nr-x⇒nr-x∩y : ∀ {ℓ} {A : Set ℓ} {x : List (Named A)} → NonRepetitiveNames x → (y : Names) → NonRepetitiveNames (filter-∈ x y)
nr-x⇒nr-x∩y {x = []} _ _ = []
nr-x⇒nr-x∩y {x = h ∷ t} (h∉t ∷ nr-t) y with y ∋! proj₁ h
... | false = nr-x⇒nr-x∩y nr-t y
... | true = x⊆y⇒e∉y⇒e∉x (x⊆y⇒nx⊆ny $ x∩y⊆x t y) h∉t ∷ nr-x⇒nr-x∩y nr-t y

e∈l⇒[e]⊆l : ∀ {ℓ} {A : Set ℓ} {e : A} {l : List A} → e ∈ l → [ e ] ⊆ l
e∈l⇒[e]⊆l e∈l (here è≡e) = ≡-elim′ (λ x → x ∈ _) (≡-sym è≡e) e∈l
e∈l⇒[e]⊆l e∈l (there ())

a∈x⇒x≋y⇒a∈y : ∀ {ℓ} {A : Set ℓ} {x y : List A} {a : A} → a ∈ x → x ≋ y → a ∈ y
a∈x⇒x≋y⇒a∈y a∈x x≋y = x⊆y≋z (e∈l⇒[e]⊆l a∈x) x≋y (here refl)

x⊆z⇒y⊆z⇒x∪y⊆z : ∀ {ℓ} {A : Set ℓ} {x y z : List A} → x ⊆ z → y ⊆ z → x ∪ y ⊆ z
x⊆z⇒y⊆z⇒x∪y⊆z {x = []} _ y⊆z = y⊆z
x⊆z⇒y⊆z⇒x∪y⊆z {x = h ∷ t} {y = y} {z = z} x⊆z y⊆z = f where
    f : (h ∷ t) ∪ y ⊆ z
    f {e} (here e≡h) = x⊆z $ here e≡h
    f {e} (there e∈t∪y) = x⊆z⇒y⊆z⇒x∪y⊆z (x∪y⊆z⇒y⊆z [ h ] t x⊆z) y⊆z e∈t∪y

x⊆x∖y∪y : (x y : Names) → x ⊆ x ∖ y ∪ y
x⊆x∖y∪y [] _ = []⊆x _
x⊆x∖y∪y (h ∷ t) y with h ∈? y
x⊆x∖y∪y (h ∷ t) y | yes h∈y = x⊆z⇒y⊆z⇒x∪y⊆z (e∈l⇒[e]⊆l $ e∈x⇒e∈y∪x (t ∖ y) h∈y) (x⊆x∖y∪y t y)
x⊆x∖y∪y (h ∷ t) y | no _ = x∪y⊆x̀∪ỳ ([ h ] ⊆ [ h ] ∋ ≋⇒⊆ refl) (x⊆x∖y∪y t y)

e₁∈l⇒e₁∉l∖e₂⇒e₁≡e₂ : {e₁ e₂ : String} {l : Names} → e₁ ∈ l → e₁ ∉ l ∖ [ e₂ ] → e₁ ≡ e₂
e₁∈l⇒e₁∉l∖e₂⇒e₁≡e₂ {e₁ = e₁} {e₂ = e₂} {l = l} e₁∈l e₁∉l∖e₂ with e₁ ≟ e₂
... | yes e₁≡e₂ = e₁≡e₂
... | no e₁≢e₂ = ⊥-elim $ p₄ e₁∈l where
         p₁ : e₁ ∉ [ e₂ ] ∪ (l ∖ [ e₂ ])
         p₁ = x≢y⇒x∉l⇒x∉y∷l e₁≢e₂ e₁∉l∖e₂
         p₂ : [ e₂ ] ∪ (l ∖ [ e₂ ]) ≋ (l ∖ [ e₂ ]) ∪ [ e₂ ]
         p₂ = ∪-sym [ e₂ ] (l ∖ [ e₂ ])
         p₃ : e₁ ∉ (l ∖ [ e₂ ]) ∪ [ e₂ ]
         p₃ = p₁ ∘ ≋⇒⊆ (∪-sym (l ∖ [ e₂ ]) [ e₂ ])
         p₄ : e₁ ∉ l
         p₄ = x⊆y⇒e∉y⇒e∉x (x⊆x∖y∪y l [ e₂ ]) p₃

e∉x⇒x∩y≋x∩y∖e : {e : String} {x : Names} (y : Names) → e ∉ x → x ∩ y ≡ x ∩ (y ∖ [ e ])
e∉x⇒x∩y≋x∩y∖e {x = []} _ _ = refl
e∉x⇒x∩y≋x∩y∖e {e = e} {x = h ∷ t} y e∉x with h ∈? y | h ∈? (y ∖ [ e ])
... | yes h∈y | yes h∈y∖e = ≡-cong (_∷_ h) $ e∉x⇒x∩y≋x∩y∖e y $ x∉y∷l⇒x∉l e∉x
... | yes h∈y | no  h∉y∖e = ⊥-elim $ e∉x e∈x where
        e∈x : e ∈ h ∷ t
        e∈x = here $ ≡-sym $ e₁∈l⇒e₁∉l∖e₂⇒e₁≡e₂ h∈y h∉y∖e
... | no  h∉y | yes h∈y∖e = ⊥-elim $ h∉y $ x∖y⊆x y [ e ] h∈y∖e
... | no  h∉y | no  h∉y∖e = e∉x⇒x∩y≋x∩y∖e y $ x∉y∷l⇒x∉l e∉x

y⊆x⇒x∩y≋y : {x y : Names} → NonRepetitive y → NonRepetitive x → y ⊆ x → x ∩ y ≋ y
y⊆x⇒x∩y≋y {x = []} _ _ y⊆[] = ≡⇒≋ $ ≡-elim′ (λ y → [] ∩ y ≡ y) (≡-sym $ x⊆[]⇒x≡[] y⊆[]) refl
y⊆x⇒x∩y≋y {x = h ∷ t} {y = y} nr-y (h∉t ∷ nr-t) y⊆h∷t with h ∈? y
... | yes h∈y = ≋-trans (∪-sym [ h ] (t ∩ y)) p₄ where
        p₁ : t ∩ y ≋ t ∩ (y ∖ [ h ])
        p₁ = ≡⇒≋ $ e∉x⇒x∩y≋x∩y∖e y h∉t
        p₂ : t ∩ (y ∖ [ h ]) ≋ y ∖ [ h ]
        p₂ = y⊆x⇒x∩y≋y (nr-x∖y nr-y [ h ]) nr-t $ x⊆e∷y⇒e∉x⇒x⊆y (y⊆h∷t ∘ x∖y⊆x y [ h ]) (e∉l∖[e] h y)
        p₃ : y ∖ [ h ] ∪ [ h ] ≋ y
        p₃ = e∈l⇒nr-l⇒l∖e∪e≋l h∈y nr-y
        p₄ : t ∩ y ∪ [ h ] ≋ y
        p₄ = ≋-trans (x≋x̀⇒x∪y≋x̀∪y (≋-trans p₁ p₂) [ h ]) p₃
... | no  h∉y = y⊆x⇒x∩y≋y nr-y nr-t $ x⊆e∷y⇒e∉x⇒x⊆y y⊆h∷t h∉y

x∪y∖n≡x∖n∪y∖n : ∀ {ℓ} {A : Set ℓ} (x y : List (Named A)) (n : Names) → (x ∪ y) ∖∖ n ≡ (x ∖∖ n) ∪ (y ∖∖ n)
x∪y∖n≡x∖n∪y∖n [] _ _ = refl
x∪y∖n≡x∖n∪y∖n (h ∷ t) y n with proj₁ h ∈? n
... | yes _ = x∪y∖n≡x∖n∪y∖n t y n
... | no  _ = ≡-cong (_∷_ h) (x∪y∖n≡x∖n∪y∖n t y n)

n-x⊆n⇒x∖n≡[] : ∀ {ℓ} {A : Set ℓ} (x : List (Named A)) (n : Names) → names x ⊆ n → x ∖∖ n ≡ []
n-x⊆n⇒x∖n≡[] [] _ _ = refl
n-x⊆n⇒x∖n≡[] (h ∷ t) n n-x⊆n with proj₁ h ∈? n
... | yes _ = n-x⊆n⇒x∖n≡[] t n $ x∪y⊆z⇒y⊆z [ proj₁ h ] (names t) (x≋y⊆z (≡⇒≋ $ n-x∪y [ h ] t) n-x⊆n)
... | no h∉n = ⊥-elim $ h∉n $ n-x⊆n (proj₁ h ∈ proj₁ h ∷ names t ∋ here refl)

x∖x≡[] : ∀ {ℓ} {A : Set ℓ} (x : List (Named A)) → x ∖∖ names x ≡ []
x∖x≡[] x = n-x⊆n⇒x∖n≡[] x (names x) (≋⇒⊆ refl)

nr-[a] : ∀ {ℓ} {A : Set ℓ} {a : A} → NonRepetitive [ a ]
nr-[a] = (λ()) ∷ []

x≋y⇒x∖n≋y∖n : ∀ {ℓ} {A : Set ℓ} {x y : List (Named A)} → x ≋ y → (n : Names) → x ∖∖ n ≋ y ∖∖ n
x≋y⇒x∖n≋y∖n refl _ = refl
x≋y⇒x∖n≋y∖n {x = x} (perm l₁ x₁ x₂ l₂ p) n = ≋-trans p₀ $ ≋-trans (≡⇒≋ p₅) $ ≋-trans pg (≡⇒≋ $ ≡-sym g₅) where
    p₀ : x ∖∖ n ≋ (l₁ ++ x₂ ∷ x₁ ∷ l₂) ∖∖ n
    p₀ = x≋y⇒x∖n≋y∖n p n

    p₁ : (l₁ ++ [ x₂ ] ++ [ x₁ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ ([ x₂ ] ++ [ x₁ ] ++ l₂) ∖∖ n
    p₁ = x∪y∖n≡x∖n∪y∖n l₁ ([ x₂ ] ++ [ x₁ ] ++ l₂) n

    p₂ : l₁ ∖∖ n ++ ([ x₂ ] ++ [ x₁ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ [ x₂ ] ∖∖ n ++ ([ x₁ ] ++ l₂) ∖∖ n
    p₂ = ≡-cong (λ z → l₁ ∖∖ n ++ z) (x∪y∖n≡x∖n∪y∖n [ x₂ ] ([ x₁ ] ++ l₂) n)

    p₃ : l₁ ∖∖ n ++ [ x₂ ] ∖∖ n ++ ([ x₁ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ [ x₂ ] ∖∖ n ++ [ x₁ ] ∖∖ n ++ l₂ ∖∖ n
    p₃ = ≡-cong (λ z → l₁ ∖∖ n ++ [ x₂ ] ∖∖ n ++ z) (x∪y∖n≡x∖n∪y∖n [ x₁ ] l₂ n)

    p₄ : l₁ ∖∖ n ++ [ x₂ ] ∖∖ n ++ [ x₁ ] ∖∖ n ++ l₂ ∖∖ n ≡ l₁ ∖∖ n ++ ([ x₂ ] ∖∖ n ++ [ x₁ ] ∖∖ n) ++ l₂ ∖∖ n
    p₄ = ≡-cong (λ z → l₁ ∖∖ n ++ z) (≡-sym $ ∪-assoc ([ x₂ ] ∖∖ n) ([ x₁ ] ∖∖ n) (l₂ ∖∖ n))

    p₅ : (l₁ ++ [ x₂ ] ++ [ x₁ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ ([ x₂ ] ∖∖ n ++ [ x₁ ] ∖∖ n) ++ l₂ ∖∖ n
    p₅ = ≡-trans p₁ $ ≡-trans p₂ $ ≡-trans p₃ p₄

    pg : l₁ ∖∖ n ++ ([ x₂ ] ∖∖ n ++ [ x₁ ] ∖∖ n) ++ l₂ ∖∖ n ≋ l₁ ∖∖ n ++ ([ x₁ ] ∖∖ n ++ [ x₂ ] ∖∖ n) ++ l₂ ∖∖ n
    pg = y≋ỳ⇒x∪y≋x∪ỳ (l₁ ∖∖ n) $ x≋x̀⇒x∪y≋x̀∪y (∪-sym ([ x₂ ] ∖∖ n) ([ x₁ ] ∖∖ n)) (l₂ ∖∖ n)

    g₁ : (l₁ ++ [ x₁ ] ++ [ x₂ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ ([ x₁ ] ++ [ x₂ ] ++ l₂) ∖∖ n
    g₁ = x∪y∖n≡x∖n∪y∖n l₁ ([ x₁ ] ++ [ x₂ ] ++ l₂) n

    g₂ : l₁ ∖∖ n ++ ([ x₁ ] ++ [ x₂ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ [ x₁ ] ∖∖ n ++ ([ x₂ ] ++ l₂) ∖∖ n
    g₂ = ≡-cong (λ z → l₁ ∖∖ n ++ z) (x∪y∖n≡x∖n∪y∖n [ x₁ ] ([ x₂ ] ++ l₂) n)

    g₃ : l₁ ∖∖ n ++ [ x₁ ] ∖∖ n ++ ([ x₂ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ [ x₁ ] ∖∖ n ++ [ x₂ ] ∖∖ n ++ l₂ ∖∖ n
    g₃ = ≡-cong (λ z → l₁ ∖∖ n ++ [ x₁ ] ∖∖ n ++ z) (x∪y∖n≡x∖n∪y∖n [ x₂ ] l₂ n)

    g₄ : l₁ ∖∖ n ++ [ x₁ ] ∖∖ n ++ [ x₂ ] ∖∖ n ++ l₂ ∖∖ n ≡ l₁ ∖∖ n ++ ([ x₁ ] ∖∖ n ++ [ x₂ ] ∖∖ n) ++ l₂ ∖∖ n
    g₄ = ≡-cong (λ z → l₁ ∖∖ n ++ z) (≡-sym $ ∪-assoc ([ x₁ ] ∖∖ n) ([ x₂ ] ∖∖ n) (l₂ ∖∖ n))

    g₅ : (l₁ ++ [ x₁ ] ++ [ x₂ ] ++ l₂) ∖∖ n ≡ l₁ ∖∖ n ++ ([ x₁ ] ∖∖ n ++ [ x₂ ] ∖∖ n) ++ l₂ ∖∖ n
    g₅ = ≡-trans g₁ $ ≡-trans g₂ $ ≡-trans g₃ g₄

nr-x∪y⇒e∈x⇒e∈y⇒⊥ : ∀ {ℓ} {A : Set ℓ} {e : A} {x y : List A} → NonRepetitive (x ∪ y) → e ∈ x → e ∈ y → ⊥
nr-x∪y⇒e∈x⇒e∈y⇒⊥ {x = []} _ ()
nr-x∪y⇒e∈x⇒e∈y⇒⊥ {x = h ∷ t} (h∉t∪y ∷ nr-t∪y) (here e≡h) = h∉t∪y ∘ e∈x⇒e∈y∪x t ∘ ≡-elim′ (λ x → x ∈ _) e≡h
nr-x∪y⇒e∈x⇒e∈y⇒⊥ {x = h ∷ t} (h∉t∪y ∷ nr-t∪y) (there e∈t) = nr-x∪y⇒e∈x⇒e∈y⇒⊥ nr-t∪y e∈t

nr-x∪y⇒x∖y≡x : ∀ {ℓ} {A : Set ℓ} (x y : List (Named A)) → NonRepetitiveNames (x ∪ y) → y ∖∖ names x ≡ y
nr-x∪y⇒x∖y≡x x y nr-x∪y = f₀ y (≋⇒⊆ refl) where
    f₀ : ∀ t → t ⊆ y → t ∖∖ names x ≡ t
    f₀ [] _ = refl
    f₀ (h ∷ t) h∷t⊆y with proj₁ h ∈? names x
    ... | yes h∈x = ⊥-elim $ nr-x∪y⇒e∈x⇒e∈y⇒⊥ (≡-elim′ NonRepetitive (n-x∪y x y) nr-x∪y) h∈x (x⊆y⇒nx⊆ny h∷t⊆y $ here refl)
    ... | no _ = ≡-cong (_∷_ h) (f₀ t $ x∪y⊆z⇒y⊆z [ h ] t h∷t⊆y)

t≋t₁∪t₂⇒t∖t₁≋t₂ : ∀ {ℓ} {A : Set ℓ} {t : List (Named A)} → NonRepetitiveNames t → (t₁ t₂ : List (Named A)) → t ≋ t₁ ∪ t₂ → t ∖∖ names t₁ ≋ t₂
t≋t₁∪t₂⇒t∖t₁≋t₂ {t = t} nr-t t₁ t₂ t≋t₁∪t₂ = ≋-trans p₂ (≡⇒≋ $ nr-x∪y⇒x∖y≡x t₁ t₂ $ nr-x≋y (n-x≋y t≋t₁∪t₂) nr-t) where
    n-t₁ = names t₁
    p₁ : t ∖∖ n-t₁ ≋ (t₁ ∖∖ n-t₁) ∪ (t₂ ∖∖ n-t₁)
    p₁ = ≋-trans (x≋y⇒x∖n≋y∖n t≋t₁∪t₂ n-t₁) (≡⇒≋ $ x∪y∖n≡x∖n∪y∖n t₁ t₂ n-t₁)
    p₂ : t ∖∖ n-t₁ ≋ t₂ ∖∖ n-t₁
    p₂ = ≡-elim′ (λ x → t ∖∖ n-t₁ ≋ x ∪ (t₂ ∖∖ n-t₁)) (x∖x≡[] t₁) p₁

x≋x̀⇒y≋ỳ⇒x∪y≋x̀∪ỳ : ∀ {ℓ} {A : Set ℓ} {x x̀ y ỳ : List A} → x ≋ x̀ → y ≋ ỳ → x ∪ y ≋ x̀ ∪ ỳ
x≋x̀⇒y≋ỳ⇒x∪y≋x̀∪ỳ x≋x̀ (refl {y}) = x≋x̀⇒x∪y≋x̀∪y x≋x̀ y
x≋x̀⇒y≋ỳ⇒x∪y≋x̀∪ỳ {x = x} {x̀ = x̀} {y = y} {ỳ = ._} x≋x̀ (perm l₁ x₁ x₂ l₂ y≋l₁x₂x₁l₂) = ≋-trans p₁ $ ≋-trans p₂ $ ≋-trans p₃ p₄ where
    p₁ : x ∪ y ≋ x̀ ∪ (l₁ ++ x₂ ∷ x₁ ∷ l₂)
    p₁ = x≋x̀⇒y≋ỳ⇒x∪y≋x̀∪ỳ x≋x̀ y≋l₁x₂x₁l₂
    p₂ : x̀ ∪ (l₁ ++ x₂ ∷ x₁ ∷ l₂) ≋ (x̀ ∪ l₁) ++ x₂ ∷ x₁ ∷ l₂
    p₂ = ≡⇒≋ $ ≡-sym $ ∪-assoc x̀ l₁ (x₂ ∷ x₁ ∷ l₂)
    p₃ : (x̀ ∪ l₁) ++ x₂ ∷ x₁ ∷ l₂ ≋ (x̀ ∪ l₁) ++ x₁ ∷ x₂ ∷ l₂
    p₃ = perm (x̀ ∪ l₁) x₁ x₂ l₂ refl
    p₄ : (x̀ ∪ l₁) ++ x₁ ∷ x₂ ∷ l₂ ≋ x̀ ∪ (l₁ ++ x₁ ∷ x₂ ∷ l₂)
    p₄ = ≡⇒≋ $ ∪-assoc x̀ l₁ (x₁ ∷ x₂ ∷ l₂)

x∖y∪y≋y∖x∪x : ∀ {ℓ} {A : Set ℓ} (x y : List (Named A)) →
               let nx = names x
                   ny = names y
               in filter-∈ x ny ≋ filter-∈ y nx → x ∖∖ ny ∪ y ≋ y ∖∖ nx ∪ x
x∖y∪y≋y∖x∪x x y p₀ = ≋-trans p₁ $ ≋-trans p₂ p₃ where
    nx = names x
    ny = names y
    p₁ : x ∖∖ ny ∪ y ≋ x ∖∖ ny ∪ y ∖∖ nx ∪ filter-∈ y nx
    p₁ = ≋-trans (y≋ỳ⇒x∪y≋x∪ỳ (x ∖∖ ny) (t≋t∖n∪t∩n y nx)) (≡⇒≋ $ ≡-sym $ ∪-assoc (x ∖∖ ny) (y ∖∖ nx) (filter-∈ y nx))
    p₂ : (x ∖∖ ny ∪ y ∖∖ nx) ∪ filter-∈ y nx ≋ (y ∖∖ nx ∪ x ∖∖ ny) ∪ filter-∈ x ny
    p₂ = x≋x̀⇒y≋ỳ⇒x∪y≋x̀∪ỳ (∪-sym (x ∖∖ ny) (y ∖∖ nx)) (≋-sym p₀)
    p₃ : y ∖∖ nx ∪ x ∖∖ ny ∪ filter-∈ x ny ≋ y ∖∖ nx ∪ x
    p₃ = ≋-trans (≡⇒≋ $ ∪-assoc (y ∖∖ nx) (x ∖∖ ny) (filter-∈ x ny)) (≋-sym $ y≋ỳ⇒x∪y≋x∪ỳ (y ∖∖ nx) (t≋t∖n∪t∩n x ny))

names⇒named : Names → List (Named Unit)
names⇒named = mapL (λ x → x , unit)

nn-x∪y≡nn-x∪nn-y : ∀ x y → names⇒named (x ∪ y) ≡ names⇒named x ∪ names⇒named y
nn-x∪y≡nn-x∪nn-y [] y = refl
nn-x∪y≡nn-x∪nn-y (h ∷ t) y = ≡-cong (_∷_ _) (nn-x∪y≡nn-x∪nn-y t y)

nn-x≡x : ∀ x → names (names⇒named x) ≡ x
nn-x≡x [] = refl
nn-x≡x (h ∷ t) = ≡-cong (_∷_ h) (nn-x≡x t)

x≋y⇒nn-x≋nn-y : ∀ {x y} → x ≋ y → names⇒named x ≋ names⇒named y
x≋y⇒nn-x≋nn-y refl = refl
x≋y⇒nn-x≋nn-y {x = x} {y = ._} (perm l₁ x₁ x₂ l₂ x≋l₁x₂x₁l₂) = ≋-trans p₁ p₂ where
    p₁ : names⇒named x ≋ names⇒named l₁ ++ (x₂ , unit) ∷ (x₁ , unit) ∷ names⇒named l₂
    p₁ = ≋-trans (x≋y⇒nn-x≋nn-y x≋l₁x₂x₁l₂) (≡⇒≋ $ nn-x∪y≡nn-x∪nn-y l₁ (x₂ ∷ x₁ ∷ l₂))
    p₂ : names⇒named l₁ ++ (x₂ , unit) ∷ (x₁ , unit) ∷ names⇒named l₂ ≋ names⇒named (l₁ ++ x₁ ∷ x₂ ∷ l₂)
    p₂ = ≋-trans (perm (names⇒named l₁) (x₁ , unit) (x₂ , unit) (names⇒named l₂) refl) (≡⇒≋ $ ≡-sym $ nn-x∪y≡nn-x∪nn-y l₁ (x₁ ∷ x₂ ∷ l₂))

x≋y∪z⇒x∖y≋z : {x : Names} → NonRepetitive x → (y z : Names) → x ≋ y ∪ z → x ∖ y ≋ z
x≋y∪z⇒x∖y≋z {x} nr-x y z x≋y∪z = ≋-trans (≡⇒≋ $ ≡-sym $ ≡-trans p₂ p₃) (≋-trans p₁ $ ≡⇒≋ $ nn-x≡x z) where
    ux = names⇒named x
    uy = names⇒named y
    uz = names⇒named z
    ux≋uy∪uz : ux ≋ uy ∪ uz
    ux≋uy∪uz = ≋-trans (x≋y⇒nn-x≋nn-y x≋y∪z) (≡⇒≋ $ nn-x∪y≡nn-x∪nn-y y z)
    p₁ : names (ux ∖∖ names uy) ≋ names uz
    p₁ = n-x≋y $ t≋t₁∪t₂⇒t∖t₁≋t₂ (≡-elim′ NonRepetitive (≡-sym $ nn-x≡x x) nr-x) uy uz ux≋uy∪uz
    p₂ : names (ux ∖∖ names uy) ≡ names ux ∖ names uy
    p₂ = n-x∖y ux (names uy)
    p₃ : names ux ∖ names uy ≡ x ∖ y
    p₃ = ≡-cong₂ _∖_ (nn-x≡x x) (nn-x≡x y)

h∈x⇒∃t,x≋h∷t : ∀ {ℓ} {A : Set ℓ} {h : A} {x : List A} → h ∈ x → NonRepetitive x → Σ[ t ∈ List A ] x ≋ h ∷ t
h∈x⇒∃t,x≋h∷t {h = h} .{x = x ∷ xs} (here {x = x} {xs = xs} h≡x) (x∉xs ∷ nr-xs) = xs , ≡⇒≋ (≡-cong (λ z → z ∷ xs) (≡-sym h≡x))
h∈x⇒∃t,x≋h∷t {h = h} .{x = x ∷ xs} (there {x = x} {xs = xs} h∈xs) (x∉xs ∷ nr-xs) =
    let t , xs≋h∷t = ((Σ[ t ∈ List _ ] xs ≋ h ∷ t) ∋ h∈x⇒∃t,x≋h∷t h∈xs nr-xs)
        p₁ : x ∷ xs ≋ x ∷ h ∷ t
        p₁ = y≋ỳ⇒x∪y≋x∪ỳ [ x ] xs≋h∷t
        p₂ : x ∷ h ∷ t ≋ h ∷ x ∷ t
        p₂ = ≋-del-ins-l [] [ x ] h t
     in x ∷ t , ≋-trans p₁ p₂

nr-x∪y⇒nr-y : ∀ {ℓ} {A : Set ℓ} (x y : List A) → NonRepetitive (x ∪ y) → NonRepetitive y
nr-x∪y⇒nr-y [] _ nr-y = nr-y
nr-x∪y⇒nr-y (h ∷ t) y (_ ∷ nr-t∪y) = nr-x∪y⇒nr-y t y nr-t∪y

x⊆y⇒∃x̀,y≋x∪x̀ : ∀ {ℓ} {A : Set ℓ} {x y : List A} → NonRepetitive x → NonRepetitive y → x ⊆ y → Σ[ x̀ ∈ List A ] y ≋ x ∪ x̀
x⊆y⇒∃x̀,y≋x∪x̀ {x = []} {y = y} _ _ _ = y , refl
x⊆y⇒∃x̀,y≋x∪x̀ {x = h ∷ t} {y = y} (h∉t ∷ nr-t) nr-y h∷t⊆y =
    let ỳ , y≋h∷ỳ = h∈x⇒∃t,x≋h∷t (h∷t⊆y (h ∈ h ∷ t ∋ here refl)) nr-y
        p₁ : t ⊆ ỳ
        p₁ = x⊆e∷y⇒e∉x⇒x⊆y (x⊆y≋z (x∪y⊆z⇒y⊆z [ h ] t h∷t⊆y) y≋h∷ỳ) h∉t
        nr-ỳ = nr-x∪y⇒nr-y [ h ] ỳ $ nr-x≋y y≋h∷ỳ nr-y
        t̀ , ỳ≋t∪t̀ = x⊆y⇒∃x̀,y≋x∪x̀ nr-t nr-ỳ p₁
        p₂ : h ∷ ỳ ≋ (h ∷ t) ∪ t̀
        p₂ = y≋ỳ⇒x∪y≋x∪ỳ [ h ] ỳ≋t∪t̀
     in t̀ , ≋-trans y≋h∷ỳ p₂

t₁⊆t₂⇒t₂≋t₁∪t₂∖nt₁ : ∀ {ℓ} {A : Set ℓ} {t₁ t₂ : List (Named A)} → NonRepetitiveNames t₁ → NonRepetitiveNames t₂ → t₁ ⊆ t₂ → t₂ ≋ t₁ ∪ t₂ ∖∖ names t₁
t₁⊆t₂⇒t₂≋t₁∪t₂∖nt₁ {t₁ = t₁} {t₂ = t₂} nr-nt₁ nr-nt₂ t₁⊆t₂ = ≋-trans p₁ $ y≋ỳ⇒x∪y≋x∪ỳ t₁ p₆ where
    n-t₁ = names t₁
    nr-t₁ = nr-names⇒nr nr-nt₁
    nr-t₂ = nr-names⇒nr nr-nt₂
    t̀₁,t₁∪t̀₁≋t₂ = x⊆y⇒∃x̀,y≋x∪x̀ nr-t₁ nr-t₂ t₁⊆t₂
    t̀₁ = proj₁ t̀₁,t₁∪t̀₁≋t₂
    p₁ : t₂ ≋ t₁ ∪ t̀₁
    p₁ = proj₂ t̀₁,t₁∪t̀₁≋t₂
    p₂ : t₂ ∖∖ n-t₁ ≋ (t₁ ∪ t̀₁) ∖∖ n-t₁
    p₂ = x≋y⇒x∖n≋y∖n p₁ n-t₁
    p₃ : (t₁ ∪ t̀₁) ∖∖ n-t₁ ≡ t₁ ∖∖ n-t₁ ∪ t̀₁ ∖∖ n-t₁
    p₃ = x∪y∖n≡x∖n∪y∖n t₁ t̀₁ n-t₁
    p₄ : t₁ ∖∖ n-t₁ ∪ t̀₁ ∖∖ n-t₁ ≡ t̀₁ ∖∖ n-t₁
    p₄ = ≡-cong (λ x → x ∪ t̀₁ ∖∖ n-t₁) (x∖x≡[] t₁)
    p₅ : t̀₁ ∖∖ n-t₁ ≡ t̀₁
    p₅ = nr-x∪y⇒x∖y≡x t₁ t̀₁ $ nr-x≋y (n-x≋y p₁) nr-nt₂
    p₆ : t̀₁ ≋ t₂ ∖∖ n-t₁
    p₆ = ≋-sym $ ≋-trans p₂ $ ≡⇒≋ $ ≡-trans p₃ $ ≡-trans p₄ p₅

t₁⊆t₂⇒t₁≋f∈-t₂-nt₁ : ∀ {ℓ} {A : Set ℓ} {t₁ t₂ : List (Named A)} → NonRepetitiveNames t₁ → NonRepetitiveNames t₂ → t₁ ⊆ t₂ → t₁ ≋ filter-∈ t₂ (names t₁)
t₁⊆t₂⇒t₁≋f∈-t₂-nt₁ {t₁ = t₁} {t₂ = t₂} nr-t₁ nr-t₂ t₁⊆t₂ = ≋-trans (≋-sym p₃) p₄ where
    nt₁ = names t₁
    p₁ : t₂ ≋ t₂ ∖∖ nt₁ ∪ t₁
    p₁ = ≋-trans (t₁⊆t₂⇒t₂≋t₁∪t₂∖nt₁ nr-t₁ nr-t₂ t₁⊆t₂) (∪-sym t₁ (t₂ ∖∖ nt₁))
    p₂ : t₂ ≋ t₂ ∖∖ nt₁ ∪ filter-∈ t₂ nt₁
    p₂ = t≋t∖n∪t∩n t₂ nt₁
    p₃ : t₂ ∖∖ names (t₂ ∖∖ nt₁) ≋ t₁
    p₃ = t≋t₁∪t₂⇒t∖t₁≋t₂ nr-t₂ (t₂ ∖∖ nt₁) t₁ p₁
    p₄ : t₂ ∖∖ names (t₂ ∖∖ nt₁) ≋ filter-∈ t₂ nt₁
    p₄ = t≋t₁∪t₂⇒t∖t₁≋t₂ nr-t₂ (t₂ ∖∖ nt₁) (filter-∈ t₂ nt₁) p₂

-- /lemmas

-- assertions

infix 4 _s-≢!_
_s-≢!_ : String → String → Set
x s-≢! y with x ≟ y
... | yes _ = ⊥
... | no  _ = ⊤

s-≢!⇒≢? : ∀ {x y} → x s-≢! y → x ≢ y
s-≢!⇒≢? {x} {y} x≢!y with x ≟ y
s-≢!⇒≢? () | yes _
s-≢!⇒≢? _  | no p = p

s-NonRepetitive? : (n : Names) → Dec (NonRepetitive n)
s-NonRepetitive? [] = yes []
s-NonRepetitive? (h ∷ t) with h ∈? t | s-NonRepetitive? t
... | no h∉t | yes nr-t = yes (h∉t ∷ nr-t)
... | yes h∈t | _ = no f where
                    f : NonRepetitive (_ ∷ _) → _
                    f (h∉t ∷ _) = h∉t h∈t
... | _ | no ¬nr-t = no f where
                    f : NonRepetitive (_ ∷ _) → _
                    f (_ ∷ nr-t) = ¬nr-t nr-t

s-NonRepetitive! : Names → Set
s-NonRepetitive! n with s-NonRepetitive? n
... | yes _ = ⊤
... | no _ = ⊥

NonRepetitiveNames! : ∀ {ℓ} {A : Set ℓ} → List (Named A) → Set
NonRepetitiveNames! = s-NonRepetitive! ∘ names

s-nr!⇒nr : {n : Names} → s-NonRepetitive! n → NonRepetitive n
s-nr!⇒nr {n = n} _ with s-NonRepetitive? n
s-nr!⇒nr _ | yes p = p
s-nr!⇒nr () | no _

-- /assertions


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommAlgebra.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP
open import Cubical.Foundations.GroupoidLaws
open import Cubical.Foundations.Path

open import Cubical.Data.Sigma

open import Cubical.Reflection.StrictEquiv

open import Cubical.Structures.Axioms
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Algebra
open import Cubical.Algebra.CommAlgebra.Base

open import Cubical.HITs.PropositionalTruncation

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level

-- An R-algebra is the same as a CommRing A with a CommRingHom φ : R → A
module CommAlgChar (R : CommRing ℓ) where
 open Iso
 open IsRingHom
 open CommRingTheory

 CommRingWithHom : Type (ℓ-suc ℓ)
 CommRingWithHom = Σ[ A ∈ CommRing ℓ ] CommRingHom R A

 toCommAlg : CommRingWithHom → CommAlgebra R ℓ
 toCommAlg (A , φ , φIsHom) = ⟨ A ⟩ , ACommAlgStr
  where
  open CommRingStr (snd A)
  ACommAlgStr : CommAlgebraStr R ⟨ A ⟩
  CommAlgebraStr.0a ACommAlgStr = 0r
  CommAlgebraStr.1a ACommAlgStr = 1r
  CommAlgebraStr._+_ ACommAlgStr = _+_
  CommAlgebraStr._·_ ACommAlgStr = _·_
  CommAlgebraStr.- ACommAlgStr = -_
  CommAlgebraStr._⋆_ ACommAlgStr r a = (φ r) · a
  CommAlgebraStr.isCommAlgebra ACommAlgStr = makeIsCommAlgebra
   is-set +Assoc +Rid +Rinv +Comm ·Assoc ·Lid ·Ldist+ ·Comm
   (λ _ _ x → cong (λ y →  y · x) (pres· φIsHom _ _) ∙ sym (·Assoc _ _ _))
   (λ _ _ x → cong (λ y → y · x) (pres+ φIsHom _ _) ∙ ·Ldist+ _ _ _)
   (λ _ _ _ → ·Rdist+ _ _ _)
   (λ x → cong (λ y → y · x) (pres1 φIsHom) ∙ ·Lid x)
   (λ _ _ _ → sym (·Assoc _ _ _))

 fromCommAlg : CommAlgebra R ℓ → CommRingWithHom
 fromCommAlg A = (CommAlgebra→CommRing A) , φ , φIsHom
  where
  open CommRingStr (snd R) renaming (_·_ to _·r_) hiding (·Lid)
  open CommAlgebraStr (snd A)
  open AlgebraTheory (CommRing→Ring R) (CommAlgebra→Algebra A)
  φ : ⟨ R ⟩ → ⟨ A ⟩
  φ r = r ⋆ 1a
  φIsHom : IsRingHom (CommRing→Ring R .snd) φ (CommRing→Ring (CommAlgebra→CommRing A) .snd)
  φIsHom = makeIsRingHom (⋆-lid _) (λ _ _ → ⋆-ldist _ _ _)
           λ x y → cong (λ a → (x ·r y) ⋆ a) (sym (·Lid _)) ∙ ⋆Dist· _ _ _ _

 CommRingWithHomRoundTrip : (Aφ : CommRingWithHom) → fromCommAlg (toCommAlg Aφ) ≡ Aφ
 CommRingWithHomRoundTrip (A , φ) = ΣPathP (APath , φPathP)
  where
  open CommRingStr
  -- note that the proofs of the axioms might differ!
  APath : fst (fromCommAlg (toCommAlg (A , φ))) ≡ A
  fst (APath i) = ⟨ A ⟩
  0r (snd (APath i)) = 0r (snd A)
  1r (snd (APath i)) = 1r (snd A)
  _+_ (snd (APath i)) = _+_ (snd A)
  _·_ (snd (APath i)) = _·_ (snd A)
  -_ (snd (APath i)) = -_ (snd A)
  isCommRing (snd (APath i)) = isProp→PathP (λ i → isPropIsCommRing _ _ _ _ _ )
             (isCommRing (snd (fst (fromCommAlg (toCommAlg (A , φ)))))) (isCommRing (snd A)) i

  -- this only works because fst (APath i) = fst A definitionally!
  φPathP : PathP (λ i → CommRingHom R (APath i)) (snd (fromCommAlg (toCommAlg (A , φ)))) φ
  φPathP = RingHomPathP _ _ _ _ _ _ λ i x → ·Rid (snd A) (fst φ x) i

 CommAlgRoundTrip : (A : CommAlgebra R ℓ) → toCommAlg (fromCommAlg A) ≡ A
 CommAlgRoundTrip A = ΣPathP (refl , AlgStrPathP)
  where
  open CommAlgebraStr ⦃...⦄
  instance
   _ = snd A
  AlgStrPathP : PathP (λ i → CommAlgebraStr R ⟨ A ⟩) (snd (toCommAlg (fromCommAlg A))) (snd A)
  CommAlgebraStr.0a (AlgStrPathP i) = 0a
  CommAlgebraStr.1a (AlgStrPathP i) = 1a
  CommAlgebraStr._+_ (AlgStrPathP i) = _+_
  CommAlgebraStr._·_ (AlgStrPathP i) = _·_
  CommAlgebraStr.-_ (AlgStrPathP i) = -_
  CommAlgebraStr._⋆_ (AlgStrPathP i) r x = (⋆-lassoc r 1a x ∙ cong (r ⋆_) (·Lid x)) i
  CommAlgebraStr.isCommAlgebra (AlgStrPathP i) = isProp→PathP
    (λ i → isPropIsCommAlgebra _ _ _ _ _ _ (CommAlgebraStr._⋆_ (AlgStrPathP i)))
    (CommAlgebraStr.isCommAlgebra (snd (toCommAlg (fromCommAlg A)))) isCommAlgebra i

 CommAlgIso : Iso (CommAlgebra R ℓ) CommRingWithHom
 fun CommAlgIso = fromCommAlg
 inv CommAlgIso = toCommAlg
 rightInv CommAlgIso = CommRingWithHomRoundTrip
 leftInv CommAlgIso = CommAlgRoundTrip

 open RingHoms
 isCommRingWithHomHom : (A B : CommRingWithHom) → CommRingHom (fst A) (fst B) → Type ℓ
 isCommRingWithHomHom (_ , f) (_ , g) h = h ∘r f ≡ g

 CommRingWithHomHom : CommRingWithHom → CommRingWithHom → Type ℓ
 CommRingWithHomHom (A , f) (B , g) = Σ[ h ∈ CommRingHom A B ] h ∘r f ≡ g

 toCommAlgebraHom : (A B : CommRingWithHom) (h : CommRingHom (fst A) (fst B))
                  → isCommRingWithHomHom A B h
                  → CommAlgebraHom (toCommAlg A) (toCommAlg B)
 toCommAlgebraHom (A , f) (B , g) h commDiag =
   makeCommAlgebraHom (fst h) (pres1 (snd h)) (pres+ (snd h)) (pres· (snd h)) pres⋆h
   where
   open CommRingStr ⦃...⦄
   instance
    _ = snd A
    _ = snd B
   pres⋆h : ∀ r x → fst h (fst f r · x) ≡ fst g r · fst h x
   pres⋆h r x = fst h (fst f r · x)       ≡⟨ pres· (snd h) _ _ ⟩
                fst h (fst f r) · fst h x ≡⟨ cong (λ φ → fst φ r · fst h x) commDiag ⟩
                fst g r · fst h x ∎

 fromCommAlgebraHom : (A B : CommAlgebra R ℓ) → CommAlgebraHom A B
                    → CommRingWithHomHom (fromCommAlg A) (fromCommAlg B)
 fst (fst (fromCommAlgebraHom A B f)) = fst f
 pres0 (snd (fst (fromCommAlgebraHom A B f))) = IsAlgebraHom.pres0 (snd f)
 pres1 (snd (fst (fromCommAlgebraHom A B f))) = IsAlgebraHom.pres1 (snd f)
 pres+ (snd (fst (fromCommAlgebraHom A B f))) = IsAlgebraHom.pres+ (snd f)
 pres· (snd (fst (fromCommAlgebraHom A B f))) = IsAlgebraHom.pres· (snd f)
 pres- (snd (fst (fromCommAlgebraHom A B f))) = IsAlgebraHom.pres- (snd f)
 snd (fromCommAlgebraHom A B f) =
  RingHom≡ (funExt (λ x → IsAlgebraHom.pres⋆ (snd f) x 1a ∙ cong (x ⋆_) (IsAlgebraHom.pres1 (snd f))))
  where
  open CommAlgebraStr (snd A) using (1a)
  open CommAlgebraStr (snd B) using (_⋆_)

 isCommRingWithHomEquiv : (A B : CommRingWithHom) → CommRingEquiv (fst A) (fst B) → Type ℓ
 isCommRingWithHomEquiv A B e = isCommRingWithHomHom A B (RingEquiv→RingHom e)

 CommRingWithHomEquiv : CommRingWithHom → CommRingWithHom → Type ℓ
 CommRingWithHomEquiv A B = Σ[ e ∈ CommRingEquiv (fst A) (fst B) ] isCommRingWithHomEquiv A B e

 toCommAlgebraEquiv : (A B : CommRingWithHom) (e : CommRingEquiv (fst A) (fst B))
                    → isCommRingWithHomEquiv A B e
                    → CommAlgebraEquiv (toCommAlg A) (toCommAlg B)
 fst (toCommAlgebraEquiv A B e eCommDiag) = e .fst
 snd (toCommAlgebraEquiv A B e eCommDiag) = toCommAlgebraHom A B _ eCommDiag .snd

module CommAlgebraHoms {R : CommRing ℓ} where
  open AlgebraHoms

  idCommAlgebraHom : (A : CommAlgebra R ℓ') → CommAlgebraHom A A
  idCommAlgebraHom A = idAlgebraHom (CommAlgebra→Algebra A)

  compCommAlgebraHom : (A : CommAlgebra R ℓ') (B : CommAlgebra R ℓ'') (C : CommAlgebra R ℓ''')
                  → CommAlgebraHom A B → CommAlgebraHom B C → CommAlgebraHom A C
  compCommAlgebraHom A B C = compAlgebraHom {A = CommAlgebra→Algebra A}
                                            {CommAlgebra→Algebra B} {CommAlgebra→Algebra C}

  _∘ca_ : {A : CommAlgebra R ℓ'} {B : CommAlgebra R ℓ''} {C : CommAlgebra R ℓ'''}
        → CommAlgebraHom B C → CommAlgebraHom A B → CommAlgebraHom A C
  g ∘ca f = compCommAlgebraHom _ _ _ f g

  compIdCommAlgebraHom : {A B : CommAlgebra R ℓ'} (f : CommAlgebraHom A B)
                    → compCommAlgebraHom _ _ _ (idCommAlgebraHom A) f ≡ f
  compIdCommAlgebraHom = compIdAlgebraHom

  idCompCommAlgebraHom : {A B : CommAlgebra R ℓ'} (f : CommAlgebraHom A B)
                    → compCommAlgebraHom _ _ _ f (idCommAlgebraHom B) ≡ f
  idCompCommAlgebraHom = idCompAlgebraHom

  compAssocCommAlgebraHom : {A B C D : CommAlgebra R ℓ'}
                         (f : CommAlgebraHom A B) (g : CommAlgebraHom B C) (h : CommAlgebraHom C D)
                       → compCommAlgebraHom _ _ _ (compCommAlgebraHom _ _ _ f g) h
                       ≡ compCommAlgebraHom _ _ _ f (compCommAlgebraHom _ _ _ g h)
  compAssocCommAlgebraHom = compAssocAlgebraHom

module CommAlgebraEquivs {R : CommRing ℓ} where
 open AlgebraEquivs

 compCommAlgebraEquiv : {A : CommAlgebra R ℓ'} {B : CommAlgebra R ℓ''} {C : CommAlgebra R ℓ'''}
                   → CommAlgebraEquiv A B → CommAlgebraEquiv B C → CommAlgebraEquiv A C
 compCommAlgebraEquiv {A = A} {B = B} {C = C} = compAlgebraEquiv {A = CommAlgebra→Algebra A}
                                                           {B = CommAlgebra→Algebra B}
                                                           {C = CommAlgebra→Algebra C}

-- the CommAlgebra version of uaCompEquiv
module CommAlgebraUAFunctoriality {R : CommRing ℓ} where
 open CommAlgebraStr
 open CommAlgebraEquivs

 CommAlgebra≡ : (A B : CommAlgebra R ℓ') → (
   Σ[ p ∈ ⟨ A ⟩ ≡ ⟨ B ⟩ ]
   Σ[ q0 ∈ PathP (λ i → p i) (0a (snd A)) (0a (snd B)) ]
   Σ[ q1 ∈ PathP (λ i → p i) (1a (snd A)) (1a (snd B)) ]
   Σ[ r+ ∈ PathP (λ i → p i → p i → p i) (_+_ (snd A)) (_+_ (snd B)) ]
   Σ[ r· ∈ PathP (λ i → p i → p i → p i) (_·_ (snd A)) (_·_ (snd B)) ]
   Σ[ s- ∈ PathP (λ i → p i → p i) (-_ (snd A)) (-_ (snd B)) ]
   Σ[ s⋆ ∈ PathP (λ i → ⟨ R ⟩ → p i → p i) (_⋆_ (snd A)) (_⋆_ (snd B)) ]
   PathP (λ i → IsCommAlgebra R (q0 i) (q1 i) (r+ i) (r· i) (s- i) (s⋆ i)) (isCommAlgebra (snd A))
                                                                           (isCommAlgebra (snd B)))
   ≃ (A ≡ B)
 CommAlgebra≡ A B = isoToEquiv theIso
   where
   open Iso
   theIso : Iso _ _
   fun theIso (p , q0 , q1 , r+ , r· , s- , s⋆ , t) i = p i
                 , commalgebrastr (q0 i) (q1 i) (r+ i) (r· i) (s- i) (s⋆ i) (t i)
   inv theIso x = cong ⟨_⟩ x , cong (0a ∘ snd) x , cong (1a ∘ snd) x
                , cong (_+_ ∘ snd) x , cong (_·_ ∘ snd) x , cong (-_ ∘ snd) x , cong (_⋆_ ∘ snd) x
                , cong (isCommAlgebra ∘ snd) x
   rightInv theIso _ = refl
   leftInv theIso _ = refl

 caracCommAlgebra≡ : {A B : CommAlgebra R ℓ'} (p q : A ≡ B) → cong ⟨_⟩ p ≡ cong ⟨_⟩ q → p ≡ q
 caracCommAlgebra≡ {A = A} {B = B} p q P =
   sym (transportTransport⁻ (ua (CommAlgebra≡ A B)) p)
                                    ∙∙ cong (transport (ua (CommAlgebra≡ A B))) helper
                                    ∙∙ transportTransport⁻ (ua (CommAlgebra≡ A B)) q
     where
     helper : transport (sym (ua (CommAlgebra≡ A B))) p ≡ transport (sym (ua (CommAlgebra≡ A B))) q
     helper = Σ≡Prop
                (λ _ → isPropΣ
                          (isOfHLevelPathP' 1 (is-set (snd B)) _ _)
                          λ _ → isPropΣ (isOfHLevelPathP' 1 (is-set (snd B)) _ _)
                          λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set (snd B)) _ _)
                          λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set (snd B)) _ _)
                          λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ λ _ → is-set (snd B)) _ _)
                          λ _ → isPropΣ (isOfHLevelPathP' 1 (isSetΠ2 λ _ _ → is-set (snd B)) _ _)
                          λ _ → isOfHLevelPathP 1 (isPropIsCommAlgebra _ _ _ _ _ _ _) _ _)
               (transportRefl (cong ⟨_⟩ p) ∙ P ∙ sym (transportRefl (cong ⟨_⟩ q)))

 uaCompCommAlgebraEquiv : {A B C : CommAlgebra R ℓ'} (f : CommAlgebraEquiv A B) (g : CommAlgebraEquiv B C)
                  → uaCommAlgebra (compCommAlgebraEquiv f g) ≡ uaCommAlgebra f ∙ uaCommAlgebra g
 uaCompCommAlgebraEquiv f g = caracCommAlgebra≡ _ _ (
   cong ⟨_⟩ (uaCommAlgebra (compCommAlgebraEquiv f g))
     ≡⟨ uaCompEquiv _ _ ⟩
   cong ⟨_⟩ (uaCommAlgebra f) ∙ cong ⟨_⟩ (uaCommAlgebra g)
     ≡⟨ sym (cong-∙ ⟨_⟩ (uaCommAlgebra f) (uaCommAlgebra g)) ⟩
   cong ⟨_⟩ (uaCommAlgebra f ∙ uaCommAlgebra g) ∎)

open CommAlgebraHoms
open CommAlgebraEquivs
open CommAlgebraUAFunctoriality
recPT→CommAlgebra : {R : CommRing ℓ} {A : Type ℓ'} (𝓕  : A → CommAlgebra R ℓ'')
           → (σ : ∀ x y → CommAlgebraEquiv (𝓕 x) (𝓕 y))
           → (∀ x y z → σ x z ≡ compCommAlgebraEquiv (σ x y) (σ y z))
          ------------------------------------------------------
           → ∥ A ∥ → CommAlgebra R ℓ''
recPT→CommAlgebra 𝓕 σ compCoh = GpdElim.rec→Gpd isGroupoidCommAlgebra 𝓕
  (3-ConstantCompChar 𝓕 (λ x y → uaCommAlgebra (σ x y))
                          λ x y z → sym (  cong uaCommAlgebra (compCoh x y z)
                                         ∙ uaCompCommAlgebraEquiv (σ x y) (σ y z)))

contrCommAlgebraHom→contrCommAlgebraEquiv : {R : CommRing ℓ} {A : Type ℓ'}
        (σ : A → CommAlgebra R ℓ'')
      → (∀ x y → isContr (CommAlgebraHom (σ x) (σ y)))
      ----------------------------------------------------------------------------
      → ∀ x y → isContr (CommAlgebraEquiv (σ x) (σ y))
contrCommAlgebraHom→contrCommAlgebraEquiv σ contrHom x y = σEquiv ,
  λ e → Σ≡Prop (λ _ → isPropIsAlgebraHom _ _ _ _)
           (Σ≡Prop isPropIsEquiv (cong fst (contrHom _ _ .snd (CommAlgebraEquiv→CommAlgebraHom e))))
  where
  open Iso
  χ₁ = contrHom x y .fst
  χ₂ = contrHom y x .fst
  χ₁∘χ₂≡id : χ₁ ∘ca χ₂ ≡ idCommAlgebraHom _
  χ₁∘χ₂≡id = isContr→isProp (contrHom _ _) _ _

  χ₂∘χ₁≡id : χ₂ ∘ca χ₁ ≡ idCommAlgebraHom _
  χ₂∘χ₁≡id = isContr→isProp (contrHom _ _) _ _

  σIso : Iso ⟨ σ x ⟩ ⟨ σ y ⟩
  fun σIso = fst χ₁
  inv σIso = fst χ₂
  rightInv σIso = funExt⁻ (cong fst χ₁∘χ₂≡id)
  leftInv σIso = funExt⁻ (cong fst χ₂∘χ₁≡id)

  σEquiv : CommAlgebraEquiv (σ x) (σ y)
  fst σEquiv = isoToEquiv σIso
  snd σEquiv = snd χ₁


{-# OPTIONS --prop --allow-unsolved-metas #-}

data _≡_ {α}{A : Set α}(a : A) : A → Prop where
  refl : a ≡ a

data _≃_ {α}{A : Set α}(a : A) : ∀ {B} → B → Prop where
  refl̃ : a ≃ a

data ⊥ : Set where

data Con  : Set
data Con~ : Con → Con → Prop
data Ty   : Con → Set
data Ty~  : ∀ {Γ₀ Γ₁} → Con~ Γ₀ Γ₁ → Ty Γ₀ → Ty Γ₁ → Prop

data Con where
data Con~ where

data Ty where
  U  : ∀ {Γ} → Ty Γ

data Ty~ where
  U~  : ∀ {Γ₀ Γ₁ Γ₀₁} → Ty~ {Γ₀}{Γ₁} Γ₀₁ U U

Conᴹ  : Con → Set
Con~ᴹ : ∀ {Γ₀ Γ₁} → Con~ Γ₀ Γ₁ → Conᴹ Γ₀ ≡ Conᴹ Γ₁
Tyᴹ   : ∀ {Γ} → Ty Γ → Conᴹ Γ → Set
Ty~ᴹ  : ∀ {Γ₀ Γ₁ Γ₀₁ A₀ A₁} → Ty~ {Γ₀}{Γ₁} Γ₀₁ A₀ A₁ → Tyᴹ A₀ ≃ Tyᴹ A₁
Conᴹ  ()
Con~ᴹ ()

Tyᴹ U γ = ⊥

-- offending line: if I comment this out, the internal error goes away
-- If I use Set instead of Prop everywhere, the error also goes away
Ty~ᴹ U~ = {!!}


-- {-# OPTIONS --show-implicit --show-irrelevant #-}
module Data.QuadTree.FunctorProofs.Valid-QuadrantFunctor where

open import Haskell.Prelude renaming (zero to Z; suc to S)
open import Data.Logic
open import Data.QuadTree.InternalAgda
open import Agda.Primitive
open import Data.QuadTree.FunctorProofs.FunctorLaws
open import Data.QuadTree.Implementation.Definition
open import Data.QuadTree.Implementation.ValidTypes
open import Data.QuadTree.Implementation.Functors
open import Data.QuadTree.Implementation.QuadrantLenses

ValidFunctor-Quadrant-IdentityLaw : (dep : Nat) -> IdentityLaw (λ y -> VQuadrant y {dep}) {{quadrantFunctor dep}}
ValidFunctor-Quadrant-IdentityLaw dep (CVQuadrant (Leaf v)) = refl
ValidFunctor-Quadrant-IdentityLaw dep@(S deps) (CVQuadrant qd@(Node (Leaf a) (Leaf b) (Leaf c) (Leaf d)) {p}) =
    ifcFalse (a == b && b == c && c == d) (notTrueToFalse $ andSndI {a = (depth qd <= dep)} p)
ValidFunctor-Quadrant-IdentityLaw dep@(S deps) (CVQuadrant (Node a@(Leaf _) b@(Leaf _) c@(Leaf _) d@(Node _ _ _ _)) {p}) =
    cong4 combine
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant a))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant b))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant c))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant d))
ValidFunctor-Quadrant-IdentityLaw dep@(S deps) (CVQuadrant (Node a@(Leaf _) b@(Leaf _) c@(Node _ _ _ _) d) {p}) =
    cong4 combine
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant a))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant b))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant c))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant d))
ValidFunctor-Quadrant-IdentityLaw dep@(S deps) (CVQuadrant (Node a@(Leaf _) b@(Node _ _ _ _) c d) {p}) =
    cong4 combine
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant a))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant b))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant c))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant d))
ValidFunctor-Quadrant-IdentityLaw dep@(S deps) (CVQuadrant (Node a@(Node _ _ _ _) b c d) {p}) =
    cong4 combine
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant a))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant b))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant c))
        (ValidFunctor-Quadrant-IdentityLaw deps (CVQuadrant d))

postulate
    eq-subst : {a b : Set} {{eqA : Eq a}} {{eqB : Eq b}} -> (f : a -> b) -> (x y : a)
        -> (x == y) ≡ (f x == f y)

combine-fmap : {t s : Set} {{eqT : Eq t}} {{eqS : Eq s}} {dep : Nat} -> (a b c d : VQuadrant t {dep})
    -> (f : t -> s)
    -> combine (fmapₑ (quadrantFunctor dep) f a) (fmapₑ (quadrantFunctor dep) f b) (fmapₑ (quadrantFunctor dep) f c) (fmapₑ (quadrantFunctor dep) f d)
        ≡ fmapₑ (quadrantFunctor (S dep)) f (combine a b c d)
combine-fmap {t} {s} {dep = dep} (CVQuadrant a@(Leaf va)) (CVQuadrant b@(Leaf vb)) (CVQuadrant c@(Leaf vc)) (CVQuadrant d@(Leaf vd)) f =
    ifc (va == vb && vb == vc && vc == vd)
    then (λ {{p}} ->
        begin
            (ifc (f va == f vb) && (f vb == f vc) && (f vc == f vd) then _ else _)
        =⟨ ifcTrue _ (useEq (cong3 (λ e1 e2 e3 -> e1 && e2 && e3) (eq-subst f va vb) (eq-subst f vb vc) (eq-subst f vc vd)) p) ⟩
            fmapₑ (quadrantFunctor (S dep)) f (CVQuadrant (Leaf va))
        =⟨ cong (fmapₑ (quadrantFunctor (S dep)) f) (sym $ ifcTrue ((va == vb) && (vb == vc) && (vc == vd)) p) ⟩
            fmapₑ (quadrantFunctor (S dep)) f (ifc (va == vb) && (vb == vc) && (vc == vd) then CVQuadrant (Leaf va) else CVQuadrant (Node (Leaf va) (Leaf vb) (Leaf vc) (Leaf vd)))
        end)
    else (λ {{p}} ->
        begin
            (ifc (f va == f vb) && (f vb == f vc) && (f vc == f vd) then _ else _)
        =⟨ sym $ cong
            {y = (CVQuadrant (Node (Leaf va) (Leaf vb) (Leaf vc) (Leaf vd)) {andCombine (zeroLteAny dep) (falseToNotTrue p)})}
            p1 (ifcFalse ((va == vb) && (vb == vc) && (vc == vd)) p) ⟩
            fmapₑ (quadrantFunctor (S dep)) f (ifc (va == vb) && (vb == vc) && (vc == vd) then CVQuadrant (Leaf va) else CVQuadrant (Node (Leaf va) (Leaf vb) (Leaf vc) (Leaf vd)))
        end) where
    p1 : VQuadrant t {S dep} -> VQuadrant s {S dep}
    p1 q = (fmapₑ (quadrantFunctor (S dep)) f) q
combine-fmap (CVQuadrant (Leaf _)) (CVQuadrant (Leaf _)) (CVQuadrant (Leaf _)) (CVQuadrant (Node _ _ _ _)) f = refl
combine-fmap (CVQuadrant (Leaf _)) (CVQuadrant (Leaf _)) (CVQuadrant (Node _ _ _ _)) (CVQuadrant d) f = refl
combine-fmap (CVQuadrant (Leaf _)) (CVQuadrant (Node _ _ _ _)) (CVQuadrant c) (CVQuadrant d) f = refl
combine-fmap (CVQuadrant (Node _ _ _ _)) (CVQuadrant b) (CVQuadrant c) (CVQuadrant d) f = refl

ValidFunctor-Quadrant-CompositionLaw : (dep : Nat) -> CompositionLaw (λ y -> VQuadrant y {dep}) {{quadrantFunctor dep}}
ValidFunctor-Quadrant-CompositionLaw dep (CVQuadrant (Leaf x)) f g = refl
ValidFunctor-Quadrant-CompositionLaw dep@(S deps) {t1} {t2} {t3} cvq@(CVQuadrant qd@(Node a@(Leaf va) b@(Leaf vb) c@(Leaf vc) d@(Leaf vd)) {p}) f g =
    begin
        combine (mgf sa) (mgf sb) (mgf sc) (mgf sd)
    =⟨ cong4 combine
        (ValidFunctor-Quadrant-CompositionLaw deps sa f g)
        (ValidFunctor-Quadrant-CompositionLaw deps sb f g)
        (ValidFunctor-Quadrant-CompositionLaw deps sc f g)
        (ValidFunctor-Quadrant-CompositionLaw deps sd f g) ⟩
        combine (mg $ mf sa) (mg $ mf sb) (mg $ mf sc) (mg $ mf sd)
    =⟨ combine-fmap (mf sa) (mf sb) (mf sc) (mf sd) g ⟩
        fmapₑ (quadrantFunctor dep) g (combine (mf sa) (mf sb) (mf sc) (mf sd))
    end where
        mf = fmapₑ (quadrantFunctor deps) f
        mg = fmapₑ (quadrantFunctor deps) g
        mgf = fmapₑ (quadrantFunctor deps) (g ∘ f)
        sa = (CVQuadrant a {aSub {dep = deps} a b c d p})
        sb = (CVQuadrant b {bSub {dep = deps} a b c d p})
        sc = (CVQuadrant c {cSub {dep = deps} a b c d p})
        sd = (CVQuadrant d {dSub {dep = deps} a b c d p})
ValidFunctor-Quadrant-CompositionLaw dep@(S deps) cvq@(CVQuadrant (Node a@(Leaf va) b@(Leaf vb) c@(Leaf vc) d@(Node _ _ _ _)) {p}) f g =
    begin
        combine (mgf sa) (mgf sb) (mgf sc) (mgf sd)
    =⟨ cong4 combine
        (ValidFunctor-Quadrant-CompositionLaw deps sa f g)
        (ValidFunctor-Quadrant-CompositionLaw deps sb f g)
        (ValidFunctor-Quadrant-CompositionLaw deps sc f g)
        (ValidFunctor-Quadrant-CompositionLaw deps sd f g) ⟩
        combine (mg $ mf sa) (mg $ mf sb) (mg $ mf sc) (mg $ mf sd)
    =⟨ combine-fmap (mf sa) (mf sb) (mf sc) (mf sd) g ⟩
        fmapₑ (quadrantFunctor dep) g (combine (mf sa) (mf sb) (mf sc) (mf sd))
    end where
        mf = fmapₑ (quadrantFunctor deps) f
        mg = fmapₑ (quadrantFunctor deps) g
        mgf = fmapₑ (quadrantFunctor deps) (g ∘ f)
        sa = (CVQuadrant a {aSub {dep = deps} a b c d p})
        sb = (CVQuadrant b {bSub {dep = deps} a b c d p})
        sc = (CVQuadrant c {cSub {dep = deps} a b c d p})
        sd = (CVQuadrant d {dSub {dep = deps} a b c d p})
ValidFunctor-Quadrant-CompositionLaw dep@(S deps) cvq@(CVQuadrant (Node a@(Leaf _) b@(Leaf _) c@(Node _ _ _ _) d) {p}) f g =
    trans
        (cong4 combine
            (ValidFunctor-Quadrant-CompositionLaw deps sa f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sb f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sc f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sd f g))
        (combine-fmap (mf sa) (mf sb) (mf sc) (mf sd) g)
    where
        mf = fmapₑ (quadrantFunctor deps) f
        sa = (CVQuadrant a {aSub {dep = deps} a b c d p})
        sb = (CVQuadrant b {bSub {dep = deps} a b c d p})
        sc = (CVQuadrant c {cSub {dep = deps} a b c d p})
        sd = (CVQuadrant d {dSub {dep = deps} a b c d p})
ValidFunctor-Quadrant-CompositionLaw dep@(S deps) cvq@(CVQuadrant (Node a@(Leaf _) b@(Node _ _ _ _) c d) {p}) f g =
    trans
        (cong4 combine
            (ValidFunctor-Quadrant-CompositionLaw deps sa f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sb f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sc f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sd f g))
        (combine-fmap (mf sa) (mf sb) (mf sc) (mf sd) g)
    where
        mf = fmapₑ (quadrantFunctor deps) f
        sa = (CVQuadrant a {aSub {dep = deps} a b c d p})
        sb = (CVQuadrant b {bSub {dep = deps} a b c d p})
        sc = (CVQuadrant c {cSub {dep = deps} a b c d p})
        sd = (CVQuadrant d {dSub {dep = deps} a b c d p})
ValidFunctor-Quadrant-CompositionLaw dep@(S deps) cvq@(CVQuadrant (Node a@(Node _ _ _ _) b c d) {p}) f g =
    trans
        (cong4 combine
            (ValidFunctor-Quadrant-CompositionLaw deps sa f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sb f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sc f g)
            (ValidFunctor-Quadrant-CompositionLaw deps sd f g))
        (combine-fmap (mf sa) (mf sb) (mf sc) (mf sd) g)
    where
        mf = fmapₑ (quadrantFunctor deps) f
        sa = (CVQuadrant a {aSub {dep = deps} a b c d p})
        sb = (CVQuadrant b {bSub {dep = deps} a b c d p})
        sc = (CVQuadrant c {cSub {dep = deps} a b c d p})
        sd = (CVQuadrant d {dSub {dep = deps} a b c d p})


{-# OPTIONS --type-in-type #-}
module dyn where
open import prelude
open import functors
open import poly0 public
open import prelude.Stream
open Stream
open import Data.List as L using (List)

record Dyn : Set where
  constructor dyn
  field
    {state} : Set
    {body}  : ∫
    pheno   : ∫[ (state , λ _ → state) , body ]
open Dyn public

run : (d : Dyn) → ∫[ body d , 𝒴 ] → state d → Stream (π₁ (body d))
hd (run d@(dyn l) e s₀) = s₀ ★ l
tl (run d@(dyn l) e s₀) = run d e (s₀ # l ← hd (run d e s₀) # e ← tt)

module _ (d₁ d₂ : Dyn) where
    _⊠⊠⊠_ : Dyn
    _⊠⊠⊠_ = dyn (pheno d₁ ⟦⊠⟧ pheno d₂)

_⟫_ : (d : Dyn) → ∫[ body d , A ] → Dyn
d ⟫ l = dyn (pheno d ▸ l)

fun→dyn : ∀ {a b} → (a → b) → Dyn
fun→dyn f = dyn (λ a⁺ → a⁺ , f)

delay : Set → Dyn
delay s = fun→dyn (id {A = s})


------------------------------------------------------------------------------
-- Fairness of the ABP channels
------------------------------------------------------------------------------

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

module FOTC.Program.ABP.Fair.Type where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- The Fair co-inductive predicate

-- From (Dybjer and Sander 1989): al : F*T if al is a list of zero or
-- more 0's followed by a final 1.
data F*T : D → Set where
  f*tnil  : F*T (T ∷ [])
  f*tcons : ∀ {ft} → F*T ft → F*T (F ∷ ft)

-- Functor for the Fair type.
-- FairF : (D → Set) → D → Set
-- FairF A os = ∃[ ft ] ∃[ os' ] F*T ft ∧ os ≡ ft ++ os' ∧ A os'

-- Fair is the greatest fixed of FairF (by Fair-out and Fair-coind).

postulate Fair : D → Set

-- Fair a is post-fixed point of FairF, i.e.
--
-- Fair ≤ FairF Fair.
postulate Fair-out : ∀ {os} → Fair os →
                     ∃[ ft ] ∃[ os' ] F*T ft ∧ os ≡ ft ++ os' ∧ Fair os'
{-# ATP axiom Fair-out #-}

-- Fair is the greatest post-fixed point of FairF, i.e.
--
-- ∀ A. A ≤ FairF A ⇒ A ≤ Fair.
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  Fair-coind :
    (A : D → Set) →
    -- A is post-fixed point of FairF.
    (∀ {os} → A os → ∃[ ft ] ∃[ os' ] F*T ft ∧ os ≡ ft ++ os' ∧ A os') →
    -- Fair is greater than A.
    ∀ {os} → A os → Fair os

------------------------------------------------------------------------------
-- References
--
-- Dybjer, Peter and Sander, Herbert P. (1989). A Functional
-- Programming Approach to the Specification and Verification of
-- Concurrent Systems. Formal Aspects of Computing 1, pp. 303–319.