{-# OPTIONS --cubical --safe #-}

module Cubical.Data.Strict2Group.Explicit.ToXModule where

open import Cubical.Foundations.Prelude hiding (comp)

open import Cubical.Data.Group.Base
open import Cubical.Data.XModule.Base
open import Cubical.Data.Group.Action.Base
open import Cubical.Data.Sigma

open import Cubical.Data.Strict2Group.Explicit.Base
open import Cubical.Data.Strict2Group.Explicit.Interface

Strict2GroupExp→XModuleExp : {ℓ : Level} (S : Strict2GroupExp ℓ) → (XModuleExp ℓ)
Strict2GroupExp→XModuleExp (strict2groupexp C₀ C₁ s t i ∘ si ti s∘ t∘ isMorph∘ assoc∘ lUnit∘ rUnit∘) =
  record
    { G = C₀ ;
    H = ks ;
    τ = tₖₛ ;
    α = laction
      (λ g h → lAction.act lad (id g) h)
      (λ h →
         ΣPathP (p1 h ,
           isProp→PathP
             (λ i → snd (P (p1 h i)))
             (kerIsNormal {G = C₁} {H = C₀} s (id 1₀) h)
             (kerIsNormal {G = C₁} {H = C₀} s 1₁ h))
         ∙ lAction.identity lad h)
      (λ g g' h →
         ΣPathP (p2 g g' h ,
           isProp→PathP
             (λ i → snd (P (p2 g g' h i)))
             (kerIsNormal {G = C₁} {H = C₀} s (id (g ∙₀ g')) h)
             (kerIsNormal {G = C₁} {H = C₀} s (id g ∙₁ id g') h))
         ∙ (lAction.coh lad (id g) (id g') h))
      λ g h h' → lAction.hom lad (id g) h h' ;
    equivar = equivar ;
    peiffer = pf }
      where
        S = strict2groupexp C₀ C₁ s t i ∘ si ti s∘ t∘ isMorph∘ assoc∘ lUnit∘ rUnit∘
        open S2GInterface S
        -- the kernel of the source map
        kers = ker {G = C₁} {H = C₀} s
        -- the family of propositions ker(x) ≡ 1
        P = Subgroup.typeProp kers
        -- kernel coerced to group
        ks = Subgroup→Group {G = C₁} kers

        -- the left adjoint action of hom on its normal subgroup ker(src)
        lad : lAction C₁ ks
        lad = lActionAdjSubgroup C₁ kers (kerIsNormal {G = C₁} {H = C₀} s)

        -- the target map restricted to ker(src)
        tₖₛ = restrictGroupMorph {G = C₁} {H = C₀} t kers
        tarₖₛ = fst tₖₛ
        tar∙ₖₛ = snd tₖₛ
        -- multiplication, inverse in ker src
        _∙₁ₖₛ_ = isGroup.comp (Group.groupStruc ks)
        ks⁻¹ = isGroup.inv (Group.groupStruc ks)
        -- group laws in ker(src)
        lUnitₖₛ = isGroup.lUnit (Group.groupStruc ks)
        rUnitₖₛ = isGroup.rUnit (Group.groupStruc ks)
        rCancelₖₛ = isGroup.rCancel (Group.groupStruc ks)
        assocₖₛ = isGroup.assoc (Group.groupStruc ks)
        1ₖₛ = isGroup.id (Group.groupStruc ks)

        -- Composition restricted to ks×₀ks
        ∘ₖₛ : (g f : Group.type ks) → (src (fst g) ≡ tarₖₛ f) → Group.type ks
        ∘ₖₛ g f coh = (⊙' (fst g) (fst f) coh) , ((src⊙' (fst g) (fst f) coh) ∙ snd f)

        -- right and left unit law for restricted ∘
        abstract
          rUnit∘ₖₛ : (h : Group.type ks) →
            ∘ₖₛ h (id (src (fst h)) , si (src (fst h)) ∙ snd h)
              (sym (ti (src (fst h)))) ≡ h
          rUnit∘ₖₛ h = ΣPathP (rUnit∘ (fst h) ,
            isProp→PathP
              (λ i → snd (P (rUnit∘ (fst h) i)))
              (src⊙' (fst h) (id (src (fst h))) (sym (ti (src (fst h)))) ∙ si (src (fst h)) ∙ snd h)
              (snd h))
        abstract
          lUnit∘ₖₛ : (h : Group.type ks) →
            (⊙ (co (id (tar (fst h))) (fst h) (si (tar (fst h)))) , (src⊙' (id (tar (fst h))) (fst h) (si (tar (fst h)))) ∙ snd h) ≡ h
          lUnit∘ₖₛ h = ΣPathP (
            lUnit∘ (fst h) ,
            isProp→PathP
              (λ i → snd (P (lUnit∘ (fst h) i))) (src⊙' (id (tar (fst h))) (fst h) (si (tar (fst h))) ∙ snd h) (snd h))

        -- two proofs used in equivariant
        abstract
          p1 = λ (h : Group.type ks) → cong (λ z → (z ∙₁ fst h) ∙₁ (C₁⁻¹ z)) (morphId {G = C₀} {H = C₁} i)
          p2 = λ (g g' : Group.type C₀) (h : Group.type ks) → cong (λ z → (z ∙₁ fst h) ∙₁ (C₁⁻¹ z)) (id∙₀ g g')

          equivar = λ g h → tar∙₁ (id g ∙₁ fst h) (C₁⁻¹ (id g)) ∙∙
            cong (_∙₀ (tar (C₁⁻¹ (id g)))) (tar∙₁ (id g) (fst h)) ∙∙
            cong (((tar (id g)) ∙₀ (tar (fst h))) ∙₀_) (morphInv {G = C₁} {H = C₀} t (id g)) ∙
            cong (λ z → (z ∙₀ (tar (fst h))) ∙₀ (C₀⁻¹ z)) (ti g)

        -- the peiffer identity, proved according to
        -- ixh'ix- ≡ eixh'ix- ≡ hh-ixh'ix- ≡ hh-ixh'ixe

          pf : (h h' : Group.type ks) → lAction.act lad (id (tarₖₛ h)) h' ≡ (h ∙₁ₖₛ h') ∙₁ₖₛ (ks⁻¹ h)
          pf h h' =
            ixh'ix-
              ≡⟨ sym (lUnitₖₛ ixh'ix-) ⟩
            1ₖₛ ∙₁ₖₛ ixh'ix-
              ≡⟨ cong (_∙₁ₖₛ ixh'ix-) (sym (rCancelₖₛ h)) ⟩
            (h ∙₁ₖₛ h-) ∙₁ₖₛ ixh'ix-
              ≡⟨ assocₖₛ h h- ixh'ix- ⟩
            h ∙₁ₖₛ (h- ∙₁ₖₛ ixh'ix-)
              ≡⟨ cong (h ∙₁ₖₛ_) (
                h- ∙₁ₖₛ ixh'ix-
                  ≡⟨ cong (h- ∙₁ₖₛ_) (sym (rUnit∘ₖₛ ixh'ix-)) ⟩
                h- ∙₁ₖₛ (∘ₖₛ ixh'ix- (is ixh'ix-) (src≡tarIdSrc (fst ixh'ix-)))
                  ≡⟨ cong (_∙₁ₖₛ (∘ₖₛ ixh'ix- (is ixh'ix-) (src≡tarIdSrc (fst ixh'ix-)))) (sym (lUnit∘ₖₛ h-)) ⟩
                (⊙ ix-⊙h-₁ , (src⊙ ix-⊙h-₁) ∙ snd h-) ∙₁ₖₛ ∘ₖₛ ixh'ix- (is ixh'ix-) (src≡tarIdSrc (fst ixh'ix-))
                  ≡⟨ ΣPathP (q3 , isProp→PathP (λ i → snd (P (q3 i))) (snd ((ix-∘h-₁ , (src⊙ ix-⊙h-₁) ∙ snd h-) ∙₁ₖₛ ∘ₖₛ ixh'ix- (is ixh'ix-) (src≡tarIdSrc (fst ixh'ix-)))) (src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ fst (is ixh'ix-)) q1 ∙ q2)) ⟩
                (⊙ (co (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ fst (is ixh'ix-)) q1)) , (src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ fst (is ixh'ix-)) q1) ∙ q2
                  ≡⟨ ΣPathP (q18 , (isProp→PathP (λ j → snd (P (q18 j))) ((src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ fst (is ixh'ix-)) q1) ∙ q2) ((src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ 1₁) (q5 ∙ q8)) ∙ q9))) ⟩
                (⊙ (co (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ 1₁) (q5 ∙ q8))) ,
                  (src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ 1₁) (q5 ∙ q8)) ∙ q9
                  ≡⟨ ΣPathP (q17 , (isProp→PathP (λ j → snd (P (q17 j))) ((src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ 1₁) (q5 ∙ q8)) ∙ q9) ((src⊙' (ix- ∙₁ fst ixh'ix-) (fst h-) q5) ∙ snd h-))) ⟩
                (⊙ (co (ix- ∙₁ fst ixh'ix-) (h- .fst) q5)) ,
                  (src⊙' (ix- ∙₁ fst ixh'ix-) (h- .fst) q5)  ∙ snd h-
                  ≡⟨ ΣPathP (q16 , isProp→PathP (λ j → snd (P (q16 j))) ((src⊙' (ix- ∙₁ fst ixh'ix-) (fst h-) q5) ∙ snd h-) ((src⊙' (ix- ∙₁ fst ixh'ix-) (1₁ ∙₁ h- .fst) (q5 ∙ q6)) ∙ q7)) ⟩
                (⊙ (co (ix- ∙₁ fst ixh'ix-) (1₁ ∙₁ h- .fst) (q5 ∙ q6))) ,
                  (src⊙' (ix- ∙₁ fst ixh'ix-) (1₁ ∙₁ h- .fst) (q5 ∙ q6)) ∙ q7
                  ≡⟨ ΣPathP (q15 , (isProp→PathP (λ j → snd (P (q15 j))) ((src⊙' (ix- ∙₁ fst ixh'ix-) (1₁ ∙₁ h- .fst) (q5 ∙ q6)) ∙ q7) ((src⊙' ((fst h') ∙₁ ix-) (1₁ ∙₁ h- .fst) q4) ∙ q7))) ⟩
                (⊙ (co ((fst h') ∙₁ ix-) (1₁ ∙₁ h- .fst) q4)) ,
                  (src⊙' ((fst h') ∙₁ ix-) (1₁ ∙₁ h- .fst) q4) ∙ q7
                  ≡⟨ ΣPathP (q14 , isProp→PathP (λ j → snd (P (q14 j))) ((src⊙' ((fst h') ∙₁ ix-) (1₁ ∙₁ h- .fst) q4) ∙ q7) q12) ⟩
                (⊙ (co (fst h') 1₁ ((snd h') ∙ (sym tar1₁≡1₀)))) ∙₁ ix-∘h-₁ , q12
                  ≡⟨ ΣPathP (q11 , isProp→PathP (λ j → snd (P (q11 j))) q12 q13) ⟩
                h' .fst ∙₁ ix-∘h-₁ , q13
                  ≡⟨ ΣPathP (q10 , isProp→PathP (λ j → snd (P (q10 j)))
                    (src∙₁ (fst h') ix-∘h-₁ ∙∙
                      (λ i₁ → snd h' i₁ ∙₀ src ix-∘h-₁) ∙∙
                      lUnit₀ (src ix-∘h-₁) ∙∙
                      src⊙ ix-⊙h-₁ ∙∙
                      snd h-)
                    (Subgroup.compClosed kers h' h-)) ⟩
                h' .fst ∙₁ h- .fst , Subgroup.compClosed kers h' h- ≡⟨ refl ⟩
                (h' ∙₁ₖₛ h-) ≡⟨ refl ⟩ refl ) ⟩
              h ∙₁ₖₛ (h' ∙₁ₖₛ h-)
              ≡⟨ sym (assocₖₛ h h' h-) ⟩
            (h ∙₁ₖₛ h') ∙₁ₖₛ h- ≡⟨ refl ⟩ refl
            where
              -- some abbreviations
            h- = ks⁻¹ h -- h⁻¹
            x = tarₖₛ h -- target of h
            x- = tarₖₛ h- -- target of h⁻¹
            x-≡x⁻¹ : x- ≡ C₀⁻¹ x
            x-≡x⁻¹ = morphInv {G = ks} {H = C₀} tₖₛ h
            ix = id x -- i (t h)
            ix- = id x- -- i (t h⁻¹)
            ixh'ix- : Group.type ks -- abv. for (ix ∙₁ h') ∙₁ ix-
            ixh'ix- = lAction.act lad (id (tarₖₛ h)) h'
            is : Group.type ks → Group.type ks -- abv. for i(s _) in ks
            is h = id (src (fst h)) , (si (src (fst h))) ∙ snd h
            ix-⊙h-₁ = co ix- (fst h-) (si x-)
            ix-∘h-₁ = ⊙ ix-⊙h-₁

            -- some identities
            ix-≡ix⁻¹ : ix- ≡ (C₁⁻¹ ix)
            ix-≡ix⁻¹ = (cong id x-≡x⁻¹) ∙ (morphInv {G = C₀} {H = C₁} i x)
            ish≡1ₖₛ : (h : Group.type ks) → (is h) ≡ 1ₖₛ
            ish≡1ₖₛ h =
              ΣPathP
                (cong (fst i) (snd h) ∙ id1₀≡1₁ ,
                isProp→PathP
                  (λ j → snd (P (((λ k → id(snd h k)) ∙ id1₀≡1₁) j)))
                  (si (src (fst h)) ∙ snd h)
                  (Subgroup.subId kers))
            -- t h⁻¹ ≡ (t h)⁻¹
            th-≡x- = morphInv {G = ks} {H = C₀} tₖₛ h

            -----------------------------------------
            -- here comes particles of the main proof
            -----------------------------------------

            -- coherence condition for the composition
            -- ∘ (ix- ∙₁ fst ixh'ix-) (h- .fst ∙₁ fst (is ixh'ix-))
            q1 =
              src∙₁ ix- (fst ixh'ix-) ∙∙
              cong (_∙₀ src (fst ixh'ix-)) (si x-) ∙∙
              cong (x- ∙₀_) (snd ixh'ix-) ∙∙
              rUnit₀ x- ∙∙
              th-≡x- ∙∙
              sym (rUnit₀ (C₀⁻¹ x)) ∙∙
              cong ((C₀⁻¹ x) ∙₀_) (sym ((ti ((src (fst ixh'ix-)))) ∙ (snd ixh'ix-))) ∙∙
              cong (_∙₀ (tar (fst (is ixh'ix-)))) (sym th-≡x-) ∙∙
              sym (tar∙₁ (fst h-) (fst (is ixh'ix-)))

            -- to show that ∘ q1 is in ks, p2 is proof that f is in ks
            q2 = src∙₁ (fst h-) (fst (is ixh'ix-)) ∙∙
              cong (_∙₀ (src (fst (is ixh'ix-)))) (snd h-) ∙∙
              lUnit₀ (src (fst (is ixh'ix-))) ∙∙
              cong (λ z → src (fst z)) (ish≡1ₖₛ ixh'ix-) ∙∙
              snd 1ₖₛ

            -- (∘ (si x-)) ∙₁ (fst (∘ₖₛ (src≡tarIdSrc (fst ixh'ix-)))) ≡ ∘ q1
            q3 =
              (ix-∘h-₁ ∙₁ fst (∘ₖₛ ixh'ix- (is ixh'ix-) (src≡tarIdSrc (fst ixh'ix-)))) ≡⟨ refl ⟩
              ⊙ ix-⊙h-₁ ∙₁ ⊙ co3
                ≡⟨ sym (isMorph⊙ ix-⊙h-₁ co3) ⟩
              ⊙ (ix-⊙h-₁ ∙Co co3)
                ≡⟨ ⊙≡c (ix-⊙h-₁ ∙Co co3) q1 ⟩
              ⊙ co1 ≡⟨ refl ⟩ refl
              where
                co1 = co (ix- ∙₁ fst ixh'ix-) (fst h- ∙₁ fst (is ixh'ix-)) q1
                co3 = co (fst ixh'ix-) (fst (is ixh'ix-)) (src≡tarIdSrc (fst ixh'ix-))

            -- coherence condition for ∘ {g = ?} {f = 1₁ ∙₁ h- .fst} (_∙ q6)
            q6 = sym (lUnit₀ (tar (fst h-))) ∙∙
                 sym (cong (_∙₀ (tar (fst h-))) (morphId {G = C₁} {H = C₀} t)) ∙∙
                 sym (tar∙₁ 1₁ (fst h-))

            -- coherence condition for ∘ {g = (fst h') ∙₁ ix- } {f = 1₁ ∙₁ h- .fst } q4
            q4 =
              src∙₁ (fst h') ix- ∙∙
              (cong (_∙₀ src ix-) (snd h')) ∙∙
              lUnit₀ (src ix-) ∙∙
              si x- ∙∙
              q6

            -- coherence condition for ∘ {g = ix- ∙₁ fst ixh'ix- } {f = ?} (q5 ∙ ?)
            q5 =
              src∙₁ ix- (fst ixh'ix-) ∙∙
              cong ((src ix-) ∙₀_) (snd ixh'ix-) ∙∙
              rUnit₀ (src ix-) ∙
              si x-

            -- proof that 1₁ ∙₁ h- .fst : ker s
            q7 = src∙₁ 1₁ (fst h-) ∙∙
              cong (src 1₁ ∙₀_) (snd h-) ∙∙
              rUnit₀ (src 1₁) ∙ src1₁≡1₀

            -- proof that s x- ≡ t (h- .fst ∙₁ 1₁)
            q8 = sym (rUnit₀ (tar (fst h-))) ∙∙
              (sym (cong ((tar (fst h-)) ∙₀_) tar1₁≡1₀)) ∙∙
              (sym (tar∙₁ (fst h-) 1₁))

            -- proof that h- .fst ∙₁ 1₁ : ker s
            q9 = src∙₁ (fst h-) 1₁ ∙∙
              cong (_∙₀ (src 1₁)) (snd h-) ∙∙
              lUnit₀ (src 1₁) ∙
              src1₁≡1₀

            -- proof that (h' .fst ∙₁ ix-∘h-₁) ≡ (h' .fst ∙₁ h- .fst)
            q10 = cong (h' .fst ∙₁_) (lUnit∘ (fst h-))

            -- proof that (h'∘1₁)∙₁ ix-∘h-₁ ≡ h' ∙₁ ix-∘h-₁
            q11 = cong (_∙₁ ix-∘h-₁)
                       (⊙≡ (co (fst h') 1₁ (snd h' ∙ sym tar1₁≡1₀)) (id (src (fst h')) , sym id1₀≡1₁ ∙ sym (cong id (snd h'))) ∙
                       rUnit⊙c
                         (fst h')
                         ((snd h' ∙ (λ i₁ → tar1₁≡1₀ (~ i₁))) ∙ cong tar ((λ i₁ → id1₀≡1₁ (~ i₁)) ∙ (λ i₁ → id (snd h' (~ i₁))))))

            q12 =
                src∙₁ ((⊙ (co (fst h') 1₁ ((snd h') ∙ sym tar1₁≡1₀)))) ix-∘h-₁ ∙∙
                cong (_∙₀ (src ix-∘h-₁)) ((src⊙' (fst h') 1₁ ((snd h') ∙ (sym tar1₁≡1₀))) ∙  src1₁≡1₀) ∙∙
                lUnit₀ (src ix-∘h-₁) ∙
                src⊙' ix- (fst h-) (si x-) ∙ snd h-

            q13 = src∙₁ (fst h') ix-∘h-₁ ∙∙
              cong (_∙₀ (src ix-∘h-₁)) (snd h') ∙∙
              lUnit₀ (src ix-∘h-₁) ∙∙
              src⊙' ix- (fst h-) (si x-) ∙∙
              snd h-

            q14 =
              ⊙' ((fst h') ∙₁ ix-) (1₁ ∙₁ h- .fst) q4
                ≡⟨ ⊙≡c~ q4 (𝒸 (co (fst h') 1₁ (snd h' ∙ (λ i₁ → tar1₁≡1₀ (~ i₁))) ∙Co ix-⊙h-₁)) ⟩
              ⊙' ((fst h') ∙₁ ix-) (1₁ ∙₁ (fst h-)) (𝒸 (co (fst h') 1₁ (snd h' ∙ (λ i₁ → tar1₁≡1₀ (~ i₁))) ∙Co ix-⊙h-₁))
                ≡⟨ isMorph⊙ (co (fst h') 1₁ (snd h' ∙ (λ i₁ → tar1₁≡1₀ (~ i₁)))) ix-⊙h-₁ ⟩
             -- (⊙' (fst h') 1₁ (snd h' ∙ (λ i₁ → tar1₁≡1₀ (~ i₁)))) ∙₁ ix-∘h-₁ ≡⟨ refl ⟩
              refl

            q15 = ≡⊙c* (q5 ∙ q6)
                  (cong (ix- ∙₁_) (assoc₁ ix (fst h') (C₁⁻¹ ix)) ∙∙
                    sym (assoc₁ ix- ix (fst h' ∙₁ C₁⁻¹ ix)) ∙∙
                    cong (λ z → (z ∙₁ ix) ∙₁ (fst h' ∙₁ C₁⁻¹ ix)) ix-≡ix⁻¹ ∙∙
                    cong (_∙₁ (fst h' ∙₁ C₁⁻¹ ix)) (lCancel₁ ix) ∙∙
                    lUnit₁ (fst h' ∙₁ C₁⁻¹ ix) ∙
                    cong (fst h' ∙₁_) (sym ix-≡ix⁻¹))
                  q4
              {- use this to see what's going on
              ⊙ co1
                ≡⟨ ≡⊙c* (q5 ∙ q6)
                  ((cong (ix- ∙₁_) (assoc₁ ix (fst h') (C₁⁻¹ ix))) ∙
                    sym (assoc₁ ix- ix (fst h' ∙₁ C₁⁻¹ ix)) ∙
                    cong (λ z → (z ∙₁ ix) ∙₁ (fst h' ∙₁ C₁⁻¹ ix)) ix-≡ix⁻¹ ∙
                    cong (_∙₁ (fst h' ∙₁ C₁⁻¹ ix)) (lCancel₁ ix) ∙
                    (lUnit₁ (fst h' ∙₁ C₁⁻¹ ix)) ∙
                    (cong (fst h' ∙₁_) (sym ix-≡ix⁻¹)))
                  q4 ⟩
              ⊙ co2 ≡⟨ refl ⟩ refl
              where
                co1 = co (ix- ∙₁ (fst ixh'ix-)) (1₁ ∙₁ (fst h-)) (q5 ∙ q6)
                co2 = co ((fst h') ∙₁ ix-) (1₁ ∙₁ (fst h-)) q4 -}

            q16 = ⊙≡c* q5 (sym (lUnit₁ (fst h-))) (q5 ∙ q6)
              {- use this to see what's going on
              ⊙ co1
                ≡⟨ ⊙≡c* q5 (sym (lUnit₁ (fst h-))) (q5 ∙ q6) ⟩
              ⊙ co2 ≡⟨ refl ⟩ refl
              where
                co1 = co (ix- ∙₁ fst ixh'ix-) (fst h-) q5
                co2 = co (ix- ∙₁ fst ixh'ix-) (1₁ ∙₁ fst h-) (q5 ∙ q6) -}

            q17 = ⊙≡c* (q5 ∙ q8) (rUnit₁ (fst h-)) q5
              {- use this to see what's going on
              ⊙ co1
                ≡⟨ ⊙≡c* (q5 ∙ q8) (rUnit₁ (fst h-)) q5 ⟩
              ⊙ co2 ≡⟨ refl ⟩ refl
              where
                co1 = co (ix- ∙₁ fst ixh'ix-) (fst h- ∙₁ 1₁) (q5 ∙ q8)
                co2 = co (ix- ∙₁ fst ixh'ix-) (fst h-) q5 -}

            q18 = ⊙≡c* q1 (cong (fst h- ∙₁_) ((cong id (snd ixh'ix-)) ∙ id1₀≡1₁)) (q5 ∙ q8)
              {- use this to see what's going on
              ⊙ co1 ≡⟨ ⊙≡c* q1 (cong (fst h- ∙₁_)
                ((cong id (snd ixh'ix-)) ∙ id1₀≡1₁))
                (q5 ∙ q8) ⟩
              ⊙ co2 ≡⟨ refl ⟩ refl
              where
                co1 = co (ix- ∙₁ fst ixh'ix-) (fst h- ∙₁ (fst (is ixh'ix-))) q1
                co2 = co (ix- ∙₁ fst ixh'ix-) (fst h- ∙₁ 1₁) (q5 ∙ q8) -}


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

-- Obtain Unit
open import Agda.Builtin.Unit public
  renaming ( ⊤ to Unit )


------------------------------------------------------------------------------
-- The alternating bit protocol (ABP) is correct
------------------------------------------------------------------------------

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

-- This module proves the correctness of the ABP by simplifing the
-- formalization in Dybjer and Sander (1989) using a stronger (maybe
-- invalid) co-induction principle.

module FOT.FOTC.Program.ABP.StrongerInductionPrinciple.CorrectnessProofI where

open import FOT.FOTC.Relation.Binary.Bisimilarity.Type
open import FOT.FOTC.Program.ABP.StrongerInductionPrinciple.LemmaI

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Stream.Type
open import FOTC.Data.Stream.Equality.PropertiesI
open import FOTC.Program.ABP.ABP hiding ( B )
open import FOTC.Program.ABP.Fair.Type
open import FOTC.Program.ABP.Terms
open import FOTC.Relation.Binary.Bisimilarity.Type

------------------------------------------------------------------------------
-- Main theorem.
abpCorrect : ∀ {b is os₁ os₂} → Bit b → Stream is → Fair os₁ → Fair os₂ →
             is ≈ abpTransfer b os₁ os₂ is
abpCorrect {b} {is} {os₁} {os₂} Bb Sis Fos₁ Fos₂ = ≈-stronger-coind B h refl
  where
  B : D → D → Set
  B xs ys = xs ≡ xs

  h : B is (abpTransfer b os₁ os₂ is) →
      ∃[ i' ] ∃[ is' ] ∃[ js' ]
        is ≡ i' ∷ is' ∧ abpTransfer b os₁ os₂ is ≡ i' ∷ js' ∧ B is' js'
  h _ with Stream-out Sis
  ... | i' , is' , prf₁ , Sis' with lemma Bb Fos₁ Fos₂ prf₂
    where
    aux₁ aux₂ aux₃ aux₄ aux₅ : D
    aux₁ = send b
    aux₂ = ack b
    aux₃ = out b
    aux₄ = corrupt os₁
    aux₅ = corrupt os₂

    prf₂ : S b (i' ∷ is') os₁ os₂
            (has aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is'))
            (hbs aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is'))
            (hcs aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is'))
            (hds aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is'))
            (abpTransfer b os₁ os₂ (i' ∷ is'))
    prf₂ = has-eq aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is')
           , hbs-eq aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is')
           , hcs-eq aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is')
           , hds-eq aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is')
           , trans (abpTransfer-eq b os₁ os₂ (i' ∷ is'))
               (transfer-eq aux₁ aux₂ aux₃ aux₄ aux₅ (i' ∷ is'))

  ... | js' , prf₃ = i'
                     , is'
                     , js'
                     , prf₁
                     , subst (λ t → abpTransfer b os₁ os₂ t ≡ i' ∷ js' )
                             (sym prf₁)
                             prf₃
                     , refl

------------------------------------------------------------------------------
-- abpTransfer produces a Stream.
abpTransfer-Stream : ∀ {b is os₁ os₂} →
                     Bit b →
                     Stream is →
                     Fair os₁ →
                     Fair os₂ →
                     Stream (abpTransfer b os₁ os₂ is)
abpTransfer-Stream Bb Sis Fos₁ Fos₂ = ≈→Stream₂ (abpCorrect Bb Sis Fos₁ Fos₂)

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


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

module Cham.Label where

open import Cham.Name

data Label : Set where
  _⁺ : Name → Label
  _⁻ : Name → Label


-- Andreas, 2015-08-26
{-# OPTIONS --rewriting #-} -- Should give error

open import Common.Equality

{-# BUILTIN REWRITE _≡_ #-}
{-# REWRITE refl #-}


module Issue1252 where

data Bool : Set where
  true false : Bool

{-# COMPILED_DATA Bool Bool True False #-}

foo : Bool → Bool
foo true  = false
foo false = true

{-# COMPILED_EXPORT foo foohs #-}


{-# OPTIONS --rewriting --confluence-check #-}
module Issue4333.N0 where

open import Issue4333.M
{-# REWRITE p₀ #-}

b₀' : B a₀'
b₀' = b


-- Andrease, 2016-12-31, issue #1975 reported by nad.

-- {-# OPTIONS -v tc.lhs.split:40 #-}

data ⊥ : Set where

record ⊤ : Set where

data Bool : Set where
  true false : Bool

T : Bool → Set
T false = ⊥
T true  = ⊤

module M (b : Bool) where

  data D : Set where
    c : T b → D

open M true

-- The following definition is rejected:

-- rejected : M.D false → ⊥
-- rejected (c x) = x

data D₂ : Set where
  c : D₂

-- WAS: However, the following definition is accepted:

test : M.D false → ⊥
test (c x) = x

-- I think both definitions should be rejected.
-- NOW: Both are rejected.


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

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

module Bisimilarity.Weak.Alternative.Comparison where

open import Equality.Propositional
open import Logical-equivalence using (_⇔_)
open import Prelude

open import H-level equality-with-J
open import Surjection equality-with-J using (_↠_)
open import Univalence-axiom equality-with-J

import Bisimilarity
import Bisimilarity.Classical
import Bisimilarity.Comparison as Comp
import Bisimilarity.Weak.Alternative
import Bisimilarity.Weak.Alternative.Classical
open import Labelled-transition-system

module _ {ℓ} {lts : LTS ℓ} where

  open LTS lts

  private
    module Co = Bisimilarity.Weak.Alternative           lts
    module Cl = Bisimilarity.Weak.Alternative.Classical lts

  -- Classically weakly bisimilar processes are coinductively weakly
  -- bisimilar.

  cl⇒co : ∀ {i p q} → p Cl.≈ q → Co.[ i ] p ≈ q
  cl⇒co = Comp.cl⇒co

  -- Coinductively weakly bisimilar processes are classically weakly
  -- bisimilar.

  co⇒cl : ∀ {p q} → p Co.≈ q → p Cl.≈ q
  co⇒cl = Comp.co⇒cl

  -- The function cl⇒co is a left inverse of co⇒cl (up to pointwise
  -- bisimilarity).

  cl⇒co∘co⇒cl : ∀ {i p q}
                (p≈q : p Co.≈ q) →
                Co.[ i ] cl⇒co (co⇒cl p≈q) ≡ p≈q
  cl⇒co∘co⇒cl = Comp.cl⇒co∘co⇒cl

  -- If there are two processes that are not equal, but weakly
  -- bisimilar, then co⇒cl is not a left inverse of cl⇒co.

  co⇒cl∘cl⇒co : ∀ {p q} →
                p ≢ q → p Co.≈ q →
                ∃ λ (p≈p : p Cl.≈ p) → co⇒cl (cl⇒co p≈p) ≢ p≈p
  co⇒cl∘cl⇒co = Comp.co⇒cl∘cl⇒co

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

  classical⇔coinductive : ∀ {p q} → p Cl.≈ q ⇔ p Co.≈ q
  classical⇔coinductive = Comp.classical⇔coinductive

  -- There is a split surjection from the classical definition of
  -- bisimilarity to the coinductive one (assuming two kinds of
  -- extensionality).

  classical↠coinductive :
    Extensionality ℓ ℓ →
    Co.Extensionality →
    ∀ {p q} → p Cl.≈ q ↠ p Co.≈ q
  classical↠coinductive = Comp.classical↠coinductive

-- There is at least one LTS for which there is a split surjection
-- from the coinductive definition of weak bisimilarity to the
-- classical one.

coinductive↠classical :
  ∀ {p q} →
  Bisimilarity.Weak.Alternative._≈_           empty p q ↠
  Bisimilarity.Weak.Alternative.Classical._≈_ empty p q
coinductive↠classical {p = ()}

-- There is an LTS for which coinductive weak bisimilarity is
-- pointwise propositional (assuming two kinds of extensionality and
-- univalence).

coinductive-weak-bisimilarity-is-sometimes-propositional :
  Extensionality lzero (lsuc lzero) →
  Univalence lzero →
  let module Co = Bisimilarity.Weak.Alternative one-loop in
  Co.Extensionality → Is-proposition (tt Co.≈ tt)
coinductive-weak-bisimilarity-is-sometimes-propositional ext univ =
  subst (λ lts → let module Co = Bisimilarity lts in
                  ∀ p → Co.Extensionality → Is-proposition (p Co.∼ p))
        (sym $ weak≡id ext univ one-loop (λ _ ()))
        (λ _ → Comp.coinductive-bisimilarity-is-sometimes-propositional
                 (lower-extensionality _ _ ext))
        _

-- However, classical weak bisimilarity (of any size) is, for the same
-- LTS, not pointwise propositional (assuming extensionality and
-- univalence).

classical-weak-bisimilarity-is-not-propositional :
  Extensionality lzero (lsuc lzero) →
  Univalence lzero →
  let module Cl = Bisimilarity.Weak.Alternative.Classical one-loop in
  ∀ {ℓ} → ¬ Is-proposition (Cl.Weak-bisimilarity′ ℓ (tt , tt))
classical-weak-bisimilarity-is-not-propositional ext univ {ℓ} =
  subst (λ lts → let module Cl = Bisimilarity.Classical lts in
                 ∀ p → ¬ Is-proposition (Cl.Bisimilarity′ ℓ (p , p)))
        (sym $ weak≡id ext univ one-loop (λ _ ()))
        (λ _ → Comp.classical-bisimilarity-is-not-propositional)
        _

-- Thus, assuming two kinds of extensionality and univalence, there is
-- in general no split surjection from the coinductive definition of
-- weak bisimilarity to the classical one (of any size).

¬coinductive↠classical :
  Extensionality lzero (lsuc lzero) →
  Univalence lzero →
  Bisimilarity.Weak.Alternative.Extensionality one-loop →
  ∀ {ℓ} →
  ¬ (∀ {p q} →
     Bisimilarity.Weak.Alternative._≈_ one-loop p q ↠
     Bisimilarity.Weak.Alternative.Classical.Weak-bisimilarity′
       one-loop ℓ (p , q))
¬coinductive↠classical ext univ ext′ {ℓ} =
  subst (λ lts → Bisimilarity.Extensionality lts →
                 ¬ (∀ {p q} → Bisimilarity._∼_ lts p q ↠
                              Bisimilarity.Classical.Bisimilarity′
                                lts ℓ (p , q)))
        (sym $ weak≡id ext univ one-loop (λ _ ()))
        (λ ext′ → Comp.¬coinductive↠classical
                    (lower-extensionality _ _ ext) ext′)
        ext′

-- Note also that coinductive weak bisimilarity is not always
-- propositional (assuming extensionality and univalence).

coinductive-weak-bisimilarity-is-not-propositional :
  Extensionality lzero (lsuc lzero) →
  Univalence lzero →
  let open Bisimilarity.Weak.Alternative two-bisimilar-processes in
  ¬ (∀ {p q} → Is-proposition (p ≈ q))
coinductive-weak-bisimilarity-is-not-propositional ext univ =
  subst (λ lts → let open Bisimilarity lts in
                 ¬ (∀ {p q} → Is-proposition (p ∼ q)))
        (sym $ weak≡id ext univ two-bisimilar-processes (λ _ ()))
        Comp.coinductive-bisimilarity-is-not-propositional

-- In fact, for every type A there is a pointwise split surjection
-- from a certain instance of weak bisimilarity to equality on A
-- (assuming extensionality and univalence).

weak-bisimilarity↠equality :
  ∀ {a} →
  Extensionality a (lsuc a) →
  Univalence a →
  {A : Type a} →
  let open Bisimilarity.Weak.Alternative (bisimilarity⇔equality A) in
  {p q : A} → p ≈ q ↠ p ≡ q
weak-bisimilarity↠equality ext univ {A} =
  subst (λ lts → let open Bisimilarity lts in
                 ∀ {p q} → p ∼ q ↠ p ≡ q)
        (sym $ weak≡id ext univ (bisimilarity⇔equality A) (λ _ ()))
        (Comp.bisimilarity↠equality {A = A})


module Luau.RuntimeType where

open import Luau.Value using (Value; nil; addr; number)

data RuntimeType : Set where
  function : RuntimeType
  number : RuntimeType
  nil : RuntimeType

valueType : Value → RuntimeType
valueType nil = nil
valueType (addr x) = function
valueType (number x) = number


open import Coinduction using ( ∞ ; ♯_ ; ♭ )
open import Data.Product using ( ∃ ; _×_ ; _,_ ; proj₂ )
open import Data.Nat using ( ℕ ; zero ; suc )
open import Data.Empty using ( ⊥ )
open import FRP.LTL.ISet.Core using ( ISet ; M⟦_⟧ ; ⟦_⟧ ; ⌈_⌉ ; _,_ ; splitM⟦_⟧ ) renaming ( [_] to ⟪_⟫ )
open import FRP.LTL.ISet.Globally using ( □ ; [_] )
open import FRP.LTL.ISet.Stateless using ( _⇒_ ; _$_  )
open import FRP.LTL.RSet.Core using ( RSet )
open import FRP.LTL.Time.Bound using
  ( Time∞ ; fin ; +∞ ; _≺_ ; _≼_ ; _⋠_ ; ≺-Indn ; _,_
  ; ≺-impl-≼ ; ≼-refl ; _≼-trans_ ; ≡-impl-≽ ; ≺-impl-≢ ; ≺-impl-⋡ ; t≺+∞ ; ∞≼-impl-≡∞ ; ≺-indn )
open import FRP.LTL.Time.Interval using ( [_⟩ ; Int ; ↑ )
open import FRP.LTL.Util using ( ⊥-elim )
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl )
open import Relation.Unary using ( _∈_ )

module FRP.LTL.ISet.Causal where

infixr 2 _⊵_
infixr 3 _⋙_ _≫_ _⊨_≫_

-- A ⊵ B is the causal function space from A to B

data _∙_⊸_∙_ (A : ISet) (s : Time∞) (B : ISet) (u : Time∞) : Set where
  inp : .(s ≼ u) → .(u ≺ +∞) →
    (∀ {t} .(s≺t : s ≺ t) → M⟦ A ⟧ [ s≺t ⟩ → ∞ (A ∙ t ⊸ B ∙ u)) →
      (A ∙ s ⊸ B ∙ u)
  out : ∀ {v} .(u≺v : u ≺ v) →
    M⟦ B ⟧ [ u≺v ⟩ → ∞ (A ∙ s ⊸ B ∙ v) →
      (A ∙ s ⊸ B ∙ u)
  done : .(u ≡ +∞) →
    (A ∙ s ⊸ B ∙ u)

_⊵_ : ISet → ISet → ISet
A ⊵ B = ⌈ (λ t → A ∙ fin t ⊸ B ∙ fin t) ⌉

-- Categorical structure

ar : ∀ {A B} t → M⟦ A ⇒ B ⟧ (↑ t) → (A ∙ fin t ⊸ B ∙ fin t)
ar {A} {B} t f = inp ≼-refl t≺+∞ P where

  P : ∀ {u} .(t≺u : fin t ≺ u) → M⟦ A ⟧ [ t≺u ⟩ → ∞ (A ∙ u ⊸ B ∙ fin t)
  P {+∞}    t≺u σ = ♯ out t≺u (f $ σ) (♯ done refl)
  P {fin u} t≺u σ with splitM⟦ A ⇒ B ⟧ [ t≺u ⟩ (↑ u) refl f
  P {fin u} t≺u σ | (f₁ , f₂) = ♯ out t≺u (f₁ $ σ) (♯ ar u f₂)

arr : ∀ {A B} → ⟦ □ (A ⇒ B) ⇒ (A ⊵ B) ⟧
arr ⟪ ⟪ f ⟫ ⟫ = ⟪ (λ t t∈i → ar t (f t t∈i) ) ⟫

-- We could define id in terms of arr, but we define it explictly for efficiency.

id : ∀ {A} t → (A ∙ t ⊸ A ∙ t)
id +∞      = done refl
id (fin t) = inp ≼-refl t≺+∞ (λ {u} t≺u σ → ♯ out t≺u σ (♯ id u))

identity : ∀ {A} → ⟦ A ⊵ A ⟧
identity = ⟪ (λ t t∈i → id (fin t)) ⟫

-- The following typechecks but does not pass the termination checker,
-- due to the possibility of infinite left-to-right chatter:

-- _≫_ : ∀ {A B C s t u} → (A ∙ s ⊸ B ∙ t) → (B ∙ t ⊸ C ∙ u) → (A ∙ s ⊸ C ∙ u)
-- P             ≫ out u≺w τ Q   = out u≺w τ (♯ (P ≫ ♭ Q))
-- P             ≫ done u≡∞      = done u≡∞
-- inp s≼t t≺∞ P ≫ inp t≼u u≺∞ Q = inp (s≼t ≼-trans t≼u) u≺∞ (λ s≺v σ → ♯ (♭ (P s≺v σ) ≫ inp t≼u u≺∞ Q))
-- done t≡∞      ≫ inp t≼u u≺∞ Q = ⊥-elim (≺-impl-≢ u≺∞ (∞≼-impl-≡∞ (≡-impl-≽ t≡∞ ≼-trans t≼u)))
-- out t≺v σ P   ≫ inp t≼u u≺∞ Q = out t≺v σ P ≫ inp t≼u u≺∞ Q

-- We have to be explicit about the induction scheme in the case of left-to-right
-- communication, which is because, for any t and u ≺ ∞, there is a bound
-- on the length of any ≺-chain between t and u.

mutual

  _⊨_≫_ : ∀ {A B C s t u} → (≺-Indn t u) → (A ∙ s ⊸ B ∙ t) → (B ∙ t ⊸ C ∙ u) → (A ∙ s ⊸ C ∙ u)
  n     , t+n≻u   ⊨ P             ≫ out u≺w τ Q   = out u≺w τ (♯ (P ≫ ♭ Q))
  n     , t+n≻u   ⊨ P             ≫ done u≡∞      = done u≡∞
  n     , t+n≻u   ⊨ inp s≼t t≺∞ P ≫ inp t≼u u≺∞ Q = inp (s≼t ≼-trans t≼u) u≺∞ (λ s≺v σ → ♯ (♭ (P s≺v σ) ≫ inp t≼u u≺∞ Q))
  n     , t+n≻u   ⊨ done t≡∞      ≫ inp t≼u u≺∞ Q = ⊥-elim (≺-impl-≢ u≺∞ (∞≼-impl-≡∞ (≡-impl-≽ t≡∞ ≼-trans t≼u)))
  zero  , u≺t     ⊨ out t≺v σ P   ≫ inp t≼u u≺∞ Q = ⊥-elim (≺-impl-⋡ u≺t t≼u)
  suc n , t+1+n≻u ⊨ out t≺v σ P   ≫ inp t≼u u≺∞ Q = n , t+1+n≻u t≺v ⊨ ♭ P ≫ ♭ (Q t≺v σ)

  _≫_ : ∀ {A B C s t u} → (A ∙ s ⊸ B ∙ t) → (B ∙ t ⊸ C ∙ u) → (A ∙ s ⊸ C ∙ u)
  P             ≫ out u≺w τ Q   = out u≺w τ (♯ (P ≫ ♭ Q))
  P             ≫ done u≡∞      = done u≡∞
  inp s≼t t≺∞ P ≫ inp t≼u u≺∞ Q = inp (s≼t ≼-trans t≼u) u≺∞ (λ s≺v σ → ♯ (♭ (P s≺v σ) ≫ inp t≼u u≺∞ Q))
  done t≡∞      ≫ inp t≼u u≺∞ Q = ⊥-elim (≺-impl-≢ u≺∞ (∞≼-impl-≡∞ (≡-impl-≽ t≡∞ ≼-trans t≼u)))
  out t≺v σ P   ≫ inp t≼u u≺∞ Q = ≺-indn u≺∞ ⊨ out t≺v σ P ≫ inp t≼u u≺∞ Q

_⋙_ : ∀ {A B C} → ⟦ (A ⊵ B) ⇒ (B ⊵ C) ⇒ (A ⊵ C) ⟧
(⟪ ⟪ f ⟫ ⟫ ⋙ ⟪ ⟪ g ⟫ ⟫) = ⟪ (λ t t∈i → f t t∈i ≫ g t t∈i) ⟫

-- Apply a process to some of its output

_/_/_ : ∀ {A B s t u} → (A ∙ s ⊸ B ∙ u) → .(s≺t : s ≺ t) → M⟦ A ⟧ [ s≺t ⟩ → (A ∙ t ⊸ B ∙ u)
inp s≼u u≺∞ P / s≺t / σ = ♭ (P s≺t σ)
out u≺v τ P   / s≺t / σ = out u≺v τ (♯ (♭ P / s≺t / σ))
done u≡∞      / s≺t / σ = done u≡∞


-- Intuitionistic propositional calculus.
-- Translation between different formalisations of syntax.

module IPC.Syntax.Translation where

open import IPC.Syntax.Common public

import IPC.Syntax.ClosedHilbertSequential as CHS
import IPC.Syntax.ClosedHilbert as CH
import IPC.Syntax.HilbertSequential as HS
import IPC.Syntax.Hilbert as H
import IPC.Syntax.Gentzen as G

open HS using () renaming (_⊦⊢_ to HS⟨_⊦⊢_⟩ ; _⊢_ to HS⟨_⊢_⟩) public
open H using () renaming (_⊢_ to H⟨_⊢_⟩) public
open G using () renaming (_⊢_ to G⟨_⊢_⟩) public

-- Available translations.
--
--       ┌─────┬─────┬─────┬─────┬─────┐
--       │ CHS │ CH  │ HS  │ H   │ G   │
-- ┌─────┼─────┼─────┼─────┼─────┼─────┤
-- │ CHS │     │  d  │  d  │  ∘  │  ∘  │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ CH  │  d  │     │  ∘  │  d  │  ∘  │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ HS  │  d  │  ∘  │     │  d  │  ∘  │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ H   │  ∘  │  d  │  d  │     │  d  │
-- ├─────┼─────┼─────┼─────┼─────┼─────┤
-- │ G   │  ∘  │  ∘  │  ∘  │  d  │     │
-- └─────┴─────┴─────┴─────┴─────┴─────┘
--
-- d : Direct translation.
-- ∘ : Composition of translations.

-- Translation from closed Hilbert-style sequential to closed Hilbert-style.

chs→ch : ∀ {A} → CHS.⊢ A → CH.⊢ A
chs→ch (Ξ , ts) = chs⊦→ch ts top
  where
    chs⊦→ch : ∀ {A Ξ} → CHS.⊦⊢ Ξ → A ∈ Ξ → CH.⊢ A
    chs⊦→ch (CHS.mp i j ts) top     = CH.app (chs⊦→ch ts i) (chs⊦→ch ts j)
    chs⊦→ch (CHS.ci ts)     top     = CH.ci
    chs⊦→ch (CHS.ck ts)     top     = CH.ck
    chs⊦→ch (CHS.cs ts)     top     = CH.cs
    chs⊦→ch (CHS.cpair ts)  top     = CH.cpair
    chs⊦→ch (CHS.cfst ts)   top     = CH.cfst
    chs⊦→ch (CHS.csnd ts)   top     = CH.csnd
    chs⊦→ch (CHS.unit ts)   top     = CH.unit
    chs⊦→ch (CHS.cboom ts)  top     = CH.cboom
    chs⊦→ch (CHS.cinl ts)   top     = CH.cinl
    chs⊦→ch (CHS.cinr ts)   top     = CH.cinr
    chs⊦→ch (CHS.ccase ts)  top     = CH.ccase
    chs⊦→ch (CHS.mp i j ts) (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ci ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ck ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cs ts)     (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cpair ts)  (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cfst ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.csnd ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.unit ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cboom ts)  (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cinl ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.cinr ts)   (pop k) = chs⊦→ch ts k
    chs⊦→ch (CHS.ccase ts)  (pop k) = chs⊦→ch ts k

-- Translation from closed Hilbert-style to closed Hilbert-style sequential.

ch→chs : ∀ {A} → CH.⊢ A → CHS.⊢ A
ch→chs (CH.app t u) = CHS.app (ch→chs t) (ch→chs u)
ch→chs CH.ci        = ∅ , CHS.ci CHS.nil
ch→chs CH.ck        = ∅ , CHS.ck CHS.nil
ch→chs CH.cs        = ∅ , CHS.cs CHS.nil
ch→chs CH.cpair     = ∅ , CHS.cpair CHS.nil
ch→chs CH.cfst      = ∅ , CHS.cfst CHS.nil
ch→chs CH.csnd      = ∅ , CHS.csnd CHS.nil
ch→chs CH.unit      = ∅ , CHS.unit CHS.nil
ch→chs CH.cboom     = ∅ , CHS.cboom CHS.nil
ch→chs CH.cinl      = ∅ , CHS.cinl CHS.nil
ch→chs CH.cinr      = ∅ , CHS.cinr CHS.nil
ch→chs CH.ccase     = ∅ , CHS.ccase CHS.nil

-- Translation from Hilbert-style sequential to Hilbert-style.

hs→h : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
hs→h (Ξ , ts) = hs⊦→h ts top
  where
    hs⊦→h : ∀ {A Ξ Γ} → HS⟨ Γ ⊦⊢ Ξ ⟩ → A ∈ Ξ → H⟨ Γ ⊢ A ⟩
    hs⊦→h (HS.var i ts)  top     = H.var i
    hs⊦→h (HS.mp i j ts) top     = H.app (hs⊦→h ts i) (hs⊦→h ts j)
    hs⊦→h (HS.ci ts)     top     = H.ci
    hs⊦→h (HS.ck ts)     top     = H.ck
    hs⊦→h (HS.cs ts)     top     = H.cs
    hs⊦→h (HS.cpair ts)  top     = H.cpair
    hs⊦→h (HS.cfst ts)   top     = H.cfst
    hs⊦→h (HS.csnd ts)   top     = H.csnd
    hs⊦→h (HS.unit ts)   top     = H.unit
    hs⊦→h (HS.cboom ts)  top     = H.cboom
    hs⊦→h (HS.cinl ts)   top     = H.cinl
    hs⊦→h (HS.cinr ts)   top     = H.cinr
    hs⊦→h (HS.ccase ts)  top     = H.ccase
    hs⊦→h (HS.var i ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.mp i j ts) (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ci ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ck ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cs ts)     (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cpair ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cfst ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.csnd ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.unit ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cboom ts)  (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cinl ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.cinr ts)   (pop k) = hs⊦→h ts k
    hs⊦→h (HS.ccase ts)  (pop k) = hs⊦→h ts k

-- Translation from Hilbert-style to Hilbert-style sequential.

h→hs : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
h→hs (H.var i)   = ∅ , HS.var i HS.nil
h→hs (H.app t u) = HS.app (h→hs t) (h→hs u)
h→hs H.ci        = ∅ , HS.ci HS.nil
h→hs H.ck        = ∅ , HS.ck HS.nil
h→hs H.cs        = ∅ , HS.cs HS.nil
h→hs H.cpair     = ∅ , HS.cpair HS.nil
h→hs H.cfst      = ∅ , HS.cfst HS.nil
h→hs H.csnd      = ∅ , HS.csnd HS.nil
h→hs H.unit      = ∅ , HS.unit HS.nil
h→hs H.cboom     = ∅ , HS.cboom HS.nil
h→hs H.cinl      = ∅ , HS.cinl HS.nil
h→hs H.cinr      = ∅ , HS.cinr HS.nil
h→hs H.ccase     = ∅ , HS.ccase HS.nil

-- Deduction and detachment theorems for Hilbert-style sequential.

hs-lam : ∀ {A B Γ} → HS⟨ Γ , A ⊢ B ⟩ → HS⟨ Γ ⊢ A ▻ B ⟩
hs-lam = h→hs ∘ H.lam ∘ hs→h

hs-lam⋆₀ : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → HS⟨ ∅ ⊢ Γ ▻⋯▻ A ⟩
hs-lam⋆₀ = h→hs ∘ H.lam⋆₀ ∘ hs→h

hs-det : ∀ {A B Γ} → HS⟨ Γ ⊢ A ▻ B ⟩ → HS⟨ Γ , A ⊢ B ⟩
hs-det = h→hs ∘ H.det ∘ hs→h

hs-det⋆₀ : ∀ {A Γ} → HS⟨ ∅ ⊢ Γ ▻⋯▻ A ⟩ → HS⟨ Γ ⊢ A ⟩
hs-det⋆₀ = h→hs ∘ H.det⋆₀ ∘ hs→h

-- Translation from closed Hilbert-style sequential to Hilbert-style sequential.

chs→hs₀ : ∀ {A} → CHS.⊢ A → HS⟨ ∅ ⊢ A ⟩
chs→hs₀ (Ξ , ts) = Ξ , chs⊦→hs₀⊦ ts
  where
    chs⊦→hs₀⊦ : ∀ {Ξ} → CHS.⊦⊢ Ξ → HS⟨ ∅ ⊦⊢ Ξ ⟩
    chs⊦→hs₀⊦ CHS.nil         = HS.nil
    chs⊦→hs₀⊦ (CHS.mp i j ts) = HS.mp i j (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.ci ts)     = HS.ci (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.ck ts)     = HS.ck (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cs ts)     = HS.cs (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cpair ts)  = HS.cpair (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cfst ts)   = HS.cfst (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.csnd ts)   = HS.csnd (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.unit ts)   = HS.unit (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cboom ts)  = HS.cboom (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cinl ts)   = HS.cinl (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.cinr ts)   = HS.cinr (chs⊦→hs₀⊦ ts)
    chs⊦→hs₀⊦ (CHS.ccase ts)  = HS.ccase (chs⊦→hs₀⊦ ts)

chs→hs : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → HS⟨ Γ ⊢ A ⟩
chs→hs t = hs-det⋆₀ (chs→hs₀ t)

-- Translation from Hilbert-style sequential to closed Hilbert-style sequential.

hs₀→chs : ∀ {A} → HS⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
hs₀→chs (Ξ , ts) = Ξ , hs₀⊦→chs⊦ ts
  where
    hs₀⊦→chs⊦ : ∀ {Ξ} → HS⟨ ∅ ⊦⊢ Ξ ⟩ → CHS.⊦⊢ Ξ
    hs₀⊦→chs⊦ HS.nil         = CHS.nil
    hs₀⊦→chs⊦ (HS.var () ts)
    hs₀⊦→chs⊦ (HS.mp i j ts) = CHS.mp i j (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ci ts)     = CHS.ci (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ck ts)     = CHS.ck (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cs ts)     = CHS.cs (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cpair ts)  = CHS.cpair (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cfst ts)   = CHS.cfst (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.csnd ts)   = CHS.csnd (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.unit ts)   = CHS.unit (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cboom ts)  = CHS.cboom (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cinl ts)   = CHS.cinl (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.cinr ts)   = CHS.cinr (hs₀⊦→chs⊦ ts)
    hs₀⊦→chs⊦ (HS.ccase ts)  = CHS.ccase (hs₀⊦→chs⊦ ts)

hs→chs : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
hs→chs t = hs₀→chs (hs-lam⋆₀ t)

-- Translation from closed Hilbert-style to Hilbert-style.

ch→h₀ : ∀ {A} → CH.⊢ A → H⟨ ∅ ⊢ A ⟩
ch→h₀ (CH.app t u) = H.app (ch→h₀ t) (ch→h₀ u)
ch→h₀ CH.ci        = H.ci
ch→h₀ CH.ck        = H.ck
ch→h₀ CH.cs        = H.cs
ch→h₀ CH.cpair     = H.cpair
ch→h₀ CH.cfst      = H.cfst
ch→h₀ CH.csnd      = H.csnd
ch→h₀ CH.unit      = H.unit
ch→h₀ CH.cboom     = H.cboom
ch→h₀ CH.cinl      = H.cinl
ch→h₀ CH.cinr      = H.cinr
ch→h₀ CH.ccase     = H.ccase

ch→h : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → H⟨ Γ ⊢ A ⟩
ch→h t = H.det⋆₀ (ch→h₀ t)

-- Translation from Hilbert-style to closed Hilbert-style.

h₀→ch : ∀ {A} → H⟨ ∅ ⊢ A ⟩ → CH.⊢ A
h₀→ch (H.var ())
h₀→ch (H.app t u) = CH.app (h₀→ch t) (h₀→ch u)
h₀→ch H.ci        = CH.ci
h₀→ch H.ck        = CH.ck
h₀→ch H.cs        = CH.cs
h₀→ch H.cpair     = CH.cpair
h₀→ch H.cfst      = CH.cfst
h₀→ch H.csnd      = CH.csnd
h₀→ch H.unit      = CH.unit
h₀→ch H.cboom     = CH.cboom
h₀→ch H.cinl      = CH.cinl
h₀→ch H.cinr      = CH.cinr
h₀→ch H.ccase     = CH.ccase

h→ch : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
h→ch t = h₀→ch (H.lam⋆₀ t)

-- Translation from Hilbert-style to Gentzen-style.

h→g : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
h→g (H.var i)   = G.var i
h→g (H.app t u) = G.app (h→g t) (h→g u)
h→g H.ci        = G.ci
h→g H.ck        = G.ck
h→g H.cs        = G.cs
h→g H.cpair     = G.cpair
h→g H.cfst      = G.cfst
h→g H.csnd      = G.csnd
h→g H.unit      = G.unit
h→g H.cboom     = G.cboom
h→g H.cinl      = G.cinl
h→g H.cinr      = G.cinr
h→g H.ccase     = G.ccase

-- Translation from Gentzen-style to Hilbert-style.

g→h : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → H⟨ Γ ⊢ A ⟩
g→h (G.var i)      = H.var i
g→h (G.lam t)      = H.lam (g→h t)
g→h (G.app t u)    = H.app (g→h t) (g→h u)
g→h (G.pair t u)   = H.pair (g→h t) (g→h u)
g→h (G.fst t)      = H.fst (g→h t)
g→h (G.snd t)      = H.snd (g→h t)
g→h G.unit         = H.unit
g→h (G.boom t)     = H.boom (g→h t)
g→h (G.inl t)      = H.inl (g→h t)
g→h (G.inr t)      = H.inr (g→h t)
g→h (G.case t u v) = H.case (g→h t) (g→h u) (g→h v)

-- Additional translations from closed Hilbert-style sequential.

chs→h₀ : ∀ {A} → CHS.⊢ A → H⟨ ∅ ⊢ A ⟩
chs→h₀ = ch→h₀ ∘ chs→ch

chs→h : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → H⟨ Γ ⊢ A ⟩
chs→h = ch→h ∘ chs→ch

chs→g₀ : ∀ {A} → CHS.⊢ A → G⟨ ∅ ⊢ A ⟩
chs→g₀ = h→g ∘ chs→h₀

chs→g : ∀ {A Γ} → CHS.⊢ Γ ▻⋯▻ A → G⟨ Γ ⊢ A ⟩
chs→g = h→g ∘ chs→h

-- Additional translations from closed Hilbert-style.

ch→hs₀ : ∀ {A} → CH.⊢ A → HS⟨ ∅ ⊢ A ⟩
ch→hs₀ = chs→hs₀ ∘ ch→chs

ch→hs : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → HS⟨ Γ ⊢ A ⟩
ch→hs = chs→hs ∘ ch→chs

ch→g₀ : ∀ {A} → CH.⊢ A → G⟨ ∅ ⊢ A ⟩
ch→g₀ = h→g ∘ ch→h₀

ch→g : ∀ {A Γ} → CH.⊢ Γ ▻⋯▻ A → G⟨ Γ ⊢ A ⟩
ch→g = h→g ∘ ch→h

-- Additional translations from Hilbert-style sequential.

hs₀→ch : ∀ {A} → HS⟨ ∅ ⊢ A ⟩ → CH.⊢ A
hs₀→ch = chs→ch ∘ hs₀→chs

hs→ch : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
hs→ch = chs→ch ∘ hs→chs

hs→g : ∀ {A Γ} → HS⟨ Γ ⊢ A ⟩ → G⟨ Γ ⊢ A ⟩
hs→g = h→g ∘ hs→h

-- Additional translations from Hilbert-style.

h₀→chs : ∀ {A} → H⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
h₀→chs = ch→chs ∘ h₀→ch

h→chs : ∀ {A Γ} → H⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
h→chs = ch→chs ∘ h→ch

-- Additional translations from Gentzen-style.

g₀→chs : ∀ {A} → G⟨ ∅ ⊢ A ⟩ → CHS.⊢ A
g₀→chs = h₀→chs ∘ g→h

g→chs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → CHS.⊢ Γ ▻⋯▻ A
g→chs = h→chs ∘ g→h

g₀→ch : ∀ {A} → G⟨ ∅ ⊢ A ⟩ → CH.⊢ A
g₀→ch = h₀→ch ∘ g→h

g→ch : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → CH.⊢ Γ ▻⋯▻ A
g→ch = h→ch ∘ g→h

g→hs : ∀ {A Γ} → G⟨ Γ ⊢ A ⟩ → HS⟨ Γ ⊢ A ⟩
g→hs = h→hs ∘ g→h


module Thesis.SIRelBigStep.FundamentalProperty where

open import Data.Product
open import Relation.Binary.PropositionalEquality

open import Thesis.SIRelBigStep.IlcSILR

rfundamentalV3v : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → ∀ ρ1 dρ ρ2 (ρρ : rrelρ3 Γ ρ1 dρ ρ2 n) → rrelV3 τ (⟦ x ⟧Var ρ1) (D.⟦ x ⟧Var dρ) (⟦ x ⟧Var ρ2) n
rfundamentalV3v x n ρ1 dρ ρ2 ρρ = ⟦ x ⟧RelVar3 ρρ

rfundamental3constV : ∀ {τ} k (c : Const τ) →
  rrelV3 τ (eval-const c) (deval (derive-const c) ∅ ∅) (eval-const c) k
rfundamental3constV k (lit n) = refl

rfundamental3 : ∀ {τ Γ} k (t : Term Γ τ) → ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) →
  rrelT3 t (derive-dterm t) t ρ1 dρ ρ2 k

rfundamental3svv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelV3 τ (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2) k
rfundamental3svv k (var x) ρ1 dρ ρ2 ρρ = rfundamentalV3v x k ρ1 dρ ρ2 ρρ
rfundamental3svv k (cons sv1 sv2) ρ1 dρ ρ2 ρρ = rfundamental3svv k sv1 ρ1 dρ ρ2 ρρ , rfundamental3svv k sv2 ρ1 dρ ρ2 ρρ
rfundamental3svv k (const c) ρ1 dρ ρ2 ρρ rewrite deval-derive-const-inv c ρ1 dρ = rfundamental3constV k c
rfundamental3svv k (abs t) ρ1 dρ ρ2 ρρ = (refl , refl) , refl , rrelρ3→⊕ ρ1 dρ ρ2 ρρ , refl , refl ,
    λ j j<k v1 dv v2 vv →
    -- If we replace abs t by rec t, here we would need to invoke (by
    -- well-founded recursion) rfundamental3svv on (abs t) at a smaller j, as follows:
    --   rfundamental3svv j (abs t) ρ1 dρ ρ2 (rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)
    -- As you'd expect, Agda's termination checker does not accept that call directly.
      rfundamental3 j t (v1 • ρ1) (dv • dρ) (v2 • ρ2) (vv , rrelρ3-mono j k (lt1 j<k) _ _ _ _ ρρ)

rfundamental3sv : ∀ {τ Γ} k (sv : SVal Γ τ) →
  ∀ ρ1 dρ ρ2 → (ρρ : rrelρ3 Γ ρ1 dρ ρ2 k) → rrelT3 (val sv) (dval (derive-dsval sv)) (val sv) ρ1 dρ ρ2 k
rfundamental3sv k sv ρ1 dρ ρ2 ρρ .(eval sv ρ1) .(eval sv ρ2) .0 j<k (val .sv) (val .sv) = deval (derive-dsval sv) ρ1 dρ , dval (derive-dsval sv) , rfundamental3svv k sv ρ1 dρ ρ2 ρρ

open import Theorem.Groups-Nehemiah
rfundamental3primv : ∀ {σ τ} k p →
  ∀ v1 dv v2 → (vv : rrelV3 σ v1 dv v2 k) →
  rrelV3 τ (eval-primitive p v1) (deval-primitive p v1 dv) (eval-primitive p v2) k
rfundamental3primv k succ (natV n₁) (bang .(natV n)) (natV n) refl = refl
rfundamental3primv k succ (natV n) (dnatV dn) (natV .(dn + n)) refl = +-suc dn n
rfundamental3primv k add (pairV (natV a1) (natV b1))
  (dpairV (dnatV da) (dnatV db))
  (pairV (natV .(da + a1)) (natV .(db + b1)))
  (refl , refl) = ℕ-mn·pq=mp·nq {da} {db} {a1} {b1}
rfundamental3primv k add (pairV a1 b1)
  (dpairV (dnatV da) (bang b2))
  (pairV a2 .b2) (aa , refl) rewrite rrelV3→⊕ a1 (dnatV da) a2 aa = refl
rfundamental3primv k add (pairV a1 b1)
  (dpairV (bang a2) db)
  (pairV .a2 b2) (refl , bb) rewrite rrelV3→⊕ b1 db b2 bb = refl
rfundamental3primv k add (pairV a1 b1) (bang p2) .p2 refl = refl

-- Warning: names like ρ1⊢t1↓[j]v1 are all broken, sorry for not fixing them.
rfundamental3 k (val sv) = rfundamental3sv k sv
rfundamental3 (suc k) (primapp p sv) ρ1 dρ ρ2 ρρ
  .(eval-primitive p (eval sv ρ1)) .(eval-primitive p (eval sv ρ2)) .1 (s≤s j<k) (primapp .p .sv) (primapp .p .sv) =
   deval-primitive p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) , dprimapp p sv (derive-dsval sv) ,
     rfundamental3primv k p (eval sv ρ1) (deval (derive-dsval sv) ρ1 dρ) (eval sv ρ2)
       (rfundamental3svv k sv ρ1 dρ ρ2 (rrelρ3-mono k (suc k) (≤-step ≤-refl) _ ρ1 dρ ρ2 ρρ))

rfundamental3 (suc (suc k)) (app vs vt) ρ1 dρ ρ2 ρρ v1 v2 .(suc j) (s≤s (s≤s j<k))
  (app j vtv1 ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2 ρ1⊢t1↓[j]v3)
  (app n₁ vtv2 ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3 ρ2⊢t2↓[n2]v4)
  with rfundamental3sv (suc (suc k)) vs ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
       | rfundamental3sv (suc (suc k)) vt ρ1 dρ ρ2 ρρ _ _ zero (s≤s z≤n) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
... | bang f2 , vs↓dsv , refl | dtv , vt↓dvv , dtvv
      rewrite sym (rrelV3→⊕ vtv1 dtv vtv2 dtvv) =
        bang v2 , bangapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ρ2⊢t2↓[n2]v4 , refl
... | dclosure dt ρ dρ₁ , vs↓dsv , (refl , refl) , refl , refl , refl , refl , dsvv | dtv , vt↓dvv , dtvv
      with dsvv (suc k) ≤-refl vtv1 dtv vtv2
           (rrelV3-mono (suc k) (suc (suc k)) (s≤s (≤-step ≤-refl)) _ vtv1 dtv vtv2 dtvv)
           v1 v2 j (s≤s j<k) ρ1⊢t1↓[j]v3 ρ2⊢t2↓[n2]v4
... | dv , ↓dv , dvv =
      dv , dapp vs↓dsv ρ1⊢t1↓[j]v2 vt↓dvv ↓dv , dvv

rfundamental3 (suc (suc k)) (lett s t) ρ1 dρ ρ2 ρρ v1 v2 .(suc (n1 + n2)) (s≤s (s≤s n1+n2≤k))
  (lett n1 n2 vs1 .s .t ρ1⊢t1↓[j]v1 ρ1⊢t1↓[j]v2) (lett _ _ vs2 .s .t ρ2⊢t2↓[n2]v2 ρ2⊢t2↓[n2]v3)
  with rfundamental3 (suc (suc k)) s ρ1 dρ ρ2 ρρ vs1 vs2 n1
    (s≤s (≤-trans (≤-trans (m≤m+n n1 n2) n1+n2≤k) (≤-step ≤-refl)))
    ρ1⊢t1↓[j]v1 ρ2⊢t2↓[n2]v2
... | dsv , ↓dsv , vsv
      with rfundamental3 (suc (suc k) ∸ n1) t (vs1 • ρ1) (dsv • dρ) (vs2 • ρ2) (vsv , rrelρ3-mono (suc (suc k) ∸ n1) (suc (suc k)) (m∸n≤m (suc (suc k)) n1) _ _ _ _ ρρ) v1 v2 n2 (sub∸ n1 (suc n2) (suc (suc k)) n1+[1+n2]≤2+k) ρ1⊢t1↓[j]v2 ρ2⊢t2↓[n2]v3
      where
        n1+[1+n2]≤2+k : n1 + suc n2 ≤ suc (suc k)
        n1+[1+n2]≤2+k rewrite +-suc n1 n2 = ≤-step (s≤s n1+n2≤k)
... | dv , ↓dv , dvv = dv , dlett ρ1⊢t1↓[j]v1 ↓dsv ↓dv , rrelV3-mono (suc k ∸ (n1 + n2)) (suc (suc k) ∸ n1 ∸ n2) 1+k-[n1+n2]≤2+k-n1-n2 _ v1 dv v2 dvv
  where
    1+k-[n1+n2]≤2+k-n1-n2 : suc k ∸ (n1 + n2) ≤ suc (suc k) ∸ n1 ∸ n2
    1+k-[n1+n2]≤2+k-n1-n2 rewrite ∸-+-assoc (suc (suc k)) n1 n2 = ∸-mono {suc k} {suc (suc k)} {n1 + n2} {n1 + n2} (≤-step ≤-refl) ≤-refl


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

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

-- For each desired property (VotesOnce and PreferredRoundRule), we have a
-- module containing a Type that defines a property that an implementation
-- should prove, and a proof that it implies the corresponding rule used by
-- the abstract proofs.  Then, we use those proofs to instantiate thmS5,
-- and the use thmS5 to prove a number of correctness conditions.
--
-- TODO-1: refactor this file to separate the definitions and proofs of
-- VotesOnce and PreferredRoundRule from their use in proving the correctness
-- properties.

module LibraBFT.Abstract.Properties
  (UID    : Set)
  (_≟UID_ : (u₀ u₁ : UID) → Dec (u₀ ≡ u₁))
  (NodeId : Set)
  (𝓔  : EpochConfig UID NodeId)
  (𝓥  : VoteEvidence UID NodeId 𝓔)
  where

 open import LibraBFT.Abstract.Records                 UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.Records.Extends         UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.RecordChain             UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.RecordChain.Assumptions UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.System                  UID _≟UID_ NodeId 𝓔 𝓥
 open import LibraBFT.Abstract.RecordChain.Properties  UID _≟UID_ NodeId 𝓔 𝓥
 open        EpochConfig 𝓔

 module WithAssumptions {ℓ}
   (InSys                 : Record → Set ℓ)
   (votes-only-once       : VotesOnlyOnceRule InSys)
   (preferred-round-rule  : PreferredRoundRule InSys)
  where

   open All-InSys-props InSys

   CommitsDoNotConflict : ∀{q q'}
        → {rc  : RecordChain (Q q)}  → All-InSys rc
        → {rc' : RecordChain (Q q')} → All-InSys rc'
        → {b b' : Block}
        → CommitRule rc  b
        → CommitRule rc' b'
        → NonInjective-≡ bId ⊎ ((B b) ∈RC rc' ⊎ (B b') ∈RC rc)
   CommitsDoNotConflict = WithInvariants.thmS5 InSys votes-only-once preferred-round-rule

   -- When we are dealing with a /Complete/ InSys predicate, we can go a few steps
   -- further and prove that commits do not conflict even if we have only partial
   -- knowledge about Records represented in the system.
   module _ (∈QC⇒AllSent : Complete InSys) where

    -- For a /complete/ system we can go even further; if we have evidence that
    -- only the tip of the record chains is in the system, we can infer
    -- the rest of it is also in the system (or blockIDs are not injective).
    CommitsDoNotConflict'
      : ∀{q q'}{rc  : RecordChain (Q q)}{rc' : RecordChain (Q q')}{b b' : Block}
      → InSys (Q q) → InSys (Q q')
      → CommitRule rc  b
      → CommitRule rc' b'
      → NonInjective-≡ bId ⊎ ((B b) ∈RC rc' ⊎ (B b') ∈RC rc)
    CommitsDoNotConflict' {q} {q'} {step {r = B bb} rc b←q} {step {r = B bb'} rc' b←q'} {b} {b'} q∈sys q'∈sys cr cr'
       with bft-assumption (qVotes-C1 q) (qVotes-C1 q')
    ...| α , α∈qmem , α∈q'mem , hα
       with Any-sym (Any-map⁻ α∈qmem) | Any-sym (Any-map⁻ α∈q'mem)
    ...| α∈q | α∈q'
       with ∈QC⇒AllSent {q = q} hα α∈q q∈sys | ∈QC⇒AllSent {q = q'} hα α∈q' q'∈sys
    ...| ab , (arc , ais) , ab←q | ab' , (arc' , ais') , ab←q'
       with RecordChain-irrelevant (step arc  ab←q)  (step rc  b←q) |
            RecordChain-irrelevant (step arc' ab←q') (step rc' b←q')
    ...| inj₁ hb     | _       = inj₁ hb
    ...| inj₂ _      | inj₁ hb = inj₁ hb
    ...| inj₂ arc≈rc | inj₂ arc'≈rc'
       with CommitsDoNotConflict
                 (All-InSys-step ais  ab←q  q∈sys )
                 (All-InSys-step ais' ab←q' q'∈sys)
                 (transp-CR (≈RC-sym arc≈rc  ) cr )
                 (transp-CR (≈RC-sym arc'≈rc') cr')
    ...| inj₁ hb = inj₁ hb
    ...| inj₂ (inj₁ b∈arc') = inj₂ (inj₁ (transp-B∈RC arc'≈rc' b∈arc'))
    ...| inj₂ (inj₂ b'∈arc) = inj₂ (inj₂ (transp-B∈RC arc≈rc   b'∈arc))

    -- The final property is even stronger; it states that even if an observer
    -- has access only to suffixes of record chains that match the commit rule,
    -- we can still guarantee that b and b' are non-conflicting blocks.  This
    -- will be important for showing that observers can have confidence in commit
    -- messages without participating in the protocol and without having access to
    -- all previously sent records.
    CommitsDoNotConflict''
      : ∀{o o' q q'}
      → {rcf  : RecordChainFrom o  (Q q)}
      → {rcf' : RecordChainFrom o' (Q q')}
      → {b b' : Block}
      → InSys (Q q)
      → InSys (Q q')
      → CommitRuleFrom rcf  b
      → CommitRuleFrom rcf' b'
      → NonInjective-≡ bId ⊎ Σ (RecordChain (Q q')) ((B b)  ∈RC_)
                           ⊎ Σ (RecordChain (Q q))  ((B b') ∈RC_)
    CommitsDoNotConflict'' {cb} {q = q} {q'} {rcf} {rcf'} q∈sys q'∈sys crf crf'
       with bft-assumption (qVotes-C1 q) (qVotes-C1 q')
    ...| α , α∈qmem , α∈q'mem , hα
       with Any-sym (Any-map⁻ α∈qmem) | Any-sym (Any-map⁻ α∈q'mem)
    ...| α∈q | α∈q'
       with ∈QC⇒AllSent {q = q} hα α∈q q∈sys | ∈QC⇒AllSent {q = q'} hα α∈q' q'∈sys
    ...| ab , (arc , ais) , ab←q | ab' , (arc' , ais') , ab←q'
       with step arc  ab←q | step arc' ab←q'
    ...| rcq | rcq'
       with crf⇒cr rcf  rcq  crf | crf⇒cr rcf' rcq' crf'
    ...| inj₁ hb | _       = inj₁ hb
    ...| inj₂ _  | inj₁ hb = inj₁ hb
    ...| inj₂ cr | inj₂ cr'
       with CommitsDoNotConflict' q∈sys q'∈sys cr cr'
    ...| inj₁ hb = inj₁ hb
    ...| inj₂ (inj₁ b∈arc') = inj₂ (inj₁ (rcq' , b∈arc'))
    ...| inj₂ (inj₂ b'∈arc) = inj₂ (inj₂ (rcq  , b'∈arc))


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

open import Fragment.Equational.Theory

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

open import Fragment.Algebra.Algebra (Σ Θ) using (Algebra)
open import Fragment.Algebra.Homomorphism (Σ Θ)
open import Fragment.Algebra.Free (Σ Θ)
open import Fragment.Equational.Model Θ
open import Fragment.Equational.Coproduct Θ
open import Fragment.Equational.FreeExtension.Base Θ
open import Fragment.Equational.FreeExtension.Synthetic Θ using (SynFrex)

open import Level using (Level)
open import Data.Nat using (ℕ)
open import Data.Vec using (Vec)
open import Relation.Binary using (Setoid)
import Relation.Binary.Reasoning.Setoid as Reasoning

private
  variable
    a ℓ₁ : Level

module _
  (X : FreeExtension)
  (Y : FreeExtension)
  (A : Model {a} {ℓ₁})
  (n : ℕ)
  where

  open FreeExtension X renaming (_[_] to _[_]₁; _[_]-isFrex to _[_]₁-isFrex)
  open FreeExtension Y renaming (_[_] to _[_]₂; _[_]-isFrex to _[_]₂-isFrex)

  open IsCoproduct (A [ n ]₁-isFrex)
    renaming (inl to inl₁; inr to inr₁; _[_,_] to _[_,_]₁; commute₁ to commute₁₁; commute₂ to commute₂₁)
  open IsCoproduct (A [ n ]₂-isFrex)
    renaming (inl to inl₂; inr to inr₂; _[_,_] to _[_,_]₂; commute₁ to commute₁₂; commute₂ to commute₂₂)
    using ()

  to : ∥ A [ n ]₂ ∥ₐ ⟿ ∥ A [ n ]₁ ∥ₐ
  to = (A [ n ]₁) [ inl₁ , inr₁ ]₂

  from : ∥ A [ n ]₁ ∥ₐ ⟿ ∥ A [ n ]₂ ∥ₐ
  from = (A [ n ]₂) [ inl₂ , inr₂ ]₁

  inv : to ⊙ from ≗ id
  inv = begin
      to ⊙ from
    ≈⟨ ≗-sym {f = (A [ n ]₁) [ inl₁ , inr₁ ]₁} {g = to ⊙ from} (universal {h = to ⊙ from} c₁ c₂) ⟩
      (A [ n ]₁) [ inl₁ , inr₁ ]₁
    ≈⟨ universal {h = id} (id-unitˡ {f = inl₁}) (id-unitˡ {f = inr₁}) ⟩
      id
    ∎
    where c₁ : (to ⊙ from) ⊙ inl₁ ≗ inl₁
          c₁ = begin
              (to ⊙ from) ⊙ inl₁
            ≈⟨ ⊙-assoc to from inl₁ ⟩
              to ⊙ (from ⊙ inl₁)
            ≈⟨ ⊙-congˡ to (from ⊙ inl₁) inl₂ (commute₁₁ {f = inl₂} {g = inr₂}) ⟩
              to ⊙ inl₂
            ≈⟨ commute₁₂ {X = A [ n ]₁} {f = inl₁} {g = inr₁} ⟩
              inl₁
            ∎
            where open Reasoning (∥ A ∥ₐ ⟿ ∥ A [ n ]₁ ∥ₐ /≗)

          c₂ : (to ⊙ from) ⊙ inr₁ ≗ inr₁
          c₂ = begin
              (to ⊙ from) ⊙ inr₁
            ≈⟨ ⊙-assoc to from inr₁ ⟩
              to ⊙ (from ⊙ inr₁)
            ≈⟨ ⊙-congˡ to (from ⊙ inr₁) inr₂ (commute₂₁ {f = inl₂} {g = inr₂}) ⟩
              to ⊙ inr₂
            ≈⟨ commute₂₂ {X = A [ n ]₁} {f = inl₁} {g = inr₁} ⟩
              inr₁
            ∎
            where open Reasoning (∥ J n ∥ₐ ⟿ ∥ A [ n ]₁ ∥ₐ /≗)

          open Reasoning (∥ A [ n ]₁ ∥ₐ ⟿ ∥ A [ n ]₁ ∥ₐ /≗)

module _
  (X : FreeExtension)
  (Y : FreeExtension)
  (A : Model {a} {ℓ₁})
  (n : ℕ)
  where

  open FreeExtension X renaming (_[_] to _[_]₁)
  open FreeExtension Y renaming (_[_] to _[_]₂)

  iso : ∥ A [ n ]₁ ∥ₐ ≃ ∥ A [ n ]₂ ∥ₐ
  iso = record { _⃗   = to Y X A n
               ; _⃖   = from Y X A n
               ; invˡ = inv Y X A n
               ; invʳ = inv X Y A n
               }

module _
  (X : FreeExtension)
  (A : Model {a} {ℓ₁})
  {n : ℕ}
  where

  open FreeExtension X
  open FreeExtension SynFrex renaming (_[_] to _[_]ₛ; _[_]-isFrex to _[_]ₛ-isFrex)

  open IsCoproduct (A [ n ]-isFrex)
  open IsCoproduct (A [ n ]ₛ-isFrex) renaming (_[_,_] to _[_,_]ₛ) using ()

  open Setoid ∥ A [ n ] ∥/≈ renaming (_≈_ to _≋_)
  open Setoid ∥ A ∥/≈ using (_≈_)

  norm = to X SynFrex A n
  syn = from X SynFrex A n

  reduce : (θ : Env ∥ A ∥ₐ n) → ∥ A [ n ]ₛ ∥ₐ ⟿ ∥ A ∥ₐ
  reduce θ = A [ id , interp A θ ]ₛ

  module _ (Γ : Vec ∥ A ∥ n) where

    private

      θ : Env ∥ A ∥ₐ n
      θ = env {A = ∥ A ∥ₐ} Γ

    frexify : ∀ {lhs rhs : Term (BT ∥ A ∥ n)}
              → ∣ norm ∣ lhs ≋ ∣ norm ∣ rhs
              → ∣ reduce θ ∣ lhs ≈ ∣ reduce θ ∣ rhs
    frexify {lhs = lhs} {rhs = rhs} p = begin
        ∣ reduce θ ∣ lhs
      ≈⟨ Setoid.sym ∥ A ∥/≈ (∣ reduce θ ∣-cong (inv SynFrex X A n {x = lhs})) ⟩
        ∣ reduce θ ∣ (∣ syn ∣ (∣ norm ∣ lhs))
      ≈⟨ ∣ reduce θ ∣-cong (∣ syn ∣-cong p) ⟩
        ∣ reduce θ ∣ (∣ syn ∣ (∣ norm ∣ rhs))
      ≈⟨ ∣ reduce θ ∣-cong (inv SynFrex X A n {x = rhs}) ⟩
        ∣ reduce θ ∣ rhs
      ∎
      where open Reasoning ∥ A ∥/≈


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

module Definition.Conversion.Whnf where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Conversion

open import Tools.Product

mutual
  -- Extraction of neutrality from algorithmic equality of neutrals.
  ne~↑ : ∀ {t u A Γ}
       → Γ ⊢ t ~ u ↑ A
       → Neutral t × Neutral u
  ne~↑ (var-refl x₁ x≡y) = var _ , var _
  ne~↑ (app-cong x x₁) = let _ , q , w = ne~↓ x
                         in  ∘ₙ q , ∘ₙ w
  ne~↑ (fst-cong x) =
    let _ , pNe , rNe = ne~↓ x
    in  fstₙ pNe , fstₙ rNe
  ne~↑ (snd-cong x) =
    let _ , pNe , rNe = ne~↓ x
    in  sndₙ pNe , sndₙ rNe
  ne~↑ (natrec-cong x x₁ x₂ x₃) = let _ , q , w = ne~↓ x₃
                                  in  natrecₙ q , natrecₙ w
  ne~↑ (Emptyrec-cong x x₁) = let _ , q , w = ne~↓ x₁
                              in Emptyrecₙ q , Emptyrecₙ w

  -- Extraction of neutrality and WHNF from algorithmic equality of neutrals
  -- with type in WHNF.
  ne~↓ : ∀ {t u A Γ}
       → Γ ⊢ t ~ u ↓ A
       → Whnf A × Neutral t × Neutral u
  ne~↓ ([~] A₁ D whnfB k~l) = whnfB , ne~↑ k~l

-- Extraction of WHNF from algorithmic equality of types in WHNF.
whnfConv↓ : ∀ {A B Γ}
          → Γ ⊢ A [conv↓] B
          → Whnf A × Whnf B
whnfConv↓ (U-refl x) = Uₙ , Uₙ
whnfConv↓ (ℕ-refl x) = ℕₙ , ℕₙ
whnfConv↓ (Empty-refl x) = Emptyₙ , Emptyₙ
whnfConv↓ (Unit-refl x) = Unitₙ , Unitₙ
whnfConv↓ (ne x) = let _ , neA , neB = ne~↓ x
                   in  ne neA , ne neB
whnfConv↓ (Π-cong x x₁ x₂) = Πₙ , Πₙ
whnfConv↓ (Σ-cong x x₁ x₂) = Σₙ , Σₙ

-- Extraction of WHNF from algorithmic equality of terms in WHNF.
whnfConv↓Term : ∀ {t u A Γ}
              → Γ ⊢ t [conv↓] u ∷ A
              → Whnf A × Whnf t × Whnf u
whnfConv↓Term (ℕ-ins x) = let _ , neT , neU = ne~↓ x
                           in ℕₙ , ne neT , ne neU
whnfConv↓Term (Empty-ins x) = let _ , neT , neU = ne~↓ x
                              in Emptyₙ , ne neT , ne neU
whnfConv↓Term (Unit-ins x) = let _ , neT , neU = ne~↓ x
                             in Unitₙ , ne neT , ne neU
whnfConv↓Term (ne-ins t u x x₁) =
  let _ , neT , neU = ne~↓ x₁
  in ne x , ne neT , ne neU
whnfConv↓Term (univ x x₁ x₂) = Uₙ , whnfConv↓ x₂
whnfConv↓Term (zero-refl x) = ℕₙ , zeroₙ , zeroₙ
whnfConv↓Term (suc-cong x) = ℕₙ , sucₙ , sucₙ
whnfConv↓Term (η-eq x₁ x₂ y y₁ x₃) = Πₙ , functionWhnf y , functionWhnf y₁
whnfConv↓Term (Σ-η _ _ pProd rProd _ _) = Σₙ , productWhnf pProd , productWhnf rProd
whnfConv↓Term (η-unit _ _ tWhnf uWhnf) = Unitₙ , tWhnf , uWhnf


{-# OPTIONS --no-qualified-instances #-}
module CF.Transform.UnCo where

open import Data.Product
open import Data.List
open import Data.List.Relation.Unary.All
open import Data.List.Membership.Propositional

open import Relation.Unary hiding (_∈_)
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Relation.Ternary.Core
open import Relation.Ternary.Structures
open import Relation.Ternary.Structures.Syntax
open import Relation.Ternary.Monad hiding (unit)
open import Relation.Ternary.Monad.Weakening
open import Relation.Ternary.Data.Bigstar hiding ([_])

open import CF.Types
open import CF.Syntax.Hoisted as Hoisted
open import CF.Contexts.Lexical
open import CF.Transform.Hoist
open import CF.Syntax.DeBruijn as Tgt
open Hoisted

open import Relation.Ternary.Data.Allstar Ty

{-# TERMINATING #-}
mutual
  uncoₑ : ∀[ Hoisted.Exp a ⇑ ⇒ Tgt.Exp a ]
  uncoₑ (unit ⇈ wk)     = unit
  uncoₑ (num x ⇈ wk)    = num x
  uncoₑ (bool x ⇈ wk)   = bool x
  uncoₑ (Exp.var' vars ⇈ wk)  = Tgt.var' (member wk)
  uncoₑ (bop f e₁✴e₂ ⇈ wk) with e₁ , e₂ ← unstar (e₁✴e₂ ⇈ wk) = bop f (uncoₑ e₁) (uncoₑ e₂)
  uncoₑ (ifthenelse c✴e₁✴e₂ ⇈ wk) = let
    c  , e₁✴e₂ = unstar (c✴e₁✴e₂ ⇈ wk)
    e₁ , e₂    = unstar e₁✴e₂
    in ifthenelse (uncoₑ c) (uncoₑ e₁) (uncoₑ e₂)

  uncos : ∀[ (Allstar Hoisted.Exp as) ⇑ ⇒ Exps as ]
  uncos (nil       ⇈ wk) = []
  uncos (cons e✴es ⇈ wk) with e , es ← unstar (e✴es ⇈ wk) = uncoₑ e ∷ uncos es

{-# TERMINATING #-}
mutual
  uncoₛ : ∀[ Hoisted.Stmt r ⇑ ⇒ Tgt.Stmt r ]
  uncoₛ (run x ⇈ wk) = run (uncoₑ (x ⇈ wk))
  uncoₛ (asgn v✴e ⇈ wk) with unstar (v✴e ⇈ wk)
  ... | vars ⇈ wk' , e⇑ = asgn (member wk') (uncoₑ e⇑)
  uncoₛ (ifthenelse c✴s₁✴s₂ ⇈ wk) = let
    c  , s₁✴s₂ = unstar (c✴s₁✴s₂ ⇈ wk)
    s₁ , s₂    = unstar s₁✴s₂
    in ifthenelse (uncoₑ c) (uncoₛ s₁) (uncoₛ s₂)
  uncoₛ (while c✴s ⇈ wk) with c , s ← unstar (c✴s ⇈ wk) = while (uncoₑ c) (uncoₛ s)
  uncoₛ (block x ⇈ wk) = block (unco' (x ⇈ wk))

  unco' : ∀[ Hoisted.Block r ⇑ ⇒ Tgt.Block r ]
  unco' (nil ⇈ wk) = nil
  unco' (cons s✴b ⇈ wk) with s , b ← unstar (s✴b ⇈ wk) = uncoₛ s ⍮⍮ unco' b

unco : ∀[ Hoisted.Block r ⇒ Tgt.Block r ]
unco bl = unco' (return bl)


module GUIgeneric.GUIFeatures where

open import GUIgeneric.Prelude

open import GUIgeneric.GUIDefinitions renaming (add to add'; add' to add)
open import GUIgeneric.GUI
open import GUIgeneric.GUIExampleLib
open import StateSizedIO.GUI.WxGraphicsLibLevel3

open Interfaceˢ public

-- Components
--
frameAndOKButton : ComponentEls _
frameAndOKButton = add (create-button "OK button") create-frame notOptimzed

exampleOneButton : Frame
exampleOneButton = frameAndOKButton

exampleTwoButtons : Frame
exampleTwoButtons = add (create-button "Cancel button") frameAndOKButton notOptimzed

exampleThreeButtons : Frame
exampleThreeButtons = add (create-button "Cancel button") (frameAndOKButton) notOptimzed

getFrame : Frame → ComponentEls frame
getFrame (createC tt) = create-frame
getFrame (add' buttonFrame f f₁ _) = f₁

data StateV : Set where
      s0 s1 s2 : StateV

data StateTea : Set where
      s0 s1 s2 s3 : StateTea

data FeatureTea : Set where
  yesTea noTea : FeatureTea

data FeatureFree : Set where
  yesFree noFree : FeatureFree

data FeatureCancel : Set where
  yesCancel noCancel : FeatureCancel

record FeatureVendingMachine (BaseState : Set) : Set₁ where
  field  Features : Set
         AddState : Set
         guiVendingMachine : (f : Features) → BaseState ⊎ AddState → Frame
  NewState : Set
  NewState =  BaseState ⊎ AddState

open FeatureVendingMachine public

base : FeatureVendingMachine StateV
base .Features = ⊤
base .AddState = ⊥
base .guiVendingMachine f (inj₁ s0) = exampleOneButton
base .guiVendingMachine f (inj₁ s1) = exampleOneButton
base .guiVendingMachine f (inj₁ s2) = exampleTwoButtons
base .guiVendingMachine f (inj₂ ())

upgradeFeatureVM : (baseState : Set)(vm : FeatureVendingMachine baseState)
                   → FeatureVendingMachine (baseState ⊎ vm .AddState)
upgradeFeatureVM baseState vm .Features = vm .Features
upgradeFeatureVM baseState vm .AddState = ⊥
upgradeFeatureVM baseState vm .guiVendingMachine f (inj₁ (inj₁ s)) = vm .guiVendingMachine f (inj₁ s)
upgradeFeatureVM baseState vm .guiVendingMachine f (inj₁ (inj₂ s)) = vm .guiVendingMachine f (inj₂ s)
upgradeFeatureVM baseState vm .guiVendingMachine f (inj₂ ())

changeBaseState : (baseState : Set)(vm : FeatureVendingMachine baseState)
                  (newState : Set)
                  (new2base : newState → baseState)
                  → FeatureVendingMachine newState
changeBaseState baseState vm newState new2base  .Features = vm .Features
changeBaseState baseState vm newState new2base .AddState  = vm .AddState
changeBaseState baseState vm newState new2base .guiVendingMachine f (inj₁ x) = vm .guiVendingMachine f (inj₁ (new2base x))
changeBaseState baseState vm newState new2base .guiVendingMachine f (inj₂ y) = vm .guiVendingMachine f (inj₂ y)

upgradeFeatureVM+ : (baseState : Set)(vm : FeatureVendingMachine baseState)
                    (newBaseState : Set)
                    (newAddState : Set)
                    (new2base : newBaseState ⊎ newAddState → baseState ⊎ vm .AddState)
                     → FeatureVendingMachine newBaseState
Features (upgradeFeatureVM+ baseState vm newBaseState newAddState new2Base) = vm .Features
AddState (upgradeFeatureVM+ baseState vm newBaseState newAddState new2Base) = newAddState
guiVendingMachine (upgradeFeatureVM+ baseState vm newBaseState newAddState new2Base)  f s = vm .guiVendingMachine f (new2Base s)

tea : FeatureVendingMachine StateV → FeatureVendingMachine StateV
tea otherVM .Features = otherVM .Features × FeatureTea
tea otherVM .AddState = otherVM .AddState ⊎ ⊤
tea otherVM .guiVendingMachine (f , yesTea) (inj₁ s1) = exampleThreeButtons
tea otherVM .guiVendingMachine (f , _) (inj₁ s) = otherVM .guiVendingMachine f (inj₁ s)
tea otherVM .guiVendingMachine (f , _) (inj₂ (inj₁ s)) = otherVM .guiVendingMachine f (inj₂ s)
tea otherVM .guiVendingMachine (f , _) (inj₂ (inj₂ _)) = exampleOneButton -- new state

cancel : FeatureVendingMachine StateV → FeatureVendingMachine StateV
cancel otherVM .Features = otherVM .Features × FeatureCancel
cancel otherVM .AddState = otherVM .AddState ⊎ ⊤
cancel otherVM .guiVendingMachine (f , yesCancel) (inj₁ s1) = exampleThreeButtons
cancel otherVM .guiVendingMachine (f , _) (inj₁ s) = otherVM .guiVendingMachine f (inj₁ s)
cancel otherVM .guiVendingMachine (f , _) (inj₂ (inj₁ s)) = otherVM .guiVendingMachine f (inj₂ s)
cancel otherVM .guiVendingMachine (f , _) (inj₂ (inj₂ _)) = exampleOneButton -- new state

teaBase : FeatureVendingMachine StateV
teaBase = tea base

StateTeaAux  : Set
StateTeaAux = StateV ⊎ (⊥ ⊎ ⊤)

teaBaseUnified : FeatureVendingMachine StateTeaAux
teaBaseUnified = upgradeFeatureVM StateV teaBase

stateTeaToPrevState : StateTea → StateTeaAux
stateTeaToPrevState s0 = inj₁ s0
stateTeaToPrevState s1 = inj₁ s1
stateTeaToPrevState s2 = inj₁ s2
stateTeaToPrevState s3 = inj₂ (inj₂ _)

teaBaseImproved : FeatureVendingMachine StateTea
teaBaseImproved = changeBaseState
                       StateTeaAux
                       teaBaseUnified StateTea stateTeaToPrevState

teaBaseNewToOld : StateTea ⊎ ⊥ → StateV ⊎ teaBase .AddState
teaBaseNewToOld (inj₁ s0) = inj₁ s0
teaBaseNewToOld (inj₁ s1) = inj₁ s1
teaBaseNewToOld (inj₁ s2) = inj₁ s2
teaBaseNewToOld (inj₁ s3) = inj₂ (inj₂ _)
teaBaseNewToOld (inj₂ ())

teaBaseImproved+ : FeatureVendingMachine StateTea
teaBaseImproved+  = upgradeFeatureVM+ StateV teaBase StateTea ⊥ teaBaseNewToOld

cancelTeaBase = cancel (tea base)

module base' where
  NewFeatures' : Set
  NewFeatures' = ⊤

  guiVendingMachine' : (f : NewFeatures') → StateV → Frame
  guiVendingMachine' f s0 = exampleOneButton
  guiVendingMachine' f s1 = exampleOneButton
  guiVendingMachine' f s2 = exampleTwoButtons

module tea' (OtherFeatures : Set)
           (oldV : OtherFeatures  → StateV → Frame) where
  NewFeatures' : Set
  NewFeatures' = OtherFeatures × FeatureTea

  guiVendingMachine' : (f : NewFeatures')(s : StateV) → Frame
  guiVendingMachine' (f , yesTea) s1 = exampleThreeButtons
  guiVendingMachine' (f , _) s = oldV f s

module cancel' (OtherFeatures : Set)
              (oldV : OtherFeatures → StateV → Frame) where
  NewFeatures' : Set
  NewFeatures' = OtherFeatures × FeatureCancel

  guiVendingMachine' : (f : NewFeatures')(s : StateV) → Frame
  guiVendingMachine' (f , yesCancel) s1 = exampleThreeButtons
  guiVendingMachine' (f , _) s = oldV f s

module teaBase' (OtherFeatures : Set) where
  open base' renaming (guiVendingMachine' to baseGUIVendingMachine; NewFeatures' to BaseFeatures)
  open tea' BaseFeatures baseGUIVendingMachine public

module cancelTeaBase' (OtherFeatures : Set) where
  open teaBase' OtherFeatures renaming (guiVendingMachine' to teaBaseGUIVendingMachine; NewFeatures' to TeaBaseFeatures)
  open cancel' TeaBaseFeatures teaBaseGUIVendingMachine


{-# OPTIONS --safe --without-K #-}
open import Generics.Prelude
open import Generics.Telescope
open import Generics.Desc
open import Generics.All

module Generics.Accessibility
  {P I ℓ} (A : Indexed P I ℓ)
  {n} (D : DataDesc P I n)
  (let A′ = uncurry P I A)
  (split : ∀ {pi} → A′ pi → ⟦ D ⟧Data A′ pi)
  {p} where

  -- | Accessibility predicate for datatype A at value x
  data Acc {i} (x : A′ (p , i)) : Setω where
    acc : AllDataω Acc D (split x) → Acc x


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

open import Data.Unit
open import Data.Int as ℤ using (ℤ)
open import Data.List
open import Data.List.Relation.Unary.All as List

module MyTestModule where

emptyList : List ℤ
emptyList = []

empty : List.All (λ (x : ℤ) → ⊤) emptyList
empty = checkProperty record
  { databasePath = DATABASE_PATH
  ; propertyUUID = ????
  }


postulate
  A   : Set
  x   : A
  f   : A → A → A
  _●_ : A → A → A

infix 20 _●_

syntax f x y = x ○ y

doesn't-parse : A
doesn't-parse = x ○ x ● x

-- Default fixity for syntax is no longer -666, but 20 as for normal operators.


-- Andreas, 2015-11-18 Fixing de Bruijn indices in debug print for with.

{-# OPTIONS -v tc.with.top:25 #-}  -- KEEP!

postulate
  Trash A : Set
  P : A → Set
  provokeError : Trash

-- The trash arguments should not show up in the debug printing!
-- If they do, permutations or de Bruijn indices are messed up,
-- or the debug messages are printed in the wrong context.
test : (trash1 : Trash) (b : A) (trash2 : Trash) (f : ∀ x → P x) (trash3 : Trash) → Set
test trash1 b trash2 f trash3 with f b
... | p = provokeError

-- EXPECTED:
-- ...
-- vs     = [f b]
-- as     = [P b]
-- ...
--     with arguments [f b]
--              types [P b]
-- ...
-- checkWithFunction
-- ...
--   as     = [P b]
--   vs     = [f b]
-- ...
--
-- and then a type error message.


module Data.Sum.Instance where

open import Class.Equality
open import Class.Monoid
open import Class.Show
open import Data.Bool using (false)
open import Data.String.Instance
open import Data.Sum
open import Data.Sum.Properties
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary

instance
  Sum-Eq : {A B : Set} -> {{_ : Eq A}} -> {{_ : Eq B}} -> Eq (A ⊎ B)
  Sum-Eq = record { _≟_ = ≡-dec _≟_ _≟_ }

  Sum-Show : {A B : Set} -> {{_ : Show A}} -> {{_ : Show B}} -> Show (A ⊎ B)
  Sum-Show = record { show = λ { (inj₁ x) → "inj₁ " + show x ; (inj₂ y) → "inj₂ " + show y } }

  Sum-EqB : {A B : Set} -> {{_ : EqB A}} -> {{_ : EqB B}} -> EqB (A ⊎ B)
  Sum-EqB = record { _≣_ = λ { (inj₁ x) (inj₁ y) → x ≣ y
                             ; (inj₁ x) (inj₂ y) → false
                             ; (inj₂ x) (inj₁ y) → false
                             ; (inj₂ x) (inj₂ y) → x ≣ y } }


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

-- This file is imported by Issue2372ImportInst.

module Issue2372Inst where

postulate D : Set

record R : Set₁ where
  field
    r : Set

open R {{ ... }} public

instance iR = record { r = D }


open import Common.Prelude

test : List Char → Char
test []         = 'a'
test ('a' ∷ []) = 'b'
-- test (c ∷ cs)   = c


-- Possible improvements:
-- * Most of the code below is not reachable from main.
-- * The following primitives are not used at all: primPOr, primComp,
--   primHComp, prim^glueU and prim^unglueU.

{-# OPTIONS --erased-cubical #-}

-- The code from Agda.Builtin.Cubical.Glue should not be compiled.

open import Agda.Builtin.Cubical.Glue

open import Agda.Builtin.Cubical.HCompU
open import Agda.Builtin.Cubical.Id
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub
open import Agda.Builtin.IO
open import Agda.Builtin.Nat
open import Agda.Builtin.String
open import Agda.Builtin.Unit
open import Agda.Primitive.Cubical

open import Erased-cubical-Cubical

postulate
  putStr : String → IO ⊤

{-# FOREIGN GHC import qualified Data.Text.IO #-}
{-# COMPILE GHC putStr = Data.Text.IO.putStr #-}
{-# COMPILE JS putStr =
    function (x) {
      return function(cb) {
        process.stdout.write(x); cb(0); }; } #-}

i₁ : I
i₁ = primIMax (primIMax (primINeg i0) i1) (primIMin i1 i0)

i₁-1 : IsOne i₁
i₁-1 = IsOne1 (primIMax (primINeg i0) i1) (primIMin i1 i0)
         (IsOne2 (primINeg i0) i1 itIsOne)

p₁ : Partial i1 Nat
p₁ = λ _ → 12

p₂ : PartialP i1 (λ _ → Nat)
p₂ = λ _ → 12

p₃ : PartialP i0 (λ _ → Nat)
p₃ = isOneEmpty

subst :
  ∀ {a p} {A : Set a}
  (P : A → Set p) (f : I → A) → P (f i0) → P (f i1)
subst P eq p = primTransp (λ i → P (eq i)) i0 p

p₄ : 12 ≡ 12
p₄ = λ _ → 12

n₁ : Nat
n₁ = p₄ i0

s : Sub Nat i1 (λ _ → 13)
s = inc 13

n₂ : Nat
n₂ = primSubOut s

i₂ : I
i₂ = primFaceForall (λ _ → i1)

i₃ : Id 12 12
i₃ = conid i0 p₄

i₄ : I
i₄ = primDepIMin i1 (λ _ → i0)

i₅ : I
i₅ = primIdFace i₃

p₅ : 12 ≡ 12
p₅ = primIdPath i₃

n₃ : Nat
n₃ = primIdJ (λ _ _ → Nat) 14 i₃

n₄ : Nat
n₄ = primIdElim (λ _ _ → Nat) (λ _ _ _ → 14) i₃

Is-proposition : Set → Set
Is-proposition A = (x y : A) → x ≡ y

data ∥_∥ (A : Set) : Set where
  ∣_∣        : A → ∥ A ∥
  @0 trivial : Is-proposition ∥ A ∥

rec : {A B : Set} → @0 Is-proposition B → (A → B) → ∥ A ∥ → B
rec p f ∣ x ∣           = f x
rec p f (trivial x y i) = p (rec p f x) (rec p f y) i

main : IO ⊤
main =
  putStr (rec easy
            (λ where
               true  → "Success\n"
               false → "Failure\n")
            ∣ true ∣)

-- It should be possible to mention things that are not compiled in
-- type signatures.

u₁ : Not-compiled → ⊤
u₁ _ = tt

@0 A : Set₁
A = Set

u₂ : A → ⊤
u₂ _ = tt


module STLC.Coquand.Convertibility where

open import STLC.Coquand.Substitution public

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

-- Convertibility
infix  3 _∼_
data _∼_ : ∀ {Γ A} → Γ ⊢ A → Γ ⊢ A → Set
  where
    refl∼ : ∀ {Γ A} → {M : Γ ⊢ A}
                    → M ∼ M

    _⁻¹∼  : ∀ {Γ A} → {M₁ M₂ : Γ ⊢ A}
                    → (p : M₁ ∼ M₂)
                    → M₂ ∼ M₁

    _⦙∼_  : ∀ {Γ A} → {M₁ M₂ M₃ : Γ ⊢ A}
                    → (p : M₁ ∼ M₂) (q : M₂ ∼ M₃)
                    → M₁ ∼ M₃

    ƛ∼    : ∀ {Γ A B} → {M₁ M₂ : Γ , A ⊢ B}
                      → (p : M₁ ∼ M₂)
                      → ƛ M₁ ∼ ƛ M₂

    _∙∼_  : ∀ {Γ A B} → {M₁ M₂ : Γ ⊢ A ⇒ B} {N₁ N₂ : Γ ⊢ A}
                      → (p : M₁ ∼ M₂) (q : N₁ ∼ N₂)
                      → M₁ ∙ N₁ ∼ M₂ ∙ N₂

    red⇒ : ∀ {Γ Ξ A B} → (σ : Γ ⊢⋆ Ξ) (M : Ξ , A ⊢ B) (N : Γ ⊢ A)
                        → sub σ (ƛ M) ∙ N ∼ sub (σ , N) M

    exp⇒ : ∀ {Γ A B} → (M : Γ ⊢ A ⇒ B)
                      → M ∼ ƛ (wk M ∙ 0)

≡→∼ : ∀ {Γ A} → {M₁ M₂ : Γ ⊢ A}
               → M₁ ≡ M₂
               → M₁ ∼ M₂
≡→∼ refl = refl∼

instance
  per∼ : ∀ {Γ A} → PER (Γ ⊢ A) _∼_
  per∼ =
    record
      { _⁻¹ = _⁻¹∼
      ; _⦙_ = _⦙∼_
      }

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

renred⇒ : ∀ {Γ Γ′ Ξ A B} → {η : Γ′ ∋⋆ Γ}
                          → (σ : Γ ⊢⋆ Ξ) (M : Ξ , A ⊢ B) (N : Γ ⊢ A)
                          → ren η (sub σ (ƛ M) ∙ N) ∼ ren η (sub (σ , N) M)
renred⇒ {η = η} σ M N = ƛ∼ (≡→∼ (sublift◑ η σ M ⁻¹)) ∙∼ refl∼
                       ⦙ red⇒ (η ◑ σ) M (ren η N)
                       ⦙ ≡→∼ ( (λ σ′ → sub σ′ M)
                                & ((⌊ η ⌋ ● σ ,_) & ⌊sub⌋ η N ⁻¹)
                              ⦙ sub◑ η (σ , N) M
                              )

renexp⇒𝓋 : ∀ {Γ Γ′ A B} → {η : Γ′ ∋⋆ Γ}
                         → (i : Γ ∋ A ⇒ B)
                         → ren η (𝓋 i) ∼ ren η (ƛ (wk (𝓋 i) ∙ 0))
renexp⇒𝓋 {η = η} i = exp⇒ (𝓋 (getᵣ η i))
                    ⦙ ƛ∼ (≡→∼ (𝓋 & ( get○ (wkᵣ idᵣ) η i ⁻¹
                                    ⦙ (λ η′ → getᵣ η′ i)
                                      & ( wklid○ η
                                        ⦙ liftwkrid○ η ⁻¹
                                        )
                                    ⦙ get○ (liftᵣ η) (wkᵣ idᵣ) i
                                    )) ∙∼ refl∼)

renexp⇒ƛ : ∀ {Γ Γ′ A B} → {η : Γ′ ∋⋆ Γ}
                         → (M : Γ , A ⊢ B)
                         → ren η (ƛ M) ∼ ren η (ƛ (wk (ƛ M) ∙ 0))
renexp⇒ƛ {η = η} M = exp⇒ (ƛ (ren (liftᵣ η) M))
                    ⦙ ƛ∼ (ƛ∼ (≡→∼ ( renlift○ (wkᵣ idᵣ) η M ⁻¹
                                   ⦙ (λ η′ → ren η′ M)
                                     & (liftᵣ & ( wklid○ η
                                                ⦙ wkrid○ η ⁻¹
                                                ⦙ zap○ (wkᵣ η) idᵣ 0 ⁻¹
                                                ))
                                   ⦙ renlift○ (liftᵣ η) (wkᵣ idᵣ) M
                                   )) ∙∼ refl∼)

renexp⇒∙ : ∀ {Γ Γ′ A B C} → {η : Γ′ ∋⋆ Γ}
                           → (M : Γ ⊢ A ⇒ B ⇒ C) (N : Γ ⊢ A)
                           → ren η (M ∙ N) ∼ ren η (ƛ (wk (M ∙ N) ∙ 0))
renexp⇒∙ {η = η} M N = exp⇒ (ren η M ∙ ren η N)
                      ⦙ ƛ∼ ((≡→∼ ( ren○ (wkᵣ idᵣ) η M ⁻¹
                                  ⦙ (λ η′ → ren η′ M)
                                    & ( wklid○ η
                                      ⦙ wkrid○ η ⁻¹
                                      ⦙ wk○ η idᵣ ⁻¹
                                      )
                                  ⦙ renliftwk○ η idᵣ M
                                  )
                             ∙∼
                             ≡→∼ ( ren○ (wkᵣ idᵣ) η N ⁻¹
                                  ⦙ (λ η′ → ren η′ N)
                                    & ( wklid○ η
                                      ⦙ wkrid○ η ⁻¹
                                      ⦙ wk○ η idᵣ ⁻¹
                                      )
                                  ⦙ renliftwk○ η idᵣ N
                                  )) ∙∼ refl∼)

ren∼ : ∀ {Γ Γ′ A} → {η : Γ′ ∋⋆ Γ} {M₁ M₂ : Γ ⊢ A}
                  → M₁ ∼ M₂
                  → ren η M₁ ∼ ren η M₂
ren∼ refl∼           = refl∼
ren∼ (p ⁻¹∼)         = ren∼ p ⁻¹
ren∼ (p ⦙∼ q)        = ren∼ p ⦙ ren∼ q
ren∼ (ƛ∼ p)          = ƛ∼ (ren∼ p)
ren∼ (p ∙∼ q)        = ren∼ p ∙∼ ren∼ q
ren∼ (red⇒ σ M N)   = renred⇒ σ M N
ren∼ (exp⇒ (𝓋 i))   = renexp⇒𝓋 i
ren∼ (exp⇒ (ƛ M))   = renexp⇒ƛ M
ren∼ (exp⇒ (M ∙ N)) = renexp⇒∙ M N

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

subred⇒ : ∀ {Γ Ξ Φ A B} → {σ₁ : Γ ⊢⋆ Ξ}
                         → (σ₂ : Ξ ⊢⋆ Φ) (M : Φ , A ⊢ B) (N : Ξ ⊢ A)
                         → sub σ₁ (sub σ₂ (ƛ M) ∙ N) ∼ sub σ₁ (sub (σ₂ , N) M)
subred⇒ {σ₁ = σ₁} σ₂ M N = ƛ∼ (≡→∼ (sublift● σ₁ σ₂ M ⁻¹)) ∙∼ refl∼
                          ⦙ red⇒ (σ₁ ● σ₂) M (sub σ₁ N)
                          ⦙ ≡→∼ (sub● σ₁ (σ₂ , N) M)

subexp⇒𝓋 : ∀ {Γ Ξ A B} → {σ : Γ ⊢⋆ Ξ}
                        → (i : Ξ ∋ A ⇒ B)
                        → sub σ (𝓋 i) ∼ sub σ (ƛ (wk (𝓋 i) ∙ 0))
subexp⇒𝓋 {σ = σ} i = exp⇒ (getₛ σ i)
                    ⦙ ƛ∼ (≡→∼ ( natgetₛ σ i ⁻¹
                               ⦙ (λ σ′ → getₛ σ′ i) & liftwkrid◐ σ ⁻¹
                               ⦙ get◐ (liftₛ σ) (wkᵣ idᵣ) i
                               ) ∙∼ refl∼)

subexp⇒ƛ : ∀ {Γ Ξ A B} → {σ : Γ ⊢⋆ Ξ}
                        → (M : Ξ , A ⊢ B)
                        → sub σ (ƛ M) ∼ sub σ (ƛ (wk (ƛ M) ∙ 0))
subexp⇒ƛ {σ = σ} M = ƛ∼ ( ≡→∼ ( (λ σ′ → sub σ′ M)
                                  & ((_, 0)
                                     & ( rid◐ (wkₛ σ) ⁻¹
                                       ⦙ zap◐ (wkₛ σ) idᵣ 0 ⁻¹
                                       ⦙ zap◐ (liftₛ σ) (wkᵣ idᵣ) 0 ⁻¹
                                       ))
                                ⦙ sub◐ (liftₛ σ , 0) (liftᵣ (wkᵣ idᵣ)) M
                                )
                         ⦙ red⇒ (liftₛ σ) (ren (liftᵣ (wkᵣ idᵣ)) M) 0 ⁻¹
                         )

subexp⇒∙ : ∀ {Γ Ξ A B C} → {σ : Γ ⊢⋆ Ξ}
                          → (M : Ξ ⊢ A ⇒ B ⇒ C) (N : Ξ ⊢ A)
                          → sub σ (M ∙ N) ∼ sub σ (ƛ (wk (M ∙ N) ∙ 0))
subexp⇒∙ {σ = σ} M N = exp⇒ (sub σ M ∙ sub σ N)
                      ⦙ ƛ∼ ((≡→∼ ( sub◑ (wkᵣ idᵣ) σ M ⁻¹
                                  ⦙ (λ σ′ → sub σ′ M)
                                    & ( wklid◑ σ
                                      ⦙ wkrid◐ σ ⁻¹
                                      ⦙ wk◐ σ idᵣ ⁻¹
                                      )
                                  ⦙ subliftwk◐ σ idᵣ M
                                  )
                             ∙∼
                             ≡→∼ ( sub◑ (wkᵣ idᵣ) σ N ⁻¹
                                  ⦙ (λ σ′ → sub σ′ N)
                                    & ( wklid◑ σ
                                      ⦙ wkrid◐ σ ⁻¹
                                      ⦙ wk◐ σ idᵣ ⁻¹
                                      )
                                  ⦙ subliftwk◐ σ idᵣ N
                                  )) ∙∼ refl∼)

sub∼ : ∀ {Γ Ξ A} → {σ : Γ ⊢⋆ Ξ} {M₁ M₂ : Ξ ⊢ A}
                 → M₁ ∼ M₂
                 → sub σ M₁ ∼ sub σ M₂
sub∼ refl∼           = refl∼
sub∼ (p ⁻¹∼)         = sub∼ p ⁻¹
sub∼ (p ⦙∼ q)        = sub∼ p ⦙ sub∼ q
sub∼ (ƛ∼ p)          = ƛ∼ (sub∼ p)
sub∼ (p ∙∼ q)        = sub∼ p ∙∼ sub∼ q
sub∼ (red⇒ σ M N)   = subred⇒ σ M N
sub∼ (exp⇒ (𝓋 i))   = subexp⇒𝓋 i
sub∼ (exp⇒ (ƛ M))   = subexp⇒ƛ M
sub∼ (exp⇒ (M ∙ N)) = subexp⇒∙ M N

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

-- Convertibility of substitutions
infix 3 _∼⋆_
data _∼⋆_ : ∀ {Γ Ξ} → Γ ⊢⋆ Ξ → Γ ⊢⋆ Ξ → Set
  where
    ∅   : ∀ {Γ} → ∅ {Γ} ∼⋆ ∅

    _,_ : ∀ {Γ Ξ A} → {σ₁ σ₂ : Γ ⊢⋆ Ξ} {M₁ M₂ : Γ ⊢ A}
                    → (χ : σ₁ ∼⋆ σ₂) (p : M₁ ∼ M₂)
                    → σ₁ , M₁ ∼⋆ σ₂ , M₂

refl∼⋆ : ∀ {Γ Ξ} → {σ : Γ ⊢⋆ Ξ}
                 → σ ∼⋆ σ
refl∼⋆ {σ = ∅}     = ∅
refl∼⋆ {σ = σ , M} = refl∼⋆ , refl∼

_⁻¹∼⋆ : ∀ {Γ Ξ} → {σ₁ σ₂ : Γ ⊢⋆ Ξ}
                → σ₁ ∼⋆ σ₂
                → σ₂ ∼⋆ σ₁
∅       ⁻¹∼⋆ = ∅
(χ , p) ⁻¹∼⋆ = χ ⁻¹∼⋆ , p ⁻¹

_⦙∼⋆_ : ∀ {Γ Ξ} → {σ₁ σ₂ σ₃ : Γ ⊢⋆ Ξ}
                → σ₁ ∼⋆ σ₂ → σ₂ ∼⋆ σ₃
                → σ₁ ∼⋆ σ₃
∅        ⦙∼⋆ ∅        = ∅
(χ₁ , p) ⦙∼⋆ (χ₂ , q) = (χ₁ ⦙∼⋆ χ₂) , (p ⦙ q)

≡→∼⋆ : ∀ {Γ Ξ} → {σ₁ σ₂ : Γ ⊢⋆ Ξ}
                → σ₁ ≡ σ₂
                → σ₁ ∼⋆ σ₂
≡→∼⋆ refl = refl∼⋆

instance
  per∼⋆ : ∀ {Γ Ξ} → PER (Γ ⊢⋆ Ξ) _∼⋆_
  per∼⋆ =
    record
      { _⁻¹ = _⁻¹∼⋆
      ; _⦙_ = _⦙∼⋆_
      }

wk∼⋆ : ∀ {A Γ Ξ} → {σ₁ σ₂ : Γ ⊢⋆ Ξ}
                 → σ₁ ∼⋆ σ₂
                 → wkₛ {A} σ₁ ∼⋆ wkₛ σ₂
wk∼⋆ ∅       = ∅
wk∼⋆ (χ , p) = wk∼⋆ χ , ren∼ p

lift∼⋆ : ∀ {A Γ Ξ} → {σ₁ σ₂ : Γ ⊢⋆ Ξ}
                   → σ₁ ∼⋆ σ₂
                   → liftₛ {A} σ₁ ∼⋆ liftₛ σ₂
lift∼⋆ ∅       = ∅ , refl∼
lift∼⋆ (χ , p) = wk∼⋆ χ , ren∼ p , refl∼

-- NOTE: Needs getₛ σ₁ i ∼ getₛ σ₂ i
-- ◐∼⋆ : ∀ {Γ Ξ Ξ′} → {σ₁ σ₂ : Γ ⊢⋆ Ξ′} {η : Ξ′ ∋⋆ Ξ}
--                  → σ₁ ∼⋆ σ₂ → σ₁ ◐ η ∼⋆ σ₂ ◐ η
-- ◐∼⋆ {η = ∅}        χ = ∅
-- ◐∼⋆ {η = [ η , i ]} χ = [ ◐∼⋆ χ , {!!} ]

◑∼⋆ : ∀ {Γ Γ′ Ξ} → {η : Γ′ ∋⋆ Γ} {σ₁ σ₂ : Γ ⊢⋆ Ξ}
                 → σ₁ ∼⋆ σ₂
                 → η ◑ σ₁ ∼⋆ η ◑ σ₂
◑∼⋆ ∅       = ∅
◑∼⋆ (χ , p) = ◑∼⋆ χ , sub∼ p

-- NOTE: Needs a more general sub∼
-- ●∼⋆ : ∀ {Γ Ξ Φ} → {σ₁ σ₂ : Γ ⊢⋆ Ξ} {τ₁ τ₂ : Ξ ⊢⋆ Φ}
--                 → σ₁ ∼⋆ σ₂ → τ₁ ∼⋆ τ₂
--                 → σ₁ ● τ₁ ∼⋆ σ₂ ● τ₂
-- ●∼⋆ χ₁ ∅         = ∅
-- ●∼⋆ χ₁ [ χ₂ , p ] = [ ●∼⋆ χ₁ χ₂ , {!!} ]

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


------------------------------------------------------------------------
-- The Agda standard library
--
-- Characters
------------------------------------------------------------------------

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

module Data.Char where

------------------------------------------------------------------------
-- Re-export base definitions and decidability of equality

open import Data.Char.Base public
open import Data.Char.Properties using (_≟_; _==_) public


module jarsec where

open import Algebra
open import Data.Bool
open import Data.Char
-- open import Data.Empty
-- open import Data.Fin
open import Data.List
open import Data.Maybe hiding (map)
open import Data.Nat
open import Data.Nat.Base
open import Data.Nat.Show
-- open import Data.Integer
open import Data.Product hiding (map)
open import Data.Sum hiding (map)
open import Data.String hiding (length)
open import Function
-- open import Data.Sum
-- open import Data.Unit
-- open import Data.Vec
open import Category.Functor
open import Relation.Binary
open import Data.Char.Base
open import Agda.Builtin.Char
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)

record Parser (A : Set) : Set where
  constructor mk-parser
  field
    parse : List Char → (List (A × (List Char)))
open Parser public

item : Parser Char
item = mk-parser λ where
  [] → []
  (c ∷ cs) → (c , cs) ∷ []

bind : ∀ { A B : Set } → Parser A → (A → Parser B) → Parser B
bind {A} p f = mk-parser $ λ cs →
  let rs : List (A × List Char)
      rs = parse p cs
  in concatMap (λ x → parse (f (proj₁ x)) (proj₂ x)) rs
  -- in concatMap (λ where (x , cs′) → parse (f x) cs′) rs

_>>=_ : ∀ { A B : Set } → Parser A → (A → Parser B) → Parser B
p >>= f = bind p f

_>>_ : ∀ { A B : Set } → Parser A → Parser B → Parser B
pA >> pB = pA >>= λ _ → pB

unit : ∀ { A : Set } → A → Parser A
unit a = mk-parser (λ str → ( a , str ) ∷ [])

unit* : ∀ { A : Set } → List A → Parser A
unit* xs = mk-parser (λ str → foldl (λ sum x → (x , str) ∷ sum) [] xs)

fmap : ∀ { A B : Set } → (A → B) → Parser A → Parser B
fmap f p = do
  a ← p
  unit (f a)

_<$>_ : ∀ { A B : Set } → (A → B) → Parser A → Parser B
f <$> p = fmap f p

_<*>_ : ∀ {A B : Set } → Parser A → Parser B → Parser ( A × B )
aP <*> bP = do
  a ← aP
  b ← bP
  unit (a , b)

combine : { A : Set } → Parser A → Parser A → Parser A
combine p q = mk-parser (λ cs → (parse p cs) Data.List.++ (parse q cs))

failure : { A : Set } → Parser A
failure = mk-parser (λ cs → [])

option : { A : Set } → Parser A → Parser A → Parser A
option p q = mk-parser $ λ where
  cs → case (parse p cs) of λ where
    [] → parse q cs
    result → result

{-# TERMINATING #-}
mutual
  many* : { A : Set } → Parser A → Parser (List A)
  many* v = option (many+ v) (unit [])

  many+ : { A : Set } → Parser A → Parser (List A)
  many+ v = fmap (λ { (a , list) → a ∷ list }) (v <*> (many* v))

satisfy : (Char -> Bool) -> Parser Char
satisfy f = do
  c ← item
  case (f c) of λ where
    true → unit c
    false → failure

oneOf : List Char → Parser Char
oneOf options = satisfy (flip elem options)
  where
  elem : Char → List Char → Bool
  elem a [] = false
  elem a (x ∷ xs) = case primCharEquality a x of λ where
    true → true
    false → elem a xs

module _ { A : Set } where
  {-# TERMINATING #-}
  chainl1 : Parser A → Parser (A → A → A) → Parser A
  chainl1 p op = do
    a ← p
    rest a
    where
      rest : A → Parser A
      rest a = option (do
        f ← op
        b ← p
        rest (f a b)) (unit a)

chainl : { A : Set } → Parser A → Parser (A → A → A) → A → Parser A
chainl p op a = option (chainl1 p op) (unit a)

char : Char → Parser Char
char c = satisfy (primCharEquality c)

digit : Parser Char
digit = satisfy isDigit

-- TODO: Remove
∣_-_∣ : ℕ → ℕ → ℕ
∣ zero  - y     ∣ = y
∣ x     - zero  ∣ = x
∣ suc x - suc y ∣ = ∣ x - y ∣

natural : Parser ℕ
natural = natFromList <$> ((map primCharToNat) <$> (many+ digit))
  where
  natFromList : List ℕ → ℕ
  natFromList [] = zero
  natFromList (n ∷ ns) =
    let len = length ns
    in (∣ n - 48 ∣ + (10 * len)) + (natFromList ns)

string : String → Parser String
string str = primStringFromList <$> (string-chars (primStringToList str))
  where
  string-chars : List Char → Parser (List Char)
  string-chars [] = unit []
  string-chars (c ∷ cs) = do
    char c
    string-chars cs
    unit (c ∷ cs)

spaces : Parser String
spaces = fmap primStringFromList (many* (oneOf (primStringToList " \n\r")))

token : { A : Set } → Parser A → Parser A
token p = do
  a ← p
  spaces
  unit a

reserved : String → Parser String
reserved str = token (string str)

parens : { A : Set } → Parser A → Parser A
parens m = do
  (reserved "(")
  n ← m
  (reserved ")")
  unit n

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

data Expr : Set where
  Invalid : Expr
  -- Var     : Char → Expr
  Lit : ℕ → Expr
  Add : Expr → Expr → Expr
  Mul : Expr → Expr → Expr
  -- Add Sub : Expr → Expr → Expr
  -- Mul Div : Expr → Expr → Expr

eval : Expr → ℕ
eval Invalid = 0
eval (Lit n) = n
eval (Add a b) = eval a + eval b
eval (Mul a b) = eval a * eval b

eval′ : Maybe Expr → ℕ
eval′ (just x) = eval x
eval′ nothing = 0

module _ where
  {-# TERMINATING #-}
  expr : Parser Expr
  {-# TERMINATING #-}
  term : Parser Expr
  {-# TERMINATING #-}
  factor : Parser Expr

  infixOp : {A : Set} → String → (A → A → A) → Parser (A → A → A)
  mulop : Parser (Expr → Expr → Expr)
  addop : Parser (Expr → Expr → Expr)

  number : Parser Expr

  expr = chainl1 term addop

  term = chainl1 factor mulop

  factor = option number (parens expr)

  infixOp x f = reserved x >> unit f

  mulop = infixOp "*" Mul

  addop = infixOp "+" Add

  number = do
    n ← natural
    unit (Lit n)

runParser : { A : Set } → Parser A → String → Maybe A
runParser p str = case (parse p (primStringToList str)) of λ where
  [] → nothing
  (res ∷ xs) → just (proj₁ res)

run : String → Maybe Expr
run = runParser expr

do-everything : String → ℕ
do-everything str = eval′ $ run str

partial-parse :  { A : Set } → Parser A → String → Maybe (List (A × List Char))
partial-parse p str with parse p (primStringToList str)
partial-parse p str | [] = nothing
partial-parse p str | xs = just xs

run-parser : { A : Set } → Parser A → List Char → Maybe (List (A × List Char))
run-parser p str = case (parse p str) of λ where
  [] → nothing
  xs → just xs