module utility where

open import Algebra
  using (Monoid)
open import Algebra.Structures
  using (IsMonoid ; IsSemigroup)
open import Data.Empty
open import Function
  using (_∘_)
open import Relation.Binary
  using (Decidable)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; setoid ; sym ; cong)
open import Relation.Nullary
open import Relation.Nullary.Decidable
  using (⌊_⌋)
open import Data.Bool
  using (not)
open import Data.List
open import Data.List.Properties
  using (map-id ; map-compose ; map-cong)
open import Data.List.Any as ListAny
  using (Any ; any ; here ; there)
open import Data.List.Any.Properties using ( ∷↔ ; ++⁻)
  renaming (++⁺ˡ to ++ˡ ; ++⁺ʳ to ++ʳ)
open import Data.Nat
  using (ℕ ; zero ; suc ; _≟_ ; _+_ ; _∸_)
open import Data.Nat.Properties.Simple
  using (+-comm)
open import Data.Nat.Properties
  using (n∸n≡0 ; m+n∸n≡m)
open import Data.Product
  using (_,_ ; _,′_ ; _×_ ; proj₁ ; proj₂ ; ∃)
open import Data.Sum
  using (_⊎_ ; inj₁ ; inj₂)
open import Function
  using (_∘_ ; id)
import Data.List.Membership.Setoid

++-assoc : ∀{A : Set} → (xs ys zs : List A) → (xs ++ ys) ++ zs ≡ xs ++ (ys ++ zs)
++-assoc {_} xs ys zs =
  IsSemigroup.assoc (IsMonoid.isSemigroup (Monoid.isMonoid (Data.List.Properties.++-monoid _))) xs _ _

_∈_ : {A : Set} → (x : A) → (xs : List A) → Set
_∈_ {A} x xs = Data.List.Membership.Setoid._∈_ (setoid A) x xs

_∉_ : {A : Set} → (x : A) → (xs : List A) → Set
_∉_ {A} x xs = Data.List.Membership.Setoid._∉_ (setoid A) x xs

map-second : {A B C D : Set} →
  (f : B → D) →
  A × B × C → A × D × C
map-second f = Data.Product.map id (Data.Product.map f id)

any-map⁺ : ∀ {A B} {xs : List A} {x} (f : A → B) →
  x ∈ xs → f x ∈ map f xs
any-map⁺ f (here refl)  = here refl
any-map⁺ f (there x∈xs) = there (any-map⁺ f x∈xs)

-- the map-mono like the one in Data.List.Any.Membership
-- idk why I can't import that module so I just implement one here
map-mono : ∀ {A B} {ys zs : List A} (f : A → B) →
  (∀ x → x ∈ ys → x ∈ zs) → ∀ fx → fx ∈ map f ys → fx ∈ map f zs
map-mono {ys = []} f ys⊆zs fx ()
map-mono {ys = y ∷ ys} {zs} f ys⊆zs .(f y) (here refl) =
  any-map⁺ f (ys⊆zs y (here refl))
map-mono {ys = y ∷ ys} {zs} f ys⊆zs fx (there fx∈map-f-ys) =
  map-mono f (λ x z → ys⊆zs x (there z)) fx fx∈map-f-ys

any-map⁺² : ∀ {A B : Set} {xs x fxy} (f : A → List B) →
  x ∈ xs → fxy ∈ f x → fxy ∈ concatMap f xs
any-map⁺² f (here refl)  fxy∈fx = ++ˡ fxy∈fx
any-map⁺² f (there x∈xs) fxy∈fx = ++ʳ (f _) (any-map⁺² f x∈xs fxy∈fx)

map-mono² : ∀ {A B C} {xs xs' : List A} {ys ys' : List B} (f : A → B → C) →
  (∀ u → u ∈ xs → u ∈ xs') →
  (∀ v → v ∈ ys → v ∈ ys') →
  ∀ fuv →
    fuv ∈ concatMap (λ u → map (f u) ys)  xs →
    fuv ∈ concatMap (λ u → map (f u) ys') xs'
map-mono² {xs = []} {xs'} {ys} {ys'} f xs⊆xs' ys⊆ys' fuv ()
map-mono² {xs = x ∷ xs} {xs'} {ys} {ys'} f xs⊆xs' ys⊆ys' fuv fuv∈[[fuv|ys]|x∷xs]
  with ++⁻ (map (f x) ys) fuv∈[[fuv|ys]|x∷xs]
... | inj₂ fuv∈[[fuv|ys]|xs] =
  map-mono² f (λ u → xs⊆xs' u ∘ there) ys⊆ys' fuv fuv∈[[fuv|ys]|xs]
... | inj₁ fuv∈[fxv|ys] =
  any-map⁺² (λ u → map (f u) ys')
    (xs⊆xs' x (here refl))
    (map-mono (f x) ys⊆ys' fuv fuv∈[fxv|ys])

module ListSet {A : Set} (_≟_ : Decidable {A = A} _≡_) where
  open import Relation.Nullary.Negation using (¬?)
  ST : Set
  ST = List A

  set-subtract : List A → List A → List A
  set-subtract S T = filter (λ x → ¬? (ListAny.any (_≟_ x) T)) S

  set-remove : List A → A → List A
  set-remove S x = filter (¬? ∘ _≟_ x) S

  set-remove-removed : ∀{S L} → S ∉ set-remove L S
  set-remove-removed {S} {[]} ()
  set-remove-removed {S} {x ∷ L} Sin with S ≟ x | set-remove-removed{S}{L}
  set-remove-removed {S} {x ∷ L} Sin | yes refl | r = r Sin
  set-remove-removed {S} {x ∷ L} (here px) | no ¬p | r = ¬p px
  set-remove-removed {S} {x ∷ L} (there Sin) | no ¬p | r = r Sin

  set-remove-not-eq : ∀{a a' xs} → a ∈ set-remove xs a' → ¬ a' ≡ a
  set-remove-not-eq {a}{a'}{xs} a∈xs-a' with a' ≟ a
  ... | yes refl = ⊥-elim (set-remove-removed{a}{xs} a∈xs-a')
  ... | no ¬refl = ¬refl

  set-remove-mono-∈ : ∀ {xs a} a' → a ∈ set-remove xs a' → a ∈ xs
  set-remove-mono-∈ {[]}       {a} a' ()
  set-remove-mono-∈ {(x ∷ xs)} {a} a' a∈xs-[a'] with a' ≟ x
  set-remove-mono-∈ {(x ∷ xs)} {a} a' a∈xs-[a']
    | yes a'≡x = there (set-remove-mono-∈ a' a∈xs-[a'])
  set-remove-mono-∈ {(x ∷ xs)} {a} a' (here refl)
    | no ¬a'≡x = here refl
  set-remove-mono-∈ {(x ∷ xs)} {a} a' (there a∈xs-[a'])
    | no ¬a'≡x = there (set-remove-mono-∈ a' a∈xs-[a'])

  set-remove-not-removed : ∀ {a' a xs} → ¬ (a' ≡ a) → a ∈ xs → a ∈ set-remove xs a'
  set-remove-not-removed {a'} {a} {.a ∷ xs} a'≢a (here refl)  with a' ≟ a
  ... | yes a'≡a = ⊥-elim (a'≢a a'≡a)
  ... | no ¬a'≡a = here refl
  set-remove-not-removed {a'} {a} {x ∷ xs} a'≢a (there a∈xs) with a' ≟ x
  ... | yes a'≡x = set-remove-not-removed a'≢a a∈xs
  ... | no ¬a'≡x = there (set-remove-not-removed a'≢a a∈xs)

  set-subtract-[] : ∀ xs → set-subtract xs [] ≡ xs
  set-subtract-[] [] = refl
  set-subtract-[] (x ∷ xs) rewrite set-subtract-[] xs = refl

  set-subtract-[a]≡set-remove : ∀ xs a → set-subtract xs (a ∷ []) ≡ set-remove xs a
  set-subtract-[a]≡set-remove [] a = refl
  set-subtract-[a]≡set-remove (x ∷ xs) a
    with x ≟ a | a ≟ x
  ... | yes refl | no  a≢x  = ⊥-elim (a≢x refl)
  ... | no  x≢a  | yes refl = ⊥-elim (x≢a refl)
  ... | yes refl | yes a≡x =  set-subtract-[a]≡set-remove xs x
  ... | no  x≢a  | no  a≢x  rewrite set-subtract-[a]≡set-remove xs a =  refl

  set-subtract-merge : ∀ {xs ys z} → z ∈ set-subtract xs ys → (z ∈ xs) × (z ∉ ys)
  set-subtract-merge {[]} ()
  set-subtract-merge {x ∷ xs} {ys} z∈xs-ys with ListAny.any (_≟_ x) ys
  set-subtract-merge {x ∷ xs} {ys} (here refl)     | no x∉ys = here refl ,′ x∉ys
  set-subtract-merge {x ∷ xs} {ys} (there z∈xs-ys) | no x∉ys = there z∈xs , z∉ys
    where z∈xs,z∉ys = set-subtract-merge {xs} {ys} z∈xs-ys
          z∈xs      = proj₁ z∈xs,z∉ys
          z∉ys      = proj₂ z∈xs,z∉ys
  ... | yes x∈ys = there z∈xs , z∉ys
    where z∈xs,z∉ys = set-subtract-merge {xs} {ys} z∈xs-ys
          z∈xs      = proj₁ z∈xs,z∉ys
          z∉ys      = proj₂ z∈xs,z∉ys

  set-subtract-split : ∀ {xs ys z} → z ∈ xs → z ∈ set-subtract xs ys ⊎ z ∈ ys
  set-subtract-split {[]}     ()
  set-subtract-split {x ∷ xs} {ys} (here refl) with ListAny.any (_≟_ x) ys
  ... | yes x∈ys = inj₂ x∈ys
  ... | no  x∉ys = inj₁ ( (here refl) )
  set-subtract-split {x ∷ xs} {ys} (there x∈xs)
    with ListAny.any (_≟_ x) ys | set-subtract-split x∈xs
  ... | x∈ys⊎x∉ys | inj₂ z∈ys    = inj₂ z∈ys
  ... | yes x∈ys  | inj₁ z∈xs-ys = inj₁  z∈xs-ys
  ... | no  x∉ys  | inj₁ z∈xs-ys = inj₁ ( (there z∈xs-ys) )

  set-subtract-notin : ∀ {xs ys z} → z ∈ xs → z ∉ ys → z ∈ set-subtract xs ys
  set-subtract-notin{xs}{ys}{z} z∈ z∉ with set-subtract-split{xs}{ys}{z} z∈
  ... | inj₁ a = a
  ... | inj₂ b = ⊥-elim (z∉ b)

-- note: the fixity of our triple-apply _#_ combinator
-- is different from the usual fixity of _$_.
infixl 1 _#_

-- applying three functions to three values in parallel
_#_ : {A B C : Set} → {D : A → Set} → {E : B → Set} → {F : C → Set} →
  ((a : A) → D a) × ((b : B) → E b) × ((c : C) → F c) →
  (abc : A × B × C) → D (proj₁ abc) × E (proj₁ (proj₂ abc)) × F (proj₂ (proj₂ abc))
(f , g , h) # (x , y , z) = f x ,′ g y ,′ h z

infix 6 _U̬_

_U̬_ : List ℕ × List ℕ × List ℕ → List ℕ × List ℕ × List ℕ → List ℕ × List ℕ × List ℕ
(S , s , v) U̬ (S1 , s1 , v1) = S ++ S1 ,′ s ++ s1 ,′ v ++ v1
infixr 6 _|̌_
infixr 6 _|¹_
_|¹_ = ListSet.set-subtract Data.Nat._≟_
_|̌_ : List ℕ × List ℕ × List ℕ → List ℕ × List ℕ × List ℕ → List ℕ × List ℕ × List ℕ
(S , s , x) |̌ (S1 , s1 , x1)
   = (S |¹ S1) , (s |¹ s1) , (x |¹ x1)

∪-assoc : ∀ xs³ ys³ zs³ → (xs³ U̬ ys³) U̬ zs³ ≡ xs³ U̬ (ys³ U̬ zs³)
∪-assoc xs³ ys³ zs³
  rewrite ++-assoc (proj₁ xs³)         (proj₁ ys³)         (proj₁ zs³)
        | ++-assoc (proj₁ (proj₂ xs³)) (proj₁ (proj₂ ys³)) (proj₁ (proj₂ zs³))
        | ++-assoc (proj₂ (proj₂ xs³)) (proj₂ (proj₂ ys³)) (proj₂ (proj₂ zs³)) = refl

xs++[]≡xs : ∀{A : Set} → (xs : List A) → xs ++ [] ≡ xs
xs++[]≡xs xs = proj₂ (Monoid.identity (Data.List.Properties.++-monoid _)) xs

x∈xs++[]→x∈xs : ∀{A} → {x : A} → {xs : List A} → x ∈ (xs ++ []) → x ∈ xs
x∈xs++[]→x∈xs {xs = xs} x∈xs rewrite xs++[]≡xs xs = x∈xs

_⊆¹_ : List ℕ → List ℕ → Set
xs ⊆¹ ys = ∀ x → x ∈ xs → x ∈ ys

_⊆_ : List ℕ × List ℕ × List ℕ → List ℕ × List ℕ × List ℕ → Set
(Ss₁ , ss₁ , xs₁) ⊆ (Ss₂ , ss₂ , xs₂) =
  (Ss₁ ⊆¹ Ss₂) × (ss₁ ⊆¹ ss₂) × (xs₁ ⊆¹ xs₂)

⊆¹-refl : ∀ {xs} → xs ⊆¹ xs
⊆¹-refl _ p = p

⊆-refl : ∀ {xs³} → xs³ ⊆ xs³
⊆-refl = ⊆¹-refl ,′ ⊆¹-refl ,′ ⊆¹-refl

⊆-empty-left : ∀ {xs³} → ([] ,′ [] ,′ []) ⊆ xs³
⊆-empty-left = (λ _ ()) ,′ (λ _ ()) ,′ (λ _ ())

⊆¹-trans : ∀{xs ys zs} → xs ⊆¹ ys → ys ⊆¹ zs → xs ⊆¹ zs
⊆¹-trans xs⊆ys ys⊆zs w w∈xs = ys⊆zs _ (xs⊆ys _ w∈xs)

⊆-trans : ∀{xs³ ys³ zs³} → xs³ ⊆ ys³ → ys³ ⊆ zs³ → xs³ ⊆ zs³
⊆-trans xs³⊆ys³ ys³⊆zs³ = ⊆¹-trans ,′ ⊆¹-trans ,′ ⊆¹-trans # xs³⊆ys³ # ys³⊆zs³

⊆¹-respect-|¹ : ∀{xs ys} zs → xs ⊆¹ ys → (xs |¹ zs) ⊆¹ (ys |¹ zs)
⊆¹-respect-|¹{xs}{ys} zs xs⊂ys a a∈ with ListSet.set-subtract-merge Data.Nat._≟_ {xs}{zs}{a} a∈
... | (a∈xs , a∉zs) = ListSet.set-subtract-notin Data.Nat._≟_ (xs⊂ys a a∈xs) a∉zs

⊆-respect-|̌ : ∀{xs ys} zs → xs ⊆ ys → (xs |̌ zs) ⊆ (ys |̌ zs)
⊆-respect-|̌ zs sub = ⊆¹-respect-|¹ , ⊆¹-respect-|¹  , ⊆¹-respect-|¹  # zs # sub

∷-respect-⊆¹ : ∀{xs ys} z → xs ⊆¹ ys → (z ∷ xs) ⊆¹ (z ∷ ys)
∷-respect-⊆¹ z sub .z (here refl) = here refl
∷-respect-⊆¹ z sub a (there a∈) = there (sub a a∈)

∪ˡ : ∀{xs³ ys³ zs³} → xs³ ⊆ ys³ → xs³ ⊆ (ys³ U̬ zs³)
∪ˡ (Ss₁⊆Ss₂ , ss₁⊆ss₂ , xs₁⊆xs₂) =
  (λ S → ++ˡ ∘ Ss₁⊆Ss₂ S) ,′
  (λ s → ++ˡ ∘ ss₁⊆ss₂ s) ,′
  (λ x → ++ˡ ∘ xs₁⊆xs₂ x)

∪ʳ : ∀{xs³ ys³} → (zs³ : List ℕ × List ℕ × List ℕ) → xs³ ⊆ ys³ → xs³ ⊆ (zs³ U̬ ys³)
∪ʳ xs (Ss₁⊆Ss₂ , ss₁⊆ss₂ , xs₁⊆xs₂) =
  (λ S → ++ʳ (proj₁ xs)         ∘ Ss₁⊆Ss₂ S) ,′
  (λ s → ++ʳ (proj₁ (proj₂ xs)) ∘ ss₁⊆ss₂ s) ,′
  (λ x → ++ʳ (proj₂ (proj₂ xs)) ∘ xs₁⊆xs₂ x)

∪¹-unjoin-⊆¹ : ∀ {ys zs} xs → (xs ++ ys) ⊆¹ zs → xs ⊆¹ zs × ys ⊆¹ zs
∪¹-unjoin-⊆¹ xs xs++ys⊆zs = (λ x x∈xs → xs++ys⊆zs x (++ˡ x∈xs)) ,′
                           (λ x x∈ys → xs++ys⊆zs x (++ʳ xs x∈ys))

∪-unjoin-⊆ : ∀ {ys³ zs³} xs³ → (xs³ U̬ ys³) ⊆ zs³ → xs³ ⊆ zs³ × ys³ ⊆ zs³
∪-unjoin-⊆ xs³ xs³∪ys³⊆zs³ = unzip³ (∪¹-unjoin-⊆¹ ,′ ∪¹-unjoin-⊆¹ ,′ ∪¹-unjoin-⊆¹ #
                                      xs³ # xs³∪ys³⊆zs³)
  where unzip³ : {A B C D E F : Set} → (A × D) × (B × E) × (C × F) → (A × B × C) × (D × E × F)
        unzip³ ((a , d) , (b , e) , (c , f)) = (a , b , c) , (d , e , f)

∪-unjoin-⊆ˡ : ∀{xs³ ys³ zs³} → (xs³ U̬ ys³) ⊆ zs³ → xs³ ⊆ zs³
∪-unjoin-⊆ˡ {xs³} = proj₁ ∘ ∪-unjoin-⊆ xs³

∪-unjoin-⊆ʳ : ∀ {ys³ zs³} xs³ → (xs³ U̬ ys³) ⊆ zs³ → ys³ ⊆ zs³
∪-unjoin-⊆ʳ xs³ = proj₂ ∘ ∪-unjoin-⊆ xs³

∪¹-join-⊆¹ : ∀{xs ys zs} → xs ⊆¹ zs → ys ⊆¹ zs → (xs ++ ys) ⊆¹ zs
∪¹-join-⊆¹ {xs} xs⊆zs ys⊆zs w w∈xs++ys with ++⁻ xs w∈xs++ys
... | inj₁ w∈xs = xs⊆zs _ w∈xs
... | inj₂ w∈ys = ys⊆zs _ w∈ys

∪-join-⊆ : ∀{xs³ ys³ zs³} → xs³ ⊆ zs³ → ys³ ⊆ zs³ → (xs³ U̬ ys³) ⊆ zs³
∪-join-⊆ xs³⊆zs³ ys³⊆zs³ = ∪¹-join-⊆¹ ,′ ∪¹-join-⊆¹ ,′ ∪¹-join-⊆¹ # xs³⊆zs³ # ys³⊆zs³

∪-respect-⊆-left : ∀{xs³ ys³ zs³} → xs³ ⊆ ys³ → (xs³ U̬ zs³) ⊆ (ys³ U̬ zs³)
∪-respect-⊆-left {xs³} {ys³} {zs³} xs³⊆ys³ = ∪-join-⊆ (∪ˡ xs³⊆ys³) (∪ʳ ys³ ⊆-refl)

∪-respect-⊆-right : ∀{xs³ ys³} zs³ → xs³ ⊆ ys³ → (zs³ U̬ xs³) ⊆ (zs³ U̬ ys³)
∪-respect-⊆-right {xs³} {ys³} zs³ xs³⊆ys³ = ∪-join-⊆ (∪ˡ (⊆-refl {zs³})) (∪ʳ zs³ xs³⊆ys³)

∪¹-respect-⊆¹-right : ∀ {xs ys} zs → xs ⊆¹ ys → (zs ++ xs) ⊆¹ (zs ++ ys)
∪¹-respect-⊆¹-right zs xs⊆ys = proj₁ (∪-respect-⊆-right (zs ,′ [] ,′ []) (xs⊆ys ,′ ⊆¹-refl {[]} ,′ ⊆¹-refl {[]}))

∪¹-respect-⊆¹-left : ∀ {xs ys zs} → xs ⊆¹ ys → (xs ++ zs) ⊆¹ (ys ++ zs)
∪¹-respect-⊆¹-left{zs = zs} xs⊆ys =  proj₁ (∪-respect-⊆-left{zs³ = (zs ,′ [] ,′ [])} (xs⊆ys ,′ ⊆¹-refl {[]} ,′ ⊆¹-refl {[]}))

⊆-subst-left : ∀{xs³ ys³ zs³} → xs³ ≡ ys³ → xs³ ⊆ zs³ → ys³ ⊆ zs³
⊆-subst-left refl xs³⊆zs³ = xs³⊆zs³

∪-comm-⊆-left : ∀ {ys³ zs³} xs³ → (xs³ U̬ ys³) ⊆ zs³ → (ys³ U̬ xs³) ⊆ zs³
∪-comm-⊆-left xs³ xs³∪ys³⊆zs³ =
  ∪-join-⊆ (proj₂ (∪-unjoin-⊆ xs³ xs³∪ys³⊆zs³)) (proj₁ (∪-unjoin-⊆ xs³ xs³∪ys³⊆zs³))

∪-comm-⊆-right : ∀ {xs³ ys³} zs³ → xs³ ⊆ (ys³ U̬ zs³) → xs³ ⊆ (zs³ U̬ ys³)
∪-comm-⊆-right zs³ xs³⊆ys³∪zs³ = ⊆-trans xs³⊆ys³∪zs³ (∪-join-⊆ (∪ʳ zs³ ⊆-refl) (∪ˡ ⊆-refl))

distinct' : ∀{A : Set} -> (xs : List A) -> (ys : List A) -> Set
distinct'{A} xs ys = (z : A) -> z ∈ xs -> z ∈ ys -> ⊥

distinct : (xs : List ℕ × List ℕ × List ℕ) -> (ys : List ℕ × List ℕ × List ℕ) -> Set
distinct (S , s , v) (S1 , s1 , v1) = distinct' S S1 × distinct' s s1 × distinct' v v1

distinct-empty-left : ∀ {xs³} → distinct ([] ,′ [] ,′ []) xs³
distinct-empty-left = (λ _ ()) ,′ (λ _ ()) ,′ (λ _ ())

distinct-empty-right : ∀ {xs³} → distinct xs³ ([] ,′ [] ,′ [])
distinct-empty-right = (λ _ _ ()) ,′ (λ _ _ ()) ,′ (λ _ _ ())

distinct'-sym : ∀{A L1 L2} → (distinct'{A} L1 L2) → (distinct'{A} L2 L1)
distinct'-sym d = λ z x x₁ → d z x₁ x

distinct'-to-left : {xs ys zs : List ℕ} →
  (distinct' xs ys → distinct' xs zs) →
  distinct' ys xs → distinct' zs xs
distinct'-to-left f ys≠xs = distinct'-sym (f (distinct'-sym ys≠xs))

distinct-sym : ∀{VL1 VL2} → distinct VL1 VL2 → distinct VL2 VL1
distinct-sym (a , b , c) = (distinct'-sym a) , ((distinct'-sym b) , (distinct'-sym c))

dist'++ˡ : ∀{A V1 V2 V3} → (distinct'{A} V1 (V2 ++ V3)) → (distinct'{A} V1 V2)
dist'++ˡ {A} {V1} {V2} {V3} d = λ z x x₁ → d z x (++ˡ x₁)

dist'++ʳ : ∀{A V1 V2 V3} → (distinct'{A} V1 (V2 ++ V3)) → (distinct'{A} V1 V3)
dist'++ʳ {A} {V1} {V2} {V3} d = λ z x x₁ → d z x (++ʳ V2 x₁)

dist'++b : ∀{A V1 V2 V3 V4} → (distinct'{A} (V1 ++ V2) (V3 ++ V4)) → (distinct'{A} V1 V3)
dist'++b d = λ z x x₁ → d z (++ˡ x) (++ˡ x₁)

dist':: : ∀{A V1 V2 S} → (distinct'{A} V1 (S ∷ V2)) → (distinct' V1 V2)
dist'::{A}{V1}{V2}{S} d = dist'++ʳ{A}{V1}{[ S ]}{V2} d

dist'-sym : ∀{A L1 L2} → (distinct'{A} L1 L2) → (distinct' L2 L1)
dist'-sym d = λ z x x₁ →  d z x₁ x

distinct'-union-left : ∀ {xs ys zs : List ℕ} →
  distinct' xs zs → distinct' ys zs → distinct' (xs ++ ys) zs
distinct'-union-left {xs} xs≠zs ys≠zs x x∈xs++ys x∈zs with ++⁻ xs x∈xs++ys
... | inj₁ x∈xs = xs≠zs x x∈xs x∈zs
... | inj₂ x∈ys = ys≠zs x x∈ys x∈zs

distinct-union-left : ∀ {xs ys zs} →
  distinct xs zs → distinct ys zs → distinct (xs U̬ ys) zs
distinct-union-left xs≠zs xs≠ys =
  distinct'-union-left ,′ distinct'-union-left ,′ distinct'-union-left #
    xs≠zs # xs≠ys

distinct-union-right : ∀ {xs ys zs} →
  distinct zs xs → distinct zs ys → distinct zs (xs U̬ ys)
distinct-union-right zs≠xs zs≠ys =
  distinct-sym (distinct-union-left (distinct-sym zs≠xs) (distinct-sym zs≠ys))

⊆¹-respect-distinct'-left : ∀{xs ys zs} → xs ⊆¹ ys → distinct' ys zs → distinct' xs zs
⊆¹-respect-distinct'-left xs⊆ys ys≠zs x x∈xs x∈zs = ys≠zs x (xs⊆ys x x∈xs) x∈zs

⊆-respect-distinct-left : ∀{xs³ ys³ zs³} → xs³ ⊆ ys³ → distinct ys³ zs³ → distinct xs³ zs³
⊆-respect-distinct-left {xs³} {ys³} {zs³} xs³⊆ys³ ys³≠zs³ =
  ⊆¹-respect-distinct'-left ,′ ⊆¹-respect-distinct'-left ,′ ⊆¹-respect-distinct'-left #
    xs³⊆ys³ # ys³≠zs³

⊆¹-respect-distinct'-right : ∀{xs ys zs} → xs ⊆¹ ys → distinct' zs ys → distinct' zs xs
⊆¹-respect-distinct'-right xs⊆ys zs≠ys =
  distinct'-sym (⊆¹-respect-distinct'-left xs⊆ys (distinct'-sym zs≠ys))

⊆-respect-distinct-right : ∀{xs³ ys³ zs³} → xs³ ⊆ ys³ → distinct zs³ ys³ → distinct zs³ xs³
⊆-respect-distinct-right {xs³} {ys³} {zs³} xs³⊆ys³ zs³≠ys³ =
  distinct-sym (⊆-respect-distinct-left xs³⊆ys³ (distinct-sym zs³≠ys³))

distinct'-dec : (xs ys : List ℕ) -> Dec (∃ λ z -> z ∈ xs × z ∈ ys)
distinct'-dec [] ys = no λ { (z , () , z∈ys) }
distinct'-dec (x ∷ xs) ys with ListAny.any (\ x' -> x Data.Nat.≟ x') ys
distinct'-dec (x ∷ xs) ys | yes p = yes (x , here refl , p)
distinct'-dec (x ∷ xs) ys | no ¬p with distinct'-dec xs ys
distinct'-dec (x ∷ xs) ys | no ¬p | yes (z , z∈xs , x∈ys) = yes (z , there z∈xs , x∈ys)
distinct'-dec (x ∷ xs) ys | no ¬p₁ | no ¬p =
  no (\ { (.x , here refl , z∈ys) → ¬p₁ z∈ys ;
          (z , there z∈xs , z∈ys) → ¬p (z , z∈xs , z∈ys) } )

distinct-dec : (xs ys : List ℕ × List ℕ × List ℕ) ->
  Dec ((∃ λ S → (S ∈ proj₁ xs) × (S ∈ proj₁ ys)) ⊎
       (∃ λ s → (s ∈ proj₁ (proj₂ xs)) × (s ∈ proj₁ (proj₂ ys))) ⊎
       (∃ λ x → (x ∈ proj₂ (proj₂ xs)) × (x ∈ proj₂ (proj₂ ys))))
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) with distinct'-dec S1 S2
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) | yes S1S2 = yes (inj₁ S1S2)
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) | no ¬S1S2 with distinct'-dec s1 s2
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) | no ¬S1S2 | yes s1s2 =
  yes (inj₂ (inj₁ s1s2))
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) | no ¬S1S2 | no ¬s1s2 with distinct'-dec x1 x2
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) | no ¬S1S2 | no ¬s1s2 | yes x1x2 =
  yes (inj₂ (inj₂ x1x2))
distinct-dec (S1 , s1 , x1) (S2 , s2 , x2) | no ¬S1S2 | no ¬s1s2 | no ¬x1x2 =
  no (λ { (inj₁ x) → ¬S1S2 x ; (inj₂ (inj₁ x)) → ¬s1s2 x ; (inj₂ (inj₂ y)) → ¬x1x2 y })

distinct-not-distinct-dec : ∀ {xs ys} -> distinct xs ys ->
      ((∃ λ S → (S ∈ proj₁ xs) × (S ∈ proj₁ ys)) ⊎
       (∃ λ s → (s ∈ proj₁ (proj₂ xs)) × (s ∈ proj₁ (proj₂ ys))) ⊎
       (∃ λ x → (x ∈ proj₂ (proj₂ xs)) × (x ∈ proj₂ (proj₂ ys))))
      -> ⊥
distinct-not-distinct-dec {xs} {ys} DXY (inj₁ (NDXYS , NDXYs , NDXYx)) = (proj₁ DXY) NDXYS  NDXYs  NDXYx
distinct-not-distinct-dec {xs} {ys} DXY (inj₂ (inj₁ (NDXYS , NDXYs , NDXYx))) = (proj₁ (proj₂ DXY)) NDXYS  NDXYs  NDXYx
distinct-not-distinct-dec {xs} {ys} DXY (inj₂ (inj₂ (NDXYS , NDXYs , NDXYx))) = (proj₂ (proj₂ DXY)) NDXYS  NDXYs  NDXYx

distinct-dec-is-distinct : ∀ {xs ys} ->
      (((∃ λ S → (S ∈ proj₁ xs) × (S ∈ proj₁ ys)) ⊎
        (∃ λ s → (s ∈ proj₁ (proj₂ xs)) × (s ∈ proj₁ (proj₂ ys))) ⊎
        (∃ λ x → (x ∈ proj₂ (proj₂ xs)) × (x ∈ proj₂ (proj₂ ys))))
        -> ⊥) -> distinct xs ys
distinct-dec-is-distinct {xs} {ys} FAIL =
  ((λ z z∈xs z∈ys → FAIL (inj₁ (z , z∈xs , z∈ys))) ,
   (λ z z∈xs z∈ys → FAIL (inj₂ (inj₁ (z , z∈xs , z∈ys)))) ,
   (λ z z∈xs z∈ys → FAIL (inj₂ (inj₂ (z , z∈xs , z∈ys)))))

case_return_of_ : ∀ {a b} {A : Set a} (x : A) (B : A → Set b) → (∀ x → B x) → B x
case x return B of f = f x

case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = f x

typeof : ∀{𝕝}{A : Set 𝕝} → A → Set 𝕝
typeof{_}{A} _ = A

fst : ∀{l} {A B C : Set l} → A × B × C → A
fst = proj₁

snd : ∀{l} {A B C : Set l} → A × B × C → B
snd = proj₁ ∘ proj₂

thd : ∀{l} {A B C : Set l} → A × B × C → C
thd = proj₂ ∘ proj₂

∈:: : ∀{A} {x y : A} → x ∈ (y ∷ []) → x ≡ y
∈:: (here px) = px
∈:: (there ())

n∉map-suc-n-+ : ∀ n xs  → ¬ (n ∈ map (suc n +_) xs)
n∉map-suc-n-+ n [] ()
n∉map-suc-n-+ n (x ∷ xs) (here n≡suc⟨n+x⟩) with cong (_∸ n) n≡suc⟨n+x⟩
... | n∸n≡suc⟨n+x⟩∸n rewrite n∸n≡0 n | +-comm n x | m+n∸n≡m (suc x) n with n∸n≡suc⟨n+x⟩∸n
... | ()
n∉map-suc-n-+ n (x ∷ xs) (there n∈map-suc-n-+) = n∉map-suc-n-+ n xs n∈map-suc-n-+

map-+-swap-suc : ∀ n xs →
  map (_+_ n) (map suc xs) ≡ map suc (map (_+_ n) xs)
map-+-swap-suc n xs
  rewrite sym (map-compose {g = _+_ n} {f = suc}      xs)
        |      map-cong (λ m → +-comm n (suc m))      xs
        |      map-cong (λ m → cong suc (+-comm m n)) xs
        |      map-compose {g = suc}   {f = _+_ n}    xs
  = refl

map-+-compose-suc : ∀ n xs →
  map (_+_ n) (map suc xs) ≡ map (_+_ (suc n)) xs
map-+-compose-suc n xs
  rewrite map-+-swap-suc n xs
        | sym (map-compose {g = suc} {f = _+_ n} xs)
  = refl


------------------------------------------------------------------------
-- Overloaded "equational" reasoning combinators
------------------------------------------------------------------------

{-# OPTIONS --safe #-}

module Equational-reasoning where

open import Equality.Propositional
open import Prelude

infix  -1 _■
          finally₁ finally₁∽ finally₁→ finally₁←
          finally₂ finally₂∽ finally₂→ finally₂←
          finally₁-≡∼ finally₁-≡∽ finally₁-≡→ finally₁-≡←
          finally₂-≡∼ finally₂-≡∽ finally₂-≡→ finally₂-≡←
infixr -2 step-⟨⟩∼ step-≡∼ step-≡→ step-∼ step-∼→ step-∼′ step-∼→′
infixl -2 step-⟨⟩∽ step-≡∽ step-≡← step-∽ step-∼← step-∽′ step-∼←′

------------------------------------------------------------------------
-- Reflexivity

record Reflexive {a p} {A : Type a}
                 (P : A → A → Type p) :
                 Type (a ⊔ p) where
  constructor is-reflexive
  field
    reflexive : ∀ {x} → P x x

open Reflexive ⦃ … ⦄ public

_■ : ∀ {a p} {A : Type a} {P : A → A → Type p} ⦃ r : Reflexive P ⦄
     (x : A) → P x x
_ ■ = reflexive

-- Transitivity-like combinators. These combinators can be used when
-- two arguments are definitionally equal. (The Reflexive instance
-- argument is used to make type inference easier.)

step-⟨⟩∼ step-⟨⟩∽ :
  ∀ {a p} {A : Type a} {P : A → A → Type p}
    ⦃ p : Reflexive P ⦄ x {y} →
  P x y → P x y
step-⟨⟩∼ _ p = p
step-⟨⟩∽     = step-⟨⟩∼

syntax step-⟨⟩∼ x Pxy = x ∼⟨⟩ Pxy
syntax step-⟨⟩∽ x Pxy = Pxy ∽⟨⟩ x

-- Transitivity-like combinators. These combinators can be used when
-- two arguments are propositionally equal. (The Reflexive instance
-- argument is used to make type inference easier.)

-- It can be easier for Agda to type-check typical "equational"
-- reasoning chains if the transitivity proof gets the equality
-- arguments in the opposite order, because then the y argument is
-- (perhaps more) known once the proof of P x y is type-checked.
--
-- This optimisation can be quite effective for some examples, but did
-- not seem to have much effect when I applied it to the current code
-- base.
--
-- The idea behind this optimisation came up in discussions with Ulf
-- Norell.

step-≡∼ step-≡∽ step-≡→ step-≡← :
  ∀ {a p} {A : Type a} {P : A → A → Type p}
    ⦃ r : Reflexive P ⦄ x {y z} →
  P y z → x ≡ y → P x z
step-≡∼ _ p refl = p
step-≡∽          = step-≡∼
step-≡→          = step-≡∼
step-≡←          = step-≡∼

syntax step-≡∼ x Pyz x≡y = x ∼≡⟨ x≡y ⟩ Pyz
syntax step-≡∽ x Pyz x≡y = Pyz ∽≡⟨ x≡y ⟩ x
syntax step-≡→ x Pyz x≡y = x →≡⟨ x≡y ⟩ Pyz
syntax step-≡← x Pyz x≡y = Pyz ←≡⟨ x≡y ⟩ x

finally₂-≡∼ finally₂-≡∽ finally₂-≡→ finally₂-≡← :
  ∀ {a p} {A : Type a}
    {P : A → A → Type p}
    ⦃ r : Reflexive P ⦄ x y →
  x ≡ y → P x y
finally₂-≡∼ _ _ refl = reflexive
finally₂-≡∽          = finally₂-≡∼
finally₂-≡→          = finally₂-≡∼
finally₂-≡←          = finally₂-≡∼

syntax finally₂-≡∼ x y x≡y = x ∼≡⟨ x≡y ⟩■ y
syntax finally₂-≡∽ x y x≡y = y ∽≡⟨ x≡y ⟩■ x
syntax finally₂-≡→ x y x≡y = x →≡⟨ x≡y ⟩■ y
syntax finally₂-≡← x y x≡y = y ←≡⟨ x≡y ⟩■ x

finally₁-≡∼ finally₁-≡∽ finally₁-≡→ finally₁-≡← :
  ∀ {a p} {A : Type a}
    {P : A → A → Type p}
    ⦃ r : Reflexive P ⦄ x {y} →
  x ≡ y → P x y
finally₁-≡∼ _ refl = reflexive
finally₁-≡∽        = finally₁-≡∼
finally₁-≡→        = finally₁-≡∼
finally₁-≡←        = finally₁-≡∼

syntax finally₁-≡∼ x x≡y = x ∼≡⟨ x≡y ⟩■
syntax finally₁-≡∽ x x≡y = ∽≡⟨ x≡y ⟩■ x
syntax finally₁-≡→ x x≡y = x →≡⟨ x≡y ⟩■
syntax finally₁-≡← x x≡y = ←≡⟨ x≡y ⟩■ x

------------------------------------------------------------------------
-- Symmetry

record Symmetric {a p} {A : Type a}
                 (P : A → A → Type p) :
                 Type (a ⊔ p) where
  constructor is-symmetric
  field
    symmetric : ∀ {x y} → P x y → P y x

open Symmetric ⦃ … ⦄ public

------------------------------------------------------------------------
-- Transitivity

-- One variant of transitivity.
--
-- Note that the combinator can (depending on the available instances)
-- be used to convert from one type to another, but only in its first
-- argument (in order to make instance resolution easier).

record Transitive {a b p q} {A : Type a} {B : Type b}
                  (P : A → A → Type p) (Q : A → B → Type q) :
                  Type (a ⊔ b ⊔ p ⊔ q) where
  constructor is-transitive
  field
    transitive : ∀ {x y z} → P x y → Q y z → Q x z

open Transitive ⦃ … ⦄ public

step-∼ step-∽ step-∼→ step-∼← :
  ∀ {a b p q} {A : Type a} {B : Type b}
    {P : A → A → Type p} {Q : A → B → Type q}
    ⦃ t : Transitive P Q ⦄ x {y z} →
  Q y z → P x y → Q x z
step-∼ _ = flip transitive
step-∽   = step-∼
step-∼→  = step-∼
step-∼←  = step-∼

syntax step-∼  x Qyz Pxy = x ∼⟨ Pxy ⟩ Qyz
syntax step-∽  x Qyz Pxy = Qyz ∽⟨ Pxy ⟩ x
syntax step-∼→ x Qyz Pxy = x →⟨ Pxy ⟩ Qyz
syntax step-∼← x Qyz Pxy = Qyz ←⟨ Pxy ⟩ x

-- Another variant of transitivity.
--
-- Note that the combinator can (depending on the available instances)
-- be used to convert from one type to another, but only in its second
-- argument (in order to make instance resolution easier).

record Transitive′ {a b p q} {A : Type a} {B : Type b}
                   (P : A → B → Type p) (Q : B → B → Type q) :
                   Type (a ⊔ b ⊔ p ⊔ q) where
  constructor is-transitive
  field
    transitive′ : ∀ {x y z} → P x y → Q y z → P x z

open Transitive′ ⦃ … ⦄ public

step-∼′ step-∽′ step-∼→′ step-∼←′ :
  ∀ {a b p q} {A : Type a} {B : Type b}
    {P : A → B → Type p} {Q : B → B → Type q}
    ⦃ t : Transitive′ P Q ⦄ x {y z} →
  Q y z → P x y → P x z
step-∼′ _ = flip transitive′
step-∽′   = step-∼′
step-∼→′  = step-∼′
step-∼←′  = step-∼′

syntax step-∼′  x Qyz Pxy = x ∼′⟨ Pxy ⟩ Qyz
syntax step-∽′  x Qyz Pxy = Qyz ∽′⟨ Pxy ⟩ x
syntax step-∼→′ x Qyz Pxy = x →′⟨ Pxy ⟩ Qyz
syntax step-∼←′ x Qyz Pxy = Qyz ←′⟨ Pxy ⟩ x

------------------------------------------------------------------------
-- A finally combinator

-- This combinator is intended to be used in the last step of an
-- equational reasoning proof:
--
--   x  ∼⟨ ? ⟩■
--   y
--
-- Note that the combinator can (depending on the available instances)
-- be used to convert from one type to another.

record Convertible {a b p q} {A : Type a} {B : Type b}
                   (P : A → B → Type p) (Q : A → B → Type q) :
                   Type (a ⊔ b ⊔ p ⊔ q) where
  constructor is-convertible
  field
    convert : ∀ {x y} → P x y → Q x y

open Convertible ⦃ … ⦄ public

finally₂ finally₂∽ finally₂→ finally₂← :
  ∀ {a b p q} {A : Type a} {B : Type b}
    {P : A → B → Type p} {Q : A → B → Type q}
    ⦃ c : Convertible P Q ⦄ x y →
  P x y → Q x y
finally₂ _ _ = convert
finally₂∽    = finally₂
finally₂→    = finally₂
finally₂←    = finally₂

syntax finally₂  x y x∼y = x ∼⟨ x∼y ⟩■ y
syntax finally₂∽ x y x∼y = y ∽⟨ x∼y ⟩■ x
syntax finally₂→ x y x→y = x →⟨ x→y ⟩■ y
syntax finally₂← x y x→y = y ←⟨ x→y ⟩■ x

finally₁ finally₁∽ finally₁→ finally₁← :
  ∀ {a b p q} {A : Type a} {B : Type b}
    {P : A → B → Type p} {Q : A → B → Type q}
    ⦃ c : Convertible P Q ⦄ x {y} →
  P x y → Q x y
finally₁ _ = convert
finally₁∽  = finally₁
finally₁→  = finally₁
finally₁←  = finally₁

syntax finally₁  x x∼y = x ∼⟨ x∼y ⟩■
syntax finally₁∽ x x∼y = ∽⟨ x∼y ⟩■ x
syntax finally₁→ x x→y = x →⟨ x→y ⟩■
syntax finally₁← x x→y = ←⟨ x→y ⟩■ x


-- Andreas, 2017-09-16, issue #2759
-- Allow empty declaration blocks in the parser.

open import Agda.Builtin.Nat

x0 = zero
mutual
x1 = suc x0
abstract
x2 = suc x1
private
x3 = suc x2
instance
x4 = suc x3
macro
x5 = suc x4
postulate
x6 = suc x5

-- Expected: 6 warnings about empty blocks

mutual
  postulate

-- Empty postulate block.

abstract private instance macro

-- Empty macro block.

-- Empty blocks are also tolerated in lets and lambdas.

_ = λ (let abstract ) → let abstract  in Set
_ = λ (let field    ) → let field     in Set
_ = λ (let instance ) → let instance  in Set
_ = λ (let macro    ) → let macro     in Set
_ = λ (let mutual   ) → let mutual    in Set
_ = λ (let postulate) → let postulate in Set
_ = λ (let private  ) → let private   in Set


open import Agda.Builtin.Unit

module Imports.Issue5583 (_ : ⊤) where

it : ∀ {A : Set} → ⦃ A ⦄ → A
it ⦃ x ⦄ = x

data X : Set where
  instance x : X


------------------------------------------------------------------------------
-- ABP Lemma 2
------------------------------------------------------------------------------

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

-- From Dybjer and Sander's paper: The second lemma states that given
-- a state of the latter kind (see Lemma 1) we will arrive at a new
-- start state, which is identical to the old start state except that
-- the bit has alternated and the first item in the input stream has
-- been removed.

module FOTC.Program.ABP.Lemma2ATP where

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Base.Loop
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesATP
  using ( not-x≢x
        ; not-involutive
        )
open import FOTC.Data.List
open import FOTC.Program.ABP.ABP
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Fair.PropertiesATP
open import FOTC.Program.ABP.Terms

------------------------------------------------------------------------------
-- 30 November 2013. If we don't have the following definitions
-- outside the where clause, the ATPs cannot prove the theorems.

ds^ : D → D → D
ds^ cs' os₂^ = corrupt os₂^ · cs'
{-# ATP definition ds^ #-}

as^ : D → D → D → D → D → D
as^ b i' is' cs' os₂^ = await b i' is' (ds^ cs' os₂^)
{-# ATP definition as^ #-}

bs^ : D → D → D → D → D → D → D
bs^ b i' is' cs' os₁^ os₂^ = corrupt os₁^ · as^ b i' is' cs' os₂^
{-# ATP definition bs^ #-}

cs^ : D → D → D → D → D → D → D
cs^ b i' is' cs' os₁^ os₂^ = ack (not b) · bs^ b i' is' cs' os₁^ os₂^
{-# ATP definition cs^ #-}

os₁^ : D → D
os₁^ os₁' = tail₁ os₁'
{-# ATP definition os₁^ #-}

os₂^ : D → D → D
os₂^ ft₂ os₂'' = ft₂ ++ os₂''
{-# ATP definition os₂^ #-}

-- Helper function for Lemma 2.
helper₂ : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
          Bit b →
          Fair os₁' →
          S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
          ∀ ft₂ os₂'' → F*T ft₂ → Fair os₂'' → os₂' ≡ ft₂ ++ os₂'' →
          ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
            Fair os₁''
            ∧ Fair os₂''
            ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
helper₂ {b} {i'} {is'} {js' = js'} Bb Fos₁' s'
       .(T ∷ []) os₂'' f*tnil Fos₂'' os₂'-eq = prf
  where
  postulate
    prf : ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
          Fair os₁''
          ∧ Fair os₂''
          ∧ as'' ≡ send (not b) · is' · ds''
          ∧ bs'' ≡ corrupt os₁'' · as''
          ∧ cs'' ≡ ack (not b) · bs''
          ∧ ds'' ≡ corrupt os₂'' · cs''
          ∧ js'  ≡ out (not b) · bs''
  {-# ATP prove prf #-}

helper₂ {b} {i'} {is'} {os₁'} {os₂'} {as'} {bs'} {cs'} {ds'} {js'}
        Bb Fos₁' s'
        .(F ∷ ft₂) os₂'' (f*tcons {ft₂} FTft₂) Fos₂'' os₂'-eq =
        helper₂ Bb (tail-Fair Fos₁') ihS' ft₂ os₂'' FTft₂ Fos₂'' refl
  where
  postulate os₂'-eq-helper : os₂' ≡ F ∷ os₂^ ft₂ os₂''
  {-# ATP prove os₂'-eq-helper #-}

  postulate ds'-eq : ds' ≡ error ∷ ds^ cs' (os₂^ ft₂ os₂'')
  {-# ATP prove ds'-eq os₂'-eq-helper #-}

  postulate as'-eq : as' ≡ < i' , b > ∷ as^ b i' is' cs' (os₂^ ft₂ os₂'')
  {-# ATP prove as'-eq #-}

  postulate
    bs'-eq : bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
               ∨ bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove bs'-eq as'-eq head-tail-Fair #-}

  postulate
    cs'-eq-helper₁ :
      bs' ≡ ok < i' , b > ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove cs'-eq-helper₁ not-x≢x not-involutive #-}

  postulate
    cs'-eq-helper₂ :
      bs' ≡ error ∷ bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'') →
      cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  {-# ATP prove cs'-eq-helper₂ not-involutive #-}

  cs'-eq : cs' ≡ b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  cs'-eq = case cs'-eq-helper₁ cs'-eq-helper₂ bs'-eq

  postulate
    js'-eq : js' ≡ out (not b) · bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂'')
  -- TODO (21 November 2014). See Apia issue 16
  -- {-# ATP prove js'-eq not-x≢x bs'-eq #-}

  postulate
    ds^-eq : ds^ cs' (os₂^ ft₂ os₂'') ≡
             corrupt (os₂^ ft₂ os₂'') ·
               (b ∷ cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
  {-# ATP prove ds^-eq cs'-eq #-}

  ihS' : S' b i' is'
            (os₁^ os₁')
            (os₂^ ft₂ os₂'')
            (as^ b i' is' cs' (os₂^ ft₂ os₂''))
            (bs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
            (cs^ b i' is' cs' (os₁^ os₁') (os₂^ ft₂ os₂''))
            (ds^ cs' (os₂^ ft₂ os₂''))
            js'
  ihS' = refl , refl , refl , ds^-eq , js'-eq

-- From Dybjer and Sander's paper: From the assumption that
-- os₂' ∈ Fair and hence by unfolding Fair, we conclude that there are
-- ft₂ : F*T and os₂'' : Fair, such that os₂' = ft₂ ++ os₂''.
--
-- We proceed by induction on ft₂ : F*T using helper.

lemma₂ : ∀ {b i' is' os₁' os₂' as' bs' cs' ds' js'} →
         Bit b →
         Fair os₁' →
         Fair os₂' →
         S' b i' is' os₁' os₂' as' bs' cs' ds' js' →
         ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
           Fair os₁''
           ∧ Fair os₂''
           ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
lemma₂ {b} {is' = is'} {os₂' = os₂'} {js' = js'} Bb Fos₁' Fos₂' s' =
  helper₁ (Fair-out Fos₂')
  where
  helper₁ : (∃[ ft₂ ] ∃[ os₂'' ] F*T ft₂ ∧ os₂' ≡ ft₂ ++ os₂'' ∧ Fair os₂'') →
            ∃[ os₁'' ] ∃[ os₂'' ] ∃[ as'' ] ∃[ bs'' ] ∃[ cs'' ] ∃[ ds'' ]
              Fair os₁''
              ∧ Fair os₂''
              ∧ S (not b) is' os₁'' os₂'' as'' bs'' cs'' ds'' js'
  helper₁ (ft₂ , os₂'' , FTft₂ , os₂'-eq , Fos₂'') =
    helper₂ Bb Fos₁' s' ft₂ os₂'' FTft₂ Fos₂'' os₂'-eq


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRingSolver.Utility where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Bool
open import Cubical.Data.Empty using (⊥) renaming (rec to recEmpty)
open import Cubical.Data.Sigma

open import Cubical.Relation.Nullary.Base

private
  variable
    ℓ ℓ' : Level
byBoolAbsurdity : {Anything : Type ℓ} → false ≡ true → Anything
byBoolAbsurdity p = recEmpty (false≢true p)

byAbsurdity : {Anything : Type ℓ} → ⊥ → Anything
byAbsurdity x = recEmpty x

extractFromAnd : (P Q : Bool)
              → P and Q ≡ true
              → (P ≡ true) × (Q ≡ true)
extractFromAnd false false eq = byBoolAbsurdity eq
extractFromAnd false true eq = byBoolAbsurdity eq
extractFromAnd true false eq = byBoolAbsurdity eq
extractFromAnd true true eq = eq , eq

extractFromAndLeft : {P Q : Bool}
             → P and Q ≡ true
             → P ≡ true
extractFromAndLeft eq = fst (extractFromAnd _ _ eq)

extractFromAndRight : {P Q : Bool}
             → P and Q ≡ true
             → Q ≡ true
extractFromAndRight eq = snd (extractFromAnd _ _ eq)


------------------------------------------------------------------------
-- Code related to the paper "Up-to Techniques using Sized Types"
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

module README where

------------------------------------------------------------------------
-- Pointers to results from the paper

-- In order to more easily find code corresponding to results from the
-- paper, see the following module. Note that some of the code
-- referenced below is not discussed at all in the paper.

import README.Pointers-to-results-from-the-paper

------------------------------------------------------------------------
-- Some preliminaries

-- Overloaded "equational" reasoning combinators.

import Equational-reasoning

-- Unary and binary relations.

import Relation

------------------------------------------------------------------------
-- Containers

-- Indexed containers.

import Indexed-container

-- Container combinators.

import Indexed-container.Combinators

-- The delay monad defined as the greatest fixpoint of an indexed
-- container.

import Indexed-container.Delay-monad

------------------------------------------------------------------------
-- Up-to techniques

-- Up-to techniques, compatibility, size-preserving functions, and the
-- companion.

import Up-to

-- Closure properties for Compatible and Size-preserving.
--
-- (Some negative results in this module depend on code presented
-- further down.)

import Up-to.Closure

-- Up-to techniques via.

import Up-to.Via

------------------------------------------------------------------------
-- Labelled transition systems

-- Labelled transition systems (LTSs).

import Labelled-transition-system
import Labelled-transition-system.Equational-reasoning-instances

-- CCS.

import Labelled-transition-system.CCS

-- A labelled transition system for the delay monad.

import Labelled-transition-system.Delay-monad

-- An LTS from Section 6.2.5 of "Enhancements of the bisimulation
-- proof method" by Pous and Sangiorgi.

import Labelled-transition-system.6-2-5

------------------------------------------------------------------------
-- Similarity

-- The one-sided Step function, used to define similarity and the
-- two-sided Step function.

import Similarity.Step

-- A parametrised coinductive definition that can be used to define
-- various forms of similarity.

import Similarity.General

-- For more information about similarity, see "Similarity, continued"
-- below.

------------------------------------------------------------------------
-- Strong bisimilarity

-- The Step function, used to define strong and weak bisimilarity as
-- well as expansion.

import Bisimilarity.Step

-- A parametrised coinductive definition that can be used to define
-- strong and weak bisimilarity as well as expansion.

import Bisimilarity.General

-- A coinductive definition of (strong) bisimilarity.

import Bisimilarity
import Bisimilarity.Equational-reasoning-instances

-- The classical definition of (strong) bisimilarity.

import Bisimilarity.Classical
import Bisimilarity.Classical.Equational-reasoning-instances

-- A comparison of the two definitions of bisimilarity.

import Bisimilarity.Comparison

-- Some results related to strong bisimilarity for the delay monad.

import Bisimilarity.Delay-monad

-- Some results related to CCS, implemented without using a fixed form
-- of bisimilarity.

import Bisimilarity.CCS.General

-- Various results or examples related to CCS, implemented using the
-- coinductive definition of bisimilarity.

import Bisimilarity.CCS
import Bisimilarity.CCS.Examples
import Bisimilarity.CCS.Examples.Natural-numbers

-- Some of the results/examples above have also been implemented using
-- the classical definition of bisimilarity.

import Bisimilarity.CCS.Classical
import Bisimilarity.CCS.Examples.Classical

-- Up-to techniques for strong bisimilarity.

import Bisimilarity.Up-to
import Bisimilarity.Up-to.CCS
import Bisimilarity.Up-to.Counterexamples

-- Some results related to an LTS from Section 6.2.5 of "Enhancements
-- of the bisimulation proof method" by Pous and Sangiorgi,
-- implemented using the coinductive definition of bisimilarity.

import Bisimilarity.6-2-5

------------------------------------------------------------------------
-- Expansion

-- A coinductive definition of the expansion ordering.

import Expansion
import Expansion.Equational-reasoning-instances

-- Lemmas related to expansion and CCS.

import Expansion.CCS

-- Some results related to expansion for the delay monad.

import Expansion.Delay-monad

------------------------------------------------------------------------
-- Weak bisimilarity

-- A coinductive definition of weak bisimilarity.

import Bisimilarity.Weak
import Bisimilarity.Weak.Equational-reasoning-instances

-- An alternative (non-standard) coinductive definition of weak
-- bisimilarity.

import Bisimilarity.Weak.Alternative
import Bisimilarity.Weak.Alternative.Equational-reasoning-instances

-- An alternative (non-standard) classical definition of weak
-- bisimilarity.

import Bisimilarity.Weak.Alternative.Classical

-- A comparison of the two alternative definitions of weak
-- bisimilarity.

import Bisimilarity.Weak.Alternative.Comparison

-- The two coinductive definitions of weak bisimilarity are pointwise
-- logically equivalent.

import Bisimilarity.Weak.Equivalent

-- Lemmas related to weak bisimilarity and CCS.

import Bisimilarity.Weak.CCS

-- Examples/exercises related to CCS from "Enhancements of the
-- bisimulation proof method" by Pous and Sangiorgi.

import Bisimilarity.Weak.CCS.Examples

-- Some results about various forms of coinductively defined weak
-- bisimilarity for the delay monad.

import Bisimilarity.Weak.Delay-monad

-- Up-to techniques for the standard coinductive definition of weak
-- bisimilarity.

import Bisimilarity.Weak.Up-to
import Bisimilarity.Weak.Up-to.CCS

-- Up-to techniques for the delay monad and the alternative
-- coinductive definition of weak bisimilarity.

import Bisimilarity.Weak.Alternative.Up-to.Delay-monad

------------------------------------------------------------------------
-- Similarity, continued

-- A coinductive definition of (strong) similarity.

import Similarity
import Similarity.Equational-reasoning-instances

-- Lemmas related to strong similarity for CCS.

import Similarity.CCS

-- A coinductive definition of weak similarity.

import Similarity.Weak
import Similarity.Weak.Equational-reasoning-instances

-- An up-to technique for weak similarity.

import Similarity.Weak.Up-to


-- cj-xu and fredriknordvallforsberg, 2018-04-30

open import Common.IO

data Bool : Set where
  true false : Bool

data MyUnit : Set where
  tt : MyUnit -- no eta!

HiddenFunType : MyUnit -> Set
HiddenFunType tt = Bool -> Bool

notTooManyArgs : (x : MyUnit) -> HiddenFunType x
notTooManyArgs tt b = b

{- This should not happen when compiling notTooManyArgs:

    • Couldn't match expected type ‘GHC.Prim.Any’
                  with actual type ‘a0 -> b0’
      The type variables ‘b0’, ‘a0’ are ambiguous
    • The equation(s) for ‘d10’ have two arguments,
      but its type ‘T2 -> AgdaAny’ has only one
-}

main : IO MyUnit
main = return tt


------------------------------------------------------------------------
-- "Equational" reasoning combinator setup
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Prelude

open import Labelled-transition-system

module Similarity.Weak.Equational-reasoning-instances
         {ℓ} {lts : LTS ℓ} where

open import Bisimilarity lts
open import Bisimilarity.Weak lts
import Bisimilarity.Weak.Equational-reasoning-instances
open import Equational-reasoning
open import Expansion lts
import Expansion.Equational-reasoning-instances
open import Similarity lts
open import Similarity.Weak lts

instance

  reflexive≼ : ∀ {i} → Reflexive [ i ]_≼_
  reflexive≼ = is-reflexive reflexive-≼

  reflexive≼′ : ∀ {i} → Reflexive [ i ]_≼′_
  reflexive≼′ = is-reflexive reflexive-≼′

  convert≼≼ : ∀ {i} → Convertible [ i ]_≼_ [ i ]_≼_
  convert≼≼ = is-convertible id

  convert≼′≼ : ∀ {i} → Convertible _≼′_ [ i ]_≼_
  convert≼′≼ = is-convertible λ p≼′q → force p≼′q

  convert≼≼′ : ∀ {i} → Convertible [ i ]_≼_ [ i ]_≼′_
  convert≼≼′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ≼ q → [ i ] p ≼′ q
    force (lemma p≼q) = p≼q

  convert≼′≼′ : ∀ {i} → Convertible [ i ]_≼′_ [ i ]_≼′_
  convert≼′≼′ = is-convertible id

  convert≤≼ : ∀ {i} → Convertible [ i ]_≤_ [ i ]_≼_
  convert≤≼ = is-convertible ≤⇒≼

  convert≤′≼ : ∀ {i} → Convertible _≤′_ [ i ]_≼_
  convert≤′≼ = is-convertible (convert ∘ ≤⇒≼′)

  convert≤≼′ : ∀ {i} → Convertible [ i ]_≤_ [ i ]_≼′_
  convert≤≼′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ≤ q → [ i ] p ≼′ q
    force (lemma p≤q) = convert p≤q

  convert≤′≼′ : ∀ {i} → Convertible [ i ]_≤′_ [ i ]_≼′_
  convert≤′≼′ = is-convertible ≤⇒≼′

  convert≈≼ : ∀ {i} → Convertible [ i ]_≈_ [ i ]_≼_
  convert≈≼ = is-convertible ≈⇒≼

  convert≈′≼ : ∀ {i} → Convertible _≈′_ [ i ]_≼_
  convert≈′≼ = is-convertible (convert ∘ ≈⇒≼′)

  convert≈≼′ : ∀ {i} → Convertible [ i ]_≈_ [ i ]_≼′_
  convert≈≼′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ≈ q → [ i ] p ≼′ q
    force (lemma p≈q) = convert p≈q

  convert≈′≼′ : ∀ {i} → Convertible [ i ]_≈′_ [ i ]_≼′_
  convert≈′≼′ = is-convertible ≈⇒≼′

  convert∼≼ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≼_
  convert∼≼ = is-convertible (≈⇒≼ ∘ convert {a = ℓ})

  convert∼′≼ : ∀ {i} → Convertible _∼′_ [ i ]_≼_
  convert∼′≼ = is-convertible (convert ∘ ≈⇒≼′ ∘ convert {a = ℓ})

  convert∼≼′ : ∀ {i} → Convertible [ i ]_∼_ [ i ]_≼′_
  convert∼≼′ {i} = is-convertible lemma
    where
    lemma : ∀ {p q} → [ i ] p ∼ q → [ i ] p ≼′ q
    force (lemma p∼q) = ≈⇒≼ (convert {a = ℓ} p∼q)

  convert∼′≼′ : ∀ {i} → Convertible [ i ]_∼′_ [ i ]_≼′_
  convert∼′≼′ = is-convertible (≈⇒≼′ ∘ convert {a = ℓ})

  trans≼≼ : ∀ {i} → Transitive′ [ i ]_≼_ _≼_
  trans≼≼ = is-transitive transitive-≼

  trans≼′≼ : Transitive′ _≼′_ _≼_
  trans≼′≼ = is-transitive transitive-≼′

  trans≼′≼′ : ∀ {i} → Transitive′ [ i ]_≼′_ _≼′_
  trans≼′≼′ = is-transitive (λ p≼q → transitive-≼′ p≼q ∘ convert)

  trans≼≼′ : ∀ {i} → Transitive′ [ i ]_≼_ _≼′_
  trans≼≼′ = is-transitive (λ p≼q → transitive-≼ p≼q ∘ convert)

  trans≳≼ : ∀ {i} → Transitive [ i ]_≳_ [ i ]_≼_
  trans≳≼ = is-transitive transitive-≳≼

  trans≳′≼ : ∀ {i} → Transitive _≳′_ [ i ]_≼_
  trans≳′≼ = is-transitive (transitive-≳≼ ∘ convert {a = ℓ})

  trans≳′≼′ : ∀ {i} → Transitive [ i ]_≳′_ [ i ]_≼′_
  trans≳′≼′ = is-transitive transitive-≳≼′

  trans≳≼′ : ∀ {i} → Transitive [ i ]_≳_ [ i ]_≼′_
  trans≳≼′ = is-transitive (transitive-≳≼′ ∘ convert {a = ℓ})


-- Andreas, 2017-01-01, issue #2372, reported by m0davis

-- {-# OPTIONS -v tc.def.alias:100 -v tc.decl.instance:100 #-}

-- Expected error:
-- Terms marked as eligible for instance search should end with a name
-- when checking the definition of i

postulate
  D : Set

instance
  i = D  -- NOW: Error given here (as expected).

record R : Set₁ where
  field
    r : Set

open R {{ ... }} public

f : r → Set₁ -- WAS: Here, confusingly, is where Agda registers its complaint.
f _ = Set


module Holes.Term where

open import Holes.Prelude

-- TODO: This logically ought to be abstract, but that breaks the `cong!` macro
-- because when it is abstract, `⌞ x ⌟ ≡ x` does not hold (at least
-- definitionally). Look into a way of fixing this.
⌞_⌟ : ∀ {a}{A : Set a} → A → A
⌞ x ⌟ = x

private
  -- Given a term, if it is a hole, returns the list of arguments given to it.
  -- Otherwise returns nothing.

  toHole : Term → Maybe (List (Arg Term))
  -- First three arguments are the parameters of `⌞_⌟`, respectively the universe
  -- level `a`, the set `A` and the explicit parameter (i.e. the thing in the
  -- hole). So these are ignored.
  toHole (def (quote ⌞_⌟) (_ ∷ _ ∷ _ ∷ args)) = just args
  toHole _ = nothing

-- A HoleyTerm is an Agda term that has a single 'hole' in it, where another
-- term fits

data HoleyTerm : Set where
  hole : (args : List (Arg Term)) → HoleyTerm
  var : (x : ℕ) (args : List (Arg HoleyTerm)) → HoleyTerm
  con : (c : Name) (args : List (Arg HoleyTerm)) → HoleyTerm
  def : (f : Name) (args : List (Arg HoleyTerm)) → HoleyTerm
  lam : (v : Visibility) (holeyAbs : Abs HoleyTerm) → HoleyTerm
  pi : (a : Arg HoleyTerm) (b : Abs HoleyTerm) → HoleyTerm
  agda-sort : (s : Sort) → HoleyTerm
  lit : (l : Literal) → HoleyTerm
  unknown : HoleyTerm
  meta : (x : Meta) (args : List (Arg HoleyTerm)) → HoleyTerm

data HoleyErr : Set where
  noHole : HoleyErr
  unsupportedTerm : Term → HoleyErr
  mismatchedHoleTerms : HoleyErr

printHoleyErr : Term → HoleyErr → List ErrorPart
printHoleyErr goalLhs noHole
  = strErr "LHS of goal type contains no hole:"
  ∷ termErr goalLhs
  ∷ []
printHoleyErr goalLhs (unsupportedTerm x)
  = strErr "Goal type's LHS"
  ∷ termErr goalLhs
  ∷ strErr "contains unsupported term"
  ∷ termErr x
  ∷ []
printHoleyErr goalLhs mismatched-hole-terms
  = strErr "Terms in different holes failed to unify with each other."
  ∷ strErr "Check that every hole has an identical term in it."
  ∷ strErr "Offending term:"
  ∷ termErr goalLhs
  ∷ []

private
  mapArglist : {A B : Set} → (A → B) → List (Arg A) → List (Arg B)
  mapArglist = map ∘ mapArg

-- Converts a HoleyTerm to a regular term by filling in the hole with some other
-- given term which is a function of the number of binders encountered on the
-- way to the hole.
--
-- Free variables inside the holey term are detected and modified using the
-- provided function, because otherwise they might interact wrongly with
-- surrounding terms in the result.

{-# TERMINATING #-}
fillHoley : (ℕ → ℕ) → ℕ → (ℕ → List (Arg Term) → Term) → HoleyTerm → Term
fillHoley freeVarMod binderDepth filler = go binderDepth
  where
  go : ℕ → HoleyTerm → Term
  go depth (hole args) = filler depth args
  go _ (lit l) = lit l
  go depth (var x args) =
    let freeVar = not (x <? depth)
    in var (if freeVar then freeVarMod x else x) (mapArglist (go depth) args)
  go depth (con c args) = con c (mapArglist (go depth) args)
  go depth (def f args) = def f (mapArglist (go depth) args)
  go depth (meta x args) = meta x (mapArglist (go depth) args)
  go depth (lam v (abs s holey)) = lam v (abs s (go depth holey))
  go depth (pi (arg v a) (abs s b)) =
    pi (arg v (go depth a))
       (abs s (go depth b))
  go _ (agda-sort s) = agda-sort s
  go _ unknown = unknown

-- Converts a HoleyTerm to a regular term which abstracts a variable that is
-- used to fill the hole.
--
-- The `suc` function is provided for `fillHoley`'s `freeVarMod` parameter.
-- This is because the binding level of any free variables in the given term
-- will need to be lifted over the new lambda that we're introducing. Otherwise
-- they'll end up referring to the new lambda's variables, which is wrong. Bound
-- variables inside the given term don't need to be changed.

holeyToLam : HoleyTerm → Term
holeyToLam holey = lam visible (abs "hole" (fillHoley suc 0 var holey))

-- Converts a HoleyTerm to a regular term by filling in the hole with a constant
-- other term.

fillHoley′ : (List (Arg Term) → Term) → HoleyTerm → Term
fillHoley′ filler = fillHoley id 0 (λ _ → filler)

private
  mapPair : ∀ {a b x y}{A : Set a}{B : Set b}{X : Set x}{Y : Set y} → (A → X) → (B → Y) → A × B → X × Y
  mapPair f g (x , y) = f x , g y

  pushArg : ∀ {A B : Set} → Arg (A × B) → A × Arg B
  pushArg (arg i (x , y)) = x , arg i y

  mutual
    argHelper : (List (Arg HoleyTerm) → HoleyTerm) → List (Arg Term) → Result HoleyErr (List Term × HoleyTerm)
    argHelper buildHoley
      = fmap (mapPair concat buildHoley ∘ unzip)
      ∘ traverse (fmap pushArg ∘ traverse termToHoleyHelper)

    {-# TERMINATING #-}
    termToHoleyHelper : Term → Result HoleyErr (List Term × HoleyTerm)
    termToHoleyHelper term with toHole term
    termToHoleyHelper term | just args = ok (term ∷ [] , hole args)
    termToHoleyHelper (lit l) | nothing = ok ([] , lit l)
    termToHoleyHelper (var x args) | nothing = argHelper (var x) args
    termToHoleyHelper (con c args) | nothing = argHelper (con c) args
    termToHoleyHelper (def f args) | nothing = argHelper (def f) args
    termToHoleyHelper (meta x args) | nothing = argHelper (meta x) args
    termToHoleyHelper (lam v (abs s t)) | nothing =
      mapPair id (λ h → lam v (abs s h)) <$> termToHoleyHelper t
    termToHoleyHelper (pi (arg v a) (abs s b)) | nothing =
      termToHoleyHelper a >>=² λ ts₁ a′ →
      termToHoleyHelper b >>=² λ ts₂ b′ →
      return (ts₁ ++ ts₂ , pi (arg v a′) (abs s b′))
    termToHoleyHelper unknown | nothing = ok ([] , unknown)
    termToHoleyHelper (agda-sort s) | nothing = ok ([] , agda-sort s)
    ... | _ = err (unsupportedTerm term)

-- If a term has a hole in it, specified by ⌞_⌟ around a subterm, returns a
-- HoleyTerm with the hole removed.

termToHoley : Term → Result HoleyErr HoleyTerm
termToHoley term = proj₂ <$> termToHoleyHelper term

-- A variant of `termToHoley` that also returns the term in the hole. If there
-- are multiple holes, returns all of the terms that are in them.

termToHoley′ : Term → Result HoleyErr (List Term × HoleyTerm)
termToHoley′ = termToHoleyHelper

private
  unifyAll : List Term → TC (Maybe Term)
  unifyAll [] = return nothing
  unifyAll (x ∷ xs) = traverse- (unify x) xs >> return (just x)

checkedTermToHoley : Term → RTC HoleyErr (Term × HoleyTerm)
checkedTermToHoley term =
  liftResult (termToHoley′ term) >>=² λ holeTerms holey →
  liftTC (unifyAll holeTerms)
    ⟨ catchRTC ⟩
  throw mismatchedHoleTerms >>= λ
  { nothing → return (fillHoley′ (λ _ → unknown) holey , hole [])
  ; (just holeTerm) → return (holeTerm , holey)
  }

-- A variant of `termToHoley` that also returns the term in the hole, and checks
-- that the holey term is valid by unifying it with the original term. The list
-- of error parts given is thrown as a type error if the term could not be
-- converted to a holey term. Also, if there are no holes, treats the entire
-- expression as a hole.

checkedTermToHoley′ : (HoleyErr → List ErrorPart) → Term → TC (Term × HoleyTerm)
checkedTermToHoley′ error =
  runRTC (typeError ∘ error) ∘ checkedTermToHoley

-- These macros are useful for debugging and testing

macro
  -- Given a holey term, expands to a function which accepts something to go in
  -- the hole.

  lambdaIntoHole : Term → Term → TC ⊤
  lambdaIntoHole term target =
    checkedTermToHoley′ (λ _ → strErr "Unsupported term for holiness or no hole:"
                                ∷ termErr term
                                ∷ []) term >>=² λ _ →
    unify target ∘ holeyToLam

  -- Given a holey term, expands to the quoted form of a function which accepts
  -- something to go in the hole.

  lambdaIntoHole′ : Term → Term → TC ⊤
  lambdaIntoHole′ term target =
    checkedTermToHoley′ (λ _ → strErr "Unsupported term for holiness or no hole:"
                                ∷ termErr term
                                ∷ []) term >>=² λ _ result →
    quoteTC (holeyToLam result) >>=
    unify target

  -- Quotes a holey term, reifying its abstract syntax tree.

  quoteHoley : Term → Term → TC ⊤
  quoteHoley term target =
    checkedTermToHoley′ (λ _ → strErr "Unsupported term for holiness or no hole:"
                                ∷ termErr term
                                ∷ []) term >>=² λ _ result →
    quoteTC result >>= unify target

  -- Quotes a holey term and also the term in the hole. Expanded type is always
  -- `Term × HoleyTerm`.

  quoteHoley′ : Term → Term → TC ⊤
  quoteHoley′ term target =
    checkedTermToHoley′ (λ _ → strErr "Unsupported term for holiness or no hole:"
                                ∷ termErr term
                                ∷ []) term >>=
    quoteTC >>= unify target

private
  module Tests where
    open PropEq using (_≡_; refl)

    data Fin : ℕ → Set where
      zero : ∀ {n} → Fin (suc n)
      suc : ∀ {n} → Fin n → Fin (suc n)

    eqTyped : ∀ {a}(A : Set a) → A → A → Set a
    eqTyped _ x y = x ≡ y

    syntax eqTyped A x y = x ≡[ A ] y

    -- Holes don't have to match the type of the bigger expression
    test1 : lambdaIntoHole (4 + 5 * length ⌞ 1 ∷ [] ⌟ + 7) ≡ λ hole → 4 + 5 * length hole + 7
    test1 = refl

    -- Holes can be around functions
    test2 : lambdaIntoHole (⌞ _+_ ⌟ 3 4) ≡[ ((ℕ → ℕ → ℕ) → ℕ) ] λ hole → hole 3 4
    test2 = refl

    -- Holey terms can contain free variables
    test3 : ∀ x y z → lambdaIntoHole (⌞ x + y ⌟ + z) ≡ λ hole → hole + z
    test3 x y z = refl

    -- Multiple holes are possible
    test4 : ∀ x y z → lambdaIntoHole (x + ⌞ y + z ⌟ * ⌞ y + z ⌟ + y * z) ≡ λ hole → x + hole * hole + y * z
    test4 x y z = refl

    -- Holes into Π types
    test5 : ∀ x y → lambdaIntoHole (Fin ⌞ x + y ⌟ → ℕ) ≡ λ hole → Fin hole → ℕ
    test5 x y = refl

    -- Constructors on the path
    test6 : (x y : ℕ) → lambdaIntoHole (ℕ.suc (x + ⌞ y ⌟ + y)) ≡ λ hole → suc (x + hole + y)
    test6 x y = refl


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

open import lib.Basics
open import lib.NType2
open import lib.types.Bool
open import lib.types.Empty
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Sigma

{-
This file contains various lemmas that rely on lib.types.Paths or
functional extensionality for pointed maps.
-}

module lib.types.Pointed where

{- Sequences of pointed maps and paths between their compositions -}

infixr 80 _◃⊙∘_
data ⊙FunctionSeq {i} : Ptd i → Ptd i → Type (lsucc i) where
  ⊙idf-seq : {X : Ptd i} → ⊙FunctionSeq X X
  _◃⊙∘_ : {X Y Z : Ptd i} (g : Y ⊙→ Z) (fs : ⊙FunctionSeq X Y) → ⊙FunctionSeq X Z

infix 30 _⊙–→_
_⊙–→_ = ⊙FunctionSeq

infix 90 _◃⊙idf
_◃⊙idf : ∀ {i} {X Y : Ptd i} → (X ⊙→ Y) → X ⊙–→ Y
_◃⊙idf fs = fs ◃⊙∘ ⊙idf-seq

⊙compose : ∀ {i} {X Y : Ptd i} → (X ⊙–→ Y) → X ⊙→ Y
⊙compose ⊙idf-seq = ⊙idf _
⊙compose (g ◃⊙∘ fs) = g ⊙∘ ⊙compose fs

record _=⊙∘_ {i} {X Y : Ptd i} (fs gs : X ⊙–→ Y) : Type i where
  constructor =⊙∘-in
  field
    =⊙∘-out : ⊙compose fs == ⊙compose gs
open _=⊙∘_ public

{- Pointed maps -}

⊙→-level : ∀ {i j} (X : Ptd i) (Y : Ptd j)
  {n : ℕ₋₂}
  → has-level n (de⊙ Y)
  → has-level n (X ⊙→ Y)
⊙→-level X Y Y-level =
  Σ-level
    (Π-level (λ _ → Y-level))
    (λ f' → =-preserves-level Y-level)

⊙app= : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  → f == g → f ⊙∼ g
⊙app= {X = X} {Y = Y} p =
  app= (fst= p) , ↓-ap-in (_== pt Y) (λ u → u (pt X)) (snd= p)

-- function extensionality for pointed maps
⊙λ= : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  → f ⊙∼ g → f == g
⊙λ= {g = g} (p , α) = pair= (λ= p)
  (↓-app=cst-in (↓-idf=cst-out α ∙ ap (_∙ snd g) (! (app=-β p _))))

⊙λ=' : ∀ {i j} {X : Ptd i} {Y : Ptd j} {f g : X ⊙→ Y}
  (p : fst f ∼ fst g)
  (α : snd f == snd g [ (λ y → y == pt Y) ↓ p (pt X) ])
  → f == g
⊙λ=' {g = g} = curry ⊙λ=

-- associativity of pointed maps
⊙∘-assoc-pt : ∀ {i j k} {A : Type i} {B : Type j} {C : Type k}
  {a₁ a₂ : A} (f : A → B) {b : B} (g : B → C) {c : C}
  (p : a₁ == a₂) (q : f a₂ == b) (r : g b == c)
  → ⊙∘-pt (g ∘ f) p (⊙∘-pt g q r) == ⊙∘-pt g (⊙∘-pt f p q) r
⊙∘-assoc-pt _ _ idp _ _ = idp

⊙∘-assoc : ∀ {i j k l} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} {W : Ptd l}
  (h : Z ⊙→ W) (g : Y ⊙→ Z) (f : X ⊙→ Y)
  → ((h ⊙∘ g) ⊙∘ f) ⊙∼ (h ⊙∘ (g ⊙∘ f))
⊙∘-assoc (h , hpt) (g , gpt) (f , fpt) = (λ _ → idp) , ⊙∘-assoc-pt g h fpt gpt hpt

⊙∘-cst-l : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  → (f : X ⊙→ Y) → (⊙cst :> (Y ⊙→ Z)) ⊙∘ f ⊙∼ ⊙cst
⊙∘-cst-l {Z = Z} f = (λ _ → idp) , ap (_∙ idp) (ap-cst (pt Z) (snd f))

⊙∘-cst-r : ∀ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  → (f : Y ⊙→ Z) → f ⊙∘ (⊙cst :> (X ⊙→ Y)) ⊙∼ ⊙cst
⊙∘-cst-r {X = X} f = (λ _ → snd f) , ↓-idf=cst-in' idp

private
  ⊙coe-pt : ∀ {i} {X Y : Ptd i} (p : X == Y)
    → coe (ap de⊙ p) (pt X) == pt Y
  ⊙coe-pt idp = idp

⊙coe : ∀ {i} {X Y : Ptd i}
  → X == Y → X ⊙→ Y
⊙coe p = coe (ap de⊙ p) , ⊙coe-pt p

⊙coe-equiv : ∀ {i} {X Y : Ptd i}
  → X == Y → X ⊙≃ Y
⊙coe-equiv p = ⊙coe p , snd (coe-equiv (ap de⊙ p))

transport-post⊙∘ : ∀ {i} {j} (X : Ptd i) {Y Z : Ptd j} (p : Y == Z)
  (f : X ⊙→ Y)
  → transport (X ⊙→_) p f == ⊙coe p ⊙∘ f
transport-post⊙∘ X p@idp f = ! (⊙λ= (⊙∘-unit-l f))

⊙coe-∙ : ∀ {i} {X Y Z : Ptd i} (p : X == Y) (q : Y == Z)
  → ⊙coe (p ∙ q) ◃⊙idf =⊙∘ ⊙coe q ◃⊙∘ ⊙coe p ◃⊙idf
⊙coe-∙ p@idp q = =⊙∘-in idp

private
  ⊙coe'-pt : ∀ {i} {X Y : Ptd i} (p : de⊙ X == de⊙ Y) (q : pt X == pt Y [ idf _ ↓ p ])
    → coe p (pt X) == pt Y
  ⊙coe'-pt p@idp q = q

⊙coe' : ∀ {i} {X Y : Ptd i} (p : de⊙ X == de⊙ Y) (q : pt X == pt Y [ idf _ ↓ p ])
  → X ⊙→ Y
⊙coe' p q = coe p , ⊙coe'-pt p q

private
  ⊙transport-pt : ∀ {i j} {A : Type i} (B : A → Ptd j) {x y : A} (p : x == y)
    → transport (de⊙ ∘ B) p (pt (B x)) == pt (B y)
  ⊙transport-pt B idp = idp

⊙transport : ∀ {i j} {A : Type i} (B : A → Ptd j) {x y : A} (p : x == y)
  → (B x ⊙→ B y)
⊙transport B p = transport (de⊙ ∘ B) p , ⊙transport-pt B p

⊙transport-∙ : ∀ {i j} {A : Type i} (B : A → Ptd j)
  {x y z : A} (p : x == y) (q : y == z)
  → ⊙transport B (p ∙ q) ◃⊙idf =⊙∘ ⊙transport B q ◃⊙∘ ⊙transport B p ◃⊙idf
⊙transport-∙ B p@idp q = =⊙∘-in idp

⊙transport-⊙coe : ∀ {i j} {A : Type i} (B : A → Ptd j) {x y : A} (p : x == y)
  → ⊙transport B p == ⊙coe (ap B p)
⊙transport-⊙coe B p@idp = idp

⊙transport-natural : ∀ {i j k} {A : Type i} {B : A → Ptd j} {C : A → Ptd k}
  {x y : A} (p : x == y)
  (h : ∀ a → B a ⊙→ C a)
  → h y ⊙∘ ⊙transport B p == ⊙transport C p ⊙∘ h x
⊙transport-natural p@idp h = ! (⊙λ= (⊙∘-unit-l (h _)))

{- This requires that B and C have the same universe level -}
⊙transport-natural-=⊙∘ : ∀ {i j} {A : Type i} {B C : A → Ptd j}
  {x y : A} (p : x == y)
  (h : ∀ a → B a ⊙→ C a)
  → h y ◃⊙∘ ⊙transport B p ◃⊙idf =⊙∘ ⊙transport C p ◃⊙∘ h x ◃⊙idf
⊙transport-natural-=⊙∘ p h = =⊙∘-in (⊙transport-natural p h)

{- Pointed equivalences -}

-- Extracting data from an pointed equivalence
module _ {i j} {X : Ptd i} {Y : Ptd j} (⊙e : X ⊙≃ Y) where

  ⊙≃-to-≃ : de⊙ X ≃ de⊙ Y
  ⊙≃-to-≃ = fst (fst ⊙e) , snd ⊙e

  ⊙–> : X ⊙→ Y
  ⊙–> = fst ⊙e

  ⊙–>-pt = snd ⊙–>

  ⊙<– : Y ⊙→ X
  ⊙<– = is-equiv.g (snd ⊙e) , lemma ⊙e where
    lemma : {Y : Ptd j} (⊙e : X ⊙≃ Y) → is-equiv.g (snd ⊙e) (pt Y) == pt X
    lemma ((f , idp) , f-ise) = is-equiv.g-f f-ise (pt X)

  ⊙<–-pt = snd ⊙<–

  infix 120 _⊙⁻¹
  _⊙⁻¹ : Y ⊙≃ X
  _⊙⁻¹ = ⊙<– , is-equiv-inverse (snd ⊙e)

module _ {i j} {X : Ptd i} {Y : Ptd j} where

  ⊙<–-inv-l : (⊙e : X ⊙≃ Y) → ⊙<– ⊙e ⊙∘ ⊙–> ⊙e == ⊙idf _
  ⊙<–-inv-l ⊙e = ⊙λ= (<–-inv-l (⊙≃-to-≃ ⊙e) , ↓-idf=cst-in' (lemma ⊙e)) where
    lemma : {Y : Ptd j} (⊙e : X ⊙≃ Y)
      → snd (⊙<– ⊙e ⊙∘ ⊙–> ⊙e) == is-equiv.g-f (snd ⊙e) (pt X)
    lemma ((f , idp) , f-ise) = idp

  ⊙<–-inv-r : (⊙e : X ⊙≃ Y) → ⊙–> ⊙e ⊙∘ ⊙<– ⊙e == ⊙idf _
  ⊙<–-inv-r ⊙e = ⊙λ= (<–-inv-r (⊙≃-to-≃ ⊙e) , ↓-idf=cst-in' (lemma ⊙e)) where
    lemma : {Y : Ptd j} (⊙e : X ⊙≃ Y)
      → snd (⊙–> ⊙e ⊙∘ ⊙<– ⊙e) == is-equiv.f-g (snd ⊙e) (pt Y)
    lemma ((f , idp) , f-ise) = ∙-unit-r _ ∙ is-equiv.adj f-ise (pt X)

module _ {i} {X Y : Ptd i} where

  ⊙<–-inv-l-=⊙∘ : (⊙e : X ⊙≃ Y) → ⊙<– ⊙e ◃⊙∘ ⊙–> ⊙e ◃⊙idf =⊙∘ ⊙idf-seq
  ⊙<–-inv-l-=⊙∘ ⊙e = =⊙∘-in (⊙<–-inv-l ⊙e)

  ⊙<–-inv-r-=⊙∘ : (⊙e : X ⊙≃ Y) → ⊙–> ⊙e ◃⊙∘ ⊙<– ⊙e ◃⊙idf =⊙∘ ⊙idf-seq
  ⊙<–-inv-r-=⊙∘ ⊙e = =⊙∘-in (⊙<–-inv-r ⊙e)

module _ {i j k} {X : Ptd i} {Y : Ptd j} {Z : Ptd k} (⊙e : X ⊙≃ Y) where

  post⊙∘-is-equiv : is-equiv (λ (k : Z ⊙→ X) → ⊙–> ⊙e ⊙∘ k)
  post⊙∘-is-equiv = is-eq (⊙–> ⊙e ⊙∘_) (⊙<– ⊙e ⊙∘_) (to-from ⊙e) (from-to ⊙e) where
    abstract
      to-from : ∀ {Y} (⊙e : X ⊙≃ Y) (k : Z ⊙→ Y) → ⊙–> ⊙e ⊙∘ (⊙<– ⊙e ⊙∘ k) == k
      to-from ((f , idp) , f-ise) (k , k-pt) = ⊙λ=' (f.f-g ∘ k) (↓-idf=cst-in' $ lemma k-pt)
        where
          module f = is-equiv f-ise
          lemma : ∀ {y₀} (k-pt : y₀ == f (pt X))
            → ⊙∘-pt f (⊙∘-pt f.g k-pt (f.g-f _)) idp == f.f-g y₀ ∙' k-pt
          lemma idp = ∙-unit-r _ ∙ f.adj _

      from-to : ∀ {Y} (⊙e : X ⊙≃ Y) (k : Z ⊙→ X) → ⊙<– ⊙e ⊙∘ (⊙–> ⊙e ⊙∘ k) == k
      from-to ((f , idp) , f-ise) (k , idp) = ⊙λ=' (f.g-f ∘ k) $ ↓-idf=cst-in' idp
        where module f = is-equiv f-ise

  post⊙∘-equiv : (Z ⊙→ X) ≃ (Z ⊙→ Y)
  post⊙∘-equiv = _ , post⊙∘-is-equiv

  pre⊙∘-is-equiv : is-equiv (λ (k : Y ⊙→ Z) → k ⊙∘ ⊙–> ⊙e)
  pre⊙∘-is-equiv = is-eq (_⊙∘ ⊙–> ⊙e) (_⊙∘ ⊙<– ⊙e) (to-from ⊙e) (from-to ⊙e) where
    abstract
      to-from : ∀ {Z} (⊙e : X ⊙≃ Y) (k : X ⊙→ Z) → (k ⊙∘ ⊙<– ⊙e) ⊙∘ ⊙–> ⊙e == k
      to-from ((f , idp) , f-ise) (k , idp) = ⊙λ=' (ap k ∘ f.g-f) $ ↓-idf=cst-in' $ ∙-unit-r _
        where module f = is-equiv f-ise

      from-to : ∀ {Z} (⊙e : X ⊙≃ Y) (k : Y ⊙→ Z) → (k ⊙∘ ⊙–> ⊙e) ⊙∘ ⊙<– ⊙e == k
      from-to ((f , idp) , f-ise) (k , idp) = ⊙λ=' (ap k ∘ f.f-g) $ ↓-idf=cst-in' $
        ∙-unit-r _ ∙ ap-∘ k f (f.g-f (pt X)) ∙ ap (ap k) (f.adj (pt X))
        where module f = is-equiv f-ise

  pre⊙∘-equiv : (Y ⊙→ Z) ≃ (X ⊙→ Z)
  pre⊙∘-equiv = _ , pre⊙∘-is-equiv

{- Pointed maps out of bool -}

-- intuition : [f true] is fixed and the only changable part is [f false].

⊙Bool→-to-idf : ∀ {i} {X : Ptd i}
  → ⊙Bool ⊙→ X → de⊙ X
⊙Bool→-to-idf (h , _) = h false

⊙Bool→-equiv-idf : ∀ {i} (X : Ptd i)
  → (⊙Bool ⊙→ X) ≃ de⊙ X
⊙Bool→-equiv-idf {i} X = equiv ⊙Bool→-to-idf g f-g g-f
  where
  g : de⊙ X → ⊙Bool ⊙→ X
  g x = Bool-rec (pt X) x , idp

  abstract
    f-g : ∀ x → ⊙Bool→-to-idf (g x) == x
    f-g x = idp

    g-f : ∀ H → g (⊙Bool→-to-idf H) == H
    g-f (h , hpt) = pair=
      (λ= lemma)
      (↓-app=cst-in $
        idp
          =⟨ ! (!-inv-l hpt) ⟩
        ! hpt ∙ hpt
          =⟨ ! (app=-β lemma true) |in-ctx (λ w → w ∙ hpt) ⟩
        app= (λ= lemma) true ∙ hpt
          =∎)
      where lemma : ∀ b → fst (g (h false)) b == h b
            lemma true = ! hpt
            lemma false = idp

⊙Bool→-equiv-idf-nat : ∀ {i j} {X : Ptd i} {Y : Ptd j} (F : X ⊙→ Y)
  → CommSquareEquiv
      (F ⊙∘_)
      (fst F)
      ⊙Bool→-to-idf
      ⊙Bool→-to-idf
⊙Bool→-equiv-idf-nat F = (comm-sqr λ _ → idp) ,
  snd (⊙Bool→-equiv-idf _) , snd (⊙Bool→-equiv-idf _)


module _ where

open import Agda.Builtin.Bool
open import Agda.Builtin.List
open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit

record R : Set₁ where
  field
    _≡_  : {A : Set} → A → A → Set
    refl : {A : Set} (x : A) → x ≡ x

record R′ (_ : Set) : Set where

module _ (r : R) (_ : {A : Set} → R′ A) where

  open R r

  macro

    m : Term → TC ⊤
    m goal =
      bindTC (unify (def (quote refl)
                         (arg (arg-info visible relevant) unknown ∷ []))
                    goal) λ _ →
      bindTC solveConstraints λ _ →
      bindTC (reduce goal) λ where
        (meta m _) → typeError (strErr "Meta" ∷ [])
        _          → returnTC _

  test : true ≡ true
  test = m

  macro

    m′ : Term → TC ⊤
    m′ goal =
      bindTC (unify (def (quote refl)
                         (arg (arg-info visible relevant) unknown ∷ []))
                    goal) λ _ →
      bindTC (reduce goal) λ where
        goal@(meta m _) →
          bindTC (solveConstraintsMentioning (m ∷ [])) λ _ →
          bindTC (reduce goal) λ where
            (meta _ _) → typeError (strErr "Meta" ∷ [])
            _          → returnTC _
        _ → returnTC _

  test′ : true ≡ true
  test′ = m′


open import Prelude
open import Nat
open import core
open import contexts
open import disjointness

-- this module contains lemmas and properties about the holes-disjoint
-- judgement that double check that it acts as we would expect

module holes-disjoint-checks where
  -- these lemmas are all structurally recursive and quite
  -- mechanical. morally, they establish the properties about reduction
  -- that would be obvious / baked into Agda if holes-disjoint was defined
  -- as a function rather than a judgement (datatype), or if we had defined
  -- all the O(n^2) cases rather than relying on a little indirection to
  -- only have O(n) cases. that work has to go somewhwere, and we prefer
  -- that it goes here.
  ds-lem-asc : ∀{e1 e2 τ} → holes-disjoint e2 e1 → holes-disjoint e2 (e1 ·: τ)
  ds-lem-asc HDConst = HDConst
  ds-lem-asc (HDAsc hd) = HDAsc (ds-lem-asc hd)
  ds-lem-asc HDVar = HDVar
  ds-lem-asc (HDLam1 hd) = HDLam1 (ds-lem-asc hd)
  ds-lem-asc (HDLam2 hd) = HDLam2 (ds-lem-asc hd)
  ds-lem-asc (HDHole x) = HDHole (HNAsc x)
  ds-lem-asc (HDNEHole x hd) = HDNEHole (HNAsc x) (ds-lem-asc hd)
  ds-lem-asc (HDAp hd hd₁) = HDAp (ds-lem-asc hd) (ds-lem-asc hd₁)

  ds-lem-lam1 : ∀{e1 e2 x} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x e1)
  ds-lem-lam1 HDConst = HDConst
  ds-lem-lam1 (HDAsc hd) = HDAsc (ds-lem-lam1 hd)
  ds-lem-lam1 HDVar = HDVar
  ds-lem-lam1 (HDLam1 hd) = HDLam1 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDLam2 hd) = HDLam2 (ds-lem-lam1 hd)
  ds-lem-lam1 (HDHole x₁) = HDHole (HNLam1 x₁)
  ds-lem-lam1 (HDNEHole x₁ hd) = HDNEHole (HNLam1 x₁) (ds-lem-lam1 hd)
  ds-lem-lam1 (HDAp hd hd₁) = HDAp (ds-lem-lam1 hd) (ds-lem-lam1 hd₁)

  ds-lem-lam2 : ∀{e1 e2 x τ} → holes-disjoint e2 e1 → holes-disjoint e2 (·λ x [ τ ] e1)
  ds-lem-lam2 HDConst = HDConst
  ds-lem-lam2 (HDAsc hd) = HDAsc (ds-lem-lam2 hd)
  ds-lem-lam2 HDVar = HDVar
  ds-lem-lam2 (HDLam1 hd) = HDLam1 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDLam2 hd) = HDLam2 (ds-lem-lam2 hd)
  ds-lem-lam2 (HDHole x₁) = HDHole (HNLam2 x₁)
  ds-lem-lam2 (HDNEHole x₁ hd) = HDNEHole (HNLam2 x₁) (ds-lem-lam2 hd)
  ds-lem-lam2 (HDAp hd hd₁) = HDAp (ds-lem-lam2 hd) (ds-lem-lam2 hd₁)

  ds-lem-nehole : ∀{e e1 u} → holes-disjoint e e1 → hole-name-new e u → holes-disjoint e ⦇⌜ e1 ⌟⦈[ u ]
  ds-lem-nehole HDConst ν = HDConst
  ds-lem-nehole (HDAsc hd) (HNAsc ν) = HDAsc (ds-lem-nehole hd ν)
  ds-lem-nehole HDVar ν = HDVar
  ds-lem-nehole (HDLam1 hd) (HNLam1 ν) = HDLam1 (ds-lem-nehole hd ν)
  ds-lem-nehole (HDLam2 hd) (HNLam2 ν) = HDLam2 (ds-lem-nehole hd ν)
  ds-lem-nehole (HDHole x) (HNHole x₁) = HDHole (HNNEHole (flip x₁) x)
  ds-lem-nehole (HDNEHole x hd) (HNNEHole x₁ ν) = HDNEHole (HNNEHole (flip x₁) x) (ds-lem-nehole hd ν)
  ds-lem-nehole (HDAp hd hd₁) (HNAp ν ν₁) = HDAp (ds-lem-nehole hd ν) (ds-lem-nehole hd₁ ν₁)

  ds-lem-ap : ∀{e1 e2 e3} → holes-disjoint e3 e1 → holes-disjoint e3 e2 → holes-disjoint e3 (e1 ∘ e2)
  ds-lem-ap HDConst hd2 = HDConst
  ds-lem-ap (HDAsc hd1) (HDAsc hd2) = HDAsc (ds-lem-ap hd1 hd2)
  ds-lem-ap HDVar hd2 = HDVar
  ds-lem-ap (HDLam1 hd1) (HDLam1 hd2) = HDLam1 (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDLam2 hd1) (HDLam2 hd2) = HDLam2 (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDHole x) (HDHole x₁) = HDHole (HNAp x x₁)
  ds-lem-ap (HDNEHole x hd1) (HDNEHole x₁ hd2) = HDNEHole (HNAp x x₁) (ds-lem-ap hd1 hd2)
  ds-lem-ap (HDAp hd1 hd2) (HDAp hd3 hd4) = HDAp (ds-lem-ap hd1 hd3) (ds-lem-ap hd2 hd4)

  -- holes-disjoint is symmetric
  disjoint-sym : (e1 e2 : hexp) → holes-disjoint e1 e2 → holes-disjoint e2 e1
  disjoint-sym .c c HDConst = HDConst
  disjoint-sym .c (e2 ·: x) HDConst = HDAsc (disjoint-sym _ _ HDConst)
  disjoint-sym .c (X x) HDConst = HDVar
  disjoint-sym .c (·λ x e2) HDConst = HDLam1 (disjoint-sym c e2 HDConst)
  disjoint-sym .c (·λ x [ x₁ ] e2) HDConst = HDLam2 (disjoint-sym c e2 HDConst)
  disjoint-sym .c ⦇-⦈[ x ] HDConst = HDHole HNConst
  disjoint-sym .c ⦇⌜ e2 ⌟⦈[ x ] HDConst = HDNEHole HNConst (disjoint-sym c e2 HDConst)
  disjoint-sym .c (e2 ∘ e3) HDConst = HDAp (disjoint-sym c e2 HDConst) (disjoint-sym c e3 HDConst)

  disjoint-sym _ c (HDAsc hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x) (HDAsc hd) | HDAsc ih = HDAsc (ds-lem-asc ih)
  disjoint-sym _ (X x) (HDAsc hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDAsc hd) | HDLam1 ih = HDLam1 (ds-lem-asc ih)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDAsc hd) | HDLam2 ih = HDLam2 (ds-lem-asc ih)
  disjoint-sym _ ⦇-⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇-⦈[ x ] (HDAsc hd) | HDHole x₁ = HDHole (HNAsc x₁)
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDAsc hd) | HDNEHole x₁ ih = HDNEHole (HNAsc x₁) (ds-lem-asc ih)
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDAsc hd) | HDAp ih ih₁ = HDAp (ds-lem-asc ih) (ds-lem-asc ih₁)

  disjoint-sym _ c HDVar = HDConst
  disjoint-sym _ (e2 ·: x₁) HDVar = HDAsc (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (X x₁) HDVar = HDVar
  disjoint-sym _ (·λ x₁ e2) HDVar = HDLam1 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) HDVar = HDLam2 (disjoint-sym _ e2 HDVar)
  disjoint-sym _ ⦇-⦈[ x₁ ] HDVar = HDHole HNVar
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] HDVar = HDNEHole HNVar (disjoint-sym _ e2 HDVar)
  disjoint-sym _ (e2 ∘ e3) HDVar = HDAp (disjoint-sym _ e2 HDVar) (disjoint-sym _ e3 HDVar)

  disjoint-sym _ c (HDLam1 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam1 hd) | HDAsc ih = HDAsc (ds-lem-lam1 ih)
  disjoint-sym _ (X x₁) (HDLam1 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam1 hd) | HDLam1 ih = HDLam1 (ds-lem-lam1 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam1 hd) | HDLam2 ih = HDLam2 (ds-lem-lam1 ih)
  disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam1 hd) | HDHole x = HDHole (HNLam1 x)
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam1 hd) | HDNEHole x ih = HDNEHole (HNLam1 x) (ds-lem-lam1 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam1 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam1 ih) (ds-lem-lam1 ih₁)

  disjoint-sym _ c (HDLam2 hd) = HDConst
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ·: x₁) (HDLam2 hd) | HDAsc ih = HDAsc (ds-lem-lam2 ih)
  disjoint-sym _ (X x₁) (HDLam2 hd) = HDVar
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ e2) (HDLam2 hd) | HDLam1 ih = HDLam1 (ds-lem-lam2 ih)
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x₁ [ x₂ ] e2) (HDLam2 hd) | HDLam2 ih = HDLam2 (ds-lem-lam2 ih)
  disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇-⦈[ x₁ ] (HDLam2 hd) | HDHole x = HDHole (HNLam2 x)
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x₁ ] (HDLam2 hd) | HDNEHole x ih = HDNEHole (HNLam2 x) (ds-lem-lam2 ih)
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e2 ∘ e3) (HDLam2 hd) | HDAp ih ih₁ = HDAp (ds-lem-lam2 ih) (ds-lem-lam2 ih₁)

  disjoint-sym _ c (HDHole x) = HDConst
  disjoint-sym _ (e2 ·: x) (HDHole (HNAsc x₁)) = HDAsc (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (X x) (HDHole x₁) = HDVar
  disjoint-sym _ (·λ x e2) (HDHole (HNLam1 x₁)) = HDLam1 (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDHole (HNLam2 x₂)) = HDLam2 (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₂))
  disjoint-sym _ ⦇-⦈[ x ] (HDHole (HNHole x₁)) =  HDHole (HNHole (flip x₁))
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ u' ] (HDHole (HNNEHole x x₁)) = HDNEHole (HNHole (flip x)) (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x₁))
  disjoint-sym _ (e2 ∘ e3) (HDHole (HNAp x x₁)) = HDAp (disjoint-sym ⦇-⦈[ _ ] e2 (HDHole x))
                                                    (disjoint-sym ⦇-⦈[ _ ] e3 (HDHole x₁))

  disjoint-sym _ c (HDNEHole x hd) = HDConst
  disjoint-sym _ (e2 ·: x) (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e ·: x) (HDNEHole (HNAsc x₁) hd) | HDAsc ih = HDAsc (ds-lem-nehole ih x₁)
  disjoint-sym _ (X x) (HDNEHole x₁ hd) = HDVar
  disjoint-sym _ (·λ x e2) (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x e2) (HDNEHole (HNLam1 x₁) hd) | HDLam1 ih = HDLam1 (ds-lem-nehole ih x₁)
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole x₂ hd) with disjoint-sym _ _ hd
  disjoint-sym _ (·λ x [ x₁ ] e2) (HDNEHole (HNLam2 x₂) hd) | HDLam2 ih = HDLam2 (ds-lem-nehole ih x₂)
  disjoint-sym _ ⦇-⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇-⦈[ x ] (HDNEHole (HNHole x₂) hd) | HDHole x₁ = HDHole (HNNEHole (flip x₂) x₁)
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDNEHole x₁ hd) with disjoint-sym _ _ hd
  disjoint-sym _ ⦇⌜ e2 ⌟⦈[ x ] (HDNEHole (HNNEHole x₂ x₃) hd) | HDNEHole x₁ ih = HDNEHole (HNNEHole (flip x₂) x₁) (ds-lem-nehole ih x₃)
  disjoint-sym _ (e2 ∘ e3) (HDNEHole x hd) with disjoint-sym _ _ hd
  disjoint-sym _ (e1 ∘ e3) (HDNEHole (HNAp x x₁) hd) | HDAp ih ih₁ = HDAp (ds-lem-nehole ih x) (ds-lem-nehole ih₁ x₁)

  disjoint-sym _ c (HDAp hd hd₁) = HDConst
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (e3 ·: x) (HDAp hd hd₁) | HDAsc ih | HDAsc ih1 = HDAsc (ds-lem-ap ih ih1)
  disjoint-sym _ (X x) (HDAp hd hd₁) = HDVar
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (·λ x e3) (HDAp hd hd₁) | HDLam1 ih | HDLam1 ih1 = HDLam1 (ds-lem-ap ih ih1)
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (·λ x [ x₁ ] e3) (HDAp hd hd₁) | HDLam2 ih | HDLam2 ih1 = HDLam2 (ds-lem-ap ih ih1)
  disjoint-sym _ ⦇-⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ ⦇-⦈[ x ] (HDAp hd hd₁) | HDHole x₁ | HDHole x₂ = HDHole (HNAp x₁ x₂)
  disjoint-sym _ ⦇⌜ e3 ⌟⦈[ x ] (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ ⦇⌜ e3 ⌟⦈[ x ] (HDAp hd hd₁) | HDNEHole x₁ ih | HDNEHole x₂ ih1 = HDNEHole (HNAp x₁ x₂) (ds-lem-ap ih ih1)
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) with disjoint-sym _ _ hd | disjoint-sym _ _ hd₁
  disjoint-sym _ (e3 ∘ e4) (HDAp hd hd₁) | HDAp ih ih₁ | HDAp ih1 ih2 = HDAp (ds-lem-ap ih ih1) (ds-lem-ap ih₁ ih2)

  -- note that this is false, so holes-disjoint isn't transitive
  -- disjoint-new : ∀{e1 e2 u} → holes-disjoint e1 e2 → hole-name-new e1 u → hole-name-new e2 u

  -- it's also not reflexive, because ⦇-⦈[ u ] isn't hole-disjoint with
  -- itself since refl : u == u; it's also not anti-reflexive, because the
  -- expression c *is* hole-disjoint with itself (albeit vacuously)


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

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

-- This module defines RecordChains and related types and utility definitions

module LibraBFT.Abstract.RecordChain
  (UID    : Set)
  (_≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁))
  (NodeId : Set)
  (𝓔      : EpochConfig UID NodeId)
  (𝓥      : VoteEvidence UID NodeId 𝓔)
  where
 open import LibraBFT.Abstract.Records         UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.Records.Extends UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.Types           UID        NodeId
 open        EpochConfig 𝓔

 -- One way of looking at a 'RecordChain r' is as a path from the epoch's
 -- initial record (I) to r.  For generality, we express this in two steps.
 data RecordChainFrom (o : Record) : Record → Set where
   empty : RecordChainFrom o o
   step  : ∀ {r r'}
         → (rc : RecordChainFrom o r)
         → r ← r'
         → RecordChainFrom o r'

 RecordChain : Record → Set
 RecordChain = RecordChainFrom I

 prevBlock : ∀{q} → RecordChain (Q q) → Block
 prevBlock (step {r = B b} _ (B←Q _ _)) = b

 prevQCorI : ∀{b} → RecordChain (B b) → Record
 prevQCorI (step _ (I←B _ _))           = I
 prevQCorI (step {r = Q q} _ (Q←B _ _)) = Q q

 -- Returns the unique identifier of the parent tagged to be either
 -- the initial block or a B or Q.
 parentUID : ∀{b} → RecordChain (B b) → TypedUID
 parentUID (step {r = I} _ _)   = id-I
 parentUID (step {r = Q q} _ _) = id-B∨Q (qCertBlockId q)

 -- Defition of 'previous_round' as in Section 5.5 (see Abstract.Properties).
 currRound : ∀{r} → RecordChain r → Round
 currRound empty = 0
 currRound (step {r = r} _ _) = round r

 -- TODO-1: it would be cleaner to define prevRound only for RecordChains ending in a Block.
 prevRound : ∀{r} → RecordChain r → Round
 prevRound empty = 0
 prevRound (step rc (I←B x vr)) = 0
 prevRound (step rc (Q←B x vr)) = currRound rc
 prevRound (step rc (B←Q x vr)) = prevRound rc

 -- Extensional definition of prevRound; useful to 'rewrite' on.
 prevRound-ss : ∀{b₁ q b}(rc : RecordChain (B b₁))
              → (ext₁ : B b₁ ← Q q)
              → (ext₀ : Q q  ← B b)
              → prevRound (step (step rc ext₁) ext₀) ≡ bRound b₁
 prevRound-ss rc (B←Q _ _) (Q←B _ _) = refl

 ----------------------
 -- RecordChain Equality and Irrelevance
 --

 -- Distributing a record relation pointwise
 -- over record chains. Let rc₀ and rc₁ be as illustrated
 -- below; a value of type ≈RC-pw, named prf is shown
 -- in between them.
 --
 --  rc₀    : B₀ ← C₀  ← B₁ ← C₁ ← ⋯ ← Bₖ  ← Cₖ
 --
 --  prf      ≈    ≈     ≈    ≈        ≈     ≈
 --
 --  rc₁    : 𝓑₀ ← 𝓒₀ ← 𝓑₁ ← 𝓒₁ ← ⋯ ← 𝓑ₖ ← 𝓒ₖ
 --
 --
 data ≈RC-pw {ℓ}(_≈_ : Rel Record ℓ)
     : ∀{o₀ o₁ r₀ r₁} → RecordChainFrom o₀ r₀ → RecordChainFrom o₁ r₁ → Set ℓ where
   eq-empty : ∀{o₀ o₁} → o₀ ≈ o₁ → ≈RC-pw _≈_ (empty {o = o₀}) (empty {o = o₁})
   eq-step  : ∀{o₀ o₁ r₀ r₁ s₀ s₁}
            → (rc₀ : RecordChainFrom o₀ s₀)
            → (rc₁ : RecordChainFrom o₁ s₁)
            → r₀ ≈ r₁
            → (ext₀ : s₀ ← r₀)
            → (ext₁ : s₁ ← r₁)
            → ≈RC-pw _≈_ rc₀ rc₁
            → ≈RC-pw _≈_ (step rc₀ ext₀) (step rc₁ ext₁)

 -- RecordChain equivalence is then defined in terms of
 -- record equivalence (i.e., we don't care about the set of
 -- votes for the QCs in the chain); borrowing the illustration
 -- above, we now have:
 --
 --  rc₀    : B₀ ← C₀  ← B₁ ← C₁ ← ⋯ ← Bₖ  ← Cₖ
 --
 --  prf      ≡    ≈QC   ≡    ≈QC      ≡     ≈QC
 --
 --  rc₁    : 𝓑₀ ← 𝓒₀ ← 𝓑₁ ← 𝓒₁ ← ⋯ ← 𝓑ₖ ← 𝓒ₖ
 --
 -- It is easy to see that if rc₀ ≈RC rc₁, then they contain
 -- the same blocks (propositionally!) but potentially
 -- different /sets of votes/ certifying said blocks.
 _≈RC_ : ∀{o₀ o₁ r₀ r₁} → RecordChainFrom o₀ r₀ → RecordChainFrom o₁ r₁ → Set
 _≈RC_ = ≈RC-pw _≈Rec_

 ≈RC-head : ∀{o₀ o₁ r₀ r₁}{rc₀ : RecordChainFrom o₀ r₀}{rc₁ : RecordChainFrom o₁ r₁}
          → rc₀ ≈RC rc₁ → o₀ ≈Rec o₁
 ≈RC-head (eq-empty x)          = x
 ≈RC-head (eq-step _ _ _ _ _ x) = ≈RC-head x

 -- Heterogeneous irrelevance of _≈RC_ happens only modulo
 -- propositional non-injectivity of block ids.
 ≈RC-refl : ∀{r₀ r₁}(rc₀ : RecordChain r₀)(rc₁ : RecordChain r₁)
          → r₀ ≈Rec r₁
          → NonInjective _≡_ bId ⊎ (rc₀ ≈RC rc₁)
 ≈RC-refl empty empty hyp
    = inj₂ (eq-empty hyp)
 ≈RC-refl (step r0 x) (step r1 x₁) hyp
    = (←-≈Rec x x₁ hyp ⊎⟫= ≈RC-refl r0 r1)
       ⊎⟫= (inj₂ ∘ eq-step r0 r1 hyp x x₁)
 ≈RC-refl empty (step r1 (I←B x x₁)) ()
 ≈RC-refl empty (step r1 (Q←B x x₁)) ()
 ≈RC-refl empty (step r1 (B←Q x x₁)) ()
 ≈RC-refl (step r0 (I←B x x₁)) empty ()
 ≈RC-refl (step r0 (Q←B x x₁)) empty ()
 ≈RC-refl (step r0 (B←Q x x₁)) empty ()

 ≈RC-sym : ∀{o₀ o₁ r₀ r₁}{rc₀ : RecordChainFrom o₀ r₀}{rc₁ : RecordChainFrom o₁ r₁}
         → rc₀ ≈RC rc₁ → rc₁ ≈RC rc₀
 ≈RC-sym (eq-empty x) = eq-empty (≈Rec-sym x)
 ≈RC-sym (eq-step rc₀ rc₁ x ext₀ ext₁ hyp) = eq-step rc₁ rc₀ (≈Rec-sym x) ext₁ ext₀ (≈RC-sym hyp)

 ≈RC-trans : ∀ {r₀ r₁ r₂}
           → {rc₀ : RecordChain r₀}{rc₁ : RecordChain r₁}{rc₂ : RecordChain r₂}
           → rc₀ ≈RC rc₁ → rc₁ ≈RC rc₂ → rc₀ ≈RC rc₂
 ≈RC-trans (eq-empty x) q = q
 ≈RC-trans (eq-step rc₀ rc₁ x ext₀ ext₁ p) (eq-step .rc₁ rc₂ x₁ .ext₁ ext₂ q)
    = eq-step rc₀ rc₂ (≈Rec-trans x x₁) ext₀ ext₂ (≈RC-trans p q)

 -- Heterogeneous irrelevance proves that two record chains that end at the same record
 -- have the same blocks and equivalent QCs.
 RecordChain-irrelevant : ∀{r}(rc₀ : RecordChain r)(rc₁ : RecordChain r)
                        → NonInjective _≡_ bId ⊎ rc₀ ≈RC rc₁
 RecordChain-irrelevant rc0 rc1 = ≈RC-refl rc0 rc1 ≈Rec-refl

 -------------------------------------------------
 -- Sub RecordChains

 -- A value of type '⊆RC-pw _≈_ rc1 rc2' establishes that rc1 is
 -- a suffix of rc2 modulo _≈_.
 data ⊆RC-pw {ℓ}(_≈_ : Rel Record ℓ)
     : ∀{o₀ o₁ r₀ r₁} → RecordChainFrom o₀ r₀ → RecordChainFrom o₁ r₁ → Set ℓ where
   sub-empty : ∀{o₀ o₁ s₁}{r₁ : RecordChainFrom o₁ s₁} → o₀ ≈ s₁ → ⊆RC-pw _≈_ (empty {o = o₀}) r₁
   sub-step  : ∀{o₀ o₁ r₀ r₁ s₀ s₁}
            → (rc₀ : RecordChainFrom o₀ s₀)
            → (rc₁ : RecordChainFrom o₁ s₁)
            → r₀ ≈ r₁
            → (ext₀ : s₀ ← r₀)
            → (ext₁ : s₁ ← r₁)
            → ⊆RC-pw _≈_ rc₀ rc₁
            → ⊆RC-pw _≈_ (step rc₀ ext₀) (step rc₁ ext₁)

 _⊆RC_ : ∀{o₀ o₁ r₀ r₁} → RecordChainFrom o₀ r₀ → RecordChainFrom o₁ r₁ → Set
 _⊆RC_ = ⊆RC-pw _≈Rec_

 -- The ⊆RC relation is used to establish irrelevance of suffixes
 RecordChainFrom-irrelevant : ∀{o₀ o₁ r₀ r₁}(rc₀ : RecordChainFrom o₀ r₀)(rc₁ : RecordChainFrom o₁ r₁)
                            → r₀ ≈Rec r₁
                            → NonInjective _≡_ bId ⊎ (rc₀ ⊆RC rc₁ ⊎ rc₁ ⊆RC rc₀)
 RecordChainFrom-irrelevant empty empty hyp = inj₂ (inj₁ (sub-empty hyp))
 RecordChainFrom-irrelevant empty (step rc1 x) hyp = inj₂ (inj₁ (sub-empty hyp))
 RecordChainFrom-irrelevant (step rc0 x) empty hyp = inj₂ (inj₂ (sub-empty (≈Rec-sym hyp)))
 RecordChainFrom-irrelevant (step rc0 x) (step rc1 x₁) hyp
   = (←-≈Rec x x₁ hyp ⊎⟫= RecordChainFrom-irrelevant rc0 rc1)
     ⊎⟫= (inj₂ ∘ either (inj₁ ∘ sub-step rc0 rc1 hyp x x₁) (inj₂ ∘ sub-step rc1 rc0 (≈Rec-sym hyp) x₁ x))

 -- If a chain from the initial record is a suffix from a second chain,
 -- then the second chain is also from the initial record.
 RecordChain-glb : ∀{o' r r'}{rc : RecordChain r}{rcf : RecordChainFrom o' r'}
                 → rc ⊆RC rcf
                 → rc ≈RC rcf
 RecordChain-glb {rcf = step _ ()} (sub-empty eq-I)
 RecordChain-glb {rcf = empty}     (sub-empty eq-I) = eq-empty eq-I
 RecordChain-glb (sub-step rc₀ rc₁ x ext₀ ext₁ sub) = eq-step rc₀ rc₁ x ext₀ ext₁ (RecordChain-glb sub)

 -------------------------------------------------
 -- Id congruences over RecordChain equivalences

 parentUID-≈ : ∀{b₀ b₁}(rc₀ : RecordChain (B b₀))(rc₁ : RecordChain (B b₁))
             → rc₀ ≈RC rc₁
             → parentUID rc₀ ≡ parentUID rc₁
 parentUID-≈ _ _ (eq-step _ _ (eq-B refl) _ _ (eq-empty x)) = refl
 parentUID-≈ _ _ (eq-step _ _ (eq-B refl) _ _ (eq-step _ _ (eq-Q refl) _ _ _)) = refl

 --------------------------
 -- RecordChain elements

 data _∈RC-simple_ {o : Record}(r₀ : Record) : ∀{r₁} → RecordChainFrom o r₁ → Set where
   here   : ∀{rc : RecordChainFrom o r₀} → r₀ ∈RC-simple rc
   there  : ∀{r₁ r₂}{rc : RecordChainFrom o r₁}(p : r₁ ← r₂)
          → r₀ ∈RC-simple rc
          → r₀ ∈RC-simple (step rc p)

 -- States that a given record belongs in a record chain.
 data _∈RC_ {o : Record}(r₀ : Record) : ∀{r₁} → RecordChainFrom o r₁ → Set where
   here   : ∀{rc : RecordChainFrom o r₀} → r₀ ∈RC rc
   there  : ∀{r₁ r₂}{rc : RecordChainFrom o r₁}(p : r₁ ← r₂)
          → r₀ ∈RC rc
          → r₀ ∈RC (step rc p)
   -- This is an important rule. It is the equivalent of a
   -- /congruence/ on record chains and enables us to prove
   -- the 𝕂-chain-∈RC property.
   transp : ∀{r}{rc₀ : RecordChainFrom o r}{rc₁ : RecordChainFrom o r}
          → r₀ ∈RC rc₀ → rc₀ ≈RC rc₁ → r₀ ∈RC rc₁

 ∈RC-empty-I : ∀{r} → r ∈RC (empty {o = I}) → r ≡ I
 ∈RC-empty-I here                      = refl
 ∈RC-empty-I (transp old (eq-empty x)) = ∈RC-empty-I old

 b∉RCempty : ∀ {b} → B b ∈RC empty → ⊥
 b∉RCempty xx with ∈RC-empty-I xx
 ...| ()

 transp-B∈RC : ∀{r r' b}{rc : RecordChain r}{rc' : RecordChain r'}
             → rc ≈RC rc' → B b ∈RC rc → B b ∈RC rc'
 transp-B∈RC rc≈rc' (transp b∈rc x) = transp-B∈RC (≈RC-trans x rc≈rc') b∈rc
 transp-B∈RC (eq-step rc₀ rc₁ (eq-B refl) ext₀ ext₁ rc≈rc') here = here
 transp-B∈RC (eq-step rc₀ rc₁ x .p ext₁ rc≈rc') (there p b∈rc) = there ext₁ (transp-B∈RC rc≈rc' b∈rc)

 -- A k-chain (paper Section 5.2; see Abstract.Properties) is a sequence of
 -- blocks and quorum certificates for said blocks:
 --
 --  B₀ ← C₀ ← B₁ ← C₁ ← ⋯ ← Bₖ ← Cₖ
 --
 -- such that for each Bᵢ some predicate R is satisfies for Bᵢ and Bᵢ₊₁.
 -- The first parameter R enables predicate definitions to avoid the need
 -- to find a predecessor for B₀ (see Contig definition below).
 --
 -- The 𝕂-chain datatype captures exactly that structure.
 --
 data 𝕂-chain (R : ℕ → Record → Record → Set)
     : (k : ℕ){o r : Record} → RecordChainFrom o r → Set where
   0-chain : ∀{o r}{rc : RecordChainFrom o r} → 𝕂-chain R 0 rc
   s-chain : ∀{k o r}{rc : RecordChainFrom o r}{b : Block}{q : QC}
           → (r←b : r   ← B b)
           → (prf : R k r (B b))
           → (b←q : B b ← Q q)
           → 𝕂-chain R k rc
           → 𝕂-chain R (suc k) (step (step rc r←b) b←q)

 -- Simple 𝕂-chains do not impose any restricton on its records.
 Simple : ℕ → Record → Record → Set
 Simple _ _ _ = Unit

 -- Contiguous 𝕂-chains are those in which all adjacent pairs of Records have contiguous rounds.
 Contig : ℕ → Record → Record → Set
 Contig 0       _  _ = Unit
 Contig (suc _) r r' = round r' ≡ suc (round r)

 -- The 'Contig' relation is substitutive in a rather restrictive setting,
 -- but this is enough for our purposes.
 Contig-subst : ∀{k r r' b}{rc : RecordChain r}{rc' : RecordChain r'}
              → rc ≈RC rc'
              → r ← (B b)
              → Contig k r (B b) → Contig k r' (B b)
 Contig-subst {zero}  _            _ _  = unit
 Contig-subst {suc k} (eq-empty x) _ cr = cr
 Contig-subst {suc k} (eq-step .(step rc₀ ext₂) .(step rc₁ ext₃) (eq-Q x) (B←Q refl refl) (B←Q refl refl)
                    (eq-step rc₀ rc₁ (eq-B refl) ext₂ ext₃ rc≈rc')) (Q←B h0 h1) cr = cr

 -- Consequently, contiguous 𝕂-chains are substitutive w.r.t. _≈RC_
 transp-𝕂-chain : ∀{k r r'}{rc : RecordChain r}{rc' : RecordChain r'}
                → rc ≈RC rc'
                → 𝕂-chain Contig k rc
                → 𝕂-chain Contig k rc'
 transp-𝕂-chain rc≈rc' 0-chain = 0-chain
 transp-𝕂-chain (eq-step .(step rc₀ r←b) .(step rc₁ r←b') (eq-Q refl) _ ext₁
                   (eq-step rc₀ rc₁ (eq-B refl) .r←b r←b' rc≈rc'))
                (s-chain r←b prf (B←Q _ _) kc) =
    s-chain r←b' (Contig-subst rc≈rc' r←b prf) ext₁ (transp-𝕂-chain rc≈rc' kc)

 -- TODO-2: Consider duplicating the above for the ⊆RC relation.
 -- I believe we can generalize all of this via the same function, but
 -- it's nontrivial to change the whole module.
 --
 -- Arguably, the right way to deal with all of this would be to
 -- design the bare record chain type as the most expressive possible:
 --
 -- data RC : ℕ → Record → Record
 --
 -- Then, a value r of type 'RC 12 I (B b)' represents a record chain with
 -- 12 steps from I to (B b). K-chains become trivial to express:
 --
 -- K-chain k = RC (2*k) ...

 Contig-subst-⊆ : ∀{k o o' r r' b}{rc : RecordChainFrom o r}{rc' : RecordChainFrom o' r'}
                → (kc : 𝕂-chain Contig k rc)
                → rc ⊆RC rc'
                → r ← (B b)
                → Contig k r (B b) → Contig k r' (B b)
 Contig-subst-⊆ 0-chain _ ext hyp = unit
 Contig-subst-⊆ (s-chain r←b prf _ kc) (sub-step _ _ (eq-Q x) (B←Q refl refl) (B←Q refl refl)
                                         (sub-step rc₀ rc₁ (eq-B refl) .r←b ext₂ sub)) ext hyp
   = hyp

 transp-𝕂-chain-⊆ : ∀{k o o' r r'}{rc : RecordChainFrom o r}{rc' : RecordChainFrom o' r'}
                → rc ⊆RC rc'
                → 𝕂-chain Contig k rc
                → 𝕂-chain Contig k rc'
 transp-𝕂-chain-⊆ rc⊆rc' 0-chain = 0-chain
 transp-𝕂-chain-⊆ (sub-step .(step rc₀ r←b) .(step rc₁ r←b') (eq-Q refl) _ ext₁
                   (sub-step rc₀ rc₁ (eq-B refl) .r←b r←b' rc⊆rc'))
                (s-chain r←b prf (B←Q _ _) kc) =
    s-chain r←b' (Contig-subst-⊆ kc rc⊆rc' r←b prf) ext₁ (transp-𝕂-chain-⊆ rc⊆rc' kc)

 𝕂-chain-contig : (k : ℕ){o r : Record} → RecordChainFrom o r → Set
 𝕂-chain-contig = 𝕂-chain Contig

 𝕂-chain-to-Simple : ∀{R k r}{rc : RecordChain r} → 𝕂-chain R k rc → 𝕂-chain Simple k rc
 𝕂-chain-to-Simple 0-chain = 0-chain
 𝕂-chain-to-Simple (s-chain r←b prf b←q kc) = s-chain r←b unit b←q (𝕂-chain-to-Simple kc)

 -- Every record chain that ends in a QC is a 𝕂-chain
 to-kchain : ∀{q}(rc : RecordChain (Q q)) → ∃[ k ] (𝕂-chain Simple k rc)
 to-kchain (step (step {B b} rc ()) x@(B←Q _ _))
 to-kchain (step (step {I} rc x₁)   x@(B←Q _ _))
  = 1 , s-chain x₁ unit x 0-chain
 to-kchain (step (step {Q q} rc x₁) x@(B←Q _ _))
  with to-kchain rc
 ...| k , kc = suc k , s-chain x₁ unit x kc

 kchainForget : ∀{P k r}{rc : RecordChain r}(c : 𝕂-chain P k rc) → RecordChain r
 kchainForget {rc = rc} _ = rc

 -- Returns the round of the block heading the k-chain.
 kchainHeadRound : ∀{k r P}{rc : RecordChain r} → 𝕂-chain P k rc → Round
 kchainHeadRound (0-chain {r = r})      = round r
 kchainHeadRound (s-chain r←b _ b←q kk) = kchainHeadRound kk

 kchainBlock : ∀{k o r P}{rc : RecordChainFrom o r} → Fin k → 𝕂-chain P k rc → Block
 kchainBlock zero    (s-chain {b = b} _ _ _ _) = b
 kchainBlock (suc x) (s-chain r←b _ b←q kk)    = kchainBlock x kk

 kchainBlock-toSimple-≡
   : ∀{k r P}{rc : RecordChain r}(x : Fin k)(c : 𝕂-chain P k rc)
   → kchainBlock x (𝕂-chain-to-Simple c) ≡ kchainBlock x c
 kchainBlock-toSimple-≡ zero    (s-chain _ _ _ _)  = refl
 kchainBlock-toSimple-≡ (suc x) (s-chain _ _ _ kk) = kchainBlock-toSimple-≡ x kk

 _b⟦_⟧ : ∀{k o r P}{rc : RecordChainFrom o r} → 𝕂-chain P k rc → Fin k → Block
 chain b⟦ ix ⟧ = kchainBlock ix chain

 kchainBlock-≈RC : ∀{k r r'}{rc : RecordChain r}{rc' : RecordChain r'}
                 → (c3 : 𝕂-chain Contig k rc)(ix : Fin k)
                 → (rc≈rc' : rc ≈RC rc')
                 → c3 b⟦ ix ⟧ ≡ transp-𝕂-chain rc≈rc' c3 b⟦ ix ⟧
 kchainBlock-≈RC 0-chain () _
 kchainBlock-≈RC (s-chain r←b prf (B←Q _ _) kc) ix
                 (eq-step .(step rc₀ r←b) .(step rc₁ r←b') (eq-Q refl) _ ext₁
                   (eq-step rc₀ rc₁ (eq-B refl) .r←b r←b' rc≈rc'))
   with ix
 ...| zero    = refl
 ...| suc ix' = kchainBlock-≈RC kc ix' rc≈rc'

 kchainBlock-⊆RC : ∀{k o o' r r'}{rc : RecordChainFrom o r}{rc' : RecordChainFrom o' r'}
                 → (c3 : 𝕂-chain Contig k rc)(ix : Fin k)
                 → (rc⊆rc' : rc ⊆RC rc')
                 → c3 b⟦ ix ⟧ ≡ transp-𝕂-chain-⊆ rc⊆rc' c3 b⟦ ix ⟧
 kchainBlock-⊆RC 0-chain () _
 kchainBlock-⊆RC (s-chain r←b prf (B←Q _ _) kc) ix
                 (sub-step .(step rc₀ r←b) .(step rc₁ r←b') (eq-Q refl) _ ext₁
                   (sub-step rc₀ rc₁ (eq-B refl) .r←b r←b' rc≈rc'))
   with ix
 ...| zero    = refl
 ...| suc ix' = kchainBlock-⊆RC kc ix' rc≈rc'

 kchainQC : ∀{k r P}{rc : RecordChain r} → Fin k → 𝕂-chain P k rc → QC
 kchainQC zero    (s-chain {q = q} _ _ _ _) = q
 kchainQC (suc x) (s-chain r←b _ b←q kk)    = kchainQC x kk

 kchain-to-RecordChain-at-b⟦⟧
   : ∀{P k r}{rc : RecordChain r}(c : 𝕂-chain P k rc)(ix : Fin k)
   → RecordChain (B (c b⟦ ix ⟧))
 kchain-to-RecordChain-at-b⟦⟧ 0-chain ()
 kchain-to-RecordChain-at-b⟦⟧ (s-chain {rc = rc} r←b x b←q c) zero
   = (step rc r←b)
 kchain-to-RecordChain-at-b⟦⟧ (s-chain r←b x b←q c) (suc zz)
   = kchain-to-RecordChain-at-b⟦⟧ c zz

 kchainBlockRoundZero-lemma
   : ∀{k q P}{rc : RecordChain (Q q)}(c : 𝕂-chain P (suc k) rc)
   → getRound (kchainBlock zero c) ≡ getRound q
 kchainBlockRoundZero-lemma (s-chain r←b prf (B←Q r h) c) = sym r

 kchainBlockRound≤ : ∀{k r P}{rc : RecordChain r}(x y : Fin k)(kc : 𝕂-chain P k rc)
                   → x ≤Fin y → getRound (kchainBlock y kc) ≤ getRound (kchainBlock x kc)
 kchainBlockRound≤ zero zero (s-chain r←b prf b←q kc) hyp = ≤-refl
 kchainBlockRound≤ zero (suc y) (s-chain (Q←B r r←b) prf b←q (s-chain r←b₁ prf₁ (B←Q refl b←q₁) kc)) hyp
   = ≤-trans (kchainBlockRound≤ zero y (s-chain r←b₁ prf₁ (B←Q refl b←q₁) kc) z≤n) (<⇒≤ r)
 kchainBlockRound≤ (suc x) (suc y) (s-chain r←b prf b←q kc) (s≤s hyp)
   = kchainBlockRound≤ x y kc hyp

 kchain-round-≤-lemma'
   : ∀{k q}{rc : RecordChain (Q q)}(c3 : 𝕂-chain Contig k rc)(ix : Fin k)
   → getRound (c3 b⟦ ix ⟧) ≤ getRound q
 kchain-round-≤-lemma' (s-chain r←b x (B←Q refl b←q) c3) zero = ≤-refl
 kchain-round-≤-lemma' (s-chain (I←B prf imp) unit (B←Q refl _) 0-chain) (suc ())
 kchain-round-≤-lemma' (s-chain (Q←B prf imp) x (B←Q refl _) c2) (suc ix)
   = ≤-trans (kchain-round-≤-lemma' c2 ix) (<⇒≤ prf)

 rc-←-maxRound : ∀{r r'}(rc : RecordChain r') → r ∈RC rc → round r ≤ round r'
 rc-←-maxRound rc here                 = ≤-refl
 rc-←-maxRound rc (transp n x)         = rc-←-maxRound _ n
 rc-←-maxRound .(step _ p) (there p n) = ≤-trans (rc-←-maxRound _ n) (←-round-≤ p)

 kchainBlock-correct
   : ∀{P k q b}{rc : RecordChain (B b)}{b←q : B b ← Q q}
   → (kc : 𝕂-chain P k (step rc b←q))
   → (x : Fin k) → (B (kc b⟦ x ⟧)) ∈RC rc
 kchainBlock-correct (s-chain r←b prf b←q kc) zero = here
 kchainBlock-correct (s-chain r←b prf b←q (s-chain r←b₁ prf₁ b←q₁ kc)) (suc x)
   = there r←b (there b←q₁ (kchainBlock-correct (s-chain r←b₁ prf₁ b←q₁ kc) x))

 -- This is an extended form of RecordChain-irrelevance.
 -- Let rc be:
 --
 --  B₀ ← C₀ ← B₁ ← C₁ ← ⋯ ← Bₙ ← Cₙ
 --
 -- The (c : 𝕂-chain P k rc) is a predicate on the shape
 -- of rc, establishing that it must be of the following shape:
 -- (where consecutive blocks satisfy P)
 --
 --  B₀ ← C₀ ← B₁ ← C₁ ← ⋯ ← Bₙ₋ₖ ← Cₙ₋ₖ ⋯ ← Bₙ₋₁ ← Cₙ₋₁ ← Bₙ ← Cₙ
 --                           /\             /\            /
 --                     ⋯ P ₋⌟  ⌞₋₋₋₋ P ₋₋₋₋⌟  ⌞₋₋₋₋ P ₋₋₋⌟
 --
 -- This property states that any other RecordChain that contains one
 -- block b of the kchain above, it also contains the prefix of the
 -- kchain leading to b.
 --
 𝕂-chain-∈RC : ∀{r k P}{rc : RecordChain r}
             → (c : 𝕂-chain P k rc)
             → (x y : Fin k)
             → x ≤Fin y
             → {b : Block}(prf : kchainBlock x c ≡ b)
             → (rc₁ : RecordChain (B b))
             → NonInjective _≡_ bId ⊎ (B (kchainBlock y c) ∈RC rc₁)
 𝕂-chain-∈RC (s-chain r←b prf b←q c) zero y z≤n refl rc1
   with RecordChain-irrelevant (step (kchainForget c) r←b) rc1
 ...| inj₁ hb   = inj₁ hb
 ...| inj₂ res  = inj₂ (transp (kchainBlock-correct (s-chain r←b prf b←q c) y) res)
 𝕂-chain-∈RC (s-chain r←b prf b←q c) (suc x) (suc y) (s≤s x≤y) hyp rc1
   = 𝕂-chain-∈RC c x y x≤y hyp rc1

 -----------------
 -- Commit Rule --

 -- A block (and everything preceeding it) is said to match the commit rule
 -- when the block is the head of a contiguious 3-chain. Here we define an auxiliary
 -- datatype to make definitions more readable.
 data CommitRuleFrom {o r : Record}(rc : RecordChainFrom o r)(b : Block) : Set where
   commit-rule : (c3 : 𝕂-chain Contig 3 rc)
               → b ≡ c3 b⟦ suc (suc zero) ⟧
               → CommitRuleFrom rc b

 CommitRule : ∀{r} → RecordChain r → Block → Set
 CommitRule = CommitRuleFrom

 transp-CR : ∀{b q}{rc rc' : RecordChain (Q q)}
           → rc ≈RC rc'
           → CommitRule rc  b
           → CommitRule rc' b
 transp-CR rc≈rc' (commit-rule c3 x) =
   commit-rule (transp-𝕂-chain rc≈rc' c3)
               (trans x (kchainBlock-≈RC c3 (suc (suc zero)) rc≈rc'))

 crf⇒cr : ∀ {o q b}
        → (rcf : RecordChainFrom o (Q q))
        → (rc : RecordChain (Q q))
        → CommitRuleFrom rcf b
        → NonInjective-≡ bId ⊎ CommitRule {Q q} rc b
 crf⇒cr rcf rc (commit-rule c3 prf)
   with RecordChainFrom-irrelevant rcf rc ≈Rec-refl
 ...| inj₁ hb = inj₁ hb
 ...| inj₂ (inj₁ rcf⊆rc) = inj₂ (commit-rule (transp-𝕂-chain-⊆ rcf⊆rc c3)
                                             (trans prf (kchainBlock-⊆RC c3 (suc (suc zero)) rcf⊆rc)))
 ...| inj₂ (inj₂ rc⊆rcf)
   with ≈RC-sym (RecordChain-glb rc⊆rcf)
 ...| rcf≈rc
   with ≈RC-head rcf≈rc
 ...| eq-I = inj₂ (transp-CR rcf≈rc (commit-rule c3 prf))

 vote≡⇒QPrevId≡ : {q q' : QC} {v v' : Vote}
                → v  ∈ qcVotes q
                → v' ∈ qcVotes q'
                → v ≡ v'
                → qCertBlockId q ≡ qCertBlockId q'
 vote≡⇒QPrevId≡ {q} {q'} v∈q v'∈q' refl
     with witness v∈q (qVotes-C2 q) | witness v'∈q' (qVotes-C2 q')
 ... | refl | refl = refl

 vote≡⇒QRound≡ : {q q' : QC} {v v' : Vote}
               → v  ∈ qcVotes q
               → v' ∈ qcVotes q'
               → v ≡ v'
               → getRound q ≡ getRound q'
 vote≡⇒QRound≡ {q} {q'} v∈q v'∈q' refl
     with witness v∈q (qVotes-C3 q) | witness v'∈q' (qVotes-C3 q')
 ... | refl | refl = refl

 ¬bRound≡0 : ∀{b} → RecordChain (B b) → ¬ (getRound b ≡ 0)
 ¬bRound≡0 (step s (I←B ()  h)) refl
 ¬bRound≡0 (step s (Q←B () h)) refl


-- Andreas, 2018-10-27, issue #3323, reported by Guillaume Brunerie
--
-- Mismatches between original and repeated parameter list
-- should not lead to internal errors.

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality

data T .(b : Bool) : Set
data T b where  -- Omission of relevance info allowed
  c : Bool → T b

test : ∀{b b'} → T b ≡ T b'
test = refl

-- Should succeed.

record R (@0 b : Bool) : Set
record R b where
  field foo : Bool

-- Should succeed.