{- 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 Level using (0ℓ)
open import Util.Prelude

-- This module incldes various Agda lemmas that are independent of the project's domain

module Util.Lemmas where

 cong₃ : ∀{a b c d}{A : Set a}{B : Set b}{C : Set c}{D : Set d}
       → (f : A → B → C → D) → ∀{x y u v m n} → x ≡ y → u ≡ v → m ≡ n
       → f x u m ≡ f y v n
 cong₃ f refl refl refl = refl

 ≡-pi : ∀{a}{A : Set a}{x y : A}(p q : x ≡ y) → p ≡ q
 ≡-pi refl refl = refl

 Unit-pi : {u1 u2 : Unit}
         → u1 ≡ u2
 Unit-pi {unit} {unit} = refl

 ++-inj : ∀{a}{A : Set a}{m n o p : List A}
        → length m ≡ length n → m ++ o ≡ n ++ p
        → m ≡ n × o ≡ p
 ++-inj {m = []}     {x ∷ n} () hip
 ++-inj {m = x ∷ m}  {[]}    () hip
 ++-inj {m = []}     {[]}     lhip hip
   = refl , hip
 ++-inj {m = m ∷ ms} {n ∷ ns} lhip hip
   with ++-inj {m = ms} {ns} (suc-injective lhip) (proj₂ (∷-injective hip))
 ...| (mn , op) rewrite proj₁ (∷-injective hip)
    = cong (n ∷_) mn , op

 ++-abs : ∀{a}{A : Set a}{n : List A}(m : List A)
        → 1 ≤ length m → [] ≡ m ++ n → ⊥
 ++-abs [] ()
 ++-abs (x ∷ m) imp ()

 filter-++-[]
   : ∀ {a p} {A : Set a} {P : (a : A) → Set p}
     → ∀ xs ys (p : (a : A) → Dec (P a))
     → List-filter p xs ≡ [] → List-filter p ys ≡ []
     → List-filter p (xs ++ ys) ≡ []
 filter-++-[] xs ys p pf₁ pf₂ rewrite List-filter-++ p xs ys | pf₁ | pf₂ = refl

 filter-∪?-[]₁
   : ∀ {a p} {A : Set a} {P Q : (a : A) → Set p}
     → ∀ xs (p : (a : A) → Dec (P a)) (q : (a : A) → Dec (Q a))
     → List-filter (p ∪? q) xs ≡ []
     → List-filter p xs ≡ []
 filter-∪?-[]₁ [] p q pf = refl
 filter-∪?-[]₁ (x ∷ xs) p q pf
   with p x
 ...| no  proof₁
   with q x
 ...| no  proof₂ = filter-∪?-[]₁ xs p q pf
 filter-∪?-[]₁ (x ∷ xs) p q () | no proof₁ | yes proof₂
 filter-∪?-[]₁ (x ∷ xs) p q () | yes proof

 filter-∪?-[]₂
   : ∀ {a p} {A : Set a} {P Q : (a : A) → Set p}
     → ∀ xs (p : (a : A) → Dec (P a)) (q : (a : A) → Dec (Q a))
     → List-filter (p ∪? q) xs ≡ []
     → List-filter q xs ≡ []
 filter-∪?-[]₂ [] p q pf = refl
 filter-∪?-[]₂ (x ∷ xs) p q pf
   with p x
 ...| no  proof₁
   with q x
 ...| no  proof₂ = filter-∪?-[]₂ xs p q pf
 filter-∪?-[]₂ (x ∷ xs) p q () | no proof₁ | yes proof₂
 filter-∪?-[]₂ (x ∷ xs) p q () | yes proof

 noneOfKind⇒¬Any
   : ∀ {a p} {A : Set a} {P : A → Set p}
       xs (p : (a : A) → Dec (P a))
     → NoneOfKind xs p
     → ¬ Any P xs
 noneOfKind⇒¬Any (x ∷ xs) p none ∈xs
    with p x
 noneOfKind⇒¬Any (x ∷ xs) p none (here   px) | no ¬px = ¬px px
 noneOfKind⇒¬Any (x ∷ xs) p none (there ∈xs) | no ¬px =
   noneOfKind⇒¬Any xs p none ∈xs

 noneOfKind⇒All¬
   : ∀ {a p} {A : Set a} {P : A → Set p}
       xs (p : (a : A) → Dec (P a))
     → NoneOfKind xs p
     → All (¬_ ∘ P) xs
 noneOfKind⇒All¬ xs p none = ¬Any⇒All¬ xs (noneOfKind⇒¬Any xs p none)

 ++-NoneOfKind : ∀ {ℓA} {A : Set ℓA} {ℓ} {P : A → Set ℓ} xs ys (p : (a : A) → Dec (P a))
                 → NoneOfKind xs p → NoneOfKind ys p → NoneOfKind (xs ++ ys) p
 ++-NoneOfKind xs ys p nok₁ nok₂ = filter-++-[] xs ys p nok₁ nok₂

 data All-vec {ℓ} {A : Set ℓ} (P : A → Set ℓ) : ∀ {n} → Vec {ℓ} A n → Set (Level.suc ℓ) where
   []  : All-vec P []
   _∷_ : ∀ {x n} {xs : Vec A n} (px : P x) (pxs : All-vec P xs) → All-vec P (x ∷ xs)

 ≤-unstep : ∀{m n} → suc m ≤ n → m ≤ n
 ≤-unstep (s≤s ss) = ≤-step ss

 ≡⇒≤ : ∀{m n} → m ≡ n → m ≤ n
 ≡⇒≤ refl = ≤-refl

 ∈-cong : ∀{a b}{A : Set a}{B : Set b}{x : A}{l : List A}
        → (f : A → B) → x ∈ l → f x ∈ List-map f l
 ∈-cong f (here px) = here (cong f px)
 ∈-cong f (there hyp) = there (∈-cong f hyp)

 All-self : ∀{a}{A : Set a}{xs : List A} → All (_∈ xs) xs
 All-self = All-tabulate (λ x → x)

 All-reduce⁺
   : ∀{a b}{A : Set a}{B : Set b}{Q : A → Set}{P : B → Set}
   → { xs : List A }
   → (f : ∀{x} → Q x → B)
   → (∀{x} → (prf : Q x) → P (f prf))
   → (all : All Q xs)
   → All P (All-reduce f all)
 All-reduce⁺ f hyp []         = []
 All-reduce⁺ f hyp (ax ∷ axs) = (hyp ax) ∷ All-reduce⁺ f hyp axs

 All-reduce⁻
   : ∀{a b}{A : Set a}{B : Set b}
     {Q : A → Set}
   → { xs : List A }
   → ∀ {vdq}
   → (f : ∀{x} → Q x → B)
   → (all : All Q xs)
   → vdq ∈ All-reduce f all
   → ∃[ v ] ∃[ v∈xs ] (vdq ≡ f {v} v∈xs)
 All-reduce⁻ {Q = Q} {(h ∷ _)} {vdq} f (px ∷ pxs) (here refl)  = h , px , refl
 All-reduce⁻ {Q = Q} {(_ ∷ t)} {vdq} f (px ∷ pxs) (there vdq∈) = All-reduce⁻ {xs = t} f pxs vdq∈

 List-index : ∀ {A : Set} → (_≟A_ : (a₁ a₂ : A) → Dec (a₁ ≡ a₂)) → A → (l : List A) → Maybe (Fin (length l))
 List-index _≟A_ x l with break (_≟A x) l
 ...| not≡ , _ with length not≡ <? length l
 ...| no  _     = nothing
 ...| yes found = just ( fromℕ< {length not≡} {length l} found)

 nats : ℕ → List ℕ
 nats 0 = []
 nats (suc n) = (nats n) ++ (n ∷ [])

 _ : nats 4 ≡ 0 ∷ 1 ∷ 2 ∷ 3 ∷ []
 _ = refl

 _ : Maybe-map toℕ (List-index _≟_ 2 (nats 4)) ≡ just 2
 _ = refl

 _ : Maybe-map toℕ (List-index _≟_ 4 (nats 4)) ≡ nothing
 _ = refl

 allDistinct : ∀ {A : Set} → List A → Set
 allDistinct l = ∀ (i j : Fin (length l))
                 → i ≡ j ⊎ List-lookup l i ≢ List-lookup l j

 postulate -- TODO-1: currently unused; prove it, if needed
   allDistinct? : ∀ {A : Set} → {≟A : (a₁ a₂ : A) → Dec (a₁ ≡ a₂)} → (l : List A) → Dec (allDistinct l)

  -- Extends an arbitrary relation to work on the head of
  -- the supplied list, if any.
 data OnHead {A : Set}(P : A → A → Set) (x : A) : List A → Set where
    []   : OnHead P x []
    on-∷ : ∀{y ys} → P x y → OnHead P x (y ∷ ys)

  -- Establishes that a list is sorted according to the supplied
  -- relation.
 data IsSorted {A : Set}(_<_ : A → A → Set) : List A → Set where
    []  : IsSorted _<_ []
    _∷_ : ∀{x xs} → OnHead _<_ x xs → IsSorted _<_ xs → IsSorted _<_ (x ∷ xs)

 OnHead-prop : ∀{A}(P : A → A → Set)(x : A)(l : List A)
             → Irrelevant P
             → isPropositional (OnHead P x l)
 OnHead-prop P x [] hyp [] [] = refl
 OnHead-prop P x (x₁ ∷ l) hyp (on-∷ x₂) (on-∷ x₃) = cong on-∷ (hyp x₂ x₃)

 IsSorted-prop : ∀{A}(_<_ : A → A → Set)(l : List A)
               → Irrelevant _<_
               → isPropositional (IsSorted _<_ l)
 IsSorted-prop _<_ [] hyp [] []                  = refl
 IsSorted-prop _<_ (x ∷ l) hyp (x₁ ∷ a) (x₂ ∷ b)
   = cong₂ _∷_ (OnHead-prop _<_ x l hyp x₁ x₂)
               (IsSorted-prop _<_ l hyp a b)

 IsSorted-map⁻ : {A : Set}{_≤_ : A → A → Set}
               → {B : Set}(f : B → A)(l : List B)
               → IsSorted (λ x y → f x ≤ f y) l
               → IsSorted _≤_ (List-map f l)
 IsSorted-map⁻ f .[] [] = []
 IsSorted-map⁻ f .(_ ∷ []) (x ∷ []) = [] ∷ []
 IsSorted-map⁻ f .(_ ∷ _ ∷ _) (on-∷ x ∷ (x₁ ∷ is)) = (on-∷ x) ∷ IsSorted-map⁻ f _ (x₁ ∷ is)

 transOnHead : ∀ {A} {l : List A} {y x : A} {_<_ : A → A → Set}
              → Transitive _<_
              → OnHead _<_ y l
              → x < y
              → OnHead _<_ x l
 transOnHead _ [] _ = []
 transOnHead trans (on-∷ y<f) x<y = on-∷ (trans x<y y<f)

 ++-OnHead : ∀ {A} {xs ys : List A} {y : A} {_<_ : A → A → Set}
           → OnHead _<_ y xs
           → OnHead _<_ y ys
           → OnHead _<_ y (xs ++ ys)
 ++-OnHead []         y<y₁ = y<y₁
 ++-OnHead (on-∷ y<x) _    = on-∷ y<x

 h∉t : ∀ {A} {t : List A} {h : A} {_<_ : A → A → Set}
     → Irreflexive _<_ _≡_ → Transitive _<_
     → IsSorted _<_ (h ∷ t)
     → h ∉ t
 h∉t irfl trans (on-∷ h< ∷ sxs) (here refl) = ⊥-elim (irfl h< refl)
 h∉t irfl trans (on-∷ h< ∷ (x₁< ∷ sxs)) (there h∈t)
   = h∉t irfl trans ((transOnHead trans x₁< h<) ∷ sxs) h∈t

 ≤-head : ∀ {A} {l : List A} {x y : A} {_<_ : A → A → Set} {_≤_ : A → A → Set}
        → Reflexive _≤_ → Trans _<_ _≤_ _≤_
        → y ∈ (x ∷ l) → IsSorted _<_ (x ∷ l)
        → _≤_ x y
 ≤-head ref≤ trans (here refl) _ = ref≤
 ≤-head ref≤ trans (there y∈) (on-∷ x<x₁ ∷ sl) = trans x<x₁ (≤-head ref≤ trans y∈ sl)

 -- TODO-1 : Better name and/or replace with library property
 Any-sym : ∀ {a b}{A : Set a}{B : Set b}{tgt : B}{l : List A}{f : A → B}
         → Any (λ x → tgt ≡ f x) l
         → Any (λ x → f x ≡ tgt) l
 Any-sym (here x)  = here (sym x)
 Any-sym (there x) = there (Any-sym x)

 Any-lookup-correct :  ∀ {a b}{A : Set a}{B : Set b}{tgt : B}{l : List A}{f : A → B}
                    → (p : Any (λ x → f x ≡ tgt) l)
                    → Any-lookup p ∈ l
 Any-lookup-correct (here px) = here refl
 Any-lookup-correct (there p) = there (Any-lookup-correct p)

 Any-lookup-correctP :  ∀ {a}{A : Set a}{l : List A}{P : A → Set}
                     → (p : Any P l)
                     → Any-lookup p ∈ l
 Any-lookup-correctP (here px) = here refl
 Any-lookup-correctP (there p) = there (Any-lookup-correctP p)

 Any-witness : ∀ {a b} {A : Set a} {l : List A} {P : A → Set b}
             → (p : Any P l) → P (Any-lookup p)
 Any-witness (here px) = px
 Any-witness (there x) = Any-witness x

 -- TODO-1: there is probably a library property for this.
 ∈⇒Any : ∀ {A : Set}{x : A}
       → {xs : List A}
       → x ∈ xs
       → Any (_≡ x) xs
 ∈⇒Any {x = x} (here refl) = here refl
 ∈⇒Any {x = x} {h ∷ t} (there xxxx) = there (∈⇒Any {xs = t} xxxx)

 false≢true : false ≢ true
 false≢true ()

 witness : {A : Set}{P : A → Set}{x : A}{xs : List A}
         → x ∈ xs → All P xs → P x
 witness x y = All-lookup y x

 maybe-⊥ : ∀{a}{A : Set a}{x : A}{y : Maybe A}
         → y ≡ just x
         → y ≡ nothing
         → ⊥
 maybe-⊥ () refl

 Maybe-map-cool : ∀ {S S₁ : Set} {f : S → S₁} {x : Maybe S} {z}
                → Maybe-map f x ≡ just z
                → x ≢ nothing
 Maybe-map-cool {x = nothing} ()
 Maybe-map-cool {x = just y} prf = λ x → ⊥-elim (maybe-⊥ (sym x) refl)

 Maybe-map-cool-1 : ∀ {S S₁ : Set} {f : S → S₁} {x : Maybe S} {z}
                  → Maybe-map f x ≡ just z
                  → Σ S (λ x' → f x' ≡ z)
 Maybe-map-cool-1 {x = nothing} ()
 Maybe-map-cool-1 {x = just y} {z = z} refl = y , refl

 Maybe-map-cool-2 : ∀ {S S₁ : Set} {f : S → S₁} {x : S} {z}
                  → f x ≡ z
                  → Maybe-map f (just x) ≡ just z
 Maybe-map-cool-2 {S}{S₁}{f}{x}{z} prf rewrite prf = refl

 T⇒true : ∀ {a : Bool} → T a → a ≡ true
 T⇒true {true} _ = refl

 isJust : ∀ {A : Set}{aMB : Maybe A}{a : A}
        → aMB ≡ just a
        → Is-just aMB
 isJust refl = just tt

 to-witness-isJust-≡ : ∀ {A : Set}{aMB : Maybe A}{a prf}
                     → to-witness (isJust {aMB = aMB} {a} prf) ≡ a
 to-witness-isJust-≡ {aMB = just a'} {a} {prf}
    with to-witness-lemma (isJust {aMB = just a'} {a} prf) refl
 ...| xxx = just-injective (trans (sym xxx) prf)

 deMorgan : ∀ {A B : Set} → (¬ A) ⊎ (¬ B) → ¬ (A × B)
 deMorgan (inj₁ ¬a) = λ a×b → ¬a (proj₁ a×b)
 deMorgan (inj₂ ¬b) = λ a×b → ¬b (proj₂ a×b)

 ¬subst : ∀ {ℓ₁ ℓ₂} {A : Set ℓ₁} {P : A → Set ℓ₂}
        → {x y : A}
        → ¬ (P x)
        → y ≡ x
        → ¬ (P y)
 ¬subst px refl = px

 ∸-suc-≤ : ∀ (x w : ℕ) → suc x ∸ w ≤ suc (x ∸ w)
 ∸-suc-≤ x zero = ≤-refl
 ∸-suc-≤ zero (suc w) rewrite 0∸n≡0 w = z≤n
 ∸-suc-≤ (suc x) (suc w) = ∸-suc-≤ x w

 m∸n≤o⇒m∸o≤n : ∀ (x z w : ℕ) → x ∸ z ≤ w → x ∸ w ≤ z
 m∸n≤o⇒m∸o≤n x zero w p≤ rewrite m≤n⇒m∸n≡0 p≤ = z≤n
 m∸n≤o⇒m∸o≤n zero (suc z) w p≤ rewrite 0∸n≡0 w = z≤n
 m∸n≤o⇒m∸o≤n (suc x) (suc z) w p≤ = ≤-trans (∸-suc-≤ x w) (s≤s (m∸n≤o⇒m∸o≤n x z w p≤))

 tail-⊆ : ∀ {A : Set} {x} {xs ys : List A}
        → (x ∷ xs) ⊆List ys
        → xs ⊆List ys
 tail-⊆ xxs⊆ys x∈xs = xxs⊆ys (there x∈xs)

 allDistinctTail : ∀ {A : Set} {x} {xs : List A}
                 → allDistinct (x ∷ xs)
                 → allDistinct xs
 allDistinctTail allDist i j
   with allDist (suc i) (suc j)
 ...| inj₁ refl    = inj₁ refl
 ...| inj₂ lookup≢ = inj₂ lookup≢

 ∈-Any-Index-elim : ∀ {A : Set} {x y} {ys : List A} (x∈ys : x ∈ ys)
                  → x ≢ y → y ∈ ys
                  → y ∈ ys ─ Any-index x∈ys
 ∈-Any-Index-elim (here refl)  x≢y (here refl)  = ⊥-elim (x≢y refl)
 ∈-Any-Index-elim (here refl)  _   (there y∈ys) = y∈ys
 ∈-Any-Index-elim (there _)    _   (here refl)  = here refl
 ∈-Any-Index-elim (there x∈ys) x≢y (there y∈ys) = there (∈-Any-Index-elim x∈ys x≢y y∈ys)

 ∉∧⊆List⇒∉ : ∀ {A : Set} {x} {xs ys : List A}
           → x ∉ xs → ys ⊆List xs
           → x ∉ ys
 ∉∧⊆List⇒∉ x∉xs ys∈xs x∈ys = ⊥-elim (x∉xs (ys∈xs x∈ys))

 allDistinctʳʳ : ∀ {A : Set} {x x₁ : A} {xs : List A}
               → allDistinct (x ∷ x₁ ∷ xs)
               → allDistinct (x ∷ xs)
 allDistinctʳʳ _ zero zero = inj₁ refl
 allDistinctʳʳ allDist zero (suc j)
   with allDist zero (suc (suc j))
 ...| inj₂ x≢lookup
      = inj₂ λ x≡lkpxs → ⊥-elim (x≢lookup x≡lkpxs)
 allDistinctʳʳ allDist (suc i) zero
   with allDist (suc (suc i)) zero
 ...| inj₂ x≢lookup
      = inj₂ λ x≡lkpxs → ⊥-elim (x≢lookup x≡lkpxs)
 allDistinctʳʳ allDist (suc i) (suc j)
   with allDist (suc (suc i)) (suc (suc j))
 ...| inj₁ refl    = inj₁ refl
 ...| inj₂ lookup≡ = inj₂ lookup≡

 allDistinct⇒∉ : ∀ {A : Set} {x} {xs : List A}
               → allDistinct (x ∷ xs)
               → x ∉ xs
 allDistinct⇒∉ allDist (here x≡x₁)
   with allDist zero (suc zero)
 ... | inj₂ x≢x₁ = ⊥-elim (x≢x₁ x≡x₁)
 allDistinct⇒∉ allDist (there x∈xs)
   = allDistinct⇒∉ (allDistinctʳʳ allDist) x∈xs

 sumListMap : ∀ {A : Set} {x} {xs : List A} (f : A → ℕ) → (x∈xs : x ∈ xs)
            → f-sum f xs ≡ f x + f-sum f (xs ─ Any-index x∈xs)
 sumListMap _ (here refl)  = refl
 sumListMap {_} {x} {x₁ ∷ xs} f (there x∈xs)
   rewrite sumListMap f x∈xs
         | sym (+-assoc (f x) (f x₁) (f-sum f (xs ─ Any-index x∈xs)))
         | +-comm (f x) (f x₁)
         | +-assoc (f x₁) (f x) (f-sum f (xs ─ Any-index x∈xs)) = refl

 lookup⇒Any : ∀ {A : Set} {xs : List A} {P : A → Set} (i : Fin (length xs))
            → P (List-lookup xs i) → Any P xs
 lookup⇒Any {_} {_ ∷ _} zero    px = here px
 lookup⇒Any {_} {_ ∷ _} (suc i) px = there (lookup⇒Any i px)

 x∉→AllDistinct : ∀ {A : Set} {x} {xs : List A}
                → allDistinct xs
                → x ∉ xs
                → allDistinct (x ∷ xs)
 x∉→AllDistinct _ _ zero zero = inj₁ refl
 x∉→AllDistinct _ x∉xs zero (suc j)
   = inj₂ λ x≡lkp → x∉xs (lookup⇒Any j x≡lkp)
 x∉→AllDistinct _ x∉xs (suc i) (zero)
   = inj₂ λ x≡lkp → x∉xs (lookup⇒Any i (sym x≡lkp))
 x∉→AllDistinct allDist x∉xs (suc i) (suc j)
   with allDist i j
 ...| inj₁ refl  = inj₁ refl
 ...| inj₂ lkup≢ = inj₂ lkup≢

 cast-injective : ∀ {n m} {i j : Fin n} {eq : n ≡ m}
                → cast eq i ≡ cast eq j → i ≡ j
 cast-injective {_} {_} {zero} {zero}   {refl} _ = refl
 cast-injective {_} {_} {suc i} {suc j} {refl} ci≡cj
   = cong suc (cast-injective {eq = refl} (Fin-suc-injective ci≡cj))

 List-lookup-map : ∀ {A B : Set} (xs : List A) (f : A → B) (α : Fin (length xs))
                 → let cα = cast (sym (List-length-map f xs)) α
                   in f (List-lookup xs α) ≡ List-lookup (List-map f xs) cα
 List-lookup-map (x ∷ xs) f zero = refl
 List-lookup-map (x ∷ xs) f (suc α) = List-lookup-map xs f α

 allDistinct-Map : ∀ {A B : Set} {xs : List A} {α₁ α₂ : Fin (length xs)} (f : A → B)
                 → allDistinct (List-map f xs) → α₁ ≢ α₂
                 → f (List-lookup xs α₁) ≢ f (List-lookup xs α₂)
 allDistinct-Map {_} {_} {xs} {α₁} {α₂} f all≢ α₁≢α₂ flkp≡
    with all≢ (cast (sym (List-length-map f xs)) α₁)
             (cast (sym (List-length-map f xs)) α₂)
 ...| inj₁ cα₁≡cα₂  = ⊥-elim (α₁≢α₂ (cast-injective {eq = sym (List-length-map f xs)} cα₁≡cα₂))
 ...| inj₂ lkpα₁α₂≢ = ⊥-elim (lkpα₁α₂≢ (trans (sym (List-lookup-map xs f α₁))
                                               (trans flkp≡ (List-lookup-map xs f α₂))))

 filter⊆ : ∀ {A : Set} {P : A → Set} {P? : (a : A) → Dec (P a)} {xs : List A}
         → List-filter P? xs ⊆List xs
 filter⊆ {P? = P?} x∈fxs = Any-filter⁻ P? x∈fxs

 ⊆⇒filter⊆ : ∀ {A : Set} {P : A → Set} {P? : (a : A) → Dec (P a)} {xs ys : List A}
           → xs ⊆List ys
           → List-filter P? xs ⊆List List-filter P? ys
 ⊆⇒filter⊆ {P? = P?} {xs = xs} {ys = ys} xs∈ys x∈fxs
   with List-∈-filter⁻ P? {xs = xs} x∈fxs
 ...| x∈xs , px = List-∈-filter⁺ P? (xs∈ys x∈xs) px

 map∘filter : ∀ {A B : Set} (xs : List A) (ys : List B) (f : A → B)
                {P : B → Set} (P? : (b : B) → Dec (P b))
            → List-map f xs ≡ ys
            → List-map f (List-filter (P? ∘ f) xs) ≡ List-filter P? ys
 map∘filter [] [] _ _ _ = refl
 map∘filter (x ∷ xs) (.(f x) ∷ .(List-map f xs)) f P? refl
    with P? (f x)
 ...| yes prf = cong (f x ∷_) (map∘filter xs (List-map f xs) f P? refl)
 ...| no imp = map∘filter xs (List-map f xs) f P? refl

 allDistinct-Filter : ∀ {A : Set} {P : A → Set} {P? : (a : A) → Dec (P a)} {xs : List A}
                    → allDistinct xs
                    → allDistinct (List-filter P? xs)
 allDistinct-Filter {P? = P?} {xs = x ∷ xs} all≢ i j
    with P? x
 ...| no imp = allDistinct-Filter {P? = P?} {xs = xs} (allDistinctTail all≢) i j
 ...| yes prf = let all≢Tail = allDistinct-Filter {P? = P?} {xs = xs} (allDistinctTail all≢)
                    x∉Tail = allDistinct⇒∉ all≢
                in x∉→AllDistinct all≢Tail (∉∧⊆List⇒∉ x∉Tail filter⊆) i j

 sum-f∘g : ∀ {A B : Set} (xs : List A) (g : B → ℕ) (f : A → B)
         → f-sum (g ∘ f) xs ≡ f-sum g (List-map f xs)
 sum-f∘g xs g f = cong sum (List-map-compose xs)

 map-lookup-allFin : ∀ {A : Set} (xs : List A)
                   → List-map (List-lookup xs) (allFin (length xs)) ≡ xs
 map-lookup-allFin xs = trans (map-tabulate id (List-lookup xs)) (tabulate-lookup xs)

 list-index : ∀ {A B : Set} {P : A → B → Set} (_∼_ : Decidable P)
              (xs : List A) → B → Maybe (Fin (length xs))
 list-index _∼_ [] x = nothing
 list-index _∼_ (x ∷ xs) y
    with x ∼ y
 ...| yes x≡y = just zero
 ...| no  x≢y
    with list-index _∼_ xs y
 ...| nothing = nothing
 ...| just i  = just (suc i)

 module DecLemmas {A : Set} (_≟D_ : Decidable {A = A} (_≡_)) where

   _∈?_ : ∀ (x : A) → (xs : List A) → Dec (Any (x ≡_) xs)
   x ∈? xs = Any-any (x ≟D_) xs

   y∉xs⇒Allxs≢y : ∀ {xs : List A} {x y}
                → y ∉ (x ∷ xs)
                → x ≢ y × y ∉ xs
   y∉xs⇒Allxs≢y {xs} {x} {y} y∉
     with y ∈? xs
   ...| yes y∈xs = ⊥-elim (y∉ (there y∈xs))
   ...| no  y∉xs
     with x ≟D y
   ...| yes x≡y = ⊥-elim (y∉ (here (sym x≡y)))
   ...| no  x≢y = x≢y , y∉xs

   ⊆List-Elim :  ∀ {x} {xs ys : List A} (x∈ys : x ∈ ys)
              → x ∉ xs → xs ⊆List ys
              → xs ⊆List ys ─ Any-index x∈ys
   ⊆List-Elim (here refl) x∉xs xs∈ys x₂∈xs
     with xs∈ys x₂∈xs
   ...| here refl  = ⊥-elim (x∉xs x₂∈xs)
   ...| there x∈xs = x∈xs
   ⊆List-Elim (there x∈ys) x∉xs xs∈ys x₂∈xxs
     with x₂∈xxs
   ...| there x₂∈xs
         = ⊆List-Elim (there x∈ys) (proj₂ (y∉xs⇒Allxs≢y x∉xs)) (tail-⊆ xs∈ys) x₂∈xs
   ...| here refl
     with xs∈ys x₂∈xxs
   ...| here refl = here refl
   ...| there x₂∈ys
         = there (∈-Any-Index-elim x∈ys (≢-sym (proj₁ (y∉xs⇒Allxs≢y x∉xs))) x₂∈ys)

   sum-⊆-≤ : ∀ {ys} (xs : List A) (f : A → ℕ)
           → allDistinct xs
           → xs ⊆List ys
           → f-sum f xs ≤ f-sum f ys
   sum-⊆-≤ [] _ _ _ = z≤n
   sum-⊆-≤ (x ∷ xs) f dxs xs⊆ys
      rewrite sumListMap f (xs⊆ys (here refl))
      = let x∉xs    = allDistinct⇒∉ dxs
            xs⊆ysT  = tail-⊆ xs⊆ys
            xs⊆ys-x = ⊆List-Elim (xs⊆ys (here refl)) x∉xs xs⊆ysT
            disTail = allDistinctTail dxs
       in +-monoʳ-≤ (f x) (sum-⊆-≤ xs f disTail xs⊆ys-x)

   ⊆-allFin : ∀ {n} {xs : List (Fin n)} → xs ⊆List allFin n
   ⊆-allFin {x = x} _ = Any-tabulate⁺ x refl

   intersect : List A → List A → List A
   intersect xs [] = []
   intersect xs (y ∷ ys)
     with y ∈? xs
   ...| yes _ = y ∷ intersect xs ys
   ...| no  _ = intersect xs ys

   union : List A → List A → List A
   union xs [] = xs
   union xs (y ∷ ys)
     with y ∈? xs
   ...| yes _ = union xs ys
   ...| no  _ = y ∷ union xs ys

   ∈-intersect : ∀ (xs ys : List A) {α}
               → α ∈ intersect xs ys
               → α ∈ xs × α ∈ ys
   ∈-intersect xs (y ∷ ys) α∈int
     with y ∈? xs  | α∈int
   ...| no  y∉xs   | α∈        = ×-map₂ there (∈-intersect xs ys α∈)
   ...| yes y∈xs   | here refl = y∈xs , here refl
   ...| yes y∈xs   | there α∈  = ×-map₂ there (∈-intersect xs ys α∈)

   x∉⇒x∉intersect : ∀ {x} {xs ys : List A}
                    → x ∉ xs ⊎ x ∉ ys
                    → x ∉ intersect xs ys
   x∉⇒x∉intersect {x} {xs} {ys} x∉ x∈int
     = contraposition (∈-intersect xs ys) (deMorgan x∉) x∈int

   intersectDistinct : ∀ (xs ys : List A)
                     → allDistinct xs → allDistinct ys
                     → allDistinct (intersect xs ys)
   intersectDistinct xs (y ∷ ys) dxs dys
     with y ∈? xs
   ...| yes y∈xs = let distTail  = allDistinctTail dys
                       intDTail  = intersectDistinct xs ys dxs distTail
                       y∉intTail = x∉⇒x∉intersect (inj₂ (allDistinct⇒∉ dys))
                   in x∉→AllDistinct intDTail y∉intTail
   ...| no  y∉xs = intersectDistinct xs ys dxs (allDistinctTail dys)

   x∉⇒x∉union : ∀ {x} {xs ys : List A}
              → x ∉ xs × x ∉ ys
              → x ∉ union xs ys
   x∉⇒x∉union {_} {_} {[]} (x∉xs , _) x∈∪ = ⊥-elim (x∉xs x∈∪)
   x∉⇒x∉union {x} {xs} {y ∷ ys} (x∉xs , x∉ys) x∈union
     with y ∈? xs  | x∈union
   ...| yes y∈xs   | x∈∪
        = ⊥-elim (x∉⇒x∉union (x∉xs , (proj₂ (y∉xs⇒Allxs≢y x∉ys))) x∈∪)
   ...| no y∉xs    | here refl
        = ⊥-elim (proj₁ (y∉xs⇒Allxs≢y x∉ys) refl)
   ...| no y∉xs    | there x∈∪
        = ⊥-elim (x∉⇒x∉union (x∉xs , (proj₂ (y∉xs⇒Allxs≢y x∉ys))) x∈∪)

   unionDistinct : ∀ (xs ys : List A)
               → allDistinct xs → allDistinct ys
               → allDistinct (union xs ys)
   unionDistinct xs [] dxs dys = dxs
   unionDistinct xs (y ∷ ys) dxs dys
      with y ∈? xs
   ...| yes y∈xs = unionDistinct xs ys dxs (allDistinctTail dys)
   ...| no  y∉xs = let distTail  = allDistinctTail dys
                       uniDTail  = unionDistinct xs ys dxs distTail
                       y∉intTail = x∉⇒x∉union (y∉xs , allDistinct⇒∉ dys)
                   in x∉→AllDistinct uniDTail y∉intTail

   sumIntersect≤ : ∀ (xs ys : List A) (f : A → ℕ)
                 → f-sum f (intersect xs ys) ≤ f-sum f (xs ++ ys)
   sumIntersect≤ _ [] _ = z≤n
   sumIntersect≤ xs (y ∷ ys) f
     with y ∈? xs
   ...| yes y∈xs rewrite map-++-commute f xs (y ∷ ys)
                       | sum-++-commute (List-map f xs) (List-map f (y ∷ ys))
                       | sym (+-assoc (f-sum f xs) (f y) (f-sum f ys))
                       | +-comm (f-sum f xs) (f y)
                       | +-assoc (f y) (f-sum f xs) (f-sum f ys)
                       | sym (sum-++-commute (List-map f xs) (List-map f ys))
                       | sym (map-++-commute f xs ys)
                         = +-monoʳ-≤ (f y) (sumIntersect≤ xs ys f)
   ...| no  y∉xs rewrite map-++-commute f xs (y ∷ ys)
                       | sum-++-commute (List-map f xs) (List-map f (y ∷ ys))
                       | +-comm (f y) (f-sum f ys)
                       | sym (+-assoc (f-sum f xs) (f-sum f ys) (f y))
                       | sym (sum-++-commute (List-map f xs) (List-map f ys))
                       | sym (map-++-commute f xs ys)
                         = ≤-stepsʳ (f y) (sumIntersect≤ xs ys f)

   index∘lookup-id : ∀ {B : Set} (xs : List B) (f : B → A)
                   → allDistinct (List-map f xs) → {α : Fin (length xs)}
                   → list-index (_≟D_ ∘ f) xs ((f ∘ List-lookup xs) α) ≡ just α
   index∘lookup-id (x ∷ xs) f all≢ {zero}
      with f x ≟D f x
   ...| yes fx≡fx = refl
   ...| no  fx≢fx = ⊥-elim (fx≢fx refl)
   index∘lookup-id (x ∷ xs) f all≢ {suc α}
      with f x ≟D f (List-lookup xs α)
   ...| yes fx≡lkp = ⊥-elim (allDistinct⇒∉ all≢ (Any-map⁺ (lookup⇒Any α fx≡lkp)))
   ...| no  fx≢lkp
      with list-index (_≟D_ ∘ f) xs (f (List-lookup xs α))
         | index∘lookup-id xs f (allDistinctTail all≢) {α}
   ...| just .α | refl = refl

   lookup∘index-id : ∀ {B : Set} (xs : List B) (f : B → A)
                   → allDistinct (List-map f xs) → {α : Fin (length xs)} {x : A}
                   → list-index (_≟D_ ∘ f) xs x ≡ just α
                   → (f ∘ List-lookup xs) α ≡ x
   lookup∘index-id (x₁ ∷ xs) f all≢ {α} {x} lkp≡α
      with f x₁ ≟D x
   ...| yes fx≡nId rewrite sym (just-injective lkp≡α) = fx≡nId
   ...| no  fx≢nId
      with list-index (_≟D_ ∘ f) xs x | inspect (list-index (_≟D_ ∘ f) xs) x
   ...| just _ | [ eq ] rewrite sym (just-injective lkp≡α)
        = lookup∘index-id xs f (allDistinctTail all≢) eq


module Prelude where

open import Agda.Builtin.IO public
  using (IO)

open import Data.Empty public using ()
  renaming (⊥ to 𝟘 ; ⊥-elim to elim𝟘)

open import Data.Nat public
  using (ℕ ; zero ; suc ; decTotalOrder ; _⊔_)
  renaming (_≤_ to _⊑_ ; z≤n to z⊑n ; s≤s to n⊑m→sn⊑sm ;
            _≤′_ to _≤_ ; ≤′-refl to refl≤ ; ≤′-step to step≤ ;
            _≤?_ to _⊑?_ ; _≰_ to _⋢_ ; _<′_ to _<_ ; _≟_ to _≡?_)

open import Data.Nat.Properties public using ()
  renaming (≤⇒≤′ to ⊑→≤ ; ≤′⇒≤ to ≤→⊑ ; z≤′n to z≤n ; s≤′s to n≤m→sn≤sm)

open import Data.Nat.Show public
  using (show)

open import Data.Product public
  using (Σ ; _×_ ; _,_)
  renaming (proj₁ to π₁ ; proj₂ to π₂)

open import Data.String public
  using (String)
  renaming (_≟_ to _≡ₛ?_ ; _++_ to _⧺_)

open import Data.Sum public
  using (_⊎_)
  renaming (inj₁ to ι₁ ; inj₂ to ι₂)

open import Data.Unit public using ()
  renaming (⊤ to Unit ; tt to unit)

open import Function public
  using (_∘_)

open import Relation.Binary public
  using (Antisymmetric ; Decidable ; DecTotalOrder ; Reflexive ; Rel ;
         Symmetric ; Total ; Transitive ; Trichotomous ; Tri)
  renaming (tri< to τ₍ ; tri≈ to τ₌ ; tri> to τ₎)

open module NDTO = DecTotalOrder decTotalOrder public using ()
  renaming (antisym to antisym⊑ ; trans to trans⊑ ; total to total⊑)

open import Relation.Binary.PropositionalEquality public
  using (_≡_ ; _≢_ ; refl ; trans ; sym ; cong ; cong₂ ; subst)

open import Relation.Binary.HeterogeneousEquality public
  using (_≅_ ; _≇_)
  renaming (refl to refl≅ ; trans to trans≅ ; sym to sym≅ ; cong to cong≅ ;
            cong₂ to cong₂≅ ; subst to subst≅ ; ≅-to-≡ to ≅→≡ ; ≡-to-≅ to ≡→≅)

open import Relation.Nullary public
  using (¬_ ; Dec ; yes ; no)

open import Relation.Nullary.Negation public using ()
  renaming (contradiction to _↯_)

-- I/O.

postulate
  return : ∀ {a} {A : Set a} → A → IO A
  _≫=_   : ∀ {a b} {A : Set a} {B : Set b} → IO A → (A → IO B) → IO B

{-# COMPILED return (\_ _ -> return)    #-}
{-# COMPILED _≫=_   (\_ _ _ _ -> (>>=)) #-}

_≫_ : ∀ {a b} {A : Set a} {B : Set b} → IO A → IO B → IO B
m₁ ≫ m₂ = m₁ ≫= λ _ → m₂

postulate
  putStr   : String → IO Unit
  putStrLn : String → IO Unit

{-# COMPILED putStr   putStr   #-}
{-# COMPILED putStrLn putStrLn #-}

-- Notation for I/O.

infix -10 do_
do_ : ∀ {a} {A : Set a} → A → A
do x = x

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

infixr 0 do-bind
syntax do-bind m₁ (λ x → m₂) = x ← m₁ ⁏ m₂
do-bind = _≫=_

infixr 0 do-seq
syntax do-seq m₁ m₂ = m₁ ⁏ m₂
do-seq = _≫_

infixr 0 do-let
syntax do-let m₁ (λ x → m₂) = x := m₁ ⁏ m₂
do-let = case_of_

-- Properties of binary relations.

Irreflexive : ∀ {a ℓ} {A : Set a} → Rel A ℓ → Set _
Irreflexive _∼_ = ∀ {x} → ¬ (x ∼ x)

-- Properties of _≡_.

n≡m→sn≡sm : ∀ {n m} → n ≡ m → suc n ≡ suc m
n≡m→sn≡sm refl = refl

sn≡sm→n≡m : ∀ {n m} → suc n ≡ suc m → n ≡ m
sn≡sm→n≡m refl = refl

n≢m→sn≢sm : ∀ {n m} → n ≢ m → suc n ≢ suc m
n≢m→sn≢sm n≢m refl = refl ↯ n≢m

sn≢sm→n≢m : ∀ {n m} → suc n ≢ suc m → n ≢ m
sn≢sm→n≢m sn≢sm refl = refl ↯ sn≢sm

sym≢ : ∀ {a} {A : Set a} → Symmetric (_≢_ {A = A})
sym≢ x≢y refl = refl ↯ x≢y

-- Properties of _≤_.

_≰_ : ℕ → ℕ → Set
n ≰ m = ¬ (n ≤ m)

sn≤m→n≤m : ∀ {n m} → suc n ≤ m → n ≤ m
sn≤m→n≤m refl≤        = step≤ refl≤
sn≤m→n≤m (step≤ sn≤m) = step≤ (sn≤m→n≤m sn≤m)

sn≤sm→n≤m : ∀ {n m} → suc n ≤ suc m → n ≤ m
sn≤sm→n≤m refl≤        = refl≤
sn≤sm→n≤m (step≤ sn≤m) = sn≤m→n≤m sn≤m

n≰m→sn≰sm : ∀ {n m} → n ≰ m → suc n ≰ suc m
n≰m→sn≰sm n≰m refl≤        = refl≤ ↯ n≰m
n≰m→sn≰sm n≰m (step≤ sn≤m) = sn≤m→n≤m sn≤m ↯ n≰m

sn≰sm→n≰m : ∀ {n m} → suc n ≰ suc m → n ≰ m
sn≰sm→n≰m sn≰sm refl≤       = refl≤ ↯ sn≰sm
sn≰sm→n≰m sn≰sm (step≤ n≤m) = sn≰sm→n≰m (sn≰sm ∘ step≤) n≤m

sn≰n : ∀ {n} → suc n ≰ n
sn≰n {zero}  = λ ()
sn≰n {suc n} = n≰m→sn≰sm sn≰n

n≤m⊔n : (n m : ℕ) → n ≤ m ⊔ n
n≤m⊔n zero    zero    = refl≤
n≤m⊔n zero    (suc m) = z≤n
n≤m⊔n (suc n) zero    = refl≤
n≤m⊔n (suc n) (suc m) = n≤m→sn≤sm (n≤m⊔n n m)

-- Properties of _<_.

_≮_ : ℕ → ℕ → Set
n ≮ m = ¬ (n < m)

z<sn : ∀ {n} → zero < suc n
z<sn = n≤m→sn≤sm z≤n

n<m→sn<sm : ∀ {n m} → n < m → suc n < suc m
n<m→sn<sm = n≤m→sn≤sm

sn<m→n<m : ∀ {n m} → suc n < m → n < m
sn<m→n<m = sn≤m→n≤m

sn<sm→n<m : ∀ {n m} → suc n < suc m → n < m
sn<sm→n<m = sn≤sm→n≤m

n≮m→sn≮sm : ∀ {n m} → n ≮ m → suc n ≮ suc m
n≮m→sn≮sm = n≰m→sn≰sm

sn≮sm→n≮m : ∀ {n m} → suc n ≮ suc m → n ≮ m
sn≮sm→n≮m = sn≰sm→n≰m

n<s[n⊔m] : (n m : ℕ) → n < suc (n ⊔ m)
n<s[n⊔m] zero    zero    = refl≤
n<s[n⊔m] zero    (suc m) = n≤m→sn≤sm z≤n
n<s[n⊔m] (suc n) zero    = refl≤
n<s[n⊔m] (suc n) (suc m) = n≤m→sn≤sm (n<s[n⊔m] n m)

-- Conversion between _⊑_, ⊏, _≤_, _<_, and _≡_.

≰→⋢ : ∀ {n m} → n ≰ m → n ⋢ m
≰→⋢ {zero}  {zero}  n≰m = refl≤ ↯ n≰m
≰→⋢ {suc n} {zero}  n≰m = λ ()
≰→⋢ {n}     {suc m} n≰m = λ n⊑m → ⊑→≤ n⊑m ↯ n≰m

⋢→≰ : ∀ {n m} → n ⋢ m → n ≰ m
⋢→≰ {zero}  {m}     n⋢m = z⊑n ↯ n⋢m
⋢→≰ {suc n} {zero}  n⋢m = λ ()
⋢→≰ {suc n} {suc m} n⋢m = λ n≤m → ≤→⊑ n≤m ↯ n⋢m

≤×≢→< : ∀ {n m} → n ≤ m → n ≢ m → n < m
≤×≢→< refl≤       n≢m = refl ↯ n≢m
≤×≢→< (step≤ n≤m) n≢m = n≤m→sn≤sm n≤m

≤→<⊎≡ : ∀ {n m} → n ≤ m → n < m ⊎ n ≡ m
≤→<⊎≡ refl≤       = ι₂ refl
≤→<⊎≡ (step≤ n≤m) with ≤→<⊎≡ n≤m
≤→<⊎≡ (step≤ n≤m) | ι₁ sn≤m = ι₁ (step≤ sn≤m)
≤→<⊎≡ (step≤ n≤m) | ι₂ refl = ι₁ refl≤

<→≤ : ∀ {n m} → n < m → n ≤ m
<→≤ n<m = sn≤m→n≤m n<m

≡→≤ : ∀ {n m} → n ≡ m → n ≤ m
≡→≤ refl = refl≤

-- _≤_ is a decidable non-strict total order on naturals.

antisym≤ : Antisymmetric _≡_ _≤_
antisym≤ n≤m m≤n = antisym⊑ (≤→⊑ n≤m) (≤→⊑ m≤n)

total≤ : Total _≤_
total≤ n m with total⊑ n m
total≤ n m | ι₁ n⊑m = ι₁ (⊑→≤ n⊑m)
total≤ n m | ι₂ m⊑n = ι₂ (⊑→≤ m⊑n)

trans≤ : Transitive _≤_
trans≤ n≤m m≤z = ⊑→≤ (trans⊑ (≤→⊑ n≤m) (≤→⊑ m≤z))

_≤?_ : Decidable _≤_
n ≤? m with n ⊑? m
n ≤? m | yes n⊑m = yes (⊑→≤ n⊑m)
n ≤? m | no  n⋢m = no (⋢→≰ n⋢m)

-- _<_ is a decidable strict total order on naturals.

trans< : Transitive _<_
trans< n<m m<l = trans≤ (step≤ n<m) m<l

tri< : Trichotomous _≡_ _<_
tri< zero    zero    = τ₌ (λ ()) refl   (λ ())
tri< zero    (suc m) = τ₍ z<sn   (λ ()) (λ ())
tri< (suc n) zero    = τ₎ (λ ()) (λ ()) z<sn
tri< (suc n) (suc m) with tri< n m
tri< (suc n) (suc m) | τ₍ n<m n≢m m≮n = τ₍ (n<m→sn<sm n<m) (n≢m→sn≢sm n≢m) (n≮m→sn≮sm m≮n)
tri< (suc n) (suc m) | τ₌ n≮m n≡m m≮n = τ₌ (n≮m→sn≮sm n≮m) (n≡m→sn≡sm n≡m) (n≮m→sn≮sm m≮n)
tri< (suc n) (suc m) | τ₎ n≮m n≢m m<n = τ₎ (n≮m→sn≮sm n≮m) (n≢m→sn≢sm n≢m) (n<m→sn<sm m<n)

irrefl< : Irreflexive _<_
irrefl< = sn≰n

_<?_ : Decidable _<_
n <? m = suc n ≤? m


-- Andreas, 2017-10-08, issue #2594, reported by gallais

-- Incomplete pattern matching should be reported as such,
-- rather than crashing on a split error.

-- {-# OPTIONS -v tc.cover:10 #-}

open import Agda.Builtin.Bool

dispatch : Bool → Set
dispatch true  = Bool
dispatch false = Bool

argh : (b : Bool) → dispatch b → Bool
argh false false = true
argh false true  = false

-- Error was: Cannot split on non-datatype

-- Expected error:
-- Incomplete pattern matching


apply :
  ∀ {a b} {A : Set a} {B : A → Set b} →
  ((x : A) → B x) → (x : A) → B x
apply f x = f x

syntax apply f x = f x


open import Agda.Builtin.Maybe
open import Agda.Builtin.Char
open import Agda.Builtin.String
open import Agda.Builtin.Sigma
open import Agda.Builtin.Equality

_ : primStringUncons "abcd" ≡ just ('a', "bcd")
_ = refl


-- Andreas, 2020-05-18, issue #3933
--
-- Duplicate imports of the same modules should be cumulative,
-- rather than overwriting the previous scope.

{-# OPTIONS -v scope.import:10 #-}
{-# OPTIONS -v scope:clash:20 #-}

open import Agda.Builtin.Nat using ()

Nat  = Agda.Builtin.Nat.Nat
zero = Agda.Builtin.Nat.zero

import Agda.Builtin.Nat using ()

works : Nat
works = zero

test : Agda.Builtin.Nat.Nat
test = Agda.Builtin.Nat.zero

-- Used to fail since the second import emptied
-- the contents of module Agda.Builtin.Nat.


{-

  Reflection-based tools for converting between iterated record types, particularly between
  record types and iterated Σ-types. Currently requires eta equality.

  See end of file for examples.

-}
{-# OPTIONS --cubical --no-import-sorts --no-exact-split --safe #-}
module Cubical.Reflection.RecordEquiv where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Equiv
open import Cubical.Data.List as List
open import Cubical.Data.Nat
open import Cubical.Data.Maybe
open import Cubical.Data.Sigma

import Agda.Builtin.Reflection as R
open import Cubical.Reflection.Base

Projections = List R.Name

-- Describes a correspondence between two iterated record types
Assoc = List (Projections × Projections)

-- Describes a correspondence between a record type and an iterated Σ-types;
-- more convenient than Assoc for this special case
data ΣFormat : Type where
  leaf : R.Name → ΣFormat
  _,_ : ΣFormat → ΣFormat → ΣFormat

infixr 4 _,_

module Internal where

  flipAssoc : Assoc → Assoc
  flipAssoc = List.map λ {p .fst → p .snd; p .snd → p .fst}

  list→ΣFormat : List R.Name → Maybe ΣFormat
  list→ΣFormat [] = nothing
  list→ΣFormat (x ∷ []) = just (leaf x)
  list→ΣFormat (x ∷ y ∷ xs) = map-Maybe (leaf x ,_) (list→ΣFormat (y ∷ xs))

  recordName→ΣFormat : R.Name → R.TC (Maybe ΣFormat)
  recordName→ΣFormat name = R.getDefinition name >>= go
    where
    go : R.Definition → R.TC (Maybe ΣFormat)
    go (R.record-type c fs) = R.returnTC (list→ΣFormat (List.map (λ {(R.arg _ n) → n}) fs))
    go _ = R.typeError (R.strErr "Not a record type name:" ∷ R.nameErr name ∷ [])

  ΣFormat→Assoc : ΣFormat → Assoc
  ΣFormat→Assoc = go []
    where
    go : List R.Name → ΣFormat → Assoc
    go prefix (leaf fieldName) = [ prefix , [ fieldName ] ]
    go prefix (sig₁ , sig₂) =
      go (quote fst ∷ prefix) sig₁ ++ go (quote snd ∷ prefix) sig₂

  MaybeΣFormat→Assoc : Maybe ΣFormat → Assoc
  MaybeΣFormat→Assoc nothing = [ [] , [] ]
  MaybeΣFormat→Assoc (just sig) = ΣFormat→Assoc sig

  convertTerm : Assoc → R.Term → R.Term
  convertTerm al term = R.pat-lam (List.map makeClause al) []
    where
    makeClause : Projections × Projections → R.Clause
    makeClause (projl , projr) =
      R.clause [] (goPat [] projr) (goTm projl)
      where
      goPat : List (R.Arg R.Pattern) → List R.Name → List (R.Arg R.Pattern)
      goPat acc [] = acc
      goPat acc (π ∷ projs) = goPat (varg (R.proj π) ∷ acc) projs

      goTm : List R.Name → R.Term
      goTm [] = term
      goTm (π ∷ projs) = R.def π [ varg (goTm projs) ]

  convertFun : Assoc → R.Term
  convertFun al = vlam "ρ" (convertTerm al (v 0))

  convertMacro : Assoc → R.Term → R.TC Unit
  convertMacro al hole = R.unify hole (convertFun al)

  equivMacro : Assoc → R.Term → R.TC Unit
  equivMacro al hole =
    newMeta R.unknown >>= λ hole₁ →
    newMeta R.unknown >>= λ hole₂ →
    let
      iso : R.Term
      iso =
        R.pat-lam
          ( R.clause [] [ varg (R.proj (quote Iso.fun)) ] hole₁
          ∷ R.clause [] [ varg (R.proj (quote Iso.inv)) ] hole₂
          ∷ R.clause [] [ varg (R.proj (quote Iso.rightInv)) ] (vlam "_" (R.def (quote refl) []))
          ∷ R.clause [] [ varg (R.proj (quote Iso.leftInv)) ] (vlam "_" (R.def (quote refl) []))
          ∷ []
          )
          []
    in
    R.unify hole (R.def (quote isoToEquiv) [ varg iso ]) >>
    convertMacro al hole₁ >>
    convertMacro (flipAssoc al) hole₂

open Internal

macro
  -- ΣFormat → <Σ-Type> ≃ <RecordType>
  Σ≃Record : ΣFormat → R.Term → R.TC Unit
  Σ≃Record sig = equivMacro (ΣFormat→Assoc sig)

  -- ΣFormat → <RecordType> ≃ <Σ-Type>
  Record≃Σ : ΣFormat → R.Term → R.TC Unit
  Record≃Σ sig = equivMacro (flipAssoc (ΣFormat→Assoc sig))

  -- <RecordTypeName> → <Σ-Type> ≃ <RecordType>
  FlatΣ≃Record : R.Name → R.Term → R.TC Unit
  FlatΣ≃Record name hole =
    recordName→ΣFormat name >>= λ sig →
    equivMacro (MaybeΣFormat→Assoc sig) hole

  -- <RecordTypeName> → <RecordType> ≃ <Σ-Type>
  Record≃FlatΣ : R.Name → R.Term → R.TC Unit
  Record≃FlatΣ name hole =
    recordName→ΣFormat name >>= λ sig →
    equivMacro (flipAssoc (MaybeΣFormat→Assoc sig)) hole

  -- ΣFormat → <RecordType₁> ≃ <RecordType₂>
  Record≃Record : Assoc → R.Term → R.TC Unit
  Record≃Record = equivMacro

module Example where

  private
    variable
      ℓ ℓ' : Level
      A : Type ℓ
      B : A → Type ℓ'

  record Example {A : Type ℓ} (B : A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
    field
      cool : A
      fun : A
      wow : B cool

  open Example

  {-
    Example: Equivalence between a Σ-type and record type using FlatΣ≃Record
  -}

  Example0 : (Σ[ a ∈ A ] Σ[ a' ∈ A ] B a) ≃ Example B
  Example0 = FlatΣ≃Record Example

  Example0' : Example B ≃ (Σ[ a ∈ A ] Σ[ a' ∈ A ] B a)
  Example0' = Record≃FlatΣ Example

  Example0'' : Unit ≃ Unit -- any record with no fields is equivalent to unit
  Example0'' = FlatΣ≃Record Unit

  {-
    Example: Equivalence between an arbitrarily arrange Σ-type and record type using Σ≃Record
  -}

  Example1 : (Σ[ p ∈ A × A ] B (p .snd)) ≃ Example B
  Example1 =
    Σ≃Record ((leaf (quote fun) , leaf (quote cool)) , leaf (quote wow))

  {-
    Example: Equivalence between arbitrary iterated record types (less convenient) using
    Record≃Record
  -}

  record Inner {A : Type ℓ} (B : A → Type ℓ') (a : A) : Type (ℓ-max ℓ ℓ') where
    field
      fun' : A
      wow' : B a

  record Outer {A : Type ℓ} (B : A → Type ℓ') : Type (ℓ-max ℓ ℓ') where
    field
      cool' : A
      inner : B cool'

  open Inner
  open Outer

  Example2 : Example B ≃ Outer (Inner B)
  Example2 =
    Record≃Record
      ( ([ quote cool ] , [ quote cool' ])
      ∷ ([ quote fun ] , (quote fun' ∷ quote inner ∷ []))
      ∷ ([ quote wow ] , (quote wow' ∷ quote inner ∷ []))
      ∷ []
      )


------------------------------------------------------------------------
-- The Agda standard library
--
-- Support for reflection
------------------------------------------------------------------------

{-# OPTIONS --with-K #-}

module Reflection where

open import Data.Unit.Base using (⊤)
open import Data.Bool.Base using (Bool; false; true)
open import Data.List.Base using (List); open Data.List.Base.List
open import Data.Nat using (ℕ) renaming (_≟_ to _≟-ℕ_)
open import Data.Nat.Show renaming (show to showNat)
open import Data.Float using (Float) renaming (show to showFloat)
open import Data.Float.Unsafe using () renaming (_≟_ to _≟f_)
open import Data.Char using (Char)
  renaming ( show to showChar
           ; _≟_ to _≟c_
           )
open import Data.String using (String)
  renaming ( show to showString
           ; _≟_ to _≟s_
           )
open import Data.Word using (Word64) renaming (toℕ to wordToℕ)
open import Data.Word.Unsafe using () renaming (_≟_ to _≟w_)
open import Data.Product
open import Function
open import Level
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.PropositionalEquality.TrustMe
open import Relation.Nullary hiding (module Dec)
open import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product

import Agda.Builtin.Reflection as Builtin

------------------------------------------------------------------------
-- Names

-- Names.

open Builtin public using (Name)

-- Equality of names is decidable.

infix 4 _==_ _≟-Name_

private

  _==_ : Name → Name → Bool
  _==_ = Builtin.primQNameEquality

_≟-Name_ : Decidable {A = Name} _≡_
s₁ ≟-Name s₂ with s₁ == s₂
... | true  = yes trustMe
... | false = no whatever
  where postulate whatever : _

-- Names can be shown.

showName : Name → String
showName = Builtin.primShowQName

------------------------------------------------------------------------
-- Metavariables

-- Metavariables.

open Builtin public using (Meta)

-- Equality of metavariables is decidable.

infix 4 _==-Meta_ _≟-Meta_

private

  _==-Meta_ : Meta → Meta → Bool
  _==-Meta_ = Builtin.primMetaEquality

_≟-Meta_ : Decidable {A = Meta} _≡_
s₁ ≟-Meta s₂ with s₁ ==-Meta s₂
... | true  = yes trustMe
... | false = no whatever
  where postulate whatever : _

-- Metas can be shown.

showMeta : Meta → String
showMeta = Builtin.primShowMeta

------------------------------------------------------------------------
-- Terms

-- Is the argument visible (explicit), hidden (implicit), or an
-- instance argument?
open Builtin public using (Visibility; visible; hidden; instance′)

-- Arguments can be relevant or irrelevant.
open Builtin public using (Relevance; relevant; irrelevant)

-- Arguments.
open Builtin public
  renaming ( ArgInfo to Arg-info )
  using    ( arg-info )

visibility : Arg-info → Visibility
visibility (arg-info v _) = v

relevance : Arg-info → Relevance
relevance (arg-info _ r) = r

open Builtin public using (Arg; arg)
open Builtin public using (Abs; abs)

-- Literals.

open Builtin public using (Literal; nat; word64; float; char; string; name; meta)

-- Patterns.

open Builtin public using (Pattern; con; dot; var; lit; proj; absurd)

-- Terms.

open Builtin public
  using    ( Type; Term; var; con; def; lam; pat-lam; pi; lit; meta; unknown
           ; Sort; set
           ; Clause; clause; absurd-clause )
  renaming ( agda-sort to sort )

Clauses = List Clause

------------------------------------------------------------------------
-- Definitions

open Builtin public
  using    ( Definition
           ; function
           ; data-type
           ; axiom
           )
  renaming ( record-type to record′
           ; data-cons   to constructor′
           ; prim-fun    to primitive′ )

showLiteral : Literal → String
showLiteral (nat x)    = showNat x
showLiteral (word64 x) = showNat (wordToℕ x)
showLiteral (float x)  = showFloat x
showLiteral (char x)   = showChar x
showLiteral (string x) = showString x
showLiteral (name x)   = showName x
showLiteral (meta x)   = showMeta x

------------------------------------------------------------------------
-- Type checking monad

-- Type errors
open Builtin public using (ErrorPart; strErr; termErr; nameErr)

-- The monad
open Builtin public
  using ( TC; returnTC; bindTC; unify; typeError; inferType; checkType
        ; normalise; catchTC; getContext; extendContext; inContext
        ; freshName; declareDef; defineFun; getType; getDefinition
        ; blockOnMeta; quoteTC; unquoteTC )

newMeta : Type → TC Term
newMeta = checkType unknown

------------------------------------------------------------------------
-- Term equality is decidable

-- Boring helper functions.

private

  cong₂′ : ∀ {a b c : Level} {A : Set a} {B : Set b} {C : Set c}
          (f : A → B → C) {x y u v} →
          x ≡ y × u ≡ v → f x u ≡ f y v
  cong₂′ f = uncurry (cong₂ f)

  cong₃′ : ∀ {a b c d : Level} {A : Set a} {B : Set b} {C : Set c}
             {D : Set d} (f : A → B → C → D) {x y u v r s} →
           x ≡ y × u ≡ v × r ≡ s → f x u r ≡ f y v s
  cong₃′ f (refl , refl , refl) = refl

  arg₁ : ∀ {A i i′} {x x′ : A} → arg i x ≡ arg i′ x′ → i ≡ i′
  arg₁ refl = refl

  arg₂ : ∀ {A i i′} {x x′ : A} → arg i x ≡ arg i′ x′ → x ≡ x′
  arg₂ refl = refl

  abs₁ : ∀ {A i i′} {x x′ : A} → abs i x ≡ abs i′ x′ → i ≡ i′
  abs₁ refl = refl

  abs₂ : ∀ {A i i′} {x x′ : A} → abs i x ≡ abs i′ x′ → x ≡ x′
  abs₂ refl = refl

  arg-info₁ : ∀ {v v′ r r′} → arg-info v r ≡ arg-info v′ r′ → v ≡ v′
  arg-info₁ refl = refl

  arg-info₂ : ∀ {v v′ r r′} → arg-info v r ≡ arg-info v′ r′ → r ≡ r′
  arg-info₂ refl = refl

  cons₁ : ∀ {a} {A : Set a} {x y} {xs ys : List A} → x ∷ xs ≡ y ∷ ys → x ≡ y
  cons₁ refl = refl

  cons₂ : ∀ {a} {A : Set a} {x y} {xs ys : List A} → x ∷ xs ≡ y ∷ ys → xs ≡ ys
  cons₂ refl = refl

  var₁ : ∀ {x x′ args args′} → Term.var x args ≡ var x′ args′ → x ≡ x′
  var₁ refl = refl

  var₂ : ∀ {x x′ args args′} → Term.var x args ≡ var x′ args′ → args ≡ args′
  var₂ refl = refl

  con₁ : ∀ {c c′ args args′} → Term.con c args ≡ con c′ args′ → c ≡ c′
  con₁ refl = refl

  con₂ : ∀ {c c′ args args′} → Term.con c args ≡ con c′ args′ → args ≡ args′
  con₂ refl = refl

  def₁ : ∀ {f f′ args args′} → def f args ≡ def f′ args′ → f ≡ f′
  def₁ refl = refl

  def₂ : ∀ {f f′ args args′} → def f args ≡ def f′ args′ → args ≡ args′
  def₂ refl = refl

  meta₁ : ∀ {x x′ args args′} → Term.meta x args ≡ meta x′ args′ → x ≡ x′
  meta₁ refl = refl

  meta₂ : ∀ {x x′ args args′} → Term.meta x args ≡ meta x′ args′ → args ≡ args′
  meta₂ refl = refl

  lam₁ : ∀ {v v′ t t′} → lam v t ≡ lam v′ t′ → v ≡ v′
  lam₁ refl = refl

  lam₂ : ∀ {v v′ t t′} → lam v t ≡ lam v′ t′ → t ≡ t′
  lam₂ refl = refl

  pat-lam₁ : ∀ {cs cs′ args args′} → pat-lam cs args ≡ pat-lam cs′ args′ → cs ≡ cs′
  pat-lam₁ refl = refl

  pat-lam₂ : ∀ {cs cs′ args args′} → pat-lam cs args ≡ pat-lam cs′ args′ → args ≡ args′
  pat-lam₂ refl = refl

  pi₁ : ∀ {t₁ t₁′ t₂ t₂′} → pi t₁ t₂ ≡ pi t₁′ t₂′ → t₁ ≡ t₁′
  pi₁ refl = refl

  pi₂ : ∀ {t₁ t₁′ t₂ t₂′} → pi t₁ t₂ ≡ pi t₁′ t₂′ → t₂ ≡ t₂′
  pi₂ refl = refl

  sort₁ : ∀ {x y} → sort x ≡ sort y → x ≡ y
  sort₁ refl = refl

  lit₁ : ∀ {x y} → Term.lit x ≡ lit y → x ≡ y
  lit₁ refl = refl

  pcon₁ : ∀ {c c′ args args′} → Pattern.con c args ≡ con c′ args′ → c ≡ c′
  pcon₁ refl = refl

  pcon₂ : ∀ {c c′ args args′} → Pattern.con c args ≡ con c′ args′ → args ≡ args′
  pcon₂ refl = refl

  pvar : ∀ {x y} → Pattern.var x ≡ var y → x ≡ y
  pvar refl = refl

  plit₁ : ∀ {x y} → Pattern.lit x ≡ lit y → x ≡ y
  plit₁ refl = refl

  pproj₁ : ∀ {x y} → proj x ≡ proj y → x ≡ y
  pproj₁ refl = refl

  set₁ : ∀ {x y} → set x ≡ set y → x ≡ y
  set₁ refl = refl

  slit₁ : ∀ {x y} → Sort.lit x ≡ lit y → x ≡ y
  slit₁ refl = refl

  nat₁ : ∀ {x y} → nat x ≡ nat y → x ≡ y
  nat₁ refl = refl

  word64₁ : ∀ {x y} → word64 x ≡ word64 y → x ≡ y
  word64₁ refl = refl

  float₁ : ∀ {x y} → float x ≡ float y → x ≡ y
  float₁ refl = refl

  char₁ : ∀ {x y} → char x ≡ char y → x ≡ y
  char₁ refl = refl

  string₁ : ∀ {x y} → string x ≡ string y → x ≡ y
  string₁ refl = refl

  name₁ : ∀ {x y} → name x ≡ name y → x ≡ y
  name₁ refl = refl

  lmeta₁ : ∀ {x y} → Literal.meta x ≡ meta y → x ≡ y
  lmeta₁ refl = refl

  clause₁ : ∀ {ps ps′ b b′} → clause ps b ≡ clause ps′ b′ → ps ≡ ps′
  clause₁ refl = refl

  clause₂ : ∀ {ps ps′ b b′} → clause ps b ≡ clause ps′ b′ → b ≡ b′
  clause₂ refl = refl

  absurd-clause₁ : ∀ {ps ps′} → absurd-clause ps ≡ absurd-clause ps′ → ps ≡ ps′
  absurd-clause₁ refl = refl

infix 4 _≟-Visibility_ _≟-Relevance_ _≟-Arg-info_ _≟-Lit_ _≟-AbsTerm_
        _≟-AbsType_ _≟-ArgTerm_ _≟-ArgType_ _≟-ArgPattern_ _≟-Args_
        _≟-Clause_ _≟-Clauses_ _≟-Pattern_ _≟-ArgPatterns_ _≟_
        _≟-Sort_

_≟-Visibility_ : Decidable (_≡_ {A = Visibility})
visible   ≟-Visibility visible   = yes refl
hidden    ≟-Visibility hidden    = yes refl
instance′ ≟-Visibility instance′ = yes refl
visible   ≟-Visibility hidden    = no λ()
visible   ≟-Visibility instance′ = no λ()
hidden    ≟-Visibility visible   = no λ()
hidden    ≟-Visibility instance′ = no λ()
instance′ ≟-Visibility visible   = no λ()
instance′ ≟-Visibility hidden    = no λ()

_≟-Relevance_ : Decidable (_≡_ {A = Relevance})
relevant   ≟-Relevance relevant   = yes refl
irrelevant ≟-Relevance irrelevant = yes refl
relevant   ≟-Relevance irrelevant = no λ()
irrelevant ≟-Relevance relevant   = no λ()

_≟-Arg-info_ : Decidable (_≡_ {A = Arg-info})
arg-info v r ≟-Arg-info arg-info v′ r′ =
  Dec.map′ (cong₂′ arg-info)
           < arg-info₁ , arg-info₂ >
           (v ≟-Visibility v′ ×-dec r ≟-Relevance r′)

_≟-Lit_ : Decidable (_≡_ {A = Literal})
nat x ≟-Lit nat x₁ = Dec.map′ (cong nat) nat₁ (x ≟-ℕ x₁)
nat x ≟-Lit word64 x₁ = no (λ ())
nat x ≟-Lit float x₁ = no (λ ())
nat x ≟-Lit char x₁ = no (λ ())
nat x ≟-Lit string x₁ = no (λ ())
nat x ≟-Lit name x₁ = no (λ ())
nat x ≟-Lit meta x₁ = no (λ ())
word64 x ≟-Lit word64 x₁ = Dec.map′ (cong word64) word64₁ (x ≟w x₁)
word64 x ≟-Lit nat x₁ = no (λ ())
word64 x ≟-Lit float x₁ = no (λ ())
word64 x ≟-Lit char x₁ = no (λ ())
word64 x ≟-Lit string x₁ = no (λ ())
word64 x ≟-Lit name x₁ = no (λ ())
word64 x ≟-Lit meta x₁ = no (λ ())
float x ≟-Lit nat x₁ = no (λ ())
float x ≟-Lit word64 x₁ = no (λ ())
float x ≟-Lit float x₁ = Dec.map′ (cong float) float₁ (x ≟f x₁)
float x ≟-Lit char x₁ = no (λ ())
float x ≟-Lit string x₁ = no (λ ())
float x ≟-Lit name x₁ = no (λ ())
float x ≟-Lit meta x₁ = no (λ ())
char x ≟-Lit nat x₁ = no (λ ())
char x ≟-Lit word64 x₁ = no (λ ())
char x ≟-Lit float x₁ = no (λ ())
char x ≟-Lit char x₁ = Dec.map′ (cong char) char₁ (x ≟c x₁)
char x ≟-Lit string x₁ = no (λ ())
char x ≟-Lit name x₁ = no (λ ())
char x ≟-Lit meta x₁ = no (λ ())
string x ≟-Lit nat x₁ = no (λ ())
string x ≟-Lit word64 x₁ = no (λ ())
string x ≟-Lit float x₁ = no (λ ())
string x ≟-Lit char x₁ = no (λ ())
string x ≟-Lit string x₁ = Dec.map′ (cong string) string₁ (x ≟s x₁)
string x ≟-Lit name x₁ = no (λ ())
string x ≟-Lit meta x₁ = no (λ ())
name x ≟-Lit nat x₁ = no (λ ())
name x ≟-Lit word64 x₁ = no (λ ())
name x ≟-Lit float x₁ = no (λ ())
name x ≟-Lit char x₁ = no (λ ())
name x ≟-Lit string x₁ = no (λ ())
name x ≟-Lit name x₁ = Dec.map′ (cong name) name₁ (x ≟-Name x₁)
name x ≟-Lit meta x₁ = no (λ ())
meta x ≟-Lit nat x₁ = no (λ ())
meta x ≟-Lit word64 x₁ = no (λ ())
meta x ≟-Lit float x₁ = no (λ ())
meta x ≟-Lit char x₁ = no (λ ())
meta x ≟-Lit string x₁ = no (λ ())
meta x ≟-Lit name x₁ = no (λ ())
meta x ≟-Lit meta x₁ = Dec.map′ (cong meta) lmeta₁ (x ≟-Meta x₁)

mutual
  _≟-AbsTerm_ : Decidable (_≡_ {A = Abs Term})
  abs s a ≟-AbsTerm abs s′ a′ =
    Dec.map′ (cong₂′ abs)
             < abs₁ , abs₂ >
             (s ≟s s′ ×-dec a ≟ a′)

  _≟-AbsType_ : Decidable (_≡_ {A = Abs Type})
  abs s a ≟-AbsType abs s′ a′ =
    Dec.map′ (cong₂′ abs)
             < abs₁ , abs₂ >
             (s ≟s s′ ×-dec a ≟ a′)

  _≟-ArgTerm_ : Decidable (_≡_ {A = Arg Term})
  arg i a ≟-ArgTerm arg i′ a′ =
    Dec.map′ (cong₂′ arg)
             < arg₁ , arg₂ >
             (i ≟-Arg-info i′ ×-dec a ≟ a′)

  _≟-ArgType_ : Decidable (_≡_ {A = Arg Type})
  arg i a ≟-ArgType arg i′ a′ =
    Dec.map′ (cong₂′ arg)
             < arg₁ , arg₂ >
             (i ≟-Arg-info i′ ×-dec a ≟ a′)

  _≟-ArgPattern_ : Decidable (_≡_ {A = Arg Pattern})
  arg i a ≟-ArgPattern arg i′ a′ =
    Dec.map′ (cong₂′ arg)
             < arg₁ , arg₂ >
             (i ≟-Arg-info i′ ×-dec a ≟-Pattern a′)

  _≟-Args_ : Decidable (_≡_ {A = List (Arg Term)})
  []       ≟-Args []       = yes refl
  (x ∷ xs) ≟-Args (y ∷ ys) = Dec.map′ (cong₂′ _∷_) < cons₁ , cons₂ > (x ≟-ArgTerm y ×-dec xs ≟-Args ys)
  []       ≟-Args (_ ∷ _)  = no λ()
  (_ ∷ _)  ≟-Args []       = no λ()

  _≟-Clause_ : Decidable (_≡_ {A = Clause})
  clause ps b ≟-Clause clause ps′ b′ = Dec.map′ (cong₂′ clause) < clause₁ , clause₂ > (ps ≟-ArgPatterns ps′ ×-dec b ≟ b′)
  absurd-clause ps ≟-Clause absurd-clause ps′ = Dec.map′ (cong absurd-clause) absurd-clause₁ (ps ≟-ArgPatterns ps′)
  clause _ _      ≟-Clause absurd-clause _ = no λ()
  absurd-clause _ ≟-Clause clause _ _      = no λ()

  _≟-Clauses_ : Decidable (_≡_ {A = Clauses})
  []       ≟-Clauses []       = yes refl
  (x ∷ xs) ≟-Clauses (y ∷ ys) = Dec.map′ (cong₂′ _∷_) < cons₁ , cons₂ > (x ≟-Clause y ×-dec xs ≟-Clauses ys)
  []       ≟-Clauses (_ ∷ _)  = no λ()
  (_ ∷ _)  ≟-Clauses []       = no λ()

  _≟-Pattern_ : Decidable (_≡_ {A = Pattern})
  con c ps ≟-Pattern con c′ ps′ = Dec.map′ (cong₂′ con) < pcon₁ , pcon₂ > (c ≟-Name c′ ×-dec ps ≟-ArgPatterns ps′)
  con x x₁ ≟-Pattern dot = no (λ ())
  con x x₁ ≟-Pattern var x₂ = no (λ ())
  con x x₁ ≟-Pattern lit x₂ = no (λ ())
  con x x₁ ≟-Pattern proj x₂ = no (λ ())
  con x x₁ ≟-Pattern absurd = no (λ ())
  dot ≟-Pattern con x x₁ = no (λ ())
  dot ≟-Pattern dot = yes refl
  dot ≟-Pattern var x = no (λ ())
  dot ≟-Pattern lit x = no (λ ())
  dot ≟-Pattern proj x = no (λ ())
  dot ≟-Pattern absurd = no (λ ())
  var s ≟-Pattern con x x₁ = no (λ ())
  var s ≟-Pattern dot = no (λ ())
  var s ≟-Pattern var s′ = Dec.map′ (cong var) pvar (s ≟s s′)
  var s ≟-Pattern lit x = no (λ ())
  var s ≟-Pattern proj x = no (λ ())
  var s ≟-Pattern absurd = no (λ ())
  lit x ≟-Pattern con x₁ x₂ = no (λ ())
  lit x ≟-Pattern dot = no (λ ())
  lit x ≟-Pattern var _ = no (λ ())
  lit l ≟-Pattern lit l′ = Dec.map′ (cong lit) plit₁ (l ≟-Lit l′)
  lit x ≟-Pattern proj x₁ = no (λ ())
  lit x ≟-Pattern absurd = no (λ ())
  proj x ≟-Pattern con x₁ x₂ = no (λ ())
  proj x ≟-Pattern dot = no (λ ())
  proj x ≟-Pattern var _ = no (λ ())
  proj x ≟-Pattern lit x₁ = no (λ ())
  proj x ≟-Pattern proj x₁ = Dec.map′ (cong proj) pproj₁ (x ≟-Name x₁)
  proj x ≟-Pattern absurd = no (λ ())
  absurd ≟-Pattern con x x₁ = no (λ ())
  absurd ≟-Pattern dot = no (λ ())
  absurd ≟-Pattern var _ = no (λ ())
  absurd ≟-Pattern lit x = no (λ ())
  absurd ≟-Pattern proj x = no (λ ())
  absurd ≟-Pattern absurd = yes refl

  _≟-ArgPatterns_ : Decidable (_≡_ {A = List (Arg Pattern)})
  []       ≟-ArgPatterns []       = yes refl
  (x ∷ xs) ≟-ArgPatterns (y ∷ ys) = Dec.map′ (cong₂′ _∷_) < cons₁ , cons₂ > (x ≟-ArgPattern y ×-dec xs ≟-ArgPatterns ys)
  []       ≟-ArgPatterns (_ ∷ _)  = no λ()
  (_ ∷ _)  ≟-ArgPatterns []       = no λ()

  _≟_ : Decidable (_≡_ {A = Term})
  var x args ≟ var x′ args′ = Dec.map′ (cong₂′ var) < var₁ , var₂ > (x ≟-ℕ x′          ×-dec args ≟-Args args′)
  con c args ≟ con c′ args′ = Dec.map′ (cong₂′ con) < con₁ , con₂ > (c ≟-Name c′       ×-dec args ≟-Args args′)
  def f args ≟ def f′ args′ = Dec.map′ (cong₂′ def) < def₁ , def₂ > (f ≟-Name f′       ×-dec args ≟-Args args′)
  meta x args ≟ meta x′ args′ = Dec.map′ (cong₂′ meta) < meta₁ , meta₂ > (x ≟-Meta x′   ×-dec args ≟-Args args′)
  lam v t    ≟ lam v′ t′    = Dec.map′ (cong₂′ lam) < lam₁ , lam₂ > (v ≟-Visibility v′ ×-dec t ≟-AbsTerm t′)
  pat-lam cs args ≟ pat-lam cs′ args′ =
                              Dec.map′ (cong₂′ pat-lam) < pat-lam₁ , pat-lam₂ > (cs ≟-Clauses cs′ ×-dec args ≟-Args args′)
  pi t₁ t₂   ≟ pi t₁′ t₂′   = Dec.map′ (cong₂′ pi)  < pi₁  , pi₂  > (t₁ ≟-ArgType t₁′  ×-dec t₂ ≟-AbsType t₂′)
  sort s     ≟ sort s′      = Dec.map′ (cong sort)  sort₁           (s ≟-Sort s′)
  lit l      ≟ lit l′       = Dec.map′ (cong lit)   lit₁           (l ≟-Lit l′)
  unknown    ≟ unknown      = yes refl

  var x args ≟ con c args′ = no λ()
  var x args ≟ def f args′ = no λ()
  var x args ≟ lam v t     = no λ()
  var x args ≟ pi t₁ t₂    = no λ()
  var x args ≟ sort _      = no λ()
  var x args ≟ lit _      = no λ()
  var x args ≟ meta _ _    = no λ()
  var x args ≟ unknown     = no λ()
  con c args ≟ var x args′ = no λ()
  con c args ≟ def f args′ = no λ()
  con c args ≟ lam v t     = no λ()
  con c args ≟ pi t₁ t₂    = no λ()
  con c args ≟ sort _      = no λ()
  con c args ≟ lit _      = no λ()
  con c args ≟ meta _ _    = no λ()
  con c args ≟ unknown     = no λ()
  def f args ≟ var x args′ = no λ()
  def f args ≟ con c args′ = no λ()
  def f args ≟ lam v t     = no λ()
  def f args ≟ pi t₁ t₂    = no λ()
  def f args ≟ sort _      = no λ()
  def f args ≟ lit _      = no λ()
  def f args ≟ meta _ _    = no λ()
  def f args ≟ unknown     = no λ()
  lam v t    ≟ var x args  = no λ()
  lam v t    ≟ con c args  = no λ()
  lam v t    ≟ def f args  = no λ()
  lam v t    ≟ pi t₁ t₂    = no λ()
  lam v t    ≟ sort _      = no λ()
  lam v t    ≟ lit _      = no λ()
  lam v t    ≟ meta _ _    = no λ()
  lam v t    ≟ unknown     = no λ()
  pi t₁ t₂   ≟ var x args  = no λ()
  pi t₁ t₂   ≟ con c args  = no λ()
  pi t₁ t₂   ≟ def f args  = no λ()
  pi t₁ t₂   ≟ lam v t     = no λ()
  pi t₁ t₂   ≟ sort _      = no λ()
  pi t₁ t₂   ≟ lit _      = no λ()
  pi t₁ t₂   ≟ meta _ _    = no λ()
  pi t₁ t₂   ≟ unknown     = no λ()
  sort _     ≟ var x args  = no λ()
  sort _     ≟ con c args  = no λ()
  sort _     ≟ def f args  = no λ()
  sort _     ≟ lam v t     = no λ()
  sort _     ≟ pi t₁ t₂    = no λ()
  sort _     ≟ lit _       = no λ()
  sort _     ≟ meta _ _    = no λ()
  sort _     ≟ unknown     = no λ()
  lit _     ≟ var x args  = no λ()
  lit _     ≟ con c args  = no λ()
  lit _     ≟ def f args  = no λ()
  lit _     ≟ lam v t     = no λ()
  lit _     ≟ pi t₁ t₂    = no λ()
  lit _     ≟ sort _      = no λ()
  lit _     ≟ meta _ _    = no λ()
  lit _     ≟ unknown     = no λ()
  meta _ _   ≟ var x args  = no λ()
  meta _ _   ≟ con c args  = no λ()
  meta _ _   ≟ def f args  = no λ()
  meta _ _   ≟ lam v t     = no λ()
  meta _ _   ≟ pi t₁ t₂    = no λ()
  meta _ _   ≟ sort _      = no λ()
  meta _ _   ≟ lit _       = no λ()
  meta _ _   ≟ unknown     = no λ()
  unknown    ≟ var x args  = no λ()
  unknown    ≟ con c args  = no λ()
  unknown    ≟ def f args  = no λ()
  unknown    ≟ lam v t     = no λ()
  unknown    ≟ pi t₁ t₂    = no λ()
  unknown    ≟ sort _      = no λ()
  unknown    ≟ lit _       = no λ()
  unknown    ≟ meta _ _    = no λ()
  pat-lam _ _ ≟ var x args  = no λ()
  pat-lam _ _ ≟ con c args  = no λ()
  pat-lam _ _ ≟ def f args  = no λ()
  pat-lam _ _ ≟ lam v t     = no λ()
  pat-lam _ _ ≟ pi t₁ t₂    = no λ()
  pat-lam _ _ ≟ sort _      = no λ()
  pat-lam _ _ ≟ lit _       = no λ()
  pat-lam _ _ ≟ meta _ _    = no λ()
  pat-lam _ _ ≟ unknown     = no λ()
  var x args  ≟ pat-lam _ _ = no λ()
  con c args  ≟ pat-lam _ _ = no λ()
  def f args  ≟ pat-lam _ _ = no λ()
  lam v t     ≟ pat-lam _ _ = no λ()
  pi t₁ t₂    ≟ pat-lam _ _ = no λ()
  sort _      ≟ pat-lam _ _ = no λ()
  lit _       ≟ pat-lam _ _ = no λ()
  meta _ _    ≟ pat-lam _ _ = no λ()
  unknown     ≟ pat-lam _ _ = no λ()

  _≟-Sort_ : Decidable (_≡_ {A = Sort})
  set t   ≟-Sort set t′  = Dec.map′ (cong set) set₁ (t ≟ t′)
  lit n   ≟-Sort lit n′  = Dec.map′ (cong lit) slit₁ (n ≟-ℕ n′)
  unknown ≟-Sort unknown = yes refl
  set _   ≟-Sort lit _   = no λ()
  set _   ≟-Sort unknown = no λ()
  lit _   ≟-Sort set _   = no λ()
  lit _   ≟-Sort unknown = no λ()
  unknown ≟-Sort set _   = no λ()
  unknown ≟-Sort lit _   = no λ()


module Luau.Addr.ToString where

open import Agda.Builtin.String using (String; primStringAppend)
open import Luau.Addr using (Addr)
open import Agda.Builtin.Int using (Int; primShowInteger; pos)

addrToString : Addr → String
addrToString a = primStringAppend "a" (primShowInteger (pos a))


{-# OPTIONS --cubical --no-import-sorts  #-}

module Utils where -- thing that currently do not belong anywhere and do not have many dependencies

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)

private
  variable
    ℓ ℓ' ℓ'' : Level

open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Relation.Nullary.Base -- ¬_
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Empty renaming (elim to ⊥-elim) -- `⊥` and `elim`

⊎-swap : ∀{x : Type ℓ} {y : Type ℓ'} → x ⊎ y → y ⊎ x
⊎-swap (inl x) = inr x
⊎-swap (inr x) = inl x

swap : ∀{x : Type ℓ} {y : Type ℓ'} → x × y → y × x
swap (x , y) = (y , x)

curry : ∀{ℓ ℓ' ℓ''} {A : Type ℓ} {B : A → Type ℓ'} {C : (a : A) → (b : B a) → Type ℓ''}
        → ((p : Σ A B) → C (fst p) (snd p))
        → ((x : A) → (y : B x) → C x y)
curry f x y = f (x , y)

-- NOTE: this is non-hProp logic

-- contraposition : {P : Type ℓ} {Q : Type ℓ'} → (P → Q) → ¬ Q → ¬ P
-- contraposition f ¬q p = ⊥-elim (¬q (f p))

deMorgan₂' : {P : Type ℓ} {Q : Type ℓ'} → ¬(P ⊎ Q) → (¬ P) × (¬ Q)
deMorgan₂' {P = P} {Q = Q} ¬[p⊎q] = (λ p → ⊥-elim (¬[p⊎q] (inl p))) , λ q → ⊥-elim (¬[p⊎q] (inr q))

deMorgan₂-back' : {P : Type ℓ} {Q : Type ℓ'} → (¬ P) × (¬ Q) → ¬(P ⊎ Q)
deMorgan₂-back' (¬p , ¬q) (inl p) = ¬p p
deMorgan₂-back' (¬p , ¬q) (inr q) = ¬q q

-- hPropRel : ∀ {ℓ} (A B : Type ℓ) (ℓ' : Level) → Type (ℓ-max ℓ (ℓ-suc ℓ'))
-- hPropRel A B ℓ' = A → B → hProp ℓ'

{- NOTE: there is also `Relation.Binary.PropositionalEquality` where they write:

-- Inspect can be used when you want to pattern match on the result r
-- of some expression e, and you also need to "remember" that r ≡ e.

-- See README.Inspect for an explanation of how/why to use this.

record Reveal_·_is_ {A : Set a} {B : A → Set b}
                    (f : (x : A) → B x) (x : A) (y : B x) :
                    Set (a ⊔ b) where
  constructor [_]
  field eq : f x ≡ y

inspect : ∀ {A : Set a} {B : A → Set b}
          (f : (x : A) → B x) (x : A) → Reveal f · x is f x
inspect f x = [ refl ]

-}

{- NOTE: an example is

plus-eq-with : ∀ m n → Plus-eq m n (m + n)
plus-eq-with m n with m + n | inspect (m +_) n
... | zero  | [ m+n≡0   ] = m+n≡0⇒m≡0 m m+n≡0 , m+n≡0⇒n≡0 m m+n≡0
... | suc p | [ m+n≡1+p ] = m+n≡1+p

-} -- so this looks like a mechanism for "@-pattern-disribution over `with` cases"

record !_ {ℓ} (X : Type ℓ) : Type ℓ where
  inductive
  constructor !!_ -- map "into"   `!!_  : X → ! X`
  field !!!_ : X  -- map "out of" `!!!_ : ! X → X`
  infix 1 !!!_

open !_ public -- brings !!!_ into scope
infix 1 !!_
infix 1 !_

!-iso : ∀{ℓ} {X : Type ℓ} → Iso (! X) X
Iso.fun      !-iso = !!!_
Iso.inv      !-iso = !!_
Iso.rightInv !-iso = λ      x  → refl
Iso.leftInv  !-iso = λ{ (!! x) → refl }

!-≡ : ∀{ℓ} {X : Type ℓ} → (! X) ≡ X
!-≡ {X = X} = isoToPath !-iso

!-equiv : ∀{ℓ} {X : Type ℓ} → (! X) ≃ X
!-equiv = !!!_ , λ where .equiv-proof x → ((!! x) , refl) , λ{ ((!! y) , p) → λ i → (!! p (~ i)) , (λ j → p (~ i ∨ j)) }

-- `A unfold refl to B` checks `A` and `B` to be definitionally equal (with `refl`) and then uses `B`
--   this allows for a nicer Goal/Have at the very beginning of implementing and when using something
unfold' : ∀{ℓ A} → (x y : A) → _≡_ {ℓ} x y → _
unfold' x y p = y
infix -8 unfold'
syntax unfold' x y p = x unfold p to y
{-# DISPLAY unfold' x y p = p #-}


------------------------------------------------------------------------
-- Semantics of the parsers
------------------------------------------------------------------------

module TotalParserCombinators.Semantics where

open import Codata.Musical.Notation
open import Data.List hiding (drop)
open import Data.List.Relation.Binary.BagAndSetEquality
  using (bag) renaming (_∼[_]_ to _List-∼[_]_)
open import Data.Maybe using (Maybe); open Data.Maybe.Maybe
open import Data.Product
open import Data.Unit using (⊤; tt)
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence as Eq using (_⇔_; module Equivalence)
open import Function.Inverse using (_↔_; module Inverse)
open import Function.Related as Related using (Related)
open import Level
import Relation.Binary.HeterogeneousEquality as H
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary

open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- Semantics

-- The semantics of the parsers. x ∈ p · s means that x can be the
-- result of applying the parser p to the string s. Note that the
-- semantics is defined inductively.

infix  60 <$>_
infixl 50 _⊛_   [_-_]_⊛_
infixl 10 _>>=_ [_-_]_>>=_
infix   4 _∈_·_

data _∈_·_ {Tok} :
       ∀ {R xs} → R → Parser Tok R xs → List Tok → Set₁ where
  return   : ∀ {R} {x : R} → x ∈ return x · []
  token    : ∀ {x} → x ∈ token · [ x ]
  ∣-left   : ∀ {R x xs₁ xs₂ s}
               {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂}
             (x∈p₁ : x ∈ p₁ · s) → x ∈ p₁ ∣ p₂ · s
  ∣-right  : ∀ {R x xs₂ s} xs₁
               {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂}
             (x∈p₂ : x ∈ p₂ · s) → x ∈ p₁ ∣ p₂ · s
  <$>_     : ∀ {R₁ R₂ x s xs} {p : Parser Tok R₁ xs} {f : R₁ → R₂}
             (x∈p : x ∈ p · s) → f x ∈ f <$> p · s
  _⊛_      : ∀ {R₁ R₂ f x s₁ s₂ fs xs}
               {p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)}
               {p₂ : ∞⟨ fs ⟩Parser Tok  R₁       (flatten xs)} →
             (f∈p₁ : f ∈ ♭? p₁ · s₁)
             (x∈p₂ : x ∈ ♭? p₂ · s₂) →
             f x ∈ p₁ ⊛ p₂ · s₁ ++ s₂
  _>>=_    : ∀ {R₁ R₂ x y s₁ s₂ xs} {f : Maybe (R₁ → List R₂)}
               {p₁ : ∞⟨ f ⟩Parser Tok R₁ (flatten xs)}
               {p₂ : (x : R₁) → ∞⟨ xs ⟩Parser Tok R₂ (apply f x)}
             (x∈p₁ : x ∈ ♭? p₁ · s₁)
             (y∈p₂x : y ∈ ♭? (p₂ x) · s₂) →
             y ∈ p₁ >>= p₂ · s₁ ++ s₂
  nonempty : ∀ {R xs x y s} {p : Parser Tok R xs}
             (x∈p : y ∈ p · x ∷ s) → y ∈ nonempty p · x ∷ s
  cast     : ∀ {R xs₁ xs₂ x s}
               {xs₁≈xs₂ : xs₁ List-∼[ bag ] xs₂} {p : Parser Tok R xs₁}
             (x∈p : x ∈ p · s) → x ∈ cast xs₁≈xs₂ p · s

-- Some variants with fewer implicit arguments. (The arguments xs and
-- fs can usually not be inferred, but I do not want to mention them
-- in the paper, so I have made them implicit in the definition
-- above.)

[_-_]_⊛_ : ∀ {Tok R₁ R₂ f x s₁ s₂} xs fs
             {p₁ : ∞⟨ xs ⟩Parser Tok (R₁ → R₂) (flatten fs)}
             {p₂ : ∞⟨ fs ⟩Parser Tok  R₁       (flatten xs)} →
           f ∈ ♭? p₁ · s₁ → x ∈ ♭? p₂ · s₂ → f x ∈ p₁ ⊛ p₂ · s₁ ++ s₂
[ xs - fs ] f∈p₁ ⊛ x∈p₂ = _⊛_ {fs = fs} {xs = xs} f∈p₁ x∈p₂

[_-_]_>>=_ : ∀ {Tok R₁ R₂ x y s₁ s₂} (f : Maybe (R₁ → List R₂)) xs
               {p₁ : ∞⟨ f ⟩Parser Tok R₁ (flatten xs)}
               {p₂ : (x : R₁) → ∞⟨ xs ⟩Parser Tok R₂ (apply f x)} →
             x ∈ ♭? p₁ · s₁ → y ∈ ♭? (p₂ x) · s₂ →
             y ∈ p₁ >>= p₂ · s₁ ++ s₂
[ f - xs ] x∈p₁ >>= y∈p₂x = _>>=_ {xs = xs} {f = f} x∈p₁ y∈p₂x

------------------------------------------------------------------------
-- Parser and language equivalence

infix 4 _∼[_]_ _≈_ _≅_ _≲_

-- There are two kinds of equivalences. Parser equivalences are
-- stronger, and correspond to bag equality. Language equivalences are
-- weaker, and correspond to set equality.

open Data.List.Relation.Binary.BagAndSetEquality public
  using (Kind)
  renaming ( bag      to parser
           ; set      to language
           ; subbag   to subparser
           ; subset   to sublanguage
           ; superbag to superparser
           ; superset to superlanguage
           )

-- General definition of equivalence between parsers. (Note that this
-- definition also gives access to some ordering relations.)

_∼[_]_ : ∀ {Tok R xs₁ xs₂} →
         Parser Tok R xs₁ → Kind → Parser Tok R xs₂ → Set₁
p₁ ∼[ k ] p₂ = ∀ {x s} → Related k (x ∈ p₁ · s) (x ∈ p₂ · s)

-- Language equivalence. (Corresponds to set equality.)

_≈_ : ∀ {Tok R xs₁ xs₂} → Parser Tok R xs₁ → Parser Tok R xs₂ → Set₁
p₁ ≈ p₂ = p₁ ∼[ language ] p₂

-- Parser equivalence. (Corresponds to bag equality.)

_≅_ : ∀ {Tok R xs₁ xs₂} → Parser Tok R xs₁ → Parser Tok R xs₂ → Set₁
p₁ ≅ p₂ = p₁ ∼[ parser ] p₂

-- p₁ ≲ p₂ means that the language defined by p₂ contains all the
-- string/result pairs contained in the language defined by p₁.

_≲_ : ∀ {Tok R xs₁ xs₂} → Parser Tok R xs₁ → Parser Tok R xs₂ → Set₁
p₁ ≲ p₂ = p₁ ∼[ sublanguage ] p₂

-- p₁ ≈ p₂ iff both p₁ ≲ p₂ and p₂ ≲ p₁.

≈⇔≲≳ : ∀ {Tok R xs₁ xs₂}
         {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
       p₁ ≈ p₂ ⇔ (p₁ ≲ p₂ × p₂ ≲ p₁)
≈⇔≲≳ = Eq.equivalence
  (λ p₁≈p₂  →
     ((λ {x s} → _⟨$⟩_ (Equivalence.to   (p₁≈p₂ {x = x} {s = s})))
     , λ {x s} → _⟨$⟩_ (Equivalence.from (p₁≈p₂ {x = x} {s = s}))))
  (λ p₁≲≳p₂ → λ {x s} → Eq.equivalence (proj₁ p₁≲≳p₂ {s = s})
                                       (proj₂ p₁≲≳p₂ {s = s}))

-- Parser equivalence implies language equivalence.

≅⇒≈ : ∀ {Tok R xs₁ xs₂}
        {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
      p₁ ≅ p₂ → p₁ ≈ p₂
≅⇒≈ p₁≅p₂ = Related.↔⇒ p₁≅p₂

-- Language equivalence does not (in general) imply parser
-- equivalence.

¬≈⇒≅ : ¬ (∀ {Tok R xs₁ xs₂}
            {p₁ : Parser Tok R xs₁} {p₂ : Parser Tok R xs₂} →
          p₁ ≈ p₂ → p₁ ≅ p₂)
¬≈⇒≅ hyp with Inverse.injective p₁≅p₂
                {∣-left return} {∣-right [ tt ] return} (lemma _ _)
  where
  p₁ : Parser ⊤ ⊤ _
  p₁ = return tt ∣ return tt

  p₂ : Parser ⊤ ⊤ _
  p₂ = return tt

  p₁≲p₂ : p₁ ≲ p₂
  p₁≲p₂ (∣-left     return) = return
  p₁≲p₂ (∣-right ._ return) = return

  p₁≅p₂ : p₁ ≅ p₂
  p₁≅p₂ = hyp $ Eq.equivalence p₁≲p₂ ∣-left

  lemma : ∀ {x s} (x∈₁ x∈₂ : x ∈ p₂ · s) → x∈₁ ≡ x∈₂
  lemma return return = P.refl

... | ()

------------------------------------------------------------------------
-- A simple cast lemma

cast∈ : ∀ {Tok R xs} {p p′ : Parser Tok R xs} {x x′ s s′} →
        x ≡ x′ → p ≡ p′ → s ≡ s′ → x ∈ p · s → x′ ∈ p′ · s′
cast∈ P.refl P.refl P.refl x∈ = x∈


module Test where

open import Agda.Builtin.Bool
  using (Bool; false; true)
open import Agda.Builtin.Unit

_∧_
  : Bool
  → Bool
  → Bool
false ∧ x
  = false
_ ∧ y
  = y


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of vector's Any
------------------------------------------------------------------------

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

module Data.Vec.Relation.Unary.Any.Properties where

open import Function
open import Function.Inverse using (_↔_; inverse)
  renaming (_∘_ to _∘↔_; id to id↔)
open import Data.Vec
  using ( Vec; []; _∷_; _++_; [_]; _>>=_
        ; toList; fromList; map; concat; tabulate; lookup )
open import Data.Vec.Relation.Unary.Any as Any using (Any; here; there)
open import Data.Nat using (suc; zero)
open import Data.Fin using (Fin) renaming (suc to fsuc; zero to fzero)
open import Data.Empty using (⊥)
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Data.Sum.Function.Propositional using (_⊎-cong_)
open import Data.Product as Prod using (∃; ∃₂; _×_; _,_; proj₁; proj₂)
open import Relation.Nullary using (¬_)
open import Relation.Unary hiding (_∈_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_; _≗_; refl)

------------------------------------------------------------------------
-- Equality properties

module _ {a p ℓ} {A : Set a} {P : A → Set p} {_≈_ : Rel A ℓ} where

  open import Data.Vec.Relation.Binary.Pointwise.Inductive using (Pointwise; []; _∷_)

  lift-resp : ∀ {n} → P Respects _≈_ → (Any P {n}) Respects (Pointwise _≈_)
  lift-resp resp []             ()
  lift-resp resp (x∼y ∷ xs∼ys) (here px)   = here (resp x∼y px)
  lift-resp resp (x∼y ∷ xs∼ys) (there pxs) = there (lift-resp resp xs∼ys pxs)

module _ {a p} {A : Set a} {P : Pred A p} where

  here-injective : ∀ {n x xs} {p q : P x} →
                   here {P = P} {n = n} {xs = xs} p ≡ here q → p ≡ q
  here-injective refl = refl

  there-injective : ∀ {n x xs} {p q : Any P xs} →
                    there {n = n} {x = x} p ≡ there q → p ≡ q
  there-injective refl = refl

------------------------------------------------------------------------
-- Misc

  ¬Any[] : ¬ Any P []
  ¬Any[] ()

  lookup-index : ∀ {m} {xs : Vec A m} (p : Any P xs) →
                 P (lookup xs (Any.index p))
  lookup-index (here px) = px
  lookup-index (there p) = lookup-index p

------------------------------------------------------------------------
-- Convert from/to List.Any

  open import Data.List.Relation.Unary.Any as List using (here; there)
  open import Data.List using ([]; _∷_)

  fromList⁺ : ∀ {xs} → List.Any P xs → Any P (fromList xs)
  fromList⁺ (here px) = here px
  fromList⁺ (there v) = there (fromList⁺ v)

  fromList⁻ : ∀ {xs} → Any P (fromList xs) → List.Any P xs
  fromList⁻ {[]}     ()
  fromList⁻ {x ∷ xs} (here px)   = here px
  fromList⁻ {x ∷ xs} (there pxs) = there (fromList⁻ pxs)

  toList⁺ : ∀ {n} {xs : Vec A n} → Any P xs → List.Any P (toList xs)
  toList⁺ (here px) = here px
  toList⁺ (there v) = there (toList⁺ v)

  toList⁻ : ∀ {n} {xs : Vec A n} → List.Any P (toList xs) → Any P xs
  toList⁻ {xs = []}     ()
  toList⁻ {xs = x ∷ xs} (here px)   = here px
  toList⁻ {xs = x ∷ xs} (there pxs) = there (toList⁻ pxs)

------------------------------------------------------------------------
-- map

map-id : ∀ {a p} {A : Set a} {P : A → Set p} (f : P ⊆ P) {n xs} →
         (∀ {x} (p : P x) → f p ≡ p) →
         (p : Any P {n} xs) → Any.map f p ≡ p
map-id f hyp (here  p) = P.cong here (hyp p)
map-id f hyp (there p) = P.cong there $ map-id f hyp p

map-∘ : ∀ {a p q r}
          {A : Set a} {P : A → Set p} {Q : A → Set q} {R : A → Set r}
        (f : Q ⊆ R) (g : P ⊆ Q)
        {n xs} (p : Any P {n} xs) →
        Any.map (f ∘ g) p ≡ Any.map f (Any.map g p)
map-∘ f g (here  p) = refl
map-∘ f g (there p) = P.cong there $ map-∘ f g p

------------------------------------------------------------------------
-- Swapping

module _ {a b ℓ} {A : Set a} {B : Set b} {P : A → B → Set ℓ} where

  swap : ∀ {n m} {xs : Vec A n} {ys : Vec B m} →
         Any (λ x → Any (P x) ys) xs →
         Any (λ y → Any (flip P y) xs) ys
  swap (here  pys)  = Any.map here pys
  swap (there pxys) = Any.map there (swap pxys)

  swap-there : ∀ {n m x xs ys} → (any : Any (λ x → Any (P x) {n} ys) {m} xs) →
               swap (Any.map (there {x = x}) any) ≡ there (swap any)
  swap-there (here  pys)  = refl
  swap-there (there pxys) = P.cong (Any.map there) (swap-there pxys)

module _ {a b ℓ} {A : Set a} {B : Set b} {P : A → B → Set ℓ} where

  swap-invol : ∀ {n m} {xs : Vec A n} {ys : Vec B m} →
               (any : Any (λ x → Any (P x) ys) xs) →
               swap (swap any) ≡ any
  swap-invol (here (here _)) = refl
  swap-invol (here (there pys)) = P.cong (Any.map there) (swap-invol (here pys))
  swap-invol (there pxys) = P.trans (swap-there (swap pxys))
                          $ P.cong there (swap-invol pxys)

module _ {a b ℓ} {A : Set a} {B : Set b} {P : A → B → Set ℓ} where

  swap↔ : ∀ {n m} {xs : Vec A n} {ys : Vec B m} →
          Any (λ x → Any (P x) ys) xs ↔ Any (λ y → Any (flip P y) xs) ys
  swap↔ = inverse swap swap swap-invol swap-invol

------------------------------------------------------------------------
-- Lemmas relating Any to ⊥

⊥↔Any⊥ : ∀ {a} {A : Set a} {n} {xs : Vec A n} → ⊥ ↔ Any (const ⊥) xs
⊥↔Any⊥ = inverse (λ ()) (λ p → from p) (λ ()) (λ p → from p)
  where
  from : ∀ {n xs} → Any (const ⊥) {n} xs → ∀ {b} {B : Set b} → B
  from (here ())
  from (there p) = from p

⊥↔Any[] : ∀ {a p} {A : Set a} {P : A → Set p} → ⊥ ↔ Any P []
⊥↔Any[] = inverse (λ()) (λ()) (λ()) (λ())

------------------------------------------------------------------------
-- Sums commute with Any

module _ {a p q} {A : Set a} {P : A → Set p} {Q : A → Set q} where

  Any-⊎⁺ : ∀ {n} {xs : Vec A n} → Any P xs ⊎ Any Q xs → Any (λ x → P x ⊎ Q x) xs
  Any-⊎⁺ = [ Any.map inj₁ , Any.map inj₂ ]′

  Any-⊎⁻ : ∀ {n} {xs : Vec A n} → Any (λ x → P x ⊎ Q x) xs → Any P xs ⊎ Any Q xs
  Any-⊎⁻ (here (inj₁ p)) = inj₁ (here p)
  Any-⊎⁻ (here (inj₂ q)) = inj₂ (here q)
  Any-⊎⁻ (there p)       = Sum.map there there (Any-⊎⁻ p)

  ⊎↔ : ∀ {n} {xs : Vec A n} → (Any P xs ⊎ Any Q xs) ↔ Any (λ x → P x ⊎ Q x) xs
  ⊎↔ = inverse Any-⊎⁺ Any-⊎⁻ from∘to to∘from
    where
    from∘to : ∀ {n} {xs : Vec A n} (p : Any P xs ⊎ Any Q xs) → Any-⊎⁻ (Any-⊎⁺ p) ≡ p
    from∘to (inj₁ (here  p)) = refl
    from∘to (inj₁ (there p)) rewrite from∘to (inj₁ p) = refl
    from∘to (inj₂ (here  q)) = refl
    from∘to (inj₂ (there q)) rewrite from∘to (inj₂ q) = refl

    to∘from : ∀ {n} {xs : Vec A n} (p : Any (λ x → P x ⊎ Q x) xs) →
              Any-⊎⁺ (Any-⊎⁻ p) ≡ p
    to∘from (here (inj₁ p)) = refl
    to∘from (here (inj₂ q)) = refl
    to∘from (there p) with Any-⊎⁻ p | to∘from p
    to∘from (there .(Any.map inj₁ p)) | inj₁ p | refl = refl
    to∘from (there .(Any.map inj₂ q)) | inj₂ q | refl = refl

------------------------------------------------------------------------
-- Products "commute" with Any.

module _ {a b p q} {A : Set a} {B : Set b} {P : Pred A p} {Q : Pred B q} where

  open import Data.Vec.Membership.Propositional using (_∈_; find; lose)

  Any-×⁺ : ∀ {n m} {xs : Vec A n} {ys : Vec B m} → Any P xs × Any Q ys →
           Any (λ x → Any (λ y → P x × Q y) ys) xs
  Any-×⁺ (p , q) = Any.map (λ p → Any.map (p ,_) q) p

  Any-×⁻ : ∀ {n m} {xs : Vec A n} {ys : Vec B m} →
           Any (λ x → Any (λ y → P x × Q y) ys) xs →
           Any P xs × Any Q ys
  Any-×⁻ pq with find pq
  ... | x , x∈xs , pxys with find pxys
  ...   | y , y∈ys , px , py = lose x∈xs px , lose y∈ys py

------------------------------------------------------------------------
-- Invertible introduction (⁺) and elimination (⁻) rules for various
-- vector functions

------------------------------------------------------------------------
-- Singleton ([_])

module _ {a p} {A : Set a} {P : Pred A p} where

  singleton⁺ : ∀ {x} → P x → Any P [ x ]
  singleton⁺ Px = here Px

  singleton⁻ : ∀ {x} → Any P [ x ] → P x
  singleton⁻ (here Px) = Px
  singleton⁻ (there ())

  singleton⁺∘singleton⁻ : ∀ {x} (p : Any P [ x ]) →
                          singleton⁺ (singleton⁻ p) ≡ p
  singleton⁺∘singleton⁻ (here px) = refl
  singleton⁺∘singleton⁻ (there ())

  singleton⁻∘singleton⁺ : ∀ {x} (p : P x) →
                          singleton⁻ (singleton⁺ p) ≡ p
  singleton⁻∘singleton⁺ p = refl

  singleton↔ : ∀ {x} → P x ↔ Any P [ x ]
  singleton↔ = inverse singleton⁺ singleton⁻ singleton⁻∘singleton⁺ singleton⁺∘singleton⁻

------------------------------------------------------------------------
-- map

module _ {a b} {A : Set a} {B : Set b} {f : A → B} where

  map⁺ : ∀ {p} {P : B → Set p} {n} {xs : Vec A n} →
         Any (P ∘ f) xs → Any P (map f xs)
  map⁺ (here p)  = here p
  map⁺ (there p) = there $ map⁺ p

  map⁻ : ∀ {p} {P : B → Set p} {n} {xs : Vec A n} →
         Any P (map f xs) → Any (P ∘ f) xs
  map⁻ {xs = []}     ()
  map⁻ {xs = x ∷ xs} (here p)  = here p
  map⁻ {xs = x ∷ xs} (there p) = there $ map⁻ p

  map⁺∘map⁻ : ∀ {p} {P : B → Set p} {n} {xs : Vec A n} →
              (p : Any P (map f xs)) → map⁺ (map⁻ p) ≡ p
  map⁺∘map⁻ {xs = []}     ()
  map⁺∘map⁻ {xs = x ∷ xs} (here  p) = refl
  map⁺∘map⁻ {xs = x ∷ xs} (there p) = P.cong there (map⁺∘map⁻ p)

  map⁻∘map⁺ : ∀ {p} (P : B → Set p) {n} {xs : Vec A n} →
              (p : Any (P ∘ f) xs) → map⁻ {P = P} (map⁺ p) ≡ p
  map⁻∘map⁺ P (here  p) = refl
  map⁻∘map⁺ P (there p) = P.cong there (map⁻∘map⁺ P p)

  map↔ : ∀ {p} {P : B → Set p} {n} {xs : Vec A n} →
         Any (P ∘ f) xs ↔ Any P (map f xs)
  map↔ = inverse map⁺ map⁻ (map⁻∘map⁺ _) map⁺∘map⁻

------------------------------------------------------------------------
-- _++_

module _ {a p} {A : Set a} {P : A → Set p} where

  ++⁺ˡ : ∀ {n m} {xs : Vec A n} {ys : Vec A m} → Any P xs → Any P (xs ++ ys)
  ++⁺ˡ (here p)  = here p
  ++⁺ˡ (there p) = there (++⁺ˡ p)

  ++⁺ʳ : ∀ {n m} (xs : Vec A n) {ys : Vec A m} → Any P ys → Any P (xs ++ ys)
  ++⁺ʳ []       p = p
  ++⁺ʳ (x ∷ xs) p = there (++⁺ʳ xs p)

  ++⁻ : ∀ {n m} (xs : Vec A n) {ys : Vec A m} → Any P (xs ++ ys) → Any P xs ⊎ Any P ys
  ++⁻ []       p         = inj₂ p
  ++⁻ (x ∷ xs) (here p)  = inj₁ (here p)
  ++⁻ (x ∷ xs) (there p) = Sum.map there id (++⁻ xs p)

  ++⁺∘++⁻ : ∀ {n m} (xs : Vec A n) {ys : Vec A m} (p : Any P (xs ++ ys)) →
           [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs p) ≡ p
  ++⁺∘++⁻ []       p         = refl
  ++⁺∘++⁻ (x ∷ xs) (here  p) = refl
  ++⁺∘++⁻ (x ∷ xs) (there p) with ++⁻ xs p | ++⁺∘++⁻ xs p
  ++⁺∘++⁻ (x ∷ xs) (there p) | inj₁ p′ | ih = P.cong there ih
  ++⁺∘++⁻ (x ∷ xs) (there p) | inj₂ p′ | ih = P.cong there ih

  ++⁻∘++⁺ : ∀ {n m} (xs : Vec A n) {ys : Vec A m} (p : Any P xs ⊎ Any P ys) →
            ++⁻ xs ([ ++⁺ˡ , ++⁺ʳ xs ]′ p) ≡ p
  ++⁻∘++⁺ []            (inj₁ ())
  ++⁻∘++⁺ []            (inj₂ p)         = refl
  ++⁻∘++⁺ (x ∷ xs)      (inj₁ (here  p)) = refl
  ++⁻∘++⁺ (x ∷ xs) {ys} (inj₁ (there p)) rewrite ++⁻∘++⁺ xs {ys} (inj₁ p) = refl
  ++⁻∘++⁺ (x ∷ xs)      (inj₂ p)         rewrite ++⁻∘++⁺ xs      (inj₂ p) = refl

  ++↔ : ∀ {n m} {xs : Vec A n} {ys : Vec A m} →
        (Any P xs ⊎ Any P ys) ↔ Any P (xs ++ ys)
  ++↔ {xs = xs} = inverse [ ++⁺ˡ , ++⁺ʳ xs ]′ (++⁻ xs) (++⁻∘++⁺ xs) (++⁺∘++⁻ xs)

  ++-comm : ∀ {n m} (xs : Vec A n) (ys : Vec A m) →
            Any P (xs ++ ys) → Any P (ys ++ xs)
  ++-comm xs ys = [ ++⁺ʳ ys , ++⁺ˡ ]′ ∘ ++⁻ xs

  ++-comm∘++-comm : ∀ {n m} (xs : Vec A n) {ys : Vec A m} (p : Any P (xs ++ ys)) →
                    ++-comm ys xs (++-comm xs ys p) ≡ p
  ++-comm∘++-comm [] {ys} p
    rewrite ++⁻∘++⁺ ys {ys = []} (inj₁ p) = refl
  ++-comm∘++-comm (x ∷ xs) {ys} (here p)
    rewrite ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₂ (here p)) = refl
  ++-comm∘++-comm (x ∷ xs)      (there p) with ++⁻ xs p | ++-comm∘++-comm xs p
  ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ʳ ys p))))
    | inj₁ p | refl
    rewrite ++⁻∘++⁺ ys (inj₂                 p)
            | ++⁻∘++⁺ ys (inj₂ $ there {x = x} p) = refl
  ++-comm∘++-comm (x ∷ xs) {ys} (there .([ ++⁺ʳ xs , ++⁺ˡ ]′ (++⁻ ys (++⁺ˡ p))))
    | inj₂ p | refl
    rewrite ++⁻∘++⁺ ys {ys =     xs} (inj₁ p)
            | ++⁻∘++⁺ ys {ys = x ∷ xs} (inj₁ p) = refl

  ++↔++ : ∀ {n m} (xs : Vec A n) (ys : Vec A m) → Any P (xs ++ ys) ↔ Any P (ys ++ xs)
  ++↔++ xs ys = inverse (++-comm xs ys) (++-comm ys xs)
                        (++-comm∘++-comm xs) (++-comm∘++-comm ys)

  ++-insert : ∀ {n m x} (xs : Vec A n) {ys : Vec A m} → P x → Any P (xs ++ [ x ] ++ ys)
  ++-insert xs Px = ++⁺ʳ xs (++⁺ˡ (singleton⁺ Px))

------------------------------------------------------------------------
-- concat

module _ {a p} {A : Set a} {P : A → Set p} where

  concat⁺ : ∀ {n m} {xss : Vec (Vec A n) m} → Any (Any P) xss → Any P (concat xss)
  concat⁺ (here p)           = ++⁺ˡ p
  concat⁺ (there {x = xs} p) = ++⁺ʳ xs (concat⁺ p)

  concat⁻ : ∀ {n m} (xss : Vec (Vec A n) m) → Any P (concat xss) → Any (Any P) xss
  concat⁻ []         ()
  concat⁻ (xs ∷ xss) p = [ here , there ∘ concat⁻ xss ]′ (++⁻ xs p)

  concat⁻∘++⁺ˡ : ∀ {n m xs} (xss : Vec (Vec A n) m) (p : Any P xs) →
                concat⁻ (xs ∷ xss) (++⁺ˡ p) ≡ here p
  concat⁻∘++⁺ˡ xss p rewrite ++⁻∘++⁺ _ {concat xss} (inj₁ p) = refl

  concat⁻∘++⁺ʳ : ∀ {n m} xs (xss : Vec (Vec A n) m) (p : Any P (concat xss)) →
                concat⁻ (xs ∷ xss) (++⁺ʳ xs p) ≡ there (concat⁻ xss p)
  concat⁻∘++⁺ʳ xs xss p rewrite ++⁻∘++⁺ xs (inj₂ p) = refl

  concat⁺∘concat⁻ : ∀ {n m} (xss : Vec (Vec A n) m) (p : Any P (concat xss)) →
                   concat⁺ (concat⁻ xss p) ≡ p
  concat⁺∘concat⁻ []         ()
  concat⁺∘concat⁻ (xs ∷ xss) p  with ++⁻ xs p | P.inspect (++⁻ xs) p
  ... | inj₁ pxs | P.[ p=inj₁ ]
    = P.trans (P.cong [ ++⁺ˡ , ++⁺ʳ xs ]′ (P.sym p=inj₁))
    $ ++⁺∘++⁻ xs p
  ... | inj₂ pxss | P.[ p=inj₂ ] rewrite concat⁺∘concat⁻ xss pxss
    = P.trans (P.cong [ ++⁺ˡ , ++⁺ʳ xs ]′ (P.sym p=inj₂))
    $ ++⁺∘++⁻ xs p

  concat⁻∘concat⁺ : ∀ {n m} {xss : Vec (Vec A n) m} (p : Any (Any P) xss) →
                    concat⁻ xss (concat⁺ p) ≡ p
  concat⁻∘concat⁺ {xss = xs ∷ xss} (here p)
    rewrite ++⁻∘++⁺ xs {concat xss} (inj₁ p) = refl
  concat⁻∘concat⁺ {xss = xs ∷ xss} (there p)
    rewrite ++⁻∘++⁺ xs {concat xss} (inj₂ (concat⁺ p))
            | concat⁻∘concat⁺ p = refl

  concat↔ : ∀ {n m} {xss : Vec (Vec A n) m} → Any (Any P) xss ↔ Any P (concat xss)
  concat↔ {xss = xss} = inverse concat⁺ (concat⁻ xss) concat⁻∘concat⁺ (concat⁺∘concat⁻ xss)

------------------------------------------------------------------------
-- tabulate

module _ {a p} {A : Set a} {P : A → Set p} where

  tabulate⁺ : ∀ {n} {f : Fin n → A} i → P (f i) → Any P (tabulate f)
  tabulate⁺ fzero    p = here p
  tabulate⁺ (fsuc i) p = there (tabulate⁺ i p)

  tabulate⁻ : ∀ {n} {f : Fin n → A} →
              Any P (tabulate f) → ∃ λ i → P (f i)
  tabulate⁻ {zero}  ()
  tabulate⁻ {suc n} (here p)  = fzero , p
  tabulate⁻ {suc n} (there p) = Prod.map fsuc id (tabulate⁻ p)

------------------------------------------------------------------------
-- mapWith∈

module _ {a b p} {A : Set a} {B : Set b} {P : B → Set p} where

  open import Data.Vec.Membership.Propositional using (_∈_; mapWith∈)

  mapWith∈⁺ : ∀ {n} {xs : Vec A n} (f : ∀ {x} → x ∈ xs → B) →
              (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) →
              Any P (mapWith∈ xs f)
  mapWith∈⁺ f (_ , here refl  , p) = here p
  mapWith∈⁺ f (_ , there x∈xs , p) =
    there $ mapWith∈⁺ (f ∘ there) (_ , x∈xs , p)

  mapWith∈⁻ : ∀ {n} (xs : Vec A n) (f : ∀ {x} → x ∈ xs → B) →
              Any P (mapWith∈ xs f) →
              ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)
  mapWith∈⁻ []       f ()
  mapWith∈⁻ (y ∷ xs) f (here  p) = (y , here refl , p)
  mapWith∈⁻ (y ∷ xs) f (there p) =
    Prod.map id (Prod.map there id) $ mapWith∈⁻ xs (f ∘ there) p

  mapWith∈↔ : ∀ {n} {xs : Vec A n} {f : ∀ {x} → x ∈ xs → B} →
    (∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) ↔ Any P (mapWith∈ xs f)
  mapWith∈↔ = inverse (mapWith∈⁺ _) (mapWith∈⁻ _ _) (from∘to _) (to∘from _ _)
    where
    from∘to : ∀ {n} {xs : Vec A n} (f : ∀ {x} → x ∈ xs → B)
              (p : ∃₂ λ x (x∈xs : x ∈ xs) → P (f x∈xs)) →
              mapWith∈⁻ xs f (mapWith∈⁺ f p) ≡ p
    from∘to f (_ , here refl  , p) = refl
    from∘to f (_ , there x∈xs , p)
      rewrite from∘to (f ∘ there) (_ , x∈xs , p) = refl

    to∘from : ∀ {n} (xs : Vec A n) (f : ∀ {x} → x ∈ xs → B)
              (p : Any P (mapWith∈ xs f)) →
              mapWith∈⁺ f (mapWith∈⁻ xs f p) ≡ p
    to∘from []       f ()
    to∘from (y ∷ xs) f (here  p) = refl
    to∘from (y ∷ xs) f (there p) =
      P.cong there $ to∘from xs (f ∘ there) p

------------------------------------------------------------------------
-- _∷_

module _ {a p} {A : Set a} where

  ∷↔ : ∀ {n} (P : Pred A p) {x} {xs : Vec A n} → (P x ⊎ Any P xs) ↔ Any P (x ∷ xs)
  ∷↔ P {x} {xs} = ++↔ ∘↔ (singleton↔ ⊎-cong id↔)

------------------------------------------------------------------------
-- _>>=_

module _ {ℓ p} {A B : Set ℓ} {P : B → Set p} {m} {f : A → Vec B m} where

  >>=↔ : ∀ {n} {xs : Vec A n} → Any (Any P ∘ f) xs ↔ Any P (xs >>= f)
  >>=↔ = concat↔ ∘↔ map↔


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

open import lib.Basics
-- open import lib.NType2
-- open import lib.PathGroupoid

open import lib.types.Bool
open import lib.types.IteratedSuspension
open import lib.types.Lift
open import lib.types.LoopSpace
open import lib.types.Nat
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.types.Suspension
open import lib.types.TLevel
open import lib.types.Unit

module nicolai.pseudotruncations.Preliminary-definitions where

-- definition of weak constancy
wconst : ∀ {i j} {A : Type i} {B : Type j} → (A → B) → Type (lmax i j)
wconst {A = A} f = (a₁ a₂ : A) → f a₁ == f a₂

{- Pointed maps (without the 'point') -}
_→̇_ : ∀ {i j} (Â : Ptd i) (B̂ : Ptd j) → Type _
Â →̇ B̂ = fst (Â ⊙→ B̂)

{- It is useful to have a lemma which allows to construct equalities
   between pointed types. Of course, we know that such an equality
   is a pair of equalities; however, transporting a function can
   make things more tedious than necessary! -}
make-=-∙ : ∀ {i j} {Â : Ptd i} {B̂ : Ptd j} (f̂ ĝ : Â →̇ B̂)
           (p : fst f̂ == fst ĝ)
           → ! (app= p (snd Â)) ∙ snd f̂ == snd ĝ
           → f̂ == ĝ
make-=-∙ (f , p) (.f , q) idp t = pair= idp t

{- A lemma that allows to prove that the value of a map between
   pointed maps, at some given point, is some given point.
   This would otherwise be an involved nesting of transports/
   PathOvers. -}
→̇-maps-to : ∀ {i} {Â B̂ Ĉ D̂ : Ptd i} (F̂ : (Â →̇ B̂) → (Ĉ →̇ D̂))
              (f̂ : Â →̇ B̂) (ĝ : Ĉ →̇ D̂)
              (p : fst (F̂ f̂) == (fst ĝ))
              (q : (app= p (snd Ĉ)) ∙ (snd ĝ) == snd (F̂ f̂))
              → F̂ f̂ == ĝ
→̇-maps-to F̂ f̂ (.(fst (F̂ f̂)) , .(snd (F̂ f̂))) idp idp = idp

{- Also trivial: make pointed equivalences from an ordinary equality -}
coe-equiv∙ : ∀ {i} {Â B̂ : Ptd i} → (Â == B̂) → Â ⊙≃ B̂
coe-equiv∙ idp = (idf _ , idp) , idf-is-equiv _

module _ {i} where

  {- Of course, spheres are defined in the library.
     Unfortunately, they do not play well together with iterated suspension.
     If f is an endofunction, one can define [f^Sn] either as [f^n ∘ f] or as
     [f ∘ f^n]. It turns out that it is much more convenient if one chooses
     different possibilites for Ω and for Σ (suspension), as the adjunction
     can then be handled much more directly.
     In summary: It's best to redefine spheres. -}

  ⊙Susp-iter' : (n : ℕ) (Â : Ptd i) → Ptd i
  ⊙Susp-iter' O Â = Â
  ⊙Susp-iter' (S n) Â = ⊙Susp-iter' n (⊙Susp Â)

  {- compare: definition of iterated Ω
    ⊙Ω-iter : (n : ℕ) (Â : Ptd i) → Ptd i
    ⊙Ω-iter O Â = Â
    ⊙Ω-iter (S n) Â = ⊙Ω (⊙Ω-iter n Â)
  -}

  ⊙Sphere' : (n : ℕ) → Ptd i
  ⊙Sphere' n = ⊙Susp-iter' n (⊙Lift ⊙Bool)

  Sphere' : (n : ℕ) → Type i
  Sphere' = fst ∘ ⊙Sphere'

  nor' : (n : ℕ) → Sphere' n
  nor' = snd ∘ ⊙Sphere'

  {- Unfortunately, we will sometimes still need the "other" behaviour of the sphere.
     Thus, we show at least the following: -}

  ⊙Susp-iter : (n : ℕ) (Â : Ptd i) → Ptd i
  ⊙Susp-iter O Â = Â
  ⊙Susp-iter (S n) Â = ⊙Susp (⊙Susp-iter n Â)

  ⊙Sphere* : (n : ℕ) → Ptd i
  ⊙Sphere* n = ⊙Susp-iter n (⊙Lift ⊙Bool)

  Sphere* : (n : ℕ) → Type i
  Sphere* = fst ∘ ⊙Sphere*

  {- Of course, this proof could be done for all endofunctions. -}
  susp-iter= : (n : ℕ) (Â : Ptd i) → ⊙Susp-iter' n Â == ⊙Susp-iter n Â
  susp-iter= O Â = idp
  susp-iter= (S O) Â = idp
  susp-iter= (S (S n)) Â =
    ⊙Susp-iter' (S (S n)) Â
      =⟨ susp-iter= (S n) (⊙Susp Â) ⟩
    ⊙Susp (⊙Susp-iter n (⊙Susp Â))
      =⟨ ap ⊙Susp (! (susp-iter= n (⊙Susp Â))) ⟩
    ⊙Susp (⊙Susp-iter' (S n) Â)
      =⟨ ap ⊙Susp (susp-iter= (S n) Â) ⟩
    ⊙Susp-iter (S (S n)) Â
      ∎

  {- Thus, we have for the spheres: -}
  ⊙Spheres= : (n : ℕ) → ⊙Sphere' n == ⊙Sphere* n
  ⊙Spheres= n = susp-iter= n (⊙Lift ⊙Bool)

  Spheres= : (n : ℕ) → Sphere' n == Sphere* n
  Spheres= n = ap fst (⊙Spheres= n)

  {- Also, we have this: -}
  susp'-switch : (n : ℕ) → ⊙Sphere' (S n) == ⊙Susp (⊙Sphere' n)
  susp'-switch n = (⊙Spheres= (S n)) ∙ (ap ⊙Susp (! (⊙Spheres= n)))