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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Neutral {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Properties
import Definition.Typed.Weakening as Wk
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance
open import Definition.LogicalRelation.Properties.Reflexivity
open import Definition.LogicalRelation.Properties.Escape
open import Definition.LogicalRelation.Properties.Symmetry

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Neutral reflexive types are reducible.
neu : ∀ {l Γ A} (neA : Neutral A)
    → Γ ⊢ A
    → Γ ⊢ A ~ A ∷ U
    → Γ ⊩⟨ l ⟩ A
neu neA A A~A = ne′ _ (idRed:*: A) neA A~A

  -- Helper function for reducible neutral equality of a specific type of derivation.
neuEq′ : ∀ {l Γ A B} ([A] : Γ ⊩⟨ l ⟩ne A)
         (neA : Neutral A)
         (neB : Neutral B)
       → Γ ⊢ A → Γ ⊢ B
       → Γ ⊢ A ~ B ∷ U
       → Γ ⊩⟨ l ⟩ A ≡ B / ne-intr [A]
neuEq′ (noemb (ne K [ ⊢A , ⊢B , D ] neK K≡K)) neA neB A B A~B =
  let A≡K = whnfRed* D (ne neA)
  in  ne₌ _ (idRed:*: B) neB (PE.subst (λ x → _ ⊢ x ~ _ ∷ _) A≡K A~B)
neuEq′ (emb 0<1 x) neB A:≡:B = neuEq′ x neB A:≡:B

-- Neutrally equal types are of reducible equality.
neuEq : ∀ {l Γ A B} ([A] : Γ ⊩⟨ l ⟩ A)
        (neA : Neutral A)
        (neB : Neutral B)
      → Γ ⊢ A → Γ ⊢ B
      → Γ ⊢ A ~ B ∷ U
      → Γ ⊩⟨ l ⟩ A ≡ B / [A]
neuEq [A] neA neB A B A~B =
  irrelevanceEq (ne-intr (ne-elim neA [A]))
                [A]
                (neuEq′ (ne-elim neA [A]) neA neB A B A~B)

mutual
  -- Neutral reflexive terms are reducible.
  neuTerm : ∀ {l Γ A n} ([A] : Γ ⊩⟨ l ⟩ A) (neN : Neutral n)
          → Γ ⊢ n ∷ A
          → Γ ⊢ n ~ n ∷ A
          → Γ ⊩⟨ l ⟩ n ∷ A / [A]
  neuTerm (Uᵣ′ .⁰ 0<1 ⊢Γ) neN n n~n =
    Uₜ _ (idRedTerm:*: n) (ne neN) (~-to-≅ₜ n~n) (neu neN (univ n) n~n)
  neuTerm (ℕᵣ [ ⊢A , ⊢B , D ]) neN n n~n =
    let A≡ℕ  = subset* D
        n~n′ = ~-conv n~n A≡ℕ
        n≡n  = ~-to-≅ₜ n~n′
    in  ℕₜ _ (idRedTerm:*: (conv n A≡ℕ)) n≡n (ne (neNfₜ neN (conv n A≡ℕ) n~n′))
  neuTerm (Emptyᵣ [ ⊢A , ⊢B , D ]) neN n n~n =
    let A≡Empty  = subset* D
        n~n′ = ~-conv n~n A≡Empty
        n≡n  = ~-to-≅ₜ n~n′
    in  Emptyₜ _ (idRedTerm:*: (conv n A≡Empty)) n≡n (ne (neNfₜ neN (conv n A≡Empty) n~n′))
  neuTerm (Unitᵣ [ ⊢A , ⊢B , D ]) neN n n~n =
    let A≡Unit  = subset* D
        n~n′ = ~-conv n~n A≡Unit
    in  Unitₜ _ (idRedTerm:*: (conv n A≡Unit)) (ne neN)
  neuTerm (ne′ K [ ⊢A , ⊢B , D ] neK K≡K) neN n n~n =
    let A≡K = subset* D
    in  neₜ _ (idRedTerm:*: (conv n A≡K)) (neNfₜ neN (conv n A≡K)
            (~-conv n~n A≡K))
  neuTerm (Πᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN n n~n =
    let A≡ΠFG = subset* (red D)
    in  Πₜ _ (idRedTerm:*: (conv n A≡ΠFG)) (ne neN) (~-to-≅ₜ (~-conv n~n A≡ΠFG))
           (λ {ρ} [ρ] ⊢Δ [a] [b] [a≡b] →
              let A≡ΠFG = subset* (red D)
                  ρA≡ρΠFG = Wk.wkEq [ρ] ⊢Δ (subset* (red D))
                  G[a]≡G[b] = escapeEq ([G] [ρ] ⊢Δ [b])
                                          (symEq ([G] [ρ] ⊢Δ [a]) ([G] [ρ] ⊢Δ [b])
                                                 (G-ext [ρ] ⊢Δ [a] [b] [a≡b]))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  b = escapeTerm ([F] [ρ] ⊢Δ) [b]
                  a≡b = escapeTermEq ([F] [ρ] ⊢Δ) [a≡b]
                  ρn = conv (Wk.wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG
                  neN∘a = ∘ₙ (wkNeutral ρ neN)
                  neN∘b = ∘ₙ (wkNeutral ρ neN)
              in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∘a neN∘b
                            (ρn ∘ⱼ a)
                            (conv (ρn ∘ⱼ b) (≅-eq G[a]≡G[b]))
                            (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡b))
           (λ {ρ} [ρ] ⊢Δ [a] →
              let ρA≡ρΠFG = Wk.wkEq [ρ] ⊢Δ (subset* (red D))
                  a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                  a≡a = escapeTermEq ([F] [ρ] ⊢Δ) (reflEqTerm ([F] [ρ] ⊢Δ) [a])
              in  neuTerm ([G] [ρ] ⊢Δ [a]) (∘ₙ (wkNeutral ρ neN))
                          (conv (Wk.wkTerm [ρ] ⊢Δ n) ρA≡ρΠFG ∘ⱼ a)
                          (~-app (~-wk [ρ] ⊢Δ (~-conv n~n A≡ΠFG)) a≡a))
  neuTerm (Σᵣ′ F G D ⊢F ⊢G A≡A [F] [G] G-ext) neN ⊢n n~n =
    let A≡ΣFG = subset* (red D)
        ⊢Γ = wf ⊢F
        ⊢n = conv ⊢n A≡ΣFG
        n~n = ~-conv n~n A≡ΣFG

        [F] = [F] Wk.id ⊢Γ
        [fst] = neuTerm [F] (fstₙ neN)
                        (PE.subst
                          (λ x → _ ⊢ fst _ ∷ x)
                          (PE.sym (wk-id F))
                          (fstⱼ ⊢F ⊢G ⊢n))
                        (PE.subst
                          (λ x → _ ⊢ _ ~ _ ∷ x)
                          (PE.sym (wk-id F))
                          (~-fst ⊢F ⊢G n~n))
        [Gfst] = [G] Wk.id ⊢Γ [fst]
        [snd] = neuTerm [Gfst] (sndₙ neN)
                        (PE.subst
                          (λ x → _ ⊢ snd _ ∷ x)
                          (PE.cong (λ x → x [ fst _ ]) (PE.sym (wk-lift-id G)))
                          (sndⱼ ⊢F ⊢G ⊢n))
                        (PE.subst
                          (λ x → _ ⊢ _ ~ _ ∷ x)
                          (PE.cong (λ x → x [ fst _ ]) (PE.sym (wk-lift-id G)))
                          (~-snd ⊢F ⊢G n~n))
    in  Σₜ _ (idRedTerm:*: ⊢n) (ne neN) (~-to-≅ₜ n~n)
           [fst]
           [snd]
  neuTerm (emb 0<1 x) neN n = neuTerm x neN n

  -- Neutrally equal terms are of reducible equality.
  neuEqTerm : ∀ {l Γ A n n′} ([A] : Γ ⊩⟨ l ⟩ A)
              (neN : Neutral n) (neN′ : Neutral n′)
            → Γ ⊢ n  ∷ A
            → Γ ⊢ n′ ∷ A
            → Γ ⊢ n ~ n′ ∷ A
            → Γ ⊩⟨ l ⟩ n ≡ n′ ∷ A / [A]
  neuEqTerm (Uᵣ′ .⁰ 0<1 ⊢Γ) neN neN′ n n′ n~n′ =
    let [n]  = neu neN  (univ n) (~-trans n~n′ (~-sym n~n′))
        [n′] = neu neN′ (univ n′) (~-trans (~-sym n~n′) n~n′)
    in  Uₜ₌ _ _ (idRedTerm:*: n) (idRedTerm:*: n′) (ne neN) (ne neN′)
            (~-to-≅ₜ n~n′) [n] [n′] (neuEq [n] neN neN′ (univ n) (univ n′) n~n′)
  neuEqTerm (ℕᵣ [ ⊢A , ⊢B , D ]) neN neN′ n n′ n~n′ =
    let A≡ℕ = subset* D
        n~n′₁ = ~-conv n~n′ A≡ℕ
        n≡n′ = ~-to-≅ₜ n~n′₁
    in  ℕₜ₌ _ _ (idRedTerm:*: (conv n A≡ℕ)) (idRedTerm:*: (conv n′ A≡ℕ))
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁))
  neuEqTerm (Emptyᵣ [ ⊢A , ⊢B , D ]) neN neN′ n n′ n~n′ =
    let A≡Empty = subset* D
        n~n′₁ = ~-conv n~n′ A≡Empty
        n≡n′ = ~-to-≅ₜ n~n′₁
    in  Emptyₜ₌ _ _ (idRedTerm:*: (conv n A≡Empty)) (idRedTerm:*: (conv n′ A≡Empty))
            n≡n′ (ne (neNfₜ₌ neN neN′ n~n′₁))
  neuEqTerm (Unitᵣ [ ⊢A , ⊢B , D ]) neN neN′ n n′ n~n′ =
    let A≡Unit = subset* D
    in  Unitₜ₌ (conv n A≡Unit) (conv n′ A≡Unit)
  neuEqTerm (ne (ne K [ ⊢A , ⊢B , D ] neK K≡K)) neN neN′ n n′ n~n′ =
    let A≡K = subset* D
    in  neₜ₌ _ _ (idRedTerm:*: (conv n A≡K)) (idRedTerm:*: (conv n′ A≡K))
             (neNfₜ₌ neN neN′ (~-conv n~n′ A≡K))
  neuEqTerm (Πᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ n n′ n~n′ =
    let [ΠFG] = Πᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΠFG = subset* D
        n~n′₁ = ~-conv n~n′ A≡ΠFG
        n≡n′ = ~-to-≅ₜ n~n′₁
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′
    in  Πₜ₌ _ _ (idRedTerm:*: (conv n A≡ΠFG)) (idRedTerm:*: (conv n′ A≡ΠFG))
            (ne neN) (ne neN′) n≡n′
            (neuTerm [ΠFG] neN n n~n) (neuTerm [ΠFG] neN′ n′ n′~n′)
            (λ {ρ} [ρ] ⊢Δ [a] →
               let ρA≡ρΠFG = Wk.wkEq [ρ] ⊢Δ A≡ΠFG
                   ρn = Wk.wkTerm [ρ] ⊢Δ n
                   ρn′ = Wk.wkTerm [ρ] ⊢Δ n′
                   a = escapeTerm ([F] [ρ] ⊢Δ) [a]
                   a≡a = escapeTermEq ([F] [ρ] ⊢Δ)
                                          (reflEqTerm ([F] [ρ] ⊢Δ) [a])
                   neN∙a   = ∘ₙ (wkNeutral ρ neN)
                   neN′∙a′ = ∘ₙ (wkNeutral ρ neN′)
               in  neuEqTerm ([G] [ρ] ⊢Δ [a]) neN∙a neN′∙a′
                             (conv ρn  ρA≡ρΠFG ∘ⱼ a)
                             (conv ρn′ ρA≡ρΠFG ∘ⱼ a)
                             (~-app (~-wk [ρ] ⊢Δ n~n′₁) a≡a))
  neuEqTerm (Σᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext) neN neN′ ⊢n ⊢n′ n~n′ =
    let [ΣFG] = Σᵣ′ F G [ ⊢A , ⊢B , D ] ⊢F ⊢G A≡A [F] [G] G-ext
        A≡ΣFG = subset* D
        n~n = ~-trans n~n′ (~-sym n~n′)
        n′~n′ = ~-trans (~-sym n~n′) n~n′

        ⊢Γ = wf ⊢F
        ⊢nΣ = conv ⊢n A≡ΣFG
        ⊢n′Σ = conv ⊢n′ A≡ΣFG
        n~n′Σ = ~-conv n~n′ A≡ΣFG
        n~nΣ = ~-conv n~n A≡ΣFG
        n′~n′Σ = ~-conv n′~n′ A≡ΣFG
        [F] = [F] Wk.id ⊢Γ
        ⊢fstnΣ = (PE.subst
                (λ x → _ ⊢ fst _ ∷ x)
                (PE.sym (wk-id F))
                (fstⱼ ⊢F ⊢G ⊢nΣ))
        ⊢fstn′Σ = (PE.subst
                    (λ x → _ ⊢ fst _ ∷ x)
                    (PE.sym (wk-id F))
                    (fstⱼ ⊢F ⊢G ⊢n′Σ))
        [fstn] = neuTerm [F] (fstₙ neN)
                         ⊢fstnΣ
                         (PE.subst
                           (λ x → _ ⊢ _ ~ _ ∷ x)
                           (PE.sym (wk-id F))
                           (~-fst ⊢F ⊢G n~nΣ))
        [fstn′] = neuTerm [F] (fstₙ neN′)
                          ⊢fstn′Σ
                          (PE.subst
                            (λ x → _ ⊢ _ ~ _ ∷ x)
                            (PE.sym (wk-id F))
                            (~-fst ⊢F ⊢G n′~n′Σ))
        [fstn≡fstn′] = neuEqTerm [F] (fstₙ neN) (fstₙ neN′)
                         ⊢fstnΣ
                         ⊢fstn′Σ
                         (PE.subst
                           (λ x → _ ⊢ _ ~ _ ∷ x)
                           (PE.sym (wk-id F))
                           (~-fst ⊢F ⊢G n~n′Σ))
        [Gfstn] = [G] Wk.id ⊢Γ [fstn]
        [Gfstn′] = PE.subst (λ x → _ ⊩⟨ _ ⟩ x [ fst _ ]) (wk-lift-id G) ([G] Wk.id ⊢Γ [fstn′])
        [fstn′≡fstn] = symEqTerm [F] [fstn≡fstn′]
        [Gfstn′≡Gfstn] = irrelevanceEq″
                           (PE.cong (λ x → x [ fst _ ]) (wk-lift-id G))
                           (PE.cong (λ x → x [ fst _ ]) (wk-lift-id G))
                           ([G] Wk.id ⊢Γ [fstn′]) [Gfstn′]
                           (G-ext Wk.id ⊢Γ [fstn′] [fstn] [fstn′≡fstn])
        Gfstn′≡Gfstn = ≅-eq (escapeEq [Gfstn′] [Gfstn′≡Gfstn])
        [sndn≡sndn′] = neuEqTerm [Gfstn] (sndₙ neN) (sndₙ neN′)
                          (PE.subst
                            (λ x → _ ⊢ snd _ ∷ x)
                            (PE.cong (λ x → x [ fst _ ]) (PE.sym (wk-lift-id G)))
                            (sndⱼ ⊢F ⊢G ⊢nΣ))
                          (PE.subst
                            (λ x → _ ⊢ snd _ ∷ x)
                            (PE.cong (λ x → x [ fst _ ]) (PE.sym (wk-lift-id G)))
                            (conv (sndⱼ ⊢F ⊢G ⊢n′Σ) Gfstn′≡Gfstn))
                          (PE.subst
                            (λ x → _ ⊢ _ ~ _ ∷ x)
                            (PE.cong (λ x → x [ fst _ ]) (PE.sym (wk-lift-id G)))
                            (~-snd ⊢F ⊢G n~n′Σ))
    in  Σₜ₌ _ _ (idRedTerm:*: ⊢nΣ) (idRedTerm:*: ⊢n′Σ)
            (ne neN) (ne neN′) (~-to-≅ₜ n~n′Σ)
            (neuTerm [ΣFG] neN ⊢n n~n) (neuTerm [ΣFG] neN′ ⊢n′ n′~n′)
            [fstn] [fstn′] [fstn≡fstn′] [sndn≡sndn′]
  neuEqTerm (emb 0<1 x) neN neN′ n:≡:n′ = neuEqTerm x neN neN′ n:≡:n′


-- {-# OPTIONS -v tc.lhs.problem:10 #-}
-- Do not normalize goals!
module Issue734 where

id : Set → Set
id A = A

g : (A : Set) → id A
g A = {!!}
-- goal should be displayed as "id A", not as "A"


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

open import HoTT
open import homotopy.LoopSpaceCircle
open import homotopy.PinSn
open import homotopy.SphereEndomorphism
open import homotopy.SuspAdjointLoop
open import groups.FromSusp
open import groups.Int
open import groups.Pointed
open import groups.SuspAdjointLoop
open import groups.ToOmega

module groups.SphereEndomorphism where

  ⊙SphereS-endo-group-structure : ∀ n → GroupStructure (⊙Sphere-endo (S n))
  ⊙SphereS-endo-group-structure n = Susp⊙→-group-structure (⊙Sphere n) (⊙Sphere (S n))

{-
  ⊙LiftSphereS-endo-group-structure : ∀ {i} n → GroupStructure (⊙LiftSphere-endo {i} (S n))
  ⊙LiftSphereS-endo-group-structure {i} n =
    LiftSusp⊙→-group-structure {j = i} (⊙Sphere n) (⊙Lift {j = i} (⊙Sphere (S n)))

  ⊙SphereS-endo-siso-⊙LiftSphereS-endo : ∀ {i} n →
    ⊙SphereS-endo-group-structure n ≃ᴳˢ ⊙LiftSphereS-endo-group-structure {i} n
  ⊙SphereS-endo-siso-⊙LiftSphereS-endo {i} n = ≃-to-≃ᴳˢ
    ⊙Lift-fmap-equiv
    (λ f g → ap (_⊙∘ ⊙pinch (⊙Sphere n) ⊙∘ ⊙lower {j = i}) $ ! $
      ⊙∨-rec (⊙Lift-fmap f) (⊙Lift-fmap g) ⊙∘ ⊙∨-fmap ⊙lift ⊙lift
        =⟨ ⊙λ= $ ⊙∨-rec-fmap (⊙Lift-fmap f) (⊙Lift-fmap g) ⊙lift ⊙lift ⟩
      ⊙∨-rec (⊙lift ⊙∘ f) (⊙lift ⊙∘ g)
        =⟨ ! $ ⊙λ= $ ⊙∨-rec-post∘ ⊙lift f g ⟩
      ⊙lift ⊙∘ ⊙∨-rec f g
        =∎)
-}

  Trunc-⊙SphereS-endo-group : ∀ n → Group₀
  Trunc-⊙SphereS-endo-group n = Trunc-Susp⊙→-group (⊙Sphere n) (⊙Sphere (S n))

{-
  Trunc-⊙LiftSphereS-endo-group : ∀ {i} n → Group i
  Trunc-⊙LiftSphereS-endo-group {i} n = Trunc-LiftSusp⊙→-group {j = i} (⊙Sphere n) (⊙Lift {j = i} (⊙Sphere (S n)))
-}

  Trunc-⊙SphereS-endo-⊙group : ∀ n → ⊙Group₀
  Trunc-⊙SphereS-endo-⊙group n = ⊙[ Trunc-⊙SphereS-endo-group n , [ ⊙idf _ ] ]ᴳ

{-
  Trunc-⊙LiftSphereS-endo-⊙group : ∀ {i} n → ⊙Group i
  Trunc-⊙LiftSphereS-endo-⊙group {i} n = ⊙[ Trunc-⊙LiftSphereS-endo-group {i = i} n , [ ⊙idf _ ] ]ᴳ
-}

  Trunc-⊙S¹-endo-group-iso-ℤ : Trunc-⊙SphereS-endo-group 0 ≃ᴳ ℤ-group
  Trunc-⊙S¹-endo-group-iso-ℤ =
    Trunc-⊙SphereS-endo-group 0
      ≃ᴳ⟨ Trunc-Susp⊙→-iso-Trunc-⊙→Ω ⊙Bool ⊙S¹ ⟩
    Trunc-⊙→Ω-group ⊙Bool ⊙S¹
      ≃ᴳ⟨ Trunc-⊙Bool→Ω-iso-π₁ ⊙S¹ ⟩
    πS 0 ⊙S¹
      ≃ᴳ⟨ πS-SphereS-iso-ℤ 0 ⟩
    ℤ-group
      ≃ᴳ∎

  Trunc-⊙S¹-endo-⊙group-iso-⊙ℤ : Trunc-⊙SphereS-endo-⊙group 0 ⊙≃ᴳ ℤ-⊙group
  Trunc-⊙S¹-endo-⊙group-iso-⊙ℤ = Trunc-⊙S¹-endo-group-iso-ℤ ,
    equiv-adj' ΩS¹-equiv-ℤ {a = ap (idf _) loop} {b = 1} (ap-idf loop)

  Trunc-⊙S¹-endo-⊙group-is-infinite-cyclic : is-infinite-cyclic (Trunc-⊙SphereS-endo-⊙group 0)
  Trunc-⊙S¹-endo-⊙group-is-infinite-cyclic =
    isomorphism-preserves'-infinite-cyclic Trunc-⊙S¹-endo-⊙group-iso-⊙ℤ ℤ-is-infinite-cyclic

  Trunc-⊙SphereS-endo-Susp-fmap-iso :
    ∀ n → Trunc-⊙SphereS-endo-group n ≃ᴳ Trunc-⊙SphereS-endo-group (S n)
  Trunc-⊙SphereS-endo-Susp-fmap-iso n =
    Trunc-group-fmap (Susp⊙→-Susp-fmap-shom (⊙Sphere n) (⊙Sphere (S n))) ,
    Trunc-⊙SphereS-endo-Susp-is-equiv n

  Trunc-⊙SphereS-endo-Susp-fmap-⊙iso :
    ∀ n → Trunc-⊙SphereS-endo-⊙group n ⊙≃ᴳ Trunc-⊙SphereS-endo-⊙group (S n)
  Trunc-⊙SphereS-endo-Susp-fmap-⊙iso n =
    Trunc-⊙SphereS-endo-Susp-fmap-iso n , ap [_] (⊙Susp-fmap-idf (⊙Sphere (S n)))

  Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic : ∀ n → is-infinite-cyclic (Trunc-⊙SphereS-endo-⊙group n)
  Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic O = Trunc-⊙S¹-endo-⊙group-is-infinite-cyclic
  Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic (S n) =
    isomorphism-preserves-infinite-cyclic
      (Trunc-⊙SphereS-endo-Susp-fmap-⊙iso n)
      (Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic n)

{-
  Trunc-⊙SphereS-endo-iso-Trunc-⊙LiftSphereS-endo : ∀ {i} n →
    Trunc-⊙SphereS-endo-group n ≃ᴳ Trunc-⊙LiftSphereS-endo-group {i} n
  Trunc-⊙SphereS-endo-iso-Trunc-⊙LiftSphereS-endo {i} n =
    Trunc-group-emap (⊙SphereS-endo-siso-⊙LiftSphereS-endo {i} n)

  Trunc-⊙SphereS-endo-⊙iso-Trunc-⊙LiftSphereS-endo : ∀ {i} n →
    Trunc-⊙SphereS-endo-⊙group n ⊙≃ᴳ Trunc-⊙LiftSphereS-endo-⊙group {i} n
  Trunc-⊙SphereS-endo-⊙iso-Trunc-⊙LiftSphereS-endo {i} n =
    Trunc-⊙SphereS-endo-iso-Trunc-⊙LiftSphereS-endo {i} n , idp

  Trunc-⊙LiftSphereS-endo-⊙group-is-infinite-cyclic : ∀ {i} n → is-infinite-cyclic (Trunc-⊙LiftSphereS-endo-⊙group {i} n)
  Trunc-⊙LiftSphereS-endo-⊙group-is-infinite-cyclic {i} n =
    isomorphism-preserves-infinite-cyclic
      (Trunc-⊙SphereS-endo-⊙iso-Trunc-⊙LiftSphereS-endo {i} n)
      (Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic n)
-}

  {- definition of degree -}

  Trunc-⊙SphereS-endo-degree : ∀ n → Trunc-⊙Sphere-endo (S n) → ℤ
  Trunc-⊙SphereS-endo-degree n = is-equiv.g (Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic n)

  abstract
    Trunc-⊙SphereS-endo-degree-Susp : ∀ n f
      →  Trunc-⊙SphereS-endo-degree (S n) (Trunc-fmap ⊙Susp-fmap f)
      == Trunc-⊙SphereS-endo-degree n f
    Trunc-⊙SphereS-endo-degree-Susp n f =
      ap (Trunc-⊙SphereS-endo-degree n) (GroupIso.g-f (Trunc-⊙SphereS-endo-Susp-fmap-iso n) f)

  ⊙SphereS-endo-degree : ∀ n → ⊙Sphere-endo (S n) → ℤ
  ⊙SphereS-endo-degree n = Trunc-⊙SphereS-endo-degree n ∘ [_]

  abstract
    ⊙SphereS-endo-degree-Susp : ∀ n f
      →  ⊙SphereS-endo-degree (S n) (⊙Susp-fmap f)
      == ⊙SphereS-endo-degree n f
    ⊙SphereS-endo-degree-Susp n f = Trunc-⊙SphereS-endo-degree-Susp n [ f ]

    ⊙SphereS-endo-degree-Susp' : ∀ n f
      →  ⊙SphereS-endo-degree (S n) (Susp-fmap f , idp)
      == Trunc-⊙SphereS-endo-degree n (Trunc-⊙SphereS-endo-in n [ f ])
    ⊙SphereS-endo-degree-Susp' n f =
      ⊙SphereS-endo-degree (S n) (Susp-fmap f , idp)
        =⟨ ap
            (Trunc-⊙SphereS-endo-degree (S n) ∘ Trunc-fmap (λ f → Susp-fmap f , idp))
            (! $ is-equiv.f-g (Trunc-⊙SphereS-endo-out-is-equiv n) [ f ]) ⟩
      Trunc-⊙SphereS-endo-degree (S n) (Trunc-fmap (λ f → Susp-fmap f , idp) (Trunc-fmap fst (Trunc-⊙SphereS-endo-in n [ f ])))
        =⟨ ap (Trunc-⊙SphereS-endo-degree (S n))
            (Trunc-fmap-∘ (λ f → Susp-fmap f , idp) fst (Trunc-⊙SphereS-endo-in n [ f ])) ⟩
      Trunc-⊙SphereS-endo-degree (S n) (Trunc-fmap ⊙Susp-fmap (Trunc-⊙SphereS-endo-in n [ f ]))
        =⟨ Trunc-⊙SphereS-endo-degree-Susp n (Trunc-⊙SphereS-endo-in n [ f ]) ⟩
      Trunc-⊙SphereS-endo-degree n (Trunc-⊙SphereS-endo-in n [ f ])
        =∎

    ⊙SphereS-endo-degree-base-indep : ∀ n {f g}
      → fst f ∼ fst g
      → ⊙SphereS-endo-degree n f == ⊙SphereS-endo-degree n g
    ⊙SphereS-endo-degree-base-indep n {f} {g} f∼g =
      ! (⊙SphereS-endo-degree-Susp n f)
      ∙ ap (λ f → ⊙SphereS-endo-degree (S n) (Susp-fmap f , idp)) (λ= f∼g)
      ∙ ⊙SphereS-endo-degree-Susp n g

{-
  Trunc-⊙LiftSphereS-endo-degree : ∀ {i} n → Trunc-⊙LiftSphere-endo {i} (S n) → ℤ
  Trunc-⊙LiftSphereS-endo-degree {i} n = is-equiv.g (Trunc-⊙LiftSphereS-endo-⊙group-is-infinite-cyclic {i} n)

  abstract
    Trunc-⊙LiftSphereS-endo-degree-Susp : ∀ {i} n f
      →  Trunc-⊙LiftSphereS-endo-degree {i} (S n) (Trunc-fmap (λ f → ⊙Lift-fmap (⊙Susp-fmap (⊙lower ⊙∘ f ⊙∘ ⊙lift))) f)
      == Trunc-⊙LiftSphereS-endo-degree {i} n f
    Trunc-⊙LiftSphereS-endo-degree-Susp {i} n =
      Trunc-elim
        {{λ _ → =-preserves-level ℤ-is-set}}
        (λ f → ⊙SphereS-endo-degree-Susp n (⊙lower ⊙∘ f ⊙∘ ⊙lift))

  ⊙LiftSphereS-endo-degree : ∀ {i} n → ⊙LiftSphere-endo {i} (S n) → ℤ
  ⊙LiftSphereS-endo-degree {i} n = Trunc-⊙LiftSphereS-endo-degree {i} n ∘ [_]

  abstract
    ⊙LiftSphereS-endo-degree-Susp : ∀ {i} n f
      →  ⊙LiftSphereS-endo-degree {i} (S n) (⊙Lift-fmap (⊙Susp-fmap (⊙lower ⊙∘ f ⊙∘ ⊙lift)))
      == ⊙LiftSphereS-endo-degree {i} n f
    ⊙LiftSphereS-endo-degree-Susp {i} n f =
      Trunc-⊙LiftSphereS-endo-degree-Susp {i} n [ f ]

    ⊙LiftSphereS-endo-degree-base-indep : ∀ {i} n {f g}
      → fst f ∼ fst g
      → ⊙LiftSphereS-endo-degree {i} n f == ⊙LiftSphereS-endo-degree {i} n g
    ⊙LiftSphereS-endo-degree-base-indep {i} n {f} {g} f∼g =
      ! (⊙LiftSphereS-endo-degree-Susp {i} n f)
      ∙ ap (λ f → ⊙LiftSphereS-endo-degree {i} (S n) (⊙Lift-fmap (Susp-fmap (lower ∘ f ∘ lift) , idp))) (λ= f∼g)
      ∙ ⊙LiftSphereS-endo-degree-Susp {i} n g
-}


{-# OPTIONS --safe #-}

module Definition.Conversion.Weakening where

open import Definition.Untyped as U hiding (wk)
open import Definition.Untyped.Properties
open import Definition.Typed
open import Definition.Typed.Weakening
open import Definition.Conversion

import Tools.PropositionalEquality as PE

mutual
  -- Weakening of algorithmic equality of neutrals.
  wk~↑! : ∀ {ρ t u A Γ Δ l} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
      → Γ ⊢ t ~ u ↑! A ^ l
      → Δ ⊢ U.wk ρ t ~ U.wk ρ u ↑! U.wk ρ A ^ l
  wk~↑! {ρ} [ρ] ⊢Δ (var-refl x₁ x≡y) = var-refl (wkTerm [ρ] ⊢Δ x₁) (PE.cong (wkVar ρ) x≡y)
  wk~↑! ρ ⊢Δ (app-cong {rF = !} {G = G} t~u x) =
    PE.subst (λ x → _ ⊢ _ ~ _ ↑! x ^ _) (PE.sym (wk-β G))
             (app-cong (wk~↓! ρ ⊢Δ t~u) (wkConv↑Term ρ ⊢Δ x))
  wk~↑! ρ ⊢Δ (app-cong {rF = %} {G = G} t~u x) =
    PE.subst (λ x → _ ⊢ _ ~ _ ↑! x ^ _) (PE.sym (wk-β G))
             (app-cong (wk~↓! ρ ⊢Δ t~u) (wk~↑% ρ ⊢Δ x))
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (natrec-cong {k} {l} {h} {g} {a₀} {b₀} {F} {G} {ll} x x₁ x₂ t~u) =
    PE.subst (λ x → _ ⊢ U.wk ρ (natrec _ F a₀ h k) ~ _ ↑! x ^ _) (PE.sym (wk-β F))
             (natrec-cong (wkConv↑ (lift [ρ]) (⊢Δ ∙ (univ (ℕⱼ ⊢Δ))) x)
                          (PE.subst (λ x → _ ⊢ _ [conv↑] _ ∷ x ^ _) (wk-β F)
                                    (wkConv↑Term [ρ] ⊢Δ x₁))
                          (PE.subst (λ x → Δ ⊢ U.wk ρ h [conv↑] U.wk ρ g ∷ x ^ ι ll)
                                    (wk-β-natrec _ F ! _) (wkConv↑Term [ρ] ⊢Δ x₂))
                          (wk~↓! [ρ] ⊢Δ t~u))
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Emptyrec-cong {k} {l} {F} {G} x t~u) =
    Emptyrec-cong (wkConv↑ [ρ] ⊢Δ x) (wk~↑% [ρ] ⊢Δ t~u)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-cong X x x₁) = Id-cong (wk~↓! [ρ] ⊢Δ X) (wkConv↑Term [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-ℕ x x₁) = Id-ℕ (wk~↓! [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-ℕ0 x) = Id-ℕ0 (wk~↓! [ρ] ⊢Δ x)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-ℕS x x₁) = Id-ℕS (wkConv↑Term [ρ] ⊢Δ x) (wk~↓! [ρ] ⊢Δ x₁)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-U x x₁) = Id-U (wk~↓! [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-Uℕ x) = Id-Uℕ (wk~↓! [ρ] ⊢Δ x)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (Id-UΠ x x₁) = Id-UΠ (wkConv↑Term [ρ] ⊢Δ x) (wk~↓! [ρ] ⊢Δ x₁)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-cong X x x₁ x₂ x₃) =
    cast-cong (wk~↓! [ρ] ⊢Δ X) (wkConv↑Term [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁) (wkTerm [ρ] ⊢Δ x₂) (wkTerm [ρ] ⊢Δ x₃)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-ℕ X x x₁ x₂) =
    cast-ℕ (wk~↓! [ρ] ⊢Δ X) (wkConv↑Term [ρ] ⊢Δ x) (wkTerm [ρ] ⊢Δ x₁) (wkTerm [ρ] ⊢Δ x₂)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-ℕℕ X x x₁) =
    cast-ℕℕ (wk~↓! [ρ] ⊢Δ X) (wkTerm [ρ] ⊢Δ x) (wkTerm [ρ] ⊢Δ x₁)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-Π x X x₁ x₂ x₃) =
    cast-Π (wkConv↑Term [ρ] ⊢Δ x) (wk~↓! [ρ] ⊢Δ X) (wkConv↑Term [ρ] ⊢Δ x₁) (wkTerm [ρ] ⊢Δ x₂) (wkTerm [ρ] ⊢Δ x₃)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-Πℕ x x₁ x₂ x₃) =
    cast-Πℕ (wkConv↑Term [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁) (wkTerm [ρ] ⊢Δ x₂) (wkTerm [ρ] ⊢Δ x₃)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-ℕΠ x x₁ x₂ x₃) =
    cast-ℕΠ (wkConv↑Term [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁) (wkTerm [ρ] ⊢Δ x₂) (wkTerm [ρ] ⊢Δ x₃)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-ΠΠ%! x x₁ x₂ x₃ x₄) =
    cast-ΠΠ%! (wkConv↑Term [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁) (wkConv↑Term [ρ] ⊢Δ x₂) (wkTerm [ρ] ⊢Δ x₃) (wkTerm [ρ] ⊢Δ x₄)
  wk~↑! {ρ} {Δ = Δ} [ρ] ⊢Δ (cast-ΠΠ!% x x₁ x₂ x₃ x₄) =
    cast-ΠΠ!% (wkConv↑Term [ρ] ⊢Δ x) (wkConv↑Term [ρ] ⊢Δ x₁) (wkConv↑Term [ρ] ⊢Δ x₂) (wkTerm [ρ] ⊢Δ x₃) (wkTerm [ρ] ⊢Δ x₄)

  wk~↑% : ∀ {ρ t u A Γ Δ l } ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
        → Γ ⊢ t ~ u ↑% A ^ l
        → Δ ⊢ U.wk ρ t ~ U.wk ρ u ↑% U.wk ρ A ^ l
  wk~↑% [ρ] ⊢Δ (%~↑ ⊢k ⊢l) =
    %~↑ (wkTerm [ρ] ⊢Δ ⊢k) (wkTerm [ρ] ⊢Δ ⊢l)

  wk~↑ : ∀ {ρ t u A rA lA Γ Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
      → Γ ⊢ t ~ u ↑ A ^ [ rA , lA ]
      → Δ ⊢ U.wk ρ t ~ U.wk ρ u ↑ U.wk ρ A ^ [ rA , lA ]
  wk~↑ [ρ] ⊢Δ (~↑! x) = ~↑! (wk~↑! [ρ] ⊢Δ x)
  wk~↑ [ρ] ⊢Δ (~↑% x) = ~↑% (wk~↑% [ρ] ⊢Δ x)

  -- Weakening of algorithmic equality of neutrals in WHNF.
  wk~↓! : ∀ {ρ t u A Γ Δ l} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
      → Γ ⊢ t ~ u ↓! A ^ l
      → Δ ⊢ U.wk ρ t ~ U.wk ρ u ↓! U.wk ρ A ^ l
  wk~↓! {ρ} [ρ] ⊢Δ ([~] A₁ D whnfA k~l) =
    [~] (U.wk ρ A₁) (wkRed* [ρ] ⊢Δ D) (wkWhnf ρ whnfA) (wk~↑! [ρ] ⊢Δ k~l)

  -- Weakening of algorithmic equality of types.
  wkConv↑ : ∀ {ρ A B rA Γ Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
          → Γ ⊢ A [conv↑] B ^ rA
          → Δ ⊢ U.wk ρ A [conv↑] U.wk ρ B ^ rA
  wkConv↑ {ρ} [ρ] ⊢Δ ([↑] A′ B′ D D′ whnfA′ whnfB′ A′<>B′) =
    [↑] (U.wk ρ A′) (U.wk ρ B′) (wkRed* [ρ] ⊢Δ D) (wkRed* [ρ] ⊢Δ D′)
        (wkWhnf ρ whnfA′) (wkWhnf ρ whnfB′) (wkConv↓ [ρ] ⊢Δ A′<>B′)

  -- Weakening of algorithmic equality of types in WHNF.
  wkConv↓ : ∀ {ρ A B rA Γ Δ} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
         → Γ ⊢ A [conv↓] B ^ rA
         → Δ ⊢ U.wk ρ A [conv↓] U.wk ρ B ^ rA
  wkConv↓ ρ ⊢Δ (U-refl eqr x) = U-refl eqr ⊢Δ
  wkConv↓ ρ ⊢Δ (univ x) = univ (wkConv↓Term ρ ⊢Δ x)

  -- Weakening of algorithmic equality of terms.
  wkConv↑Term : ∀ {ρ t u A Γ Δ l} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
             → Γ ⊢ t [conv↑] u ∷ A ^ l
             → Δ ⊢ U.wk ρ t [conv↑] U.wk ρ u ∷ U.wk ρ A ^ l
  wkConv↑Term {ρ} [ρ] ⊢Δ ([↑]ₜ B t′ u′ D d d′ whnfB whnft′ whnfu′ t<>u) =
    [↑]ₜ (U.wk ρ B) (U.wk ρ t′) (U.wk ρ u′)
         (wkRed* [ρ] ⊢Δ D) (wkRed*Term [ρ] ⊢Δ d) (wkRed*Term [ρ] ⊢Δ d′)
         (wkWhnf ρ whnfB) (wkWhnf ρ whnft′) (wkWhnf ρ whnfu′)
         (wkConv↓Term [ρ] ⊢Δ t<>u)

  -- Weakening of algorithmic equality of terms in WHNF.
  wkConv↓Term : ∀ {ρ t u A Γ Δ l} ([ρ] : ρ ∷ Δ ⊆ Γ) → ⊢ Δ
             → Γ ⊢ t [conv↓] u ∷ A ^ l
             → Δ ⊢ U.wk ρ t [conv↓] U.wk ρ u ∷ U.wk ρ A ^ l
  wkConv↓Term ρ ⊢Δ (U-refl eqr x) = U-refl eqr ⊢Δ
  wkConv↓Term ρ ⊢Δ (ne x) = ne (wk~↓! ρ ⊢Δ x)
  wkConv↓Term ρ ⊢Δ (ℕ-ins x) =
    ℕ-ins (wk~↓! ρ ⊢Δ x)
  -- wkConv↓Term ρ ⊢Δ (Empty-ins x) =
  --   Empty-ins (wk~↓% ρ ⊢Δ x)
  wkConv↓Term {ρ} [ρ] ⊢Δ (ne-ins t u x x₁) =
    ne-ins (wkTerm [ρ] ⊢Δ t) (wkTerm [ρ] ⊢Δ u) (wkNeutral ρ x) (wk~↓! [ρ] ⊢Δ x₁)
  wkConv↓Term ρ ⊢Δ (zero-refl x) = zero-refl ⊢Δ
  wkConv↓Term ρ ⊢Δ (suc-cong t<>u) = suc-cong (wkConv↑Term ρ ⊢Δ t<>u)
  wkConv↓Term {ρ} {Δ = Δ} [ρ] ⊢Δ (η-eq {F = F} {G = G} {rF = rF} {lF = lF} {lG = lG} l< l<' x x₁ x₂ y y₁ t<>u) =
    let ⊢ρF = wk [ρ] ⊢Δ x
    in  η-eq l< l<' ⊢ρF (wkTerm [ρ] ⊢Δ x₁) (wkTerm [ρ] ⊢Δ x₂)
             (wkFunction ρ y) (wkFunction ρ y₁)
             (PE.subst₃ (λ x y z → Δ ∙ U.wk ρ F ^ [ rF , ι lF ] ⊢ x [conv↑] y ∷ z ^ ι lG)
                        (PE.cong₃ _∘_^_ (PE.sym (wk1-wk≡lift-wk1 _ _)) PE.refl PE.refl)
                        (PE.cong₃ _∘_^_ (PE.sym (wk1-wk≡lift-wk1 _ _)) PE.refl PE.refl)
                        PE.refl
                        (wkConv↑Term (lift [ρ]) (⊢Δ ∙ ⊢ρF) t<>u))
  wkConv↓Term ρ ⊢Δ (ℕ-refl x) = ℕ-refl ⊢Δ
  wkConv↓Term ρ ⊢Δ (Empty-refl x _) = Empty-refl x ⊢Δ
  wkConv↓Term ρ ⊢Δ (Π-cong eql eqr eqlF eqlG l< l<'   x A<>B A<>B₁) =
    let ⊢ρF = wk ρ ⊢Δ x
    in  Π-cong eql eqr eqlF eqlG l< l<' ⊢ρF (wkConv↑Term ρ ⊢Δ A<>B) (wkConv↑Term (lift ρ) (⊢Δ ∙ ⊢ρF) A<>B₁)
  wkConv↓Term ρ ⊢Δ (∃-cong eql x A<>B A<>B₁) =
    let ⊢ρF = wk ρ ⊢Δ x
    in  ∃-cong eql ⊢ρF (wkConv↑Term ρ ⊢Δ A<>B) (wkConv↑Term (lift ρ) (⊢Δ ∙ ⊢ρF) A<>B₁)


module UniDB.Subst.Core where

open import UniDB.Spec public
open import UniDB.Morph.Unit

record Ap (T X : STX) : Set₁ where
  field
    ap : {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
      {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (x : X γ₁) → X γ₂
open Ap {{...}} public

record ApVr (T : STX) {{vrT : Vr T}} {{apTT : Ap T T}} : Set₁ where
  field
    ap-vr :
      {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
      {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) →
      (i : Ix γ₁) → ap {T} ξ (vr i) ≡ lk {T} ξ i
open ApVr {{...}} public

record LkCompAp
  (T : STX) {{vrT : Vr T}} {{apTT : Ap T T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{compΞ : Comp Ξ}} : Set₁ where
  field
    lk-⊙-ap : {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃)
      (i : Ix γ₁) → lk {T} (ξ₁ ⊙ ξ₂) i ≡ ap {T} ξ₂ (lk ξ₁ i)
open LkCompAp {{...}} public

record ApIdm
  (T : STX) {{vrT : Vr T}}
  (X : STX) {{apTX : Ap T X}} : Set₁ where
  field
    ap-idm :
      {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{idmΞ : Idm Ξ}}
      {{lkIdmTΞ : LkIdm T Ξ}} {{upIdmΞ : UpIdm Ξ}}
      {γ : Dom} (x : X γ) →
      ap {T} (idm {Ξ} γ) x ≡ x
open ApIdm {{...}} public

record ApRel
  (T : STX) {{vrT : Vr T}}
  (X : STX) {{apTX : Ap T X}} : Set₁ where
  field
    ap-rel≅ :
      {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
      {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}}
      {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂} (hyp : [ T ] ξ ≅ ζ)
      (x : X γ₁) → ap {T} ξ x ≡ ap {T} ζ x

  ap-rel≃ :  {{wkT : Wk T}}
    {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{lkUpTΞ : LkUp T Ξ}}
    {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} {{lkUpTΖ : LkUp T Ζ}}
    {γ₁ γ₂ : Dom} {ξ : Ξ γ₁ γ₂} {ζ : Ζ γ₁ γ₂} (hyp : [ T ] ξ ≃ ζ)
    (x : X γ₁) → ap {T} ξ x ≡ ap {T} ζ x
  ap-rel≃ hyp = ap-rel≅ (≃-to-≅` (≃-↑ hyp))
open ApRel {{...}} public

module _
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}}
  (X : STX) {{wkX : Wk X}} {{apTX : Ap T X}}
  where

  record ApWkmWk : Set₁ where
    field
      ap-wkm-wk₁ :
        {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{wkmΞ : Wkm Ξ}}
        {{lkUpTΞ : LkUp T Ξ}} {{lkWkmTΞ : LkWkm T Ξ}}
        {γ : Dom} (x : X γ) →
        ap {T} (wkm {Ξ} 1) x ≡ wk₁ x
      ap-wkm-wk :
        {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{wkmΞ : Wkm Ξ}}
        {{lkUpTΞ : LkUp T Ξ}} {{lkWkmTΞ : LkWkm T Ξ}}
        {γ : Dom} (δ : Dom) (x : X γ) →
        ap {T} (wkm {Ξ} δ) x ≡ wk δ x

  open ApWkmWk {{...}} public

module _
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}}
  (X : STX) {{wkX : Wk X}} {{apTX : Ap T X}}
  where

  record ApWk : Set₁ where
    field
      ap-wk₁ :
        {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
        {{lkUpTΞ : LkUp T Ξ}}
        {γ₁ γ₂ : Dom} (ξ : Ξ γ₁ γ₂) (x : X γ₁) →
        ap {T} (ξ ↑₁) (wk₁ x) ≡ wk₁ (ap {T} ξ x)
  open ApWk {{...}} public

module _
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}} {{apTT : Ap T T}}
  (X : STX) {{apTX : Ap T X}}
  where

  record ApComp : Set₁ where
    field
      ap-⊙ :
        {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{compΞ : Comp Ξ}}
        {{upCompΞ : UpComp Ξ}} {{lkCompTΞ : LkCompAp T Ξ}}
        {γ₁ γ₂ γ₃ : Dom} (ξ₁ : Ξ γ₁ γ₂) (ξ₂ : Ξ γ₂ γ₃) →
          (x : X γ₁) → ap {T} (ξ₁ ⊙ ξ₂) x ≡ ap {T} ξ₂ (ap {T} ξ₁ x)
  open ApComp {{...}} public

instance
  iApIx : Ap Ix Ix
  ap {{iApIx}} = lk

  iApVrIx : ApVr Ix
  ap-vr {{iApVrIx}} ξ i = refl

  iApIdmIxIx : ApIdm Ix Ix
  ap-idm {{iApIdmIxIx}} {Ξ} = lk-idm {Ix} {Ξ}

  iApWkmWkIxIx : ApWkmWk Ix Ix
  ap-wkm-wk₁ {{iApWkmWkIxIx}} {Ξ} = lk-wkm {Ix} {Ξ} 1
  ap-wkm-wk {{iApWkmWkIxIx}} {Ξ} = lk-wkm {Ix} {Ξ}

  iApRelIxIx : ApRel Ix Ix
  ap-rel≅ {{iApRelIxIx}} = lk≃ ∘ ≅-to-≃

  iApWkIxIx : ApWk Ix Ix
  ap-wk₁ {{iApWkIxIx}} {Ξ} ξ i = lk-↑₁-suc {Ix} {Ξ} ξ i

-- TODO: Remove
module _
  (T : STX) {{vrT : Vr T}} {{apTT : Ap T T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
  (Ζ : MOR) {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}}
  (Θ : MOR) {{lkTΘ : Lk T Θ}} {{upΘ : Up Θ}}
  {{hcompΞΖΘ : HComp Ξ Ζ Θ}}
  where

  record LkHCompAp : Set₁ where
    field
      lk-⊡-ap : {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃)
        (i : Ix γ₁) → lk {T} {Θ} (ξ ⊡ ζ) i ≡ ap {T} ζ (lk ξ i)
  open LkHCompAp {{...}} public

-- TODO: Remove
module _
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}} {{apTT : Ap T T}}
  (X : STX) {{apTX : Ap T X}}
  where

  record ApHComp : Set₁ where
    field
      ap-⊡ :
        {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
        {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}}
        {Θ : MOR} {{lkTΘ : Lk T Θ}} {{upΘ : Up Θ}}
        {{hcompΞΖΘ : HComp Ξ Ζ Θ}} {{upHCompΞ : UpHComp Ξ Ζ Θ}}
        {{lkHCompTΞΖΘ : LkHCompAp T Ξ Ζ Θ}}
        {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃) →
          (x : X γ₁) → ap {T} {X} {Θ} (ξ ⊡ ζ) x ≡ ap {T} ζ (ap {T} ξ x)
  open ApHComp {{...}} public

-- TODO: Move
module _
  {T : STX} {{vrT : Vr T}} {{wkT : Wk T}} {{wkVrT : WkVr T}}
  {X : STX} {{wkX : Wk X}} {{apTX : Ap T X}} {{apRelTX : ApRel T X}} {{apIdmTX : ApIdm T X}}
  {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{idmΞ : Idm Ξ}} {{lkIdmTΞ : LkIdm T Ξ}}
  {{lkUpTΞ : LkUp T Ξ}}
  where

  ap-idm` : {γ : Dom} (x : X γ) → ap {T} (idm {Ξ} γ) x ≡ x
  ap-idm` {γ} x = begin
    ap {T} (idm {Ξ} γ) x    ≡⟨ ap-rel≃ {T} lem x ⟩
    ap {T} (idm {Unit} γ) x ≡⟨ ap-idm {T} x ⟩
    x ∎
    where
      lem : [ T ] idm {Ξ} γ ≃ unit
      lk≃ lem = lk-idm {T} {Ξ}


-- The ATP pragma with the role <prove> can be used with postulates.

module ATPConjecture where

postulate
  D   : Set
  _≡_ : D → D → Set

postulate
  sym : ∀ {m n} → m ≡ n → n ≡ m
{-# ATP prove sym #-}


-- Andreas, 2011-04-07

module IrrelevantTelescope where

data Wrap .(A : Set) : Set where
  wrap : A -> Wrap A
-- cannot use A, because it is declared irrelevant


data Bool : Set where
  true false : Bool

record Top : Set where

foo : Top
foo with true
... | true  = _
... | false = top
  where
    top = record{ }  -- the only purpose of this was to force
                     -- evaluation of the with function clauses
                     -- which were in an __IMPOSSIBLE__ state


open import Agda.Builtin.Nat

record R : Set where
  field
    x : Nat

open R {{...}}

f₁ f₂ : R

-- This is fine.
x ⦃ f₁ ⦄ = 0

-- WAS: THIS WORKS BUT MAKES NO SENSE!!!
f₂ ⦃ .x ⦄ = 0

-- Error:

-- Cannot eliminate type R with pattern ⦃ .x ⦄ (suggestion: write .(x)
-- for a dot pattern, or remove the braces for a postfix projection)
-- when checking the clause left hand side
-- f₂ ⦃ .x ⦄


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

module Fragment.Equational.Theory.Base where

open import Function using (_∘_)

open import Fragment.Algebra.Signature
open import Fragment.Algebra.Free
open import Fragment.Algebra.Algebra
open import Fragment.Algebra.Properties

open import Data.Nat using (ℕ)
open import Data.Fin using (Fin)
open import Data.Product using (_×_; map)

Eq : (Σ : Signature) → (n : ℕ) → Set
Eq Σ n = ∥ F Σ n ∥ × ∥ F Σ n ∥

record Theory : Set₁ where
  field
    Σ     : Signature
    eqs   : ℕ → Set
    _⟦_⟧ₑ : ∀ {arity} → eqs arity → Eq Σ arity

  open Signature Σ

open Theory public

data ExtendedEq (Θ : Theory) (E : ℕ → Set) : ℕ → Set where
  newₑ : ∀ {n} → E n → ExtendedEq Θ E n
  oldₑ : ∀ {n} → eqs Θ n → ExtendedEq Θ E n

_⦅_⦆ₒ : (Θ : Theory) → (O : ℕ → Set) → Theory
Θ ⦅ O ⦆ₒ = record { Σ     = (Σ Θ) ⦅ O ⦆
                  ; eqs   = eqs Θ
                  ; _⟦_⟧ₑ = (map extend extend) ∘ Θ ⟦_⟧ₑ
                  }

_⦅_/_⦆ : (Θ : Theory)
         → (E : ℕ → Set)
         → (∀ {n} → E n → Eq (Σ Θ) n)
         → Theory
Θ ⦅ E / ⟦_⟧' ⦆ = record { Σ     = Σ Θ
                        ; eqs   = ExtendedEq Θ E
                        ; _⟦_⟧ₑ = withE
                        }
  where withE : ∀ {n} → ExtendedEq Θ E n → Eq (Σ Θ) n
        withE (newₑ eq) = ⟦ eq ⟧'
        withE (oldₑ eq) = Θ ⟦ eq ⟧ₑ

_⦅_∣_/_⦆ : (Θ : Theory)
           → (O : ℕ → Set)
           → (E : ℕ → Set)
           → (∀ {n} → E n → Eq ((Σ Θ) ⦅ O ⦆) n)
           → Theory
Θ ⦅ O ∣ E / ⟦_⟧' ⦆ = (Θ ⦅ O ⦆ₒ) ⦅ E / ⟦_⟧' ⦆


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Empty where

open import Cubical.Data.Empty.Base public

open import Cubical.Data.Empty.Properties public


{-# OPTIONS --cubical-compatible #-}

variable
  @0 A : Set

record D : Set₁ where
  field
    f : A


module UniDB.Subst.Pair where

open import UniDB.Subst.Core
open import UniDB.Morph.Pair

instance
  iLkPair :
    {T : STX} {{apTT : Ap T T}}
    {Ξ : MOR} {{lkTΞ : Lk T Ξ}}
    {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} →
    Lk T (Pair Ξ Ζ)
  lk {{iLkPair {T}}} (ξ ⊗ ζ) i = ap {T} ζ (lk {T} ξ i)

  iLkRenPair :
    {T : STX} {{vrT : Vr T}} {{apTT : Ap T T}} {{apVrT : ApVr T}}
    {Ξ : MOR} {{lkIxΞ : Lk Ix Ξ}} {{lkTΞ : Lk T Ξ}} {{lkRenTΞ : LkRen T Ξ}}
    {Ζ : MOR} {{lkIxΖ : Lk Ix Ζ}} {{lkTΖ : Lk T Ζ}} {{lkRenTΖ : LkRen T Ζ}} {{upΖ : Up Ζ}} →
    LkRen T (Pair Ξ Ζ)
  lk-ren {{iLkRenPair {T} {Ξ} {Ζ}}} (ξ ⊗ ζ) i = begin
    ap {T} ζ (lk {T} ξ i)        ≡⟨ cong (ap {T} ζ) (lk-ren {T} ξ i) ⟩
    ap {T} ζ (vr (lk {Ix} ξ i))  ≡⟨ ap-vr {T} ζ (lk {Ix} ξ i) ⟩
    lk {T} ζ (lk {Ix} ξ i)       ≡⟨ lk-ren {T} ζ (lk {Ix} ξ i) ⟩
    vr (lk {Ix} ζ (lk {Ix} ξ i)) ∎

  iLkHCompPair :
    {T : STX} {{vrT : Vr T}} {{apTT : Ap T T}}
    {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
    {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} →
    LkHCompAp T Ξ Ζ (Pair Ξ Ζ)
  lk-⊡-ap {{iLkHCompPair}} ξ ζ i = refl

iLkUpPairRenaming :
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}} {{apTT : Ap T T}} {{apVrT : ApVr T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{lkUpTΞ : LkUp T Ξ}}
  {{lkIxΞ : Lk Ix Ξ}} {{lkRenTΞ : LkRen T Ξ}} {{lkUpIxΞ : LkUp Ix Ξ}}
  (Ζ : MOR) {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} {{lkUpTΖ : LkUp T Ζ}} →
  LkUp T (Pair Ξ Ζ)
lk-↑₁-zero {{iLkUpPairRenaming T Ξ Ζ}} (ξ ⊗ ζ) = begin
  ap {T} (ζ ↑₁) (lk {T} (ξ ↑₁) zero)     ≡⟨ cong (ap {T} (ζ ↑₁)) (lk-↑₁-zero ξ) ⟩
  ap {T} (ζ ↑₁) (vr zero)                ≡⟨ ap-vr {T} (ζ ↑₁) zero ⟩
  lk (ζ ↑₁) zero                         ≡⟨ lk-↑₁-zero ζ ⟩
  vr zero                                ∎
lk-↑₁-suc {{iLkUpPairRenaming T Ξ Ζ}} (ξ ⊗ ζ) i = begin
  ap {T} (ζ ↑₁) (lk (ξ ↑₁) (suc i))      ≡⟨ cong (ap {T} (ζ ↑₁)) (lk-ren (ξ ↑₁) (suc i)) ⟩
  ap {T} (ζ ↑₁) (vr (lk (ξ ↑₁) (suc i))) ≡⟨ ap-vr {T} (ζ ↑₁) (lk (ξ ↑₁) (suc i)) ⟩
  lk (ζ ↑₁) (lk (ξ ↑₁) (suc i))          ≡⟨ cong (lk (_↑₁ ζ)) (lk-↑₁-suc ξ i) ⟩
  lk (ζ ↑₁) (suc (lk ξ i))               ≡⟨ lk-↑₁-suc ζ (lk ξ i) ⟩
  wk₁ (lk ζ (lk ξ i))                    ≡⟨ cong wk₁ (sym (ap-vr {T} ζ (lk ξ i))) ⟩
  wk₁ (ap {T} ζ (vr (lk ξ i)))           ≡⟨ cong wk₁ (cong (ap {T} ζ) (sym (lk-ren ξ i))) ⟩
  wk₁ (ap {T} ζ (lk ξ i))                ∎

iLkUpPairSubstitution :
  (T : STX) {{vrT : Vr T}} {{wkT : Wk T}} {{apTT : Ap T T}} {{apVrT : ApVr T}}
  (Ξ : MOR) {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{lkUpTΞ : LkUp T Ξ}}
  (Ζ : MOR) {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} {{lkUpTΖ : LkUp T Ζ}}
  (ap-wk₁-TΖ : {γ₁ γ₂ : Dom} (ζ : Ζ γ₁ γ₂) (t : T γ₁) →
    ap {T} (ζ ↑₁) (wk₁ t) ≡ wk₁ (ap {T} ζ t)) →
  LkUp T (Pair Ξ Ζ)
lk-↑₁-zero {{iLkUpPairSubstitution T Ξ Ζ ap-wk₁-TΖ}} (ξ ⊗ ζ) = begin
  ap {T} (ζ ↑₁) (lk (ξ ↑₁) zero) ≡⟨ cong (ap {T} (ζ ↑₁)) (lk-↑₁-zero ξ) ⟩
  ap {T} (ζ ↑₁) (vr zero)        ≡⟨ ap-vr {T} (ζ ↑₁) zero ⟩
  lk (ζ ↑₁) zero                 ≡⟨ lk-↑₁-zero  ζ ⟩
  vr zero                        ∎
lk-↑₁-suc {{iLkUpPairSubstitution T Ξ Ζ ap-wk₁-TΖ}} (ξ ⊗ ζ) i = begin
  ap {T} (ζ ↑₁) (lk (ξ ↑₁) (suc i)) ≡⟨ cong (ap {T} (ζ ↑₁)) (lk-↑₁-suc ξ i) ⟩
  ap {T} (ζ ↑₁) (wk₁ (lk ξ i))      ≡⟨ ap-wk₁-TΖ ζ (lk ξ i) ⟩
  wk₁ (ap {T} ζ (lk ξ i))           ∎

instance
  iLkUpPair :
    {T : STX} {{vrT : Vr T}} {{wkT : Wk T}} {{apTT : Ap T T}}
    {{apVrT : ApVr T}} {{apWkTT : ApWk T T}}
    {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}} {{lkUpTΞ : LkUp T Ξ}}
    {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}} {{lkUpTΖ : LkUp T Ζ}} →
    LkUp T (Pair Ξ Ζ)
  iLkUpPair {T} {Ξ} {Ζ} = iLkUpPairSubstitution T Ξ Ζ (ap-wk₁ {T})

record ApPair (T : STX) {{apTT : Ap T T}} (X : STX) {{apTX : Ap T X}} : Set₁ where
  field
    ap-pair :
      {Ξ : MOR} {{lkTΞ : Lk T Ξ}} {{upΞ : Up Ξ}}
      {Ζ : MOR} {{lkTΖ : Lk T Ζ}} {{upΖ : Up Ζ}}
      {γ₁ γ₂ γ₃ : Dom} (ξ : Ξ γ₁ γ₂) (ζ : Ζ γ₂ γ₃)
      (x : X γ₁) →
        ap {T} (ξ ⊗ ζ) x ≡ ap {T} ζ (ap {T} ξ x)
open ApPair {{...}} public

instance
  iApPairIxIx : ApPair Ix Ix
  ap-pair {{iApPairIxIx}} {Ξ} ξ ζ i = refl


open import Prelude
open import RW.Language.RTerm
open import RW.Language.FinTerm

module RW.Language.RTermIdx where

  open Eq {{...}}

  data RTermᵢ {a}(A : Set a) : Set a where
    ovarᵢ : (x : A) → RTermᵢ A
    ivarᵢ : (n : ℕ) → RTermᵢ A
    rlitᵢ : (l : Literal) → RTermᵢ A
    rlamᵢ : RTermᵢ A
    rappᵢ : (n : RTermName) → RTermᵢ A

  ovarᵢ-inj : ∀{a}{A : Set a}{x y : A} → ovarᵢ x ≡ ovarᵢ y → x ≡ y
  ovarᵢ-inj refl = refl

  ivarᵢ-inj : ∀{a}{A : Set a}{x y : ℕ} → ivarᵢ {a} {A} x ≡ ivarᵢ {a} y → x ≡ y
  ivarᵢ-inj refl = refl

  rlitᵢ-inj : ∀{a}{A : Set a}{x y : Literal} → rlitᵢ {a} {A} x ≡ rlitᵢ {a} y → x ≡ y
  rlitᵢ-inj refl = refl

  rappᵢ-inj : ∀{a}{A : Set a}{x y : RTermName} → rappᵢ {a} {A} x ≡ rappᵢ {a} y → x ≡ y
  rappᵢ-inj refl = refl

  _≟-RTermᵢ_ : {A : Set}{{eqA : Eq A}}
               → (t₁ t₂ : RTermᵢ A) → Dec (t₁ ≡ t₂)
  _≟-RTermᵢ_ {{eq _≟_}} (ovarᵢ x) (ovarᵢ y)
    with x ≟ y
  ...| yes x≡y = yes (cong ovarᵢ x≡y)
  ...| no  x≢y = no (x≢y ∘ ovarᵢ-inj)
  _≟-RTermᵢ_ (ovarᵢ _) (ivarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (ovarᵢ _) (rlitᵢ _) = no (λ ())
  _≟-RTermᵢ_ (ovarᵢ _) (rlamᵢ  ) = no (λ ())
  _≟-RTermᵢ_ (ovarᵢ _) (rappᵢ _) = no (λ ())
  _≟-RTermᵢ_ (ivarᵢ _) (ovarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (ivarᵢ x) (ivarᵢ y)
    with x ≟-ℕ y
  ...| yes x≡y = yes (cong ivarᵢ x≡y)
  ...| no  x≢y = no (x≢y ∘ ivarᵢ-inj)
  _≟-RTermᵢ_ (ivarᵢ _) (rlitᵢ _) = no (λ ())
  _≟-RTermᵢ_ (ivarᵢ _) (rlamᵢ  ) = no (λ ())
  _≟-RTermᵢ_ (ivarᵢ _) (rappᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlitᵢ _) (ivarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlitᵢ _) (ovarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlitᵢ x) (rlitᵢ y)
    with x ≟-Lit y
  ...| yes x≡y = yes (cong rlitᵢ x≡y)
  ...| no  x≢y = no (x≢y ∘ rlitᵢ-inj)
  _≟-RTermᵢ_ (rlitᵢ _) (rlamᵢ  ) = no (λ ())
  _≟-RTermᵢ_ (rlitᵢ _) (rappᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlamᵢ  ) (ovarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlamᵢ  ) (ivarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlamᵢ  ) (rlitᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rlamᵢ  ) (rlamᵢ  ) = yes refl
  _≟-RTermᵢ_ (rlamᵢ  ) (rappᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rappᵢ _) (ovarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rappᵢ _) (ivarᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rappᵢ _) (rlitᵢ _) = no (λ ())
  _≟-RTermᵢ_ (rappᵢ _) (rlamᵢ  ) = no (λ ())
  _≟-RTermᵢ_ (rappᵢ x) (rappᵢ y)
    with x ≟-RTermName y
  ...| yes x≡y = yes (cong rappᵢ x≡y)
  ...| no  x≢y = no (x≢y ∘ rappᵢ-inj)

  -----------------------------------
  -- Utilities

  out : ∀{a}{A : Set a} → RTerm A → RTermᵢ A × List (RTerm A)
  out (ovar x)    = ovarᵢ x , []
  out (ivar n)    = ivarᵢ n , []
  out (rlit l)    = rlitᵢ l , []
  out (rlam t)    = rlamᵢ , t ∷ []
  out (rapp n ts) = rappᵢ n , ts

  toSymbol : ∀{a}{A : Set a} → RTermᵢ A → Maybe A
  toSymbol (ovarᵢ a) = just a
  toSymbol _         = nothing

  idx-cast : ∀{a b}{A : Set a}{B : Set b}
           → (i : RTermᵢ A) → (toSymbol i ≡ nothing)
           → RTermᵢ B
  idx-cast (ovarᵢ x) ()
  idx-cast (ivarᵢ n) _ = ivarᵢ n
  idx-cast (rlitᵢ l) _ = rlitᵢ l
  idx-cast (rlamᵢ  ) _ = rlamᵢ
  idx-cast (rappᵢ n) _ = rappᵢ n

  instance
    eq-RTermᵢ : {A : Set}{{eqA : Eq A}} → Eq (RTermᵢ A)
    eq-RTermᵢ = eq _≟-RTermᵢ_

  {-
  instance

    RTerm-isTrie : {A : Set}{{eqA : Eq A}}{{enA : Enum A}}
                 → IsTrie (RTerm A)
    RTerm-isTrie {A} {{enA = enum aℕ ℕa}} = record
      { Idx     = RTermᵢ A
      ; idx≡    = eq _≟-RTermᵢ_
      ; toSym   = toSymAux
      ; fromSym = fromSymAux
      ; inₜ     = inAux
      ; outₜ    = outAux
      }
      where
        postulate
          fixme : ∀{a}{A : Set a} → A

        toSymAux : RTermᵢ A → Maybe ℕ
        toSymAux (ovarᵢ n) = aℕ n
        toSymAux _         = nothing

        fromSymAux : ℕ → Maybe (RTermᵢ A)
        fromSymAux n = maybe (λ x → just (ovarᵢ x)) nothing (ℕa n)

        inAux : RTermᵢ A × List (RTerm A) → RTerm A
        inAux (ovarᵢ x , []) = ovar x
        inAux (ivarᵢ x , []) = ivar x
        inAux (rlitᵢ l , []) = rlit l
        inAux (rlamᵢ , t ∷ []) = rlam t
        inAux (rappᵢ n , ts) = rapp n ts
        inAux _ = fixme -- maybe using vectors of the correct arity...

        outAux : RTerm A → RTermᵢ A × List (RTerm A)
        outAux (ovar x) = ovarᵢ x , []
        outAux (ivar n) = ivarᵢ n , []
        outAux (rlit l) = rlitᵢ l , []
        outAux (rlam t) = rlamᵢ , t ∷ []
        outAux (rapp n ts) = rappᵢ n , ts
  {-
    RTerm-isTrie : IsTrie (RTerm ⊥)
    RTerm-isTrie = record
      { Idx   = RTermᵢ ⊥
      ; idx≡  = eq _≟-RTermᵢ_
      ; toSym = toSymAux
      ; fromSym = fromSymAux
      ; inₜ   = inAux
      ; outₜ  = outAux
      } where
        postulate
          fixme : ∀{a}{A : Set a} → A

        toSymAux : RTermᵢ ⊥ → Maybe ℕ
        toSymAux (ovarᵢ ())
        toSymAux (ivarᵢ n) = just n
        toSymAux _         = nothing

        fromSymAux : ℕ → Maybe (RTermᵢ ⊥)
        fromSymAux x = just (ivarᵢ x)

        inAux : RTermᵢ ⊥ × List (RTerm ⊥) → RTerm ⊥
        inAux (ovarᵢ () , [])
        inAux (ivarᵢ x , []) = ivar x
        inAux (rlitᵢ l , []) = rlit l
        inAux (rlamᵢ , t ∷ []) = rlam t
        inAux (rappᵢ n , ts) = rapp n ts
        inAux _ = fixme -- maybe using vectors of the correct arity...

        outAux : RTerm ⊥ → RTermᵢ ⊥ × List (RTerm ⊥)
        outAux (ovar ()) -- = ovarᵢ x , []
        outAux (ivar n) = ivarᵢ n , []
        outAux (rlit l) = rlitᵢ l , []
        outAux (rlam t) = rlamᵢ , t ∷ []
        outAux (rapp n ts) = rappᵢ n , ts
  -}

  RTermTrie : (A : Set){{eqA : Eq A}}{{enA : Enum A}} → Set
  RTermTrie A = BTrie (RTerm A) Name

  insertTerm : {A : Set}{{eqA : Eq A}}{{enA : Enum A}}
             → Name → RTerm A → ℕ × RTermTrie A → ℕ × RTermTrie A
  insertTerm {A} = insert
    where
      open import RW.Data.BTrie.Insert (RTerm A) Name

  lookupTerm : {A : Set}{{eqA : Eq A}}{{enA : Enum A}}
             → RTerm ⊥ → RTermTrie A → List (ℕmap.to (RTerm A) × Name)
  lookupTerm {A} t = lookup (replace-A ⊥-elim t)
    where
      open import RW.Data.BTrie.Lookup (RTerm A) Name

  -}


module BadCon where

data D : Set where
  d : D

data E : Set where
  d : E

postulate
  F : D -> Set

test : (x : D) -> F x
test = d

-- Bad error (unbound de Bruijn index):
-- the constructor d does not construct an element of F @0
-- when checking that the expression d has type (x : D) → F x


open import Everything

module Test.Factsurj3 where

module Test0
  {𝔵 𝔭 𝔯 ℓ} {𝔛 : Ø 𝔵}
  (𝔓 : π̂ 𝔭 𝔛)
  (_≈_ : ∀̇ π̂² ℓ 𝔓)
  (_≈'_ : ∀̇ π̂² ℓ 𝔓)
  (ℜ : π̂² 𝔯 𝔛)
  (ε : Reflexivity.type ℜ)
  (_◃_ : Smaphomarrow!.type ℜ 𝔓)
  (_◃'_ : Smaphomarrow!.type ℜ 𝔓)
  where
  test-class' : ⦃ _ : Leftunit,smaphomarrow.class ℜ 𝔓 ε surjection _◃_ _≈_ ⦄ → Leftunit,smaphomarrow.class ℜ 𝔓 ε surjection _◃_ _≈_
  test-class' = !
  test-method' : ⦃ _ : Leftunit,smaphomarrow.class ℜ 𝔓 ε surjection _◃_ _≈_ ⦄ → Leftunit,smaphomarrow.type ℜ 𝔓 ε surjection _◃_ _≈_
  test-method' = leftunit

test-class : ∀
  {𝔵 𝔭 𝔯 ℓ} {𝔛 : Ø 𝔵}
  {𝔓 : π̂ 𝔭 𝔛}
  ⦃ _ : ∀ {x} → HasEquivalence (𝔓 x) ℓ ⦄
  {ℜ : π̂² 𝔯 𝔛}
  ⦃ _ : Reflexivity.class ℜ ⦄
  ⦃ _ : Smaphomarrow!.class ℜ 𝔓 ⦄
  → ⦃ _ : Leftunit,equivalence,smaphomarrow!.class ℜ 𝔓 ⦄
  → Leftunit,equivalence,smaphomarrow!.class ℜ 𝔓
test-class = !


open import Nat
open import Prelude
open import List
open import core
open import judgemental-erase
open import checks
open import moveerase

module aasubsume-min where
  -- this predicate on derivations of actions bans the cases that induce
  -- non-determinism.
  mutual
    aasubmin-synth : ∀{Γ e t α e' t'} → (Γ ⊢ e => t ~ α ~> e' => t') → Set
    aasubmin-synth (SAZipAsc1 x) = aasubmin-ana x
    aasubmin-synth (SAZipApArr x x₁ x₂ d x₃) = aasubmin-synth d
    aasubmin-synth (SAZipApAna x x₁ x₂) = aasubmin-ana x₂
    aasubmin-synth (SAZipPlus1 x) = aasubmin-ana x
    aasubmin-synth (SAZipPlus2 x) = aasubmin-ana x
    aasubmin-synth (SAZipHole x x₁ d) = aasubmin-synth d
    aasubmin-synth _ = ⊤

    aasubmin-ana : ∀{Γ e α e' t} → (Γ ⊢ e ~ α ~> e' ⇐ t) → Set
    aasubmin-ana (AASubsume x x₁ SAConAsc x₃) = ⊥
    aasubmin-ana (AASubsume x x₁ (SAConLam x₃) x₄) = ⊥
    aasubmin-ana (AASubsume x x₁ s x₃) = aasubmin-synth s
    aasubmin-ana (AAZipLam x₁ x₂ d) = aasubmin-ana d
    aasubmin-ana _ = ⊤

  -- the minimization predicate propagates through subsumption rules
  min-ana-lem : ∀{e e' e◆ Γ t t' t'' α}
                 {a : erase-e e e◆}
                 {b : Γ ⊢ e◆ => t'}
                 {c : t ~ t''} →
                 (d : Γ ⊢ e => t' ~ α ~> e' => t'')
                → aasubmin-ana (AASubsume a b d c) → aasubmin-synth d
  min-ana-lem (SAMove x) min = <>
  min-ana-lem (SADel) min = <>
  min-ana-lem (SAConAsc) min = <>
  min-ana-lem (SAConVar p) min = <>
  min-ana-lem (SAConLam x₁) min = <>
  min-ana-lem (SAConApArr x) min = <>
  min-ana-lem (SAConApOtw x) min = <>
  min-ana-lem (SAConNumlit) min = <>
  min-ana-lem (SAConPlus1 x) min = <>
  min-ana-lem (SAConPlus2 x) min = <>
  min-ana-lem (SAConNEHole) min = <>
  min-ana-lem (SAFinish x) min = <>
  min-ana-lem (SAZipAsc1 x) min = min
  min-ana-lem (SAZipAsc2 x x₁ x₂ x₃) min = <>
  min-ana-lem (SAZipApArr x x₁ x₂ c x₃) min = min
  min-ana-lem (SAZipApAna x x₁ x₂) min = min
  min-ana-lem (SAZipPlus1 x) min = min
  min-ana-lem (SAZipPlus2 x) min = min
  min-ana-lem (SAZipHole x x₁ c) min = min

  -- any derivation of an action can be minimized to avoid this cases that
  -- induce non-determinism.
  mutual
    min-synth : ∀{Γ e t α e' t'} → (d : Γ ⊢ e => t ~ α ~> e' => t') →
                        Σ[ e'' ∈ ê ] Σ[ d' ∈ Γ ⊢ e => t ~ α ~> e'' => t' ] aasubmin-synth d'
    min-synth (SAMove x) = _ , SAMove x , <>
    min-synth SADel = _ , SADel , <>
    min-synth SAConAsc = _ , SAConAsc , <>
    min-synth (SAConVar p) = _ , SAConVar p , <>
    min-synth (SAConLam x₁) = _ , SAConLam x₁ , <>
    min-synth (SAConApArr x) = _ , SAConApArr x , <>
    min-synth (SAConApOtw x) = _ , SAConApOtw x , <>
    min-synth SAConNumlit = _ , SAConNumlit , <>
    min-synth (SAConPlus1 x) = _ , SAConPlus1 x , <>
    min-synth (SAConPlus2 x) = _ , SAConPlus2 x , <>
    min-synth SAConNEHole = _ , SAConNEHole , <>
    min-synth (SAFinish x) = _ , SAFinish x , <>
    min-synth (SAZipAsc2 x x₁ x₂ x₃) = _ , SAZipAsc2 x x₁ x₂ x₃ , <>
    min-synth (SAZipAsc1 x) with min-ana x
    ... | _ , a , b = _ ,  SAZipAsc1 a , b
    min-synth (SAZipApArr x x₁ x₂ d x₃) with min-synth d
    ... | _ , a , b = _ , (SAZipApArr x x₁ x₂ a x₃) , b
    min-synth (SAZipApAna x x₁ x₂) with min-ana x₂
    ... | _ , a , b = _ , SAZipApAna x x₁ a , b
    min-synth (SAZipPlus1 x) with min-ana x
    ... | _ , a , b = _ , SAZipPlus1 a , b
    min-synth (SAZipPlus2 x) with min-ana x
    ... | _ , a , b = _ , SAZipPlus2 a , b
    min-synth (SAZipHole x x₁ d) with min-synth d
    ... | _ , a , b = _ , SAZipHole x x₁ a , b

    min-ana : ∀{Γ e α e' t} → (d : Γ ⊢ e ~ α ~> e' ⇐ t) → Σ[ e'' ∈ ê ] Σ[ d' ∈  Γ ⊢ e ~ α ~> e'' ⇐ t ] aasubmin-ana d'
    min-ana (AASubsume {Γ = Γ} x x₁ (SAMove x₂) x₃) = _ , AAMove x₂ , <>
    min-ana (AASubsume x x₁ SADel x₃) = _ , AADel , <>
    min-ana (AASubsume {Γ = Γ}  {t = t} {t' = t'}  x x₁ SAConAsc x₃) = _ , AAConAsc {Γ = Γ} {t = t} , <>
    min-ana (AASubsume x x₁ (SAConVar p) x₃) = _ , AASubsume x x₁ (SAConVar p) x₃ , <>
    min-ana (AASubsume EETop SEHole (SAConLam x₃) TCRefl)        = _ , AAConLam1 x₃ MAArr , <>
    min-ana (AASubsume EETop SEHole (SAConLam x₃) TCHole2)       = _ , AAConLam1 x₃ MAHole , <>
    min-ana (AASubsume EETop SEHole (SAConLam x₃) (TCArr x₄ x₅)) = _ , AAConLam1 x₃ MAArr , <>
    min-ana (AASubsume x x₁ (SAConApArr x₂) x₃) = _ , AASubsume x x₁ (SAConApArr x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConApOtw x₂) x₃) = _ , AASubsume x x₁ (SAConApOtw x₂) x₃ , <>
    min-ana (AASubsume x x₁ SAConNumlit x₃) = _ , AASubsume x x₁ SAConNumlit x₃ , <>
    min-ana (AASubsume x x₁ (SAConPlus1 x₂) x₃) = _ , AASubsume x x₁ (SAConPlus1 x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAConPlus2 x₂) x₃) = _ , AASubsume x x₁ (SAConPlus2 x₂) x₃ , <>
    min-ana (AASubsume x x₁ SAConNEHole x₃) = _ , AASubsume x x₁ SAConNEHole x₃ , <>
    min-ana (AASubsume x x₁ (SAFinish x₂) x₃) = _ ,  AASubsume x x₁ (SAFinish x₂) x₃ , <>
    min-ana (AASubsume x x₁ (SAZipAsc2 x₂ x₃ x₄ x₅) x₆) = _ , AASubsume x x₁ (SAZipAsc2 x₂ x₃ x₄ x₅) x₆ , <>
    min-ana (AASubsume x x₁ (SAZipAsc1 x₂) x₃) with min-ana x₂
    ... | a , b , c = _ , AASubsume x x₁ (SAZipAsc1 b) x₃ , c
    min-ana (AASubsume x x₁ (SAZipApArr x₂ x₃ x₄ x₅ x₆) x₇) with min-synth x₅
    ... | a , b , c = _ , AASubsume x x₁ (SAZipApArr x₂ x₃ x₄ b x₆) x₇ , c
    min-ana (AASubsume x x₁ (SAZipApAna x₂ x₃ x₄) x₅) with min-ana x₄
    ... | a , b , c = _ , AASubsume x x₁ (SAZipApAna x₂ x₃ b) x₅ , c
    min-ana (AASubsume x x₁ (SAZipPlus1 x₂) x₃) with min-ana x₂
    ... | a , b , c = _ , AASubsume x x₁ (SAZipPlus1 b) x₃ , c
    min-ana (AASubsume x x₁ (SAZipPlus2 x₂) x₃) with min-ana x₂
    ... | a , b , c = _ , AASubsume x x₁ (SAZipPlus2 b) x₃ , c
    min-ana (AASubsume x x₁ (SAZipHole x₂ x₃ x₄) x₅) with min-synth x₄
    ... | a , b , c = _ , AASubsume x x₁ (SAZipHole x₂ x₃ b) x₅ , c
    min-ana (AAMove x) = _ , AAMove x , <>
    min-ana AADel = _ , AADel , <>
    min-ana AAConAsc = _ , AAConAsc , <>
    min-ana (AAConVar x₁ p) = _ , AAConVar x₁ p , <>
    min-ana (AAConLam1 x₁ x₂) = _ , AAConLam1 x₁ x₂ , <>
    min-ana (AAConLam2 x₁ x₂) = _ , AAConLam2 x₁ x₂ , <>
    min-ana (AAConNumlit x) = _ , AAConNumlit x , <>
    min-ana (AAFinish x) = _ , AAFinish x , <>
    min-ana (AAZipLam x₁ x₂ d) with min-ana d
    ... | a , b , c = _ , AAZipLam x₁ x₂ b , c

  -- these theorems argue that if a derivation is already subsumption
  -- minimal than the minimzer does not change the resultant
  -- expression--that it's conservative in this sense. they do not argue
  -- that the derivation that's computer is itself the same as the input
  -- derivation.
  mutual
    min-fixed-synth : ∀ {Γ e t α e' t'} →
                         (d : Γ ⊢ e => t ~ α ~> e' => t') →
                         aasubmin-synth d →
                         e' == π1 (min-synth d)
    min-fixed-synth (SAMove x) min = refl
    min-fixed-synth SADel min = refl
    min-fixed-synth SAConAsc min = refl
    min-fixed-synth (SAConVar p) min = refl
    min-fixed-synth (SAConLam x₁) min = refl
    min-fixed-synth (SAConApArr x) min = refl
    min-fixed-synth (SAConApOtw x) min = refl
    min-fixed-synth SAConNumlit min = refl
    min-fixed-synth (SAConPlus1 x) min = refl
    min-fixed-synth (SAConPlus2 x) min = refl
    min-fixed-synth SAConNEHole min = refl
    min-fixed-synth (SAFinish x) min = refl
    min-fixed-synth (SAZipAsc1 x) min with min-fixed-ana x min
    ... | qq with min-ana x
    ... | (e'' , d' , min') = ap1 (λ q → q ·:₁ _) qq
    min-fixed-synth (SAZipAsc2 x x₁ x₂ x₃) min = refl
    min-fixed-synth (SAZipApArr x x₁ x₂ d x₃) min with min-fixed-synth d min
    ... | qq with min-synth d
    ... | (e'' , d' , min') = ap1 (λ q → q ∘₁ _) qq
    min-fixed-synth (SAZipApAna x x₁ x₂) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → _ ∘₂ q) qq
    min-fixed-synth (SAZipPlus1 x) min with min-fixed-ana x min
    ... | qq with min-ana x
    ... | (e'' , _ , _) = ap1 (λ q → q ·+₁ _) qq
    min-fixed-synth (SAZipPlus2 x) min with min-fixed-ana x min
    ... | qq with min-ana x
    ... | (e'' , _ , _) = ap1 (λ q → _ ·+₂ q) qq
    min-fixed-synth (SAZipHole x x₁ d) min with min-fixed-synth d min
    ... | qq with min-synth d
    ... | (e'' , _ , _) = ap1 ⦇⌜_⌟⦈ qq

    min-fixed-ana : ∀ {Γ e t α e' } →
                         (d : Γ ⊢ e ~ α ~> e' ⇐ t) →
                         aasubmin-ana d →
                         e' == π1 (min-ana d)
    min-fixed-ana (AASubsume x x₁ (SAMove x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SADel x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SAConAsc x₃) min = abort min
    min-fixed-ana (AASubsume x₁ x₂ (SAConVar p) x₃) min = refl
    min-fixed-ana (AASubsume x₁ x₂ (SAConLam x₃) x₄) min = abort min
    min-fixed-ana (AASubsume x x₁ (SAConApArr x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConApOtw x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SAConNumlit x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConPlus1 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAConPlus2 x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ SAConNEHole x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAFinish x₂) x₃) min = refl
    min-fixed-ana (AASubsume x x₁ (SAZipAsc1 x₂) x₃) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → q ·:₁ _) qq
    min-fixed-ana (AASubsume x x₁ (SAZipAsc2 x₂ x₃ x₄ x₅) x₆) min = refl
    min-fixed-ana (AASubsume x x₁ (SAZipApArr x₂ x₃ x₄ x₅ x₆) x₇) min with min-fixed-synth x₅ min
    ... | qq with min-synth x₅
    ... | (e'' , d' , min') = ap1 (λ q → q ∘₁ _) qq
    min-fixed-ana (AASubsume x x₁ (SAZipApAna x₂ x₃ x₄) x₅) min with min-fixed-ana x₄ min
    ... | qq with min-ana x₄
    ... | (e'' , _ , _) = ap1 (λ q → _ ∘₂ q) qq
    min-fixed-ana (AASubsume x x₁ (SAZipPlus1 x₂) x₃) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → q ·+₁ _) qq
    min-fixed-ana (AASubsume x x₁ (SAZipPlus2 x₂) x₃) min with min-fixed-ana x₂ min
    ... | qq with min-ana x₂
    ... | (e'' , _ , _) = ap1 (λ q → _ ·+₂ q) qq
    min-fixed-ana (AASubsume x x₁ (SAZipHole x₂ x₃ x₄) x₅) min with min-fixed-synth x₄ min
    ... | qq with min-synth x₄
    ... | (e'' , _ , _) = ap1 ⦇⌜_⌟⦈ qq
    min-fixed-ana (AAMove x) min = refl
    min-fixed-ana AADel min = refl
    min-fixed-ana AAConAsc min = refl
    min-fixed-ana (AAConVar x₁ p) min = refl
    min-fixed-ana (AAConLam1 x₁ x₂) min = refl
    min-fixed-ana (AAConLam2 x₁ x₂) min = refl
    min-fixed-ana (AAConNumlit x) min = refl
    min-fixed-ana (AAFinish x) min = refl
    min-fixed-ana (AAZipLam x₁ x₂ d) min with min-fixed-ana d min
    ... | qq with min-ana d
    ... | (e'' , _ , _) = ap1 (λ q → ·λ _ q) qq


{-# OPTIONS --no-pattern-matching #-}

id : {A : Set} (x : A) → A
id x = x

data Unit : Set where
  unit : Unit

fail : Unit → Set
fail unit = Unit
-- Expected error: Pattern matching is disabled


------------------------------------------------------------------------------
-- The predicate names are translated as constant names
------------------------------------------------------------------------------

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

module PredicateNameConstantName where

postulate
  D : Set
  P : D → Set

postulate foo : ∀ d → P d → P d
{-# ATP prove foo #-}


-- Andreas, 2016-07-28, issue #779

record P : Set where
  postulate Bla : Set
  field F : Set

-- Current error:
-- Missing definition for Bla

-- Expected:
-- Success, or error outlawing postulate before last field.


-- Sample non-literate Agda program
-- ================================
--
-- A remark to test bulleted lists:
--
-- * This file serves as example for agda2lagda.
--
-- * The content may be non-sensical.
--
-- Indeed!

module Foo where

-- Some data type.

data D : Set where
  c : D

-- A function.
foo : D → D
foo c = c   -- basically, the identity

{- This part is commented out.
{-
bar : D → Set
bar x = D
-- -}
-- -}

-- A subheading
---------------

module Submodule where

  postulate
    zeta : D

-- That's it.
-- Bye.


-- Two fun examples of generic programming using univalence

{-# OPTIONS --cubical --safe #-}
module Cubical.Experiments.Generic where

open import Agda.Builtin.String
open import Agda.Builtin.List

open import Cubical.Core.Everything

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence

open import Cubical.Data.Nat
open import Cubical.Data.Int
open import Cubical.Data.Prod

----------------------------------------------------------------------------
--
-- Dan Licata's example from slide 47 of:
-- http://dlicata.web.wesleyan.edu/pubs/l13jobtalk/l13jobtalk.pdf

There : Type₀ → Type₀
There X = List (ℕ × String × (X × ℕ))

Database : Type₀
Database = There (ℕ × ℕ)

us : Database
us = (4  , "John"  , (30 ,  5) , 1956)
   ∷ (8  , "Hugo"  , (29 , 12) , 1978)
   ∷ (15 , "James" , (1  ,  7) , 1968)
   ∷ (16 , "Sayid" , (2  , 10) , 1967)
   ∷ (23 , "Jack"  , (3  , 12) , 1969)
   ∷ (42 , "Sun"   , (20 ,  3) , 1980)
   ∷ []

convert : Database → Database
convert d = transport (λ i → There (swapEq ℕ ℕ i)) d

-- Swap the dates of the American database to get the European format
eu : Database
eu = convert us

-- A sanity check
_ : us ≡ convert eu
_ = refl

----------------------------------------------------------------------------
--
-- Example inspired by:
--
-- Scrap Your Boilerplate: A Practical Design Pattern for Generic Programming
-- Ralf Lämmel & Simon Peyton Jones, TLDI'03

Address : Type₀
Address = String

Name : Type₀
Name = String

data Person : Type₀ where
  P : Name → Address → Person

data Salary (A : Type₀) : Type₀ where
  S : A → Salary A

data Employee (A : Type₀) : Type₀ where
  E : Person → Salary A → Employee A

Manager : Type₀ → Type₀
Manager A = Employee A

-- First test of "mutual"
mutual
  data Dept (A : Type₀) : Type₀ where
    D : Name → Manager A → List (SubUnit A) → Dept A

  data SubUnit (A : Type₀) : Type₀ where
    PU : Employee A → SubUnit A
    DU : Dept A → SubUnit A

data Company (A : Type₀) : Type₀ where
  C : List (Dept A) → Company A

-- A small example

anders : Employee Int
anders = E (P "Anders" "Pittsburgh") (S (pos 2500))

andrea : Employee Int
andrea = E (P "Andrea" "Copenhagen") (S (pos 2000))

andreas : Employee Int
andreas = E (P "Andreas" "Gothenburg") (S (pos 3000))

-- For now we have a small company
genCom : Company Int
genCom =
  C ( D "Research" andreas (PU anders ∷ PU andrea ∷ [])
    ∷ [])

-- Increase the salary for everyone by 1
incSalary : Company Int → Company Int
incSalary c = transport (λ i → Company (sucPathInt i)) c

genCom1 : Company Int
genCom1 = incSalary genCom

-- Increase the salary more
incSalaryℕ : ℕ → Company Int → Company Int
incSalaryℕ n c = transport (λ i → Company (addEq n i)) c

genCom2 : Company Int
genCom2 = incSalaryℕ 2 genCom

genCom10 : Company Int
genCom10 = incSalaryℕ 10 genCom


------------------------------------------------------------------------
-- Various parser combinator laws
------------------------------------------------------------------------

-- Note that terms like "monad" and "Kleene algebra" are interpreted
-- liberally in the modules listed below.

module TotalParserCombinators.Laws where

open import Algebra
open import Category.Monad
open import Codata.Musical.Notation
open import Data.List as List
import Data.List.Categorical
open import Data.List.Properties
open import Data.List.Relation.Binary.BagAndSetEquality as Eq
  using (bag) renaming (_∼[_]_ to _List-∼[_]_)
open import Data.Maybe hiding (_>>=_)
open import Function
import Level
open import Relation.Binary.PropositionalEquality as P using (_≡_)

private
  module BagMonoid {k} {A : Set} =
    CommutativeMonoid (Eq.commutativeMonoid k A)
  open module ListMonad =
    RawMonad {f = Level.zero} Data.List.Categorical.monad
    using () renaming (_⊛_ to _⊛′_)

open import TotalParserCombinators.Derivative using (D)
open import TotalParserCombinators.Congruence
  hiding (return; fail; token)
open import TotalParserCombinators.Lib hiding (module Return⋆)
open import TotalParserCombinators.Parser

------------------------------------------------------------------------
-- Reexported modules

-- Laws related to _∣_.

import TotalParserCombinators.Laws.AdditiveMonoid
module AdditiveMonoid = TotalParserCombinators.Laws.AdditiveMonoid

-- Laws related to D.

import TotalParserCombinators.Laws.Derivative
module D = TotalParserCombinators.Laws.Derivative
  hiding (left-zero-⊛; right-zero-⊛;
          left-zero->>=; right-zero->>=)

-- Laws related to return⋆.

import TotalParserCombinators.Laws.ReturnStar
module Return⋆ = TotalParserCombinators.Laws.ReturnStar

-- Laws related to _⊛_.

import TotalParserCombinators.Laws.ApplicativeFunctor
module ApplicativeFunctor =
  TotalParserCombinators.Laws.ApplicativeFunctor

-- Laws related to _>>=_.

import TotalParserCombinators.Laws.Monad
module Monad = TotalParserCombinators.Laws.Monad

-- Do the parser combinators form a Kleene algebra?

import TotalParserCombinators.Laws.KleeneAlgebra
module KleeneAlgebra = TotalParserCombinators.Laws.KleeneAlgebra

------------------------------------------------------------------------
-- Some laws for _<$>_

module <$> where

  open D

  -- _<$>_ could have been defined using return and _⊛_.

  return-⊛ : ∀ {Tok R₁ R₂ xs} {f : R₁ → R₂} (p : Parser Tok R₁ xs) →
             f <$> p ≅P return f ⊛ p
  return-⊛ {xs = xs} {f} p =
    BagMonoid.reflexive (lemma xs) ∷ λ t → ♯ (
      f <$> D t p         ≅⟨ return-⊛ (D t p) ⟩
      return f ⊛ D t p    ≅⟨ sym $ D-return-⊛ f p ⟩
      D t (return f ⊛ p)  ∎)
    where
    lemma : ∀ xs → List.map f xs ≡ ([ f ] ⊛′ xs)
    lemma []       = P.refl
    lemma (x ∷ xs) = P.cong (_∷_ (f x)) $ lemma xs

  -- fail is a zero for _<$>_.

  zero : ∀ {Tok R₁ R₂} {f : R₁ → R₂} →
         f <$> fail {Tok = Tok} ≅P fail
  zero {f = f} =
    f <$> fail       ≅⟨ return-⊛ fail ⟩
    return f ⊛ fail  ≅⟨ ApplicativeFunctor.right-zero (return f) ⟩
    fail             ∎

  -- A variant of ApplicativeFunctor.homomorphism.

  homomorphism : ∀ {Tok R₁ R₂} (f : R₁ → R₂) {x} →
                 f <$> return {Tok = Tok} x ≅P return (f x)
  homomorphism f {x} =
    f <$> return x       ≅⟨ return-⊛ {f = f} (return x) ⟩
    return f ⊛ return x  ≅⟨ ApplicativeFunctor.homomorphism f x ⟩
    return (f x)         ∎

  -- Adjacent uses of _<$>_ can be fused.

  <$>-<$> : ∀ {Tok R₁ R₂ R₃ xs}
              {f : R₂ → R₃} {g : R₁ → R₂} {p : Parser Tok R₁ xs} →
            f <$> (g <$> p) ≅P (f ∘ g) <$> p
  <$>-<$> = BagMonoid.reflexive (P.sym (map-compose _)) ∷ λ _ → ♯ <$>-<$>

------------------------------------------------------------------------
-- A law for nonempty

module Nonempty where

  -- fail is a zero for nonempty.

  zero : ∀ {Tok R} → nonempty {Tok = Tok} {R = R} fail ≅P fail
  zero = BagMonoid.refl ∷ λ t → ♯ (fail ∎)

  -- nonempty (return x) is parser equivalent to fail.

  nonempty-return :
    ∀ {Tok R} {x : R} → nonempty {Tok = Tok} (return x) ≅P fail
  nonempty-return = BagMonoid.refl ∷ λ t → ♯ (fail ∎)

  -- nonempty can be defined in terms of token, _>>=_ and D.

  private

    nonempty′ : ∀ {Tok R xs} (p : Parser Tok R xs) → Parser Tok R []
    nonempty′ p = token >>= λ t → D t p

  nonempty-definable : ∀ {Tok R xs} (p : Parser Tok R xs) →
                       nonempty p ≅P nonempty′ p
  nonempty-definable p = BagMonoid.refl ∷ λ t → ♯ (
    D t p              ≅⟨ sym $ Monad.left-identity t (λ t′ → D t′ p) ⟩
    ret-D t            ≅⟨ sym $ AdditiveMonoid.right-identity (ret-D t) ⟩
    ret-D t ∣ fail     ≅⟨ (ret-D t ∎) ∣ sym (Monad.left-zero _) ⟩
    D t (nonempty′ p)  ∎)
    where ret-D = λ (t : _) → return t >>= (λ t′ → D t′ p)

------------------------------------------------------------------------
-- A law for cast

module Cast where

  -- Casts can be erased.

  correct : ∀ {Tok R xs₁ xs₂}
              {xs₁≈xs₂ : xs₁ List-∼[ bag ] xs₂}
              {p : Parser Tok R xs₁} →
            cast xs₁≈xs₂ p ≅P p
  correct {xs₁≈xs₂ = xs₁≈xs₂} {p} =
    BagMonoid.sym xs₁≈xs₂ ∷ λ t → ♯ (D t p ∎)

------------------------------------------------------------------------
-- A law for subst

module Subst where

  -- Uses of subst can be erased.

  correct : ∀ {Tok R xs₁ xs₂}
              (xs₁≡xs₂ : xs₁ ≡ xs₂)
              {p : Parser Tok R xs₁} →
            P.subst (Parser Tok R) xs₁≡xs₂ p ≅P p
  correct P.refl {p} = p ∎

  correct∞ : ∀ {Tok R xs₁ xs₂ A} {m : Maybe A}
              (xs₁≡xs₂ : xs₁ ≡ xs₂)
              (p : ∞⟨ m ⟩Parser Tok R xs₁) →
             ♭? (P.subst (∞⟨ m ⟩Parser Tok R) xs₁≡xs₂ p) ≅P ♭? p
  correct∞ P.refl p = ♭? p ∎


module Issue4924 where

record R (T : Set) : Set where
  field
    f : T → T

module _ {A B : Set} (ra : R A) (rb : R B) (pri : {T : Set} → {{r : R T}} → T) where
  open R ra
  open R rb

  instance
    _ = ra

  _ : A
  _ = f pri


module Categories.Monad.Algebra where


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

open import Fragment.Equational.Theory

module Fragment.Equational.FreeExtension (Θ : Theory) where

open import Fragment.Equational.FreeExtension.Base Θ public
open import Fragment.Equational.FreeExtension.Synthetic Θ using (SynFrex) public
open import Fragment.Equational.FreeExtension.Properties Θ public


-- Issue #4115 reported by Guillaume Brunerie

{-# OPTIONS --prop #-}

data Unit : Set where
  tt : Unit

postulate
  P : Prop

{-# TERMINATING #-}
p : P
p = p

works : Unit → P
works b = p

-- WAS: Agda loops during injectivity analysis of `loops`
loops : Unit → P
loops tt = p


module Generic.Function.Elim where

open import Generic.Core

AllAny : ∀ {ι α β γ δ} {I : Set ι} {A : Set α} {C : I -> Set γ}
       -> (B : I -> A -> Set β)
       -> (∀ x -> (∀ {j} -> B j x -> C j) -> Set δ)
       -> (xs : List A)
       -> (∀ {j} -> Any (B j) xs -> C j)
       -> Set δ
AllAny B D  []          k = ⊤
AllAny B D (x ∷ [])     k = D x k
AllAny B D (x ∷ y ∷ xs) k = D x (k ∘ inj₁) × AllAny B D (y ∷ xs) (k ∘ inj₂)

data VarView {ι β} {I : Set ι} : Desc I β -> Set where
  yes-var : ∀ {i} -> VarView (var i)
  no-var  : ∀ {D} -> VarView  D

varView : ∀ {ι β} {I : Set ι} -> (D : Desc I β) -> VarView D
varView (var i) = yes-var
varView  D      = no-var

mutual
  Hyp : ∀ {ι β γ} {I : Set ι} {B}
      -> (∀ {i} -> B i -> Set γ) -> (D : Desc I β) -> ⟦ D ⟧ B -> Set (β ⊔ γ)
  Hyp {β = β} C (var i)    y      = Lift β (C y)
  Hyp         C (π i q D)  f      = Hypᵇ i C D f
  Hyp         C (D ⊛ E)   (x , y) = Hyp C D x × Hyp C E y

  Hypᵇ : ∀ {ι α β γ δ q q′} {I : Set ι} {B} i
       -> (∀ {i} -> B i -> Set γ) -> (D : Binder α β δ i q′ I) -> ⟦ i / D ⟧ᵇ q B -> Set (β ⊔ γ)
  Hypᵇ {γ = γ} {q = q} i C (coerce (A , D)) f =
    Coerce′ (cong (γ ⊔_) q) $ Pi i A λ x -> Hyp C (D x) (appPi i (uncoerce′ q f) x)

mutual
  Elim : ∀ {ι β γ} {I : Set ι} {B}
       -> (∀ {i} -> B i -> Set γ)
       -> (D : Desc I β)
       -> (∀ {j} -> Extend D B j -> B j)
       -> Set (β ⊔ γ)
  Elim {β = β} C (var i)   k = Lift β (C (k lrefl))
  Elim         C (π i q D) k = Elimᵇ i C D k
  Elim         C (D ⊛ E)   k with varView D
  ... | yes-var = ∀ {x} -> C x -> Elim C E (k ∘ _,_ x)
  ... | no-var  = ∀ {x} -> Hyp C D x -> Elim C E (k ∘ _,_ x)

  Elimᵇ : ∀ {ι α β γ δ q q′} {I : Set ι} {B} i
        -> (∀ {i} -> B i -> Set γ)
        -> (D : Binder α β δ i q′ I)
        -> (∀ {j} -> Extendᵇ i D q B j -> B j)
        -> Set (β ⊔ γ)
  Elimᵇ {γ = γ} {q = q} i C (coerce (A , D)) k =
    Coerce′ (cong (γ ⊔_) q) $ Pi i A λ x -> Elim C (D x) (k ∘ coerce′ q ∘ _,_ x)

module _ {ι β γ} {I : Set ι} {D₀ : Data (Desc I β)} (C : ∀ {j} -> μ D₀ j -> Set γ) where
  K : Name -> Type -> Type -> (Ds : List (Desc I β)) -> All (const Name) Ds -> Set (ι ⊔ β)
  K d a b Ds ns = ∀ {j} -> Node D₀ (packData d a b Ds ns) j -> μ D₀ j

  Elims : ∀ d a b (Ds : List (Desc I β)) ns -> K d a b Ds ns -> Set (β ⊔ γ)
  Elims d a b Ds ns = AllAny (λ j D -> Extend D (μ D₀) j) (Elim C) Ds

  module _ (hs : Elims (dataName  D₀)
                       (parsTele  D₀)
                       (indsTele  D₀)
                       (consTypes D₀)
                       (consNames D₀)
                        node) where
    {-# TERMINATING #-}
    mutual
      elimHyp : (D : Desc I β) -> (d : ⟦ D ⟧ (μ D₀)) -> Hyp C D d
      elimHyp (var i)    d      = lift (elim d)
      elimHyp (π i q D)  f      = elimHypᵇ i D f
      elimHyp (D ⊛ E)   (x , y) = elimHyp D x , elimHyp E y

      elimHypᵇ : ∀ {α δ q q′} i
               -> (D : Binder α β δ i q′ I)
               -> (f : ⟦ i / D ⟧ᵇ q (μ D₀))
               -> Hypᵇ i C D f
      elimHypᵇ {q = q} i (coerce (A , D)) f =
        coerce′ (cong (_⊔_ γ) q) (lamPi i λ x -> elimHyp (D x) (appPi i (uncoerce′ q f) x))

      elimExtend : ∀ {j}
                 -> (D : Desc I β) {k : ∀ {j} -> Extend D (μ D₀) j -> μ D₀ j}
                 -> Elim C D k
                 -> (e : Extend D (μ D₀) j)
                 -> C (k e)
      elimExtend (var i)   z  lrefl  = lower z
      elimExtend (π i q D) h  p      = elimExtendᵇ i D h p
      elimExtend (D ⊛ E)   h (d , e) with varView D
      ... | yes-var = elimExtend E (h (elim d))  e
      ... | no-var  = elimExtend E (h (elimHyp D d)) e

      elimExtendᵇ : ∀ {α δ q q′ j} i
                  -> (D : Binder α β δ i q′ I) {k : ∀ {j} -> Extendᵇ i D q (μ D₀) j -> μ D₀ j}
                  -> Elimᵇ i C D k
                  -> (p : Extendᵇ i D q (μ D₀) j)
                  -> C (k p)
      elimExtendᵇ {q = q} i (coerce (A , D)) h p with p | inspectUncoerce′ q p
      ... | _ | (x , e) , refl = elimExtend (D x) (appPi i (uncoerce′ (cong (γ ⊔_) q) h) x) e

      elimAny : ∀ {j} (Ds : List (Desc I β)) d a b ns {k : K d a b Ds ns}
              -> Elims d a b Ds ns k -> (a : Node D₀ (packData d a b Ds ns) j) -> C (k a)
      elimAny  []          d a b  tt       tt       ()
      elimAny (D ∷ [])     d a b (n , ns)  h        e       = elimExtend D h e
      elimAny (D ∷ E ∷ Ds) d a b (n , ns) (h , hs) (inj₁ e) = elimExtend D h e
      elimAny (D ∷ E ∷ Ds) d a b (n , ns) (h , hs) (inj₂ r) = elimAny (E ∷ Ds) d a b ns hs r

      elim : ∀ {j} -> (d : μ D₀ j) -> C d
      elim (node e) = elimAny (consTypes D₀)
                              (dataName  D₀)
                              (parsTele  D₀)
                              (indsTele  D₀)
                              (consNames D₀)
                               hs
                               e


------------------------------------------------------------------------
-- Correct-by-construction pretty-printing
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

-- A pretty-printing library that guarantees that pretty-printers are
-- correct (on the assumption that grammars are unambiguous).

{-# OPTIONS --guardedness #-}

module README where

-- Various utility functions.

import Utilities

-- Infinite grammars.

import Grammar.Infinite.Basic
import Grammar.Infinite

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

import Pretty

-- Document renderers.

import Renderer

-- Examples.

import Examples.Bool
import Examples.Expression
import Examples.Identifier
import Examples.Identifier-list
import Examples.Precedence
import Examples.Tree
import Examples.XML

-- Abstract grammars. (Not used by the pretty-printer.)

import Grammar.Abstract

-- Grammars defined as functions from non-terminals to productions.
-- (Not used by the pretty-printer.)

import Grammar.Non-terminal

-- A README directed towards readers of the paper
-- "Correct-by-Construction Pretty-Printing".

import README.Correct-by-Construction-Pretty-Printing


module ASN1.X509 where

open import Data.Word8 using (Word8; _and_; _or_; _==_) renaming (primWord8fromNat to to𝕎; primWord8toNat to from𝕎)
open import Data.ByteString using (ByteString; Strict; pack; fromChunks; toStrict)
open import Data.ByteString.Utf8 using (packStrict)
open import Data.Bool using (Bool; true; false)
open import Data.Nat using (ℕ; _+_; _*_)
open import Data.List using (List; []; _∷_; foldl)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_)
open import Data.String using (String)

open import ASN1.Untyped
import ASN1.BER as BER

AlgorithmIdentifier : List ℕ → AST → AST
AlgorithmIdentifier oid params = SEQUENCE (OBJECT-IDENTIFIER oid ∷ params ∷ [])

AttributeTypeAndValue : List ℕ → AST → AST
AttributeTypeAndValue type value = SEQUENCE (OBJECT-IDENTIFIER type ∷ value ∷ [])

id-at-commonName : List ℕ
id-at-commonName = 2 ∷ 5 ∷ 4 ∷ 3 ∷ []

CommonName : String → AST
CommonName cn = AttributeTypeAndValue id-at-commonName (UTF8String cn)

RDN : String → AST
RDN cn = SET (CommonName cn ∷ [])

RDNSequence : String → AST
RDNSequence cn = SEQUENCE (RDN cn ∷ [])

Name : String → AST
Name cn = RDNSequence cn

Validity : (from to : String) → AST
Validity from to = SEQUENCE (GeneralizedTime from ∷ GeneralizedTime to ∷ [])

bign-with-hbelt-oid : List ℕ
bign-with-hbelt-oid = 1 ∷ 2 ∷ 112 ∷ 0 ∷ 2 ∷ 0 ∷ 34 ∷ 101 ∷ 45 ∷ 12 ∷ []

bign-pubkey-oid : List ℕ
bign-pubkey-oid = 1 ∷ 2 ∷ 112 ∷ 0 ∷ 2 ∷ 0 ∷ 34 ∷ 101 ∷ 45 ∷ 2 ∷ 1 ∷ []

bign-curve256v1-oid : List ℕ
bign-curve256v1-oid = 1 ∷ 2 ∷ 112 ∷ 0 ∷ 2 ∷ 0 ∷ 34 ∷ 101 ∷ 45 ∷ 3 ∷ 1 ∷ []

SubjectPublicKeyInfo : ByteString Strict → AST
SubjectPublicKeyInfo pub = SEQUENCE
  ( AlgorithmIdentifier bign-pubkey-oid (OBJECT-IDENTIFIER bign-curve256v1-oid)
  ∷ BIT-STRING 0 pub ∷ [])

Extension : OID → (critical : Bool) → ByteString Strict → AST
Extension oid true value = SEQUENCE (OBJECT-IDENTIFIER oid ∷ BOOLEAN true ∷ OCTET-STRING value ∷ [])
Extension oid false value = SEQUENCE (OBJECT-IDENTIFIER oid ∷ OCTET-STRING value ∷ [])

module mkCert
  (issuer-cn : String)
  (subject-cn : String)
  (validity-from : String)
  (validity-to : String)
  (pub : ByteString Strict)
  (sign : ByteString Strict → ByteString Strict) -- tbs → sig
  where

  sa version serial issuer validity subject spki : AST
  sa = AlgorithmIdentifier bign-with-hbelt-oid NULL
  version = EXPLICIT (to𝕎 0) (INTEGER 2) -- v3
  serial = INTEGER 1
  issuer = Name issuer-cn
  validity = Validity validity-from validity-to
  subject = Name subject-cn
  spki = SubjectPublicKeyInfo pub
  {-
  ku
  eku
  skid
  ikid
  -- id-ce = 2 ∷ 5 ∷ 29 ∷ []
  -}
  id-ce-arc : OID → OID
  id-ce-arc tail = 2 ∷ 5 ∷ 29 ∷ tail
  id-kp-arc : OID → OID
  id-kp-arc tail = 1 ∷ 3 ∷ 6 ∷ 1 ∷ 5 ∷ 5 ∷ 7 ∷ 3 ∷ tail

  ku-oid : OID
  ku-oid = id-ce-arc (15 ∷ [])
  data KeyUsage : Set where
    digitalSignature nonRepudation keyEncipherment dataEncipherment
      keyAgreement keyCertSign cRLSign encipherOnly decipherOnly : KeyUsage
  pattern contentCommitment = nonRepudation
  ku : List KeyUsage → AST
  ku kus = Extension ku-oid true (BER.encode″ (BIT-STRING 7 (pack (w₀ ∷ w₁ ∷ [])))) where
    kuIdx : KeyUsage → ℕ
    kuIdx digitalSignature = 0
    kuIdx nonRepudation = 1
    kuIdx keyEncipherment = 2
    kuIdx dataEncipherment = 3
    kuIdx keyAgreement = 4
    kuIdx keyCertSign = 5
    kuIdx cRLSign = 6
    kuIdx encipherOnly = 7
    kuIdx decipherOnly = 8

    i₀ i₁ : KeyUsage → Word8
    i₀ digitalSignature = to𝕎 0x80
    i₀ nonRepudation = to𝕎 0x40
    i₀ keyEncipherment = to𝕎 0x20
    i₀ dataEncipherment = to𝕎 0x10
    i₀ keyAgreement = to𝕎 0x08
    i₀ keyCertSign = to𝕎 0x04
    i₀ cRLSign = to𝕎 0x02
    i₀ encipherOnly = to𝕎 0x01
    i₀ decipherOnly = to𝕎 0
    i₁ digitalSignature = to𝕎 0
    i₁ nonRepudation = to𝕎 0
    i₁ keyEncipherment = to𝕎 0
    i₁ dataEncipherment = to𝕎 0
    i₁ keyAgreement = to𝕎 0
    i₁ keyCertSign = to𝕎 0
    i₁ cRLSign = to𝕎 0
    i₁ encipherOnly = to𝕎 0
    i₁ decipherOnly = to𝕎 0x80

    f₀ f₁ : Word8 → KeyUsage → Word8
    f₀ w u = w or (i₀ u)
    f₁ w u = w or (i₁ u)
    w₀ w₁ : Word8
    w₀ = foldl f₀ (to𝕎 0) kus
    w₁ = foldl f₁ (to𝕎 0) kus

  id-kp-serverAuth id-kp-clientAuth : OID
  id-kp-serverAuth = id-kp-arc (1 ∷ [])
  id-kp-clientAuth = id-kp-arc (2 ∷ [])

  eku-oid : OID
  eku-oid = id-ce-arc (37 ∷ [])
  eku : AST
  eku = Extension eku-oid false (BER.encode″ (SEQUENCE (OBJECT-IDENTIFIER id-kp-serverAuth ∷ OBJECT-IDENTIFIER id-kp-clientAuth ∷ [])))

  bc-oid : OID
  bc-oid = id-ce-arc (19 ∷ [])
  bc : AST
  bc = Extension bc-oid true (BER.encode″ (SEQUENCE (BOOLEAN is-ca-true ∷ []))) where
    is-ca-true : Bool
    is-ca-true = true

  exts : AST
  exts = EXPLICIT (tag 3) (SEQUENCE (bc ∷ ku (keyAgreement ∷ []) ∷ eku ∷ []))

  tbs : AST
  tbs = SEQUENCE (version ∷ serial ∷ sa ∷ issuer ∷ validity ∷ subject ∷ spki ∷ exts ∷ [])
  tbs′ : ByteString Strict
  tbs′ = toStrict (fromChunks (BER.encode tbs))
  sig : ByteString Strict
  sig = sign tbs′

  sv : AST
  sv = BIT-STRING 0 sig
  cert : AST
  cert = SEQUENCE (tbs ∷ sa ∷ sv ∷ [])


{-# OPTIONS --rewriting #-}

open import Agda.Builtin.Bool
open import Agda.Builtin.Equality
{-# BUILTIN REWRITE _≡_ #-}

data D (A : Set) : Set where
  c c' : D A

postulate rew : c {Bool} ≡ c' {Bool}

{-# REWRITE rew #-}


------------------------------------------------------------------------
-- Library parsers which do not require the complicated setup used in
-- RecursiveDescent.Inductive.Lib
------------------------------------------------------------------------

-- This module also provides more examples of parsers for which the
-- indices cannot be inferred.

module RecursiveDescent.Inductive.SimpleLib where

open import RecursiveDescent.Inductive
open import RecursiveDescent.Index

open import Data.Nat
open import Data.Vec hiding (_⊛_; _>>=_)
open import Data.Vec1 using (Vec₁; []; _∷_)
open import Data.List using (List; []; _∷_)
open import Relation.Nullary
open import Data.Product.Record hiding (_×_)
open import Data.Product using (_×_) renaming (_,_ to pair)
open import Data.Bool
open import Data.Function
open import Data.Maybe
open import Data.Unit
open import Data.Bool.Properties as Bool
open import Algebra
private
  module BCS = CommutativeSemiring Bool.commutativeSemiring-∨-∧
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Applicative functor parsers

-- We could get these for free with better library support.

infixl 50 _⊛_ _⊛!_ _<⊛_ _⊛>_ _<$>_ _<$_ _⊗_ _⊗!_

_⊛_ : forall {tok nt i₁ i₂ r₁ r₂} ->
      Parser tok nt i₁ (r₁ -> r₂) ->
      Parser tok nt i₂ r₁ ->
      Parser tok nt _  r₂
p₁ ⊛ p₂ = p₁ >>= \f -> p₂ >>= \x -> return (f x)

-- A variant: If the second parser does not accept the empty string,
-- then neither does the combination. (This is immediate for the first
-- parser, but for the second one a small lemma is needed, hence this
-- variant.)

_⊛!_ : forall {tok nt i₁ c₂ r₁ r₂} ->
       Parser tok nt i₁ (r₁ -> r₂) ->
       Parser tok nt (false , c₂) r₁ ->
       Parser tok nt (false , _)  r₂
_⊛!_ {i₁ = i₁} p₁ p₂ = cast (BCS.*-comm (proj₁ i₁) false) refl
                            (p₁ ⊛ p₂)

_<$>_ : forall {tok nt i r₁ r₂} ->
        (r₁ -> r₂) ->
        Parser tok nt i r₁ ->
        Parser tok nt _ r₂
f <$> x = return f ⊛ x

_<⊛_ : forall {tok nt i₁ i₂ r₁ r₂} ->
       Parser tok nt i₁ r₁ ->
       Parser tok nt i₂ r₂ ->
       Parser tok nt _ r₁
x <⊛ y = const <$> x ⊛ y

_⊛>_ : forall {tok nt i₁ i₂ r₁ r₂} ->
       Parser tok nt i₁ r₁ ->
       Parser tok nt i₂ r₂ ->
       Parser tok nt _ r₂
x ⊛> y = flip const <$> x ⊛ y

_<$_ : forall {tok nt i r₁ r₂} ->
       r₁ ->
       Parser tok nt i r₂ ->
       Parser tok nt _ r₁
x <$ y = const x <$> y

_⊗_ : forall {tok nt i₁ i₂ r₁ r₂} ->
      Parser tok nt i₁ r₁ -> Parser tok nt i₂ r₂ ->
      Parser tok nt _ (r₁ × r₂)
p₁ ⊗ p₂ = pair <$> p₁ ⊛ p₂

_⊗!_ : forall {tok nt i₁ c₂ r₁ r₂} ->
      Parser tok nt i₁ r₁ -> Parser tok nt (false , c₂) r₂ ->
      Parser tok nt (false , _) (r₁ × r₂)
p₁ ⊗! p₂ = pair <$> p₁ ⊛! p₂

------------------------------------------------------------------------
-- Parsing sequences

-- Note that the resulting index here cannot be inferred...

private

  exactly'-corners : Corners -> ℕ -> Corners
  exactly'-corners c zero    = _
  exactly'-corners c (suc n) = _

  exactly' : forall {tok nt c r} n ->
             Parser tok nt (false , c) r ->
             Parser tok nt (false , exactly'-corners c n)
                           (Vec r (suc n))
  exactly' zero    p = [_] <$> p
  exactly' (suc n) p = _∷_ <$> p ⊛ exactly' n p

-- ...so we might as well generalise the function a little.
-- exactly n p parses n occurrences of p.

exactly-index : Index -> ℕ -> Index
exactly-index i zero    = _
exactly-index i (suc n) = _

exactly : forall {tok nt i r} n ->
          Parser tok nt i r ->
          Parser tok nt (exactly-index i n) (Vec r n)
exactly zero    p = return []
exactly (suc n) p = _∷_ <$> p ⊛ exactly n p

-- A function with a similar type:

sequence : forall {tok nt i r n} ->
           Vec₁ (Parser tok nt i r) n ->
           Parser tok nt (exactly-index i n) (Vec r n)
sequence []       = return []
sequence (p ∷ ps) = _∷_ <$> p ⊛ sequence ps

-- p between ps parses p repeatedly, between the elements of ps:
--   ∙ between (x ∷ y ∷ z ∷ []) ≈ x ∙ y ∙ z.

between-corners : Corners -> ℕ -> Corners
between-corners c′ zero    = _
between-corners c′ (suc n) = _

_between_ : forall {tok nt i r c′ r′ n} ->
            Parser tok nt i r ->
            Vec₁ (Parser tok nt (false , c′) r′) (suc n) ->
            Parser tok nt (false , between-corners c′ n) (Vec r n)
p between (x ∷ [])     = [] <$ x
p between (x ∷ y ∷ xs) = _∷_ <$> (x ⊛> p) ⊛ (p between (y ∷ xs))

------------------------------------------------------------------------
-- N-ary variants of _∣_

-- choice ps parses one of the elements in ps.

choice-corners : Corners -> ℕ -> Corners
choice-corners c zero    = _
choice-corners c (suc n) = _

choice : forall {tok nt c r n} ->
         Vec₁ (Parser tok nt (false , c) r) n ->
         Parser tok nt (false , choice-corners c n) r
choice []       = fail
choice (p ∷ ps) = p ∣ choice ps

-- choiceMap f xs ≈ choice (map f xs), but avoids use of Vec₁ and
-- fromList.

choiceMap-corners : forall {a} -> (a -> Corners) -> List a -> Corners
choiceMap-corners c []       = _
choiceMap-corners c (x ∷ xs) = _

choiceMap : forall {tok nt r a} {c : a -> Corners} ->
            ((x : a) -> Parser tok nt (false , c x) r) ->
            (xs : List a) ->
            Parser tok nt (false , choiceMap-corners c xs) r
choiceMap f []       = fail
choiceMap f (x ∷ xs) = f x ∣ choiceMap f xs

------------------------------------------------------------------------
-- sat and friends

sat : forall {tok nt r} ->
      (tok -> Maybe r) -> Parser tok nt (0I ·I 1I) r
sat {tok} {nt} {r} p = symbol !>>= \c -> ok (p c)
  where
  okIndex : Maybe r -> Index
  okIndex nothing  = _
  okIndex (just _) = _

  ok : (x : Maybe r) -> Parser tok nt (okIndex x) r
  ok nothing  = fail
  ok (just x) = return x

sat' : forall {tok nt} -> (tok -> Bool) -> Parser tok nt _ ⊤
sat' p = sat (boolToMaybe ∘ p)

any : forall {tok nt} -> Parser tok nt _ tok
any = sat just


-- Andreas, 2021-12-31, issue #5712, reported by Trebor-Huang

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

open import Agda.Builtin.Reflection
open import Agda.Builtin.Unit

nothing : Term → TC ⊤
nothing hole = returnTC _

record Foo : Set1 where
  field
    A : Set
    @(tactic nothing) foo : A → A
open Foo

F : Foo
F .A     = ⊤
F .foo n = _

-- Should succeed.
-- There was an internal error, because the coverage checker did
-- not expand the last clause due to the presence of a tactic (#5358).
-- However, in this case, there is a user argument that forces the
-- expansion.  This is now recognized by the coverage checker.


module Prelude.Float where

open import Prelude.String

postulate
  Float : Set
  floatToString : Float  -> String
  stringToFloat : String -> Float

{-# BUILTIN FLOAT Float #-}
{-# COMPILED_EPIC floatToString (f : Float) -> String = frString(floatToStr(f)) #-}
{-# COMPILED_EPIC stringToFloat (s : Any) -> Float = strToFloat(mkString(s)) #-}


module Warnings where

-- empty rewrite pragma
{-# REWRITE #-}

-- termination checking error
A : Set
A = A

data Nat : Set where
  zero : Nat
  suc : Nat -> Nat

{-# BUILTIN NATURAL Nat #-}

-- deprecated BUILTIN ZERO
{-# BUILTIN ZERO zero #-}

-- An open goal
g : Set
g = {!!}


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

module Light.Library.Data.Empty where

open import Light.Level using (Level ; Setω)
open import Light.Variable.Sets

record Dependencies : Setω where

record Library (dependencies : Dependencies) : Setω where
      field
            ℓ : Level
            Empty : Set ℓ
            eliminate : Empty → 𝕒
open Library ⦃ ... ⦄ public


{-# OPTIONS --cubical-compatible --rewriting #-}

open import Agda.Primitive using (Level; _⊔_; Setω; lzero; lsuc)

module Issue4020b where

data _≡_ {ℓ : Level} {A : Set ℓ} (a : A) : A → Set ℓ where
  refl : a ≡ a

{-# BUILTIN REWRITE _≡_ #-}

ap : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) {a₁ a₂} → a₁ ≡ a₂ → f a₁ ≡ f a₂
ap f refl = refl

ap-const-Pi : ∀ {a b} {A : Set a} {B : A → Set b} {a₁ a₂ : A} (p : a₁ ≡ a₂) → ap (\ _ → (x : A) → B x) p ≡ refl
ap-const-Pi refl = refl

{-# REWRITE ap-const-Pi #-}
{- /home/jason/bug2.agda:18,1-28
ap-const-Pi  is not a legal rewrite rule, since the following variables are not bound by the left hand side:  b
when checking the pragma REWRITE ap-const-Pi -}