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

open import HoTT

module homotopy.EilenbergMacLane1 {i} (G : Group i) where
  private
    module G = Group G

    comp-equiv : ∀ g → G.El ≃ G.El
    comp-equiv g = equiv
      (λ x → G.comp x g)
      (λ x → G.comp x (G.inv g))
      (λ x → G.assoc x (G.inv g) g ∙ ap (G.comp x) (G.inv-l g) ∙ G.unit-r x)
      (λ x → G.assoc x g (G.inv g) ∙ ap (G.comp x) (G.inv-r g) ∙ G.unit-r x)

    comp-equiv-comp : (g₁ g₂ : G.El) → comp-equiv (G.comp g₁ g₂)
                      == (comp-equiv g₂ ∘e comp-equiv g₁)
    comp-equiv-comp g₁ g₂ =
      pair= (λ= (λ x → ! (G.assoc x g₁ g₂)))
            (prop-has-all-paths-↓ {B = is-equiv})

    Ω-group : Group (lsucc i)
    Ω-group = Ω^S-group 0
      ⊙[ (0 -Type i) , (G.El , G.El-level) ]

    Codes-hom : G →ᴳ Ω-group
    Codes-hom = group-hom (nType=-out ∘ ua ∘ comp-equiv) pres-comp where
      abstract
        pres-comp : ∀ g₁ g₂
          → nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv (G.comp g₁ g₂)))
          == nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv g₁))
          ∙ nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv g₂))
        pres-comp g₁ g₂ =
          nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv (G.comp g₁ g₂)))
            =⟨ comp-equiv-comp g₁ g₂ |in-ctx nType=-out ∘ ua ⟩
          nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv g₂ ∘e comp-equiv g₁))
            =⟨ ua-∘e (comp-equiv g₁) (comp-equiv g₂) |in-ctx nType=-out ⟩
          nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv g₁) ∙ ua (comp-equiv g₂))
            =⟨ ! $ nType-∙ {A = G.El , G.El-level} {B = G.El , G.El-level} {C = G.El , G.El-level}
                  (ua (comp-equiv g₁)) (ua (comp-equiv g₂)) ⟩
          nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv g₁))
          ∙ nType=-out {A = G.El , G.El-level} {B = G.El , G.El-level} (ua (comp-equiv g₂))
            =∎

    module CodesRec = EM₁Level₁Rec {G = G} {C = 0 -Type i} (G.El , G.El-level) Codes-hom

    Codes : EM₁ G → 0 -Type i
    Codes = CodesRec.f

    encode : {x : EM₁ G} → embase == x → fst (Codes x)
    encode α = transport (fst ∘ Codes) α G.ident

    abstract
      transp-Codes-β : ∀ g g' → transport (fst ∘ Codes) (emloop g) g' == G.comp g' g
      transp-Codes-β g g' =
        coe (ap (fst ∘ Codes) (emloop g)) g'
          =⟨ ap (λ v → coe v g') (ap-∘ fst Codes (emloop g)) ⟩
        coe (ap fst (ap Codes (emloop g))) g'
          =⟨ ap (λ v → coe (ap fst v) g') (CodesRec.emloop-β g) ⟩
        coe (ap fst (nType=-out (ua (comp-equiv g)))) g'
          =⟨ ap (λ v → coe v g') (fst=-β (ua (comp-equiv g)) _) ⟩
        coe (ua (comp-equiv g)) g'
          =⟨ coe-β (comp-equiv g) g' ⟩
        –> (comp-equiv g) g' =∎

      encode-emloop : ∀ g → encode (emloop g) == g
      encode-emloop g =
        transport (fst ∘ Codes) (emloop g) G.ident
          =⟨ transp-Codes-β g G.ident ⟩
        G.comp G.ident g
          =⟨ G.unit-l g ⟩
        g =∎

    module Decode where

      private
        {- transport in path fibration of EM₁ -}
        transp-PF : embase' G == embase → embase' G == embase → embase' G == embase
        transp-PF = transport (embase' G ==_)

        {- transport in Codes -}
        transp-C : embase' G == embase → G.El → G.El
        transp-C = transport (fst ∘ Codes)

        transp-emloop : embase' G == embase → G.El → embase' G == embase
        transp-emloop p = transp-PF p ∘ emloop

        emloop-transp : embase' G == embase → G.El → embase' G == embase
        emloop-transp p = emloop ∘ transp-C p

        swap-transp-emloop-seq : ∀ g h → transp-emloop (emloop g) h =-= emloop-transp (emloop g) h
        swap-transp-emloop-seq g h =
          transp-emloop (emloop g) h
            =⟪ transp-cst=idf (emloop g) (emloop h) ⟫
          emloop h ∙ emloop g
            =⟪ ! (emloop-comp h g) ⟫
          emloop (G.comp h g)
            =⟪ ap emloop (! (transp-Codes-β g h)) ⟫
          emloop-transp (emloop g) h ∎∎

        swap-transp-emloop : ∀ g h → transp-emloop (emloop g) h == emloop-transp (emloop g) h
        swap-transp-emloop g h = ↯ (swap-transp-emloop-seq g h)

      private

        decode-emloop-comp : ∀ g₁ g₂ h →
          swap-transp-emloop (G.comp g₁ g₂) h ◃∙
          ap (λ p → emloop (transp-C p h)) (emloop-comp g₁ g₂) ◃∙
          ap emloop (transp-∙ (emloop g₁) (emloop g₂) h) ◃∎
          =ₛ
          ap (λ p → transp-PF p (emloop h)) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (swap-transp-emloop g₁ h) ◃∙
          swap-transp-emloop g₂ (transp-C (emloop g₁) h) ◃∎
        decode-emloop-comp g₁ g₂ h =
          swap-transp-emloop g₁g₂ h ◃∙
          ap (λ p → emloop-transp p h) (emloop-comp g₁ g₂) ◃∙
          ap emloop (transp-∙ (emloop g₁) (emloop g₂) h) ◃∎
            =ₛ₁⟨ 1 & 1 & ap-∘ emloop (λ p → transp-C p h) (emloop-comp g₁ g₂) ⟩
          swap-transp-emloop g₁g₂ h ◃∙
          ap emloop (ap (λ p → transp-C p h) (emloop-comp g₁ g₂)) ◃∙
          ap emloop (transp-∙ (emloop g₁) (emloop g₂) h) ◃∎
            =ₛ⟨ 0 & 1 & expand (swap-transp-emloop-seq g₁g₂ h) ⟩
          transp-cst=idf (emloop g₁g₂) (emloop h) ◃∙
          ! (emloop-comp h g₁g₂) ◃∙
          ap emloop (! (transp-Codes-β g₁g₂ h)) ◃∙
          ap emloop (ap (λ p → transp-C p h) (emloop-comp g₁ g₂)) ◃∙
          ap emloop (transp-∙ (emloop g₁) (emloop g₂) h) ◃∎
            =ₛ⟨ 2 & 3 &
                ap-seq-=ₛ emloop $
                =ₛ-in {s = ! (transp-Codes-β g₁g₂ h) ◃∙
                           ap (λ p → transp-C p h) (emloop-comp g₁ g₂) ◃∙
                           transp-∙ (emloop g₁) (emloop g₂) h ◃∎}
                      {t = ! (G.assoc h g₁ g₂) ◃∙
                           ap (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h)) ◃∙
                           ! (transp-Codes-β g₂ (transp-C (emloop g₁) h)) ◃∎} $
                prop-path (has-level-apply G.El-level _ _) _ _
              ⟩
          transp-cst=idf (emloop g₁g₂) (emloop h) ◃∙
          ! (emloop-comp h g₁g₂) ◃∙
          ap emloop (! (G.assoc h g₁ g₂)) ◃∙
          ap emloop (ap (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h))) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 0 & 1 &
                post-rotate-in {p = _ ◃∎} $ !ₛ $
                homotopy-naturality (λ p → transp-PF p (emloop h))
                                    (emloop h ∙_)
                                    (λ p → transp-cst=idf p (emloop h))
                                    (emloop-comp g₁ g₂)
              ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-cst=idf (emloop g₁ ∙ emloop g₂) (emloop h) ◃∙
          ! (ap (emloop h ∙_) (emloop-comp g₁ g₂)) ◃∙
          ! (emloop-comp h g₁g₂) ◃∙
          ap emloop (! (G.assoc h g₁ g₂)) ◃∙
          ap emloop (ap (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h))) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ₁⟨ 4 & 1 & ap-! emloop (G.assoc h g₁ g₂) ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-cst=idf (emloop g₁ ∙ emloop g₂) (emloop h) ◃∙
          ! (ap (emloop h ∙_) (emloop-comp g₁ g₂)) ◃∙
          ! (emloop-comp h g₁g₂) ◃∙
          ! (ap emloop (G.assoc h g₁ g₂)) ◃∙
          ap emloop (ap (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h))) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 2 & 3 & !ₛ (!-=ₛ (emloop-coh' G h g₁ g₂)) ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-cst=idf (emloop g₁ ∙ emloop g₂) (emloop h) ◃∙
          ! (∙-assoc (emloop h) (emloop g₁) (emloop g₂)) ◃∙
          ! (ap (_∙ emloop g₂) (emloop-comp h g₁)) ◃∙
          ! (emloop-comp (G.comp h g₁) g₂) ◃∙
          ap emloop (ap (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h))) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 1 & 2 &
                post-rotate'-in {p = _ ◃∙ _ ◃∙ _ ◃∎} $
                transp-cst=idf-pentagon (emloop g₁) (emloop g₂) (emloop h)
              ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          transp-cst=idf (emloop g₂) (emloop h ∙ emloop g₁) ◃∙
          ! (ap (_∙ emloop g₂) (emloop-comp h g₁)) ◃∙
          ! (emloop-comp (G.comp h g₁) g₂) ◃∙
          ap emloop (ap (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h))) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ₁⟨ 6 & 1 & ∘-ap emloop (λ k → G.comp k g₂) (! (transp-Codes-β g₁ h)) ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          transp-cst=idf (emloop g₂) (emloop h ∙ emloop g₁) ◃∙
          ! (ap (_∙ emloop g₂) (emloop-comp h g₁)) ◃∙
          ! (emloop-comp (G.comp h g₁) g₂) ◃∙
          ap (λ k → emloop (G.comp k g₂)) (! (transp-Codes-β g₁ h)) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 5 & 2 & !ₛ $
                homotopy-naturality (λ k → emloop k ∙ emloop g₂)
                                    (λ k → emloop (G.comp k g₂))
                                    (λ k → ! (emloop-comp k g₂))
                                    (! (transp-Codes-β g₁ h))
              ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          transp-cst=idf (emloop g₂) (emloop h ∙ emloop g₁) ◃∙
          ! (ap (_∙ emloop g₂) (emloop-comp h g₁)) ◃∙
          ap (λ k → emloop k ∙ emloop g₂) (! (transp-Codes-β g₁ h)) ◃∙
          ! (emloop-comp (transp-C (emloop g₁) h) g₂) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ₁⟨ 4 & 1 & !-ap (_∙ emloop g₂) (emloop-comp h g₁) ⟩
          ap (λ p → transp-PF p (emloop h)) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          transp-cst=idf (emloop g₂) (emloop h ∙ emloop g₁) ◃∙
          ap (_∙ emloop g₂) (! (emloop-comp h g₁)) ◃∙
          ap (λ k → emloop k ∙ emloop g₂) (! (transp-Codes-β g₁ h)) ◃∙
          ! (emloop-comp (transp-C (emloop g₁) h) g₂) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 3 & 2 & !ₛ $
                homotopy-naturality (transp-PF (emloop g₂))
                                    (_∙ emloop g₂)
                                    (transp-cst=idf (emloop g₂))
                                    (! (emloop-comp h g₁))
              ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          ap (transp-PF (emloop g₂)) (! (emloop-comp h g₁)) ◃∙
          transp-cst=idf (emloop g₂) (emloop (G.comp h g₁)) ◃∙
          ap (λ k → emloop k ∙ emloop g₂) (! (transp-Codes-β g₁ h)) ◃∙
          ! (emloop-comp (transp-C (emloop g₁) h) g₂) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ₁⟨ 5 & 1 & ap-∘ (_∙ emloop g₂) emloop (! (transp-Codes-β g₁ h)) ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          ap (transp-PF (emloop g₂)) (! (emloop-comp h g₁)) ◃∙
          transp-cst=idf (emloop g₂) (emloop (G.comp h g₁)) ◃∙
          ap (_∙ emloop g₂) (ap emloop (! (transp-Codes-β g₁ h))) ◃∙
          ! (emloop-comp (transp-C (emloop g₁) h) g₂) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 4 & 2 & !ₛ $
                homotopy-naturality (transp-PF (emloop g₂))
                                    (_∙ emloop g₂)
                                    (transp-cst=idf (emloop g₂))
                                    (ap emloop (! (transp-Codes-β g₁ h)))
              ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (transp-cst=idf (emloop g₁) (emloop h)) ◃∙
          ap (transp-PF (emloop g₂)) (! (emloop-comp h g₁)) ◃∙
          ap (transp-PF (emloop g₂)) (ap emloop (! (transp-Codes-β g₁ h))) ◃∙
          transp-cst=idf (emloop g₂) (emloop (transp-C (emloop g₁) h)) ◃∙
          ! (emloop-comp (transp-C (emloop g₁) h) g₂) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 2 & 3 & ∙-ap-seq (transp-PF (emloop g₂)) (swap-transp-emloop-seq g₁ h) ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (swap-transp-emloop g₁ h) ◃∙
          transp-cst=idf (emloop g₂) (emloop (transp-C (emloop g₁) h)) ◃∙
          ! (emloop-comp (transp-C (emloop g₁) h) g₂) ◃∙
          ap emloop (! (transp-Codes-β g₂ (transp-C (emloop g₁) h))) ◃∎
            =ₛ⟨ 3 & 3 & contract ⟩
          ap (λ p → transp-emloop p h) (emloop-comp g₁ g₂) ◃∙
          transp-∙ (emloop g₁) (emloop g₂) (emloop h) ◃∙
          ap (transp-PF (emloop g₂)) (swap-transp-emloop g₁ h) ◃∙
          swap-transp-emloop g₂ (transp-C (emloop g₁) h) ◃∎ ∎ₛ
          where g₁g₂ = G.comp g₁ g₂

      decode : {x : EM₁ G} → fst (Codes x) → embase == x
      decode {x} = Decode.f x
        where
        module Decode =
          EM₁Level₁FunElim {B = fst ∘ Codes} {C = embase' G ==_}
            emloop
            swap-transp-emloop
            decode-emloop-comp

    open Decode using (decode)

    decode-encode : ∀ {x} (α : embase' G == x) → decode (encode α) == α
    decode-encode idp = emloop-ident {G = G}

  emloop-equiv : G.El ≃ (embase' G == embase)
  emloop-equiv = equiv emloop encode decode-encode encode-emloop

  ⊙emloop-equiv : G.⊙El ⊙≃ ⊙Ω (⊙EM₁ G)
  ⊙emloop-equiv = ≃-to-⊙≃ emloop-equiv emloop-ident

  abstract
    instance
      EM₁-level₁ : {n : ℕ₋₂} → has-level (S (S (S n))) (EM₁ G)
      EM₁-level₁ {⟨-2⟩} = has-level-in pathspace-is-set
        where
        embase-loopspace-is-set : is-set (embase' G == embase)
        embase-loopspace-is-set = transport is-set (ua emloop-equiv) ⟨⟩
        pathspace-is-set : ∀ (x y : EM₁ G) → is-set (x == y)
        pathspace-is-set = EM₁-prop-elim (EM₁-prop-elim embase-loopspace-is-set)
      EM₁-level₁ {S n} = raise-level _ EM₁-level₁

  Ω¹-EM₁ : Ω^S-group 0 (⊙EM₁ G) ≃ᴳ G
  Ω¹-EM₁ = ≃-to-≃ᴳ (emloop-equiv ⁻¹)
    (λ l₁ l₂ → <– (ap-equiv emloop-equiv _ _) $
      emloop (encode (l₁ ∙ l₂))
        =⟨ decode-encode (l₁ ∙ l₂) ⟩
      l₁ ∙ l₂
        =⟨ ! $ ap2 _∙_ (decode-encode l₁) (decode-encode l₂) ⟩
      emloop (encode l₁) ∙ emloop (encode l₂)
        =⟨ ! $ emloop-comp (encode l₁) (encode l₂) ⟩
      emloop (G.comp (encode l₁) (encode l₂))
        =∎)

  π₁-EM₁ : πS 0 (⊙EM₁ G) ≃ᴳ G
  π₁-EM₁ = Ω¹-EM₁ ∘eᴳ unTrunc-iso (Ω^S-group-structure 0 (⊙EM₁ G))


------------------------------------------------------------------------------
-- Auxiliary properties of the McCarthy 91 function
------------------------------------------------------------------------------

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

module FOTC.Program.McCarthy91.AuxiliaryPropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP using ( x<y→y≤z→x<z )
open import FOTC.Data.Nat.PropertiesATP
  using ( +-N
        ; ∸-N
        )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
  using ( x<x+1 )
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.McCarthy91

------------------------------------------------------------------------------
--- Auxiliary properties

postulate x>100→x<f₉₁-x+11 : ∀ {n} → N n → n > 100' → n < f₉₁ n + 11'
{-# ATP prove x>100→x<f₉₁-x+11 +-N ∸-N x<y→y≤z→x<z x<x+1 x+1≤x∸10+11 #-}

-- Case n ≡ 100 can be proved automatically
postulate f₉₁-100 : f₉₁ 100' ≡ 91'
{-# ATP prove f₉₁-100 100+11>100 100+11∸10>100 101≡100+11∸10 91≡100+11∸10∸10 #-}

postulate  f₉₁x+11<f₉₁x+11 : ∀ n →
                             n ≯ 100' →
                             f₉₁ (n + 11') < f₉₁ (f₉₁ (n + 11')) + 11' →
                             f₉₁ (n + 11') < f₉₁ n + 11'
{-# ATP prove f₉₁x+11<f₉₁x+11 #-}

postulate f₉₁-x≯100-helper : ∀ m n →
                             m ≯ 100' →
                             f₉₁ (m + 11') ≡ n →
                             f₉₁ n ≡ 91' →
                             f₉₁ m ≡ 91'
{-# ATP prove f₉₁-x≯100-helper #-}

postulate
  f₉₁-110 : f₉₁ (99' + 11') ≡ 100'
  f₉₁-109 : f₉₁ (98' + 11') ≡ 99'
  f₉₁-108 : f₉₁ (97' + 11') ≡ 98'
  f₉₁-107 : f₉₁ (96' + 11') ≡ 97'
  f₉₁-106 : f₉₁ (95' + 11') ≡ 96'
  f₉₁-105 : f₉₁ (94' + 11') ≡ 95'
  f₉₁-104 : f₉₁ (93' + 11') ≡ 94'
  f₉₁-103 : f₉₁ (92' + 11') ≡ 93'
  f₉₁-102 : f₉₁ (91' + 11') ≡ 92'
  f₉₁-101 : f₉₁ (90' + 11') ≡ 91'
{-# ATP prove f₉₁-110 99+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-109 98+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-108 97+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-107 96+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-106 95+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-105 94+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-104 93+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-103 92+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-102 91+11>100 x+11∸10≡Sx #-}
{-# ATP prove f₉₁-101 90+11>100 x+11∸10≡Sx #-}

postulate
  f₉₁-99 : f₉₁ 99' ≡ 91'
  f₉₁-98 : f₉₁ 98' ≡ 91'
  f₉₁-97 : f₉₁ 97' ≡ 91'
  f₉₁-96 : f₉₁ 96' ≡ 91'
  f₉₁-95 : f₉₁ 95' ≡ 91'
  f₉₁-94 : f₉₁ 94' ≡ 91'
  f₉₁-93 : f₉₁ 93' ≡ 91'
  f₉₁-92 : f₉₁ 92' ≡ 91'
  f₉₁-91 : f₉₁ 91' ≡ 91'
  f₉₁-90 : f₉₁ 90' ≡ 91'
{-# ATP prove f₉₁-99 f₉₁-x≯100-helper f₉₁-110 f₉₁-100 #-}
{-# ATP prove f₉₁-98 f₉₁-x≯100-helper f₉₁-109 f₉₁-99 #-}
{-# ATP prove f₉₁-97 f₉₁-x≯100-helper f₉₁-108 f₉₁-98 #-}
{-# ATP prove f₉₁-96 f₉₁-x≯100-helper f₉₁-107 f₉₁-97 #-}
{-# ATP prove f₉₁-95 f₉₁-x≯100-helper f₉₁-106 f₉₁-96 #-}
{-# ATP prove f₉₁-94 f₉₁-x≯100-helper f₉₁-105 f₉₁-95 #-}
{-# ATP prove f₉₁-93 f₉₁-x≯100-helper f₉₁-104 f₉₁-94 #-}
{-# ATP prove f₉₁-92 f₉₁-x≯100-helper f₉₁-103 f₉₁-93 #-}
{-# ATP prove f₉₁-91 f₉₁-x≯100-helper f₉₁-102 f₉₁-92 #-}
{-# ATP prove f₉₁-90 f₉₁-x≯100-helper f₉₁-101 f₉₁-91 #-}

f₉₁-x≡y : ∀ {m n o} → f₉₁ m ≡ n → o ≡ m → f₉₁ o ≡ n
f₉₁-x≡y h refl = h


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

-- A Logical Relation for Dependent Type Theory Formalized in Agda

module Logrel-MLTT where

-- README
import README

-- Minimal library
import Tools.Empty
import Tools.Unit
import Tools.Nat
import Tools.Sum
import Tools.Product
import Tools.Function
import Tools.Nullary
import Tools.List
import Tools.PropositionalEquality
import Tools.Fin

-- Grammar of the language
import Definition.Untyped
import Definition.Untyped.Properties

-- Typing and conversion rules of language
import Definition.Typed
import Definition.Typed.Properties
import Definition.Typed.Weakening
import Definition.Typed.Reduction
import Definition.Typed.RedSteps
import Definition.Typed.EqualityRelation
import Definition.Typed.EqRelInstance

-- Logical relation
import Definition.LogicalRelation
import Definition.LogicalRelation.ShapeView
import Definition.LogicalRelation.Irrelevance
import Definition.LogicalRelation.Weakening
import Definition.LogicalRelation.Properties
import Definition.LogicalRelation.Application

import Definition.LogicalRelation.Substitution
import Definition.LogicalRelation.Substitution.Properties
import Definition.LogicalRelation.Substitution.Irrelevance
import Definition.LogicalRelation.Substitution.Conversion
import Definition.LogicalRelation.Substitution.Reduction
import Definition.LogicalRelation.Substitution.Reflexivity
import Definition.LogicalRelation.Substitution.Weakening
import Definition.LogicalRelation.Substitution.Reducibility
import Definition.LogicalRelation.Substitution.Escape
import Definition.LogicalRelation.Substitution.MaybeEmbed
import Definition.LogicalRelation.Substitution.Introductions

import Definition.LogicalRelation.Fundamental
import Definition.LogicalRelation.Fundamental.Reducibility

-- Consequences of the logical relation for typing and conversion
import Definition.Typed.Consequences.Canonicity
import Definition.Typed.Consequences.Injectivity
import Definition.Typed.Consequences.Syntactic
import Definition.Typed.Consequences.Inversion
import Definition.Typed.Consequences.Inequality
import Definition.Typed.Consequences.Substitution
import Definition.Typed.Consequences.Equality
import Definition.Typed.Consequences.InverseUniv
import Definition.Typed.Consequences.Reduction
import Definition.Typed.Consequences.NeTypeEq
import Definition.Typed.Consequences.SucCong
import Definition.Typed.Consequences.Consistency

-- Algorithmic equality with lemmas that depend on typing consequences
import Definition.Conversion
import Definition.Conversion.Conversion
import Definition.Conversion.Lift
import Definition.Conversion.Reduction
import Definition.Conversion.Soundness
import Definition.Conversion.Stability
import Definition.Conversion.Symmetry
import Definition.Conversion.Transitivity
import Definition.Conversion.Universe
import Definition.Conversion.Weakening
import Definition.Conversion.Whnf
import Definition.Conversion.Decidable
import Definition.Conversion.EqRelInstance
import Definition.Conversion.FullReduction

-- Consequences of the logical relation for algorithmic equality
import Definition.Conversion.Consequences.Completeness

-- Decidability of conversion
import Definition.Typed.Decidable


{- COMPLEXITY LANGUAGE -}

open import Preliminaries
open import Preorder-Max

module Complexity where

  data CTp : Set where
    unit : CTp
    nat : CTp
    _->c_ : CTp → CTp → CTp
    _×c_ : CTp → CTp → CTp
    list : CTp → CTp
    bool : CTp
    C : CTp

  -- represent a context as a list of types
  Ctx = List CTp

  -- de Bruijn indices (for free variables)
  data _∈_ : CTp → Ctx → Set where
    i0 : ∀ {Γ τ}
       → τ ∈ (τ :: Γ)
    iS : ∀ {Γ τ τ1}
       → τ ∈ Γ
       → τ ∈ (τ1 :: Γ)

  data _|-_ : Ctx → CTp → Set where
    unit : ∀ {Γ}
         → Γ |- unit
    0C : ∀ {Γ}
       → Γ |- C
    1C : ∀ {Γ}
       → Γ |- C
    plusC : ∀ {Γ}
         → Γ |- C
         → Γ |- C
         → Γ |- C
    var : ∀ {Γ τ}
        → τ ∈ Γ
        → Γ |- τ
    z : ∀ {Γ}
      → Γ |- nat
    suc : ∀ {Γ}
        → (e : Γ |- nat)
        → Γ |- nat
    rec : ∀ {Γ τ}
        → Γ |- nat
        → Γ |- τ
        → (nat :: (τ :: Γ)) |- τ
        → Γ |- τ
    lam : ∀ {Γ τ ρ}
        → (ρ :: Γ) |- τ
        → Γ |- (ρ ->c τ)
    app : ∀ {Γ τ1 τ2}
        → Γ |- (τ2 ->c τ1)
        → Γ |- τ2
        → Γ |- τ1
    prod : ∀ {Γ τ1 τ2}
         → Γ |- τ1
         → Γ |- τ2
         → Γ |- (τ1 ×c τ2)
    l-proj : ∀ {Γ τ1 τ2}
           → Γ |- (τ1 ×c τ2)
           → Γ |- τ1
    r-proj : ∀ {Γ τ1 τ2}
           → Γ |- (τ1 ×c τ2)
           → Γ |- τ2
    nil : ∀ {Γ τ} → Γ |- list τ
    _::c_ : ∀ {Γ τ} → Γ |- τ → Γ |- list τ → Γ |- list τ
    listrec : ∀ {Γ τ τ'} → Γ |- list τ → Γ |- τ' → (τ :: (list τ :: (τ' :: Γ))) |- τ' → Γ |- τ'
    true : ∀ {Γ} → Γ |- bool
    false : ∀ {Γ} → Γ |- bool

  _+C_ : ∀ {Γ τ} → Γ |- C  → Γ |- (C ×c τ)→ Γ |- (C ×c τ)
  c +C e = prod (plusC c (l-proj e)) (r-proj e)

------weakening and substitution lemmas

      -- renaming = variable for variable substitution
      --functional view:
      --avoids induction,
      --some associativity/unit properties for free

  -- read: you can rename Γ' as Γ
  rctx : Ctx → Ctx → Set
  rctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → τ ∈ Γ

  rename-var : ∀ {Γ Γ' τ} → rctx Γ Γ' → τ ∈ Γ' → τ ∈ Γ
  rename-var ρ a = ρ a

  idr : ∀ {Γ} → rctx Γ Γ
  idr x = x

  -- weakening with renaming
  p∙ : ∀ {Γ Γ' τ} → rctx Γ Γ' → rctx (τ :: Γ) Γ'
  p∙ ρ = λ x → iS (ρ x)

  p : ∀ {Γ τ} → rctx (τ :: Γ) Γ
  p = p∙ idr

  _∙rr_ : ∀ {A B C} → rctx A B → rctx B C → rctx A C
  ρ1 ∙rr ρ2 = ρ1 o ρ2

  -- free stuff
  rename-var-ident : ∀ {Γ τ} → (x : τ ∈ Γ) → rename-var idr x == x
  rename-var-ident _ = Refl

  rename-var-∙ : ∀ {A B C τ} → (r1 : rctx A B) (r2 : rctx B C) (x : τ ∈ C)
              → rename-var r1 (rename-var r2 x) == rename-var (r1 ∙rr r2) x
  rename-var-∙ _ _ _ = Refl

  ∙rr-assoc : ∀ {A B C D} → (r1 : rctx A B) (r2 : rctx B C) (r3 : rctx C D) → _==_ {_} {rctx A D} (r1 ∙rr (r2 ∙rr r3)) ((r1 ∙rr r2) ∙rr r3)
  ∙rr-assoc r1 r2 r3 = Refl

  r-extend : ∀ {Γ Γ' τ} → rctx Γ Γ' → rctx (τ :: Γ) (τ :: Γ')
  r-extend ρ i0 = i0
  r-extend ρ (iS x) = iS (ρ x)

  ren : ∀ {Γ Γ' τ} → Γ' |- τ → rctx Γ Γ' → Γ |- τ
  ren unit ρ = unit
  ren 0C ρ = 0C
  ren 1C ρ = 1C
  ren (plusC e e₁) ρ = plusC (ren e ρ) (ren e₁ ρ)
  ren (var x) ρ = var (ρ x)
  ren z ρ = z
  ren (suc e) ρ = suc (ren e ρ)
  ren (rec e e₁ e₂) ρ = rec (ren e ρ) (ren e₁ ρ) (ren e₂ (r-extend (r-extend ρ)))
  ren (lam e) ρ = lam (ren e (r-extend ρ))
  ren (app e e₁) ρ = app (ren e ρ) (ren e₁ ρ)
  ren (prod e1 e2) ρ = prod (ren e1 ρ) (ren e2 ρ)
  ren (l-proj e) ρ = l-proj (ren e ρ)
  ren (r-proj e) ρ = r-proj (ren e ρ)
  ren nil ρ = nil
  ren (x ::c xs) ρ = ren x ρ ::c ren xs ρ
  ren true ρ = true
  ren false ρ = false
  ren (listrec e e₁ e₂) ρ = listrec (ren e ρ) (ren e₁ ρ) (ren e₂ (r-extend (r-extend (r-extend ρ))))

  extend-ren-comp-lemma : ∀ {Γ Γ' Γ'' τ τ'} → (x : τ ∈ τ' :: Γ'') (ρ1 : rctx Γ Γ') (ρ2 : rctx Γ' Γ'')
                        → Id {_} {_} ((r-extend ρ1 ∙rr r-extend ρ2) x) (r-extend (ρ1 ∙rr ρ2) x)
  extend-ren-comp-lemma i0 ρ1 ρ2 = Refl
  extend-ren-comp-lemma (iS x) ρ1 ρ2 = Refl

  extend-ren-comp : ∀ {Γ Γ' Γ'' τ} → (ρ1 : rctx Γ Γ') → (ρ2 : rctx Γ' Γ'')
                  → Id {_} {rctx (τ :: Γ) (τ :: Γ'')} (r-extend ρ1 ∙rr r-extend ρ2) (r-extend (ρ1 ∙rr ρ2))
  extend-ren-comp ρ1 ρ2 = λ=i (λ τ → λ= (λ x → extend-ren-comp-lemma x ρ1 ρ2))

  ren-comp : ∀ {Γ Γ' Γ'' τ} → (ρ1 : rctx Γ Γ') → (ρ2 : rctx Γ' Γ'') → (e : Γ'' |- τ)
           → (ren (ren e ρ2) ρ1) == (ren e (ρ1 ∙rr ρ2))
  ren-comp ρ1 ρ2 unit = Refl
  ren-comp ρ1 ρ2 0C = Refl
  ren-comp ρ1 ρ2 1C = Refl
  ren-comp ρ1 ρ2 (plusC e e₁) = ap2 plusC (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
  ren-comp ρ1 ρ2 (var x) = ap var (rename-var-∙ ρ1 ρ2 x)
  ren-comp ρ1 ρ2 z = Refl
  ren-comp ρ1 ρ2 (suc e) = ap suc (ren-comp ρ1 ρ2 e)
  ren-comp ρ1 ρ2 (rec e e₁ e₂) = ap3 rec (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
                                     (ap (ren e₂) (ap r-extend (extend-ren-comp ρ1 ρ2) ∘
                                       extend-ren-comp (r-extend ρ1) (r-extend ρ2)) ∘
                                       ren-comp (r-extend (r-extend ρ1)) (r-extend (r-extend ρ2)) e₂)
  ren-comp ρ1 ρ2 (lam e) = ap lam ((ap (ren e) (extend-ren-comp ρ1 ρ2)) ∘ ren-comp (r-extend ρ1) (r-extend ρ2) e)
  ren-comp ρ1 ρ2 (app e e₁) = ap2 app (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
  ren-comp ρ1 ρ2 (prod e e₁) = ap2 prod (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
  ren-comp ρ1 ρ2 (l-proj e) = ap l-proj (ren-comp ρ1 ρ2 e)
  ren-comp ρ1 ρ2 (r-proj e) = ap r-proj (ren-comp ρ1 ρ2 e)
  ren-comp ρ1 ρ2 nil = Refl
  ren-comp ρ1 ρ2 (e ::c e₁) = ap2 _::c_ (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
  ren-comp ρ1 ρ2 (listrec e e₁ e₂) = ap3 listrec (ren-comp ρ1 ρ2 e) (ren-comp ρ1 ρ2 e₁)
                                       (ap (ren e₂) (ap r-extend (ap r-extend (extend-ren-comp ρ1 ρ2)) ∘
                                       (ap r-extend (extend-ren-comp (r-extend ρ1) (r-extend ρ2)) ∘
                                       extend-ren-comp (r-extend (r-extend ρ1)) (r-extend (r-extend ρ2)))) ∘
                                       ren-comp (r-extend (r-extend (r-extend ρ1)))
                                                (r-extend (r-extend (r-extend ρ2))) e₂)
  ren-comp ρ1 ρ2 true = Refl
  ren-comp ρ1 ρ2 false = Refl

  -- weakening a context
  wkn : ∀ {Γ τ1 τ2} → Γ |- τ2 → (τ1 :: Γ) |- τ2
  wkn e = ren e iS

  sctx : Ctx → Ctx → Set
  sctx Γ Γ' = ∀ {τ} → τ ∈ Γ' → Γ |- τ

  --lem2 (addvar)
  s-extend : ∀ {Γ Γ' τ} → sctx Γ Γ' → sctx (τ :: Γ) (τ :: Γ')
  s-extend Θ i0 = var i0
  s-extend Θ (iS x) = wkn (Θ x)

  ids : ∀ {Γ} → sctx Γ Γ
  ids x = var x

    -- weakening with substitution
  q∙ : ∀ {Γ Γ' τ} → sctx Γ Γ' → sctx (τ :: Γ) Γ'
  q∙ Θ = λ x → wkn (Θ x)

  lem3' : ∀ {Γ Γ' τ} → sctx Γ Γ' → Γ |- τ → sctx Γ (τ :: Γ')
  lem3' Θ e i0 = e
  lem3' Θ e (iS i) = Θ i

    --lem3
  q : ∀ {Γ τ} → Γ |- τ → sctx Γ (τ :: Γ)
  q e = lem3' ids e

  -- subst-var
  svar : ∀ {Γ1 Γ2 τ} → sctx Γ1 Γ2 → τ ∈ Γ2 → Γ1 |- τ
  svar Θ i = q (Θ i) i0

  lem4' : ∀ {Γ Γ' τ1 τ2} → sctx Γ Γ' → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ'))
  lem4' Θ a b = lem3' (lem3' Θ b) a

  lem4 : ∀ {Γ τ1 τ2} → Γ |- τ1 → Γ |- τ2 → sctx Γ (τ1 :: (τ2 :: Γ))
  lem4 e1 e2 = lem4' ids e1 e2

  lem5' : ∀ {Γ Γ' τ1 τ2 τ3} → sctx Γ Γ' → Γ |- τ1 → Γ |- τ2 → Γ |- τ3 → sctx Γ (τ1 :: (τ2 :: (τ3 :: Γ')))
  lem5' Θ a b c = lem3' (lem3' (lem3' Θ c) b) a

  lem5 : ∀ {Γ τ1 τ2 τ3} → Γ |- τ1 → Γ |- τ2 → Γ |- τ3 → sctx Γ (τ1 :: (τ2 :: (τ3 :: Γ)))
  lem5 e1 e2 e3 = lem5' ids e1 e2 e3

  subst : ∀ {Γ Γ' τ} → Γ' |- τ → sctx Γ Γ' → Γ |- τ
  subst unit Θ = unit
  subst 0C Θ = 0C
  subst 1C Θ = 1C
  subst (plusC e e₁) Θ = plusC (subst e Θ) (subst e₁ Θ)
  subst (var x) Θ = Θ x
  subst z Θ = z
  subst (suc e) Θ = suc (subst e Θ)
  subst (rec e e₁ e₂) Θ = rec (subst e Θ) (subst e₁ Θ) (subst e₂ (s-extend (s-extend Θ)))
  subst (lam e) Θ = lam (subst e (s-extend Θ))
  subst (app e e₁) Θ = app (subst e Θ) (subst e₁ Θ)
  subst (prod e1 e2) Θ = prod (subst e1 Θ) (subst e2 Θ)
  subst (l-proj e) Θ = l-proj (subst e Θ)
  subst (r-proj e) Θ = r-proj (subst e Θ)
  subst nil Θ = nil
  subst (x ::c xs) Θ = subst x Θ ::c subst xs Θ
  subst true Θ = true
  subst false Θ = false
  subst (listrec e e₁ e₂) Θ = listrec (subst e Θ) (subst e₁ Θ) (subst e₂ (s-extend (s-extend (s-extend Θ))))

  subst1 : ∀ {Γ τ τ1} → Γ |- τ1 → (τ1 :: Γ) |- τ → Γ |- τ
  subst1 e e' = subst e' (q e)

  _rs_ : ∀ {A B C} → rctx A B → sctx B C → sctx A C
  _rs_ ρ Θ x = ren (subst (var x) Θ) ρ

  _ss_ : ∀ {A B C} → sctx A B → sctx B C → sctx A C
  _ss_ Θ1 Θ2 x = subst (subst (var x) Θ2) Θ1

  _sr_ : ∀ {A B C} → sctx A B → rctx B C → sctx A C
  _sr_ Θ ρ x = subst (ren (var x) ρ) Θ

  --free stuff
  svar-rs : ∀ {A B C τ} (ρ : rctx A B) (Θ : sctx B C) (x : τ ∈ C)
          → svar (ρ rs Θ) x == ren (svar Θ x) ρ
  svar-rs = λ ρ Θ x → Refl

  svar-ss : ∀ {A B C τ} (Θ1 : sctx A B) (Θ2 : sctx B C) (x : τ ∈ C)
          → svar (Θ1 ss Θ2) x == subst (svar Θ2 x) Θ1
  svar-ss = λ Θ1 Θ2 x → Refl

  svar-sr : ∀ {A B C τ} (Θ : sctx A B) (ρ : rctx B C) (x : τ ∈ C)
          → svar Θ (rename-var ρ x) == svar (Θ sr ρ) x
  svar-sr = λ Θ ρ x → Refl

  svar-id : ∀ {Γ τ} → (x : τ ∈ Γ) → var x == svar ids x
  svar-id = λ x → Refl

  rsr-assoc : ∀ {A B C D} → (ρ1 : rctx A B) (Θ : sctx B C) (ρ2 : rctx C D)
            → Id {_} {sctx A D} ((ρ1 rs Θ) sr ρ2) (ρ1 rs (Θ sr ρ2))
  rsr-assoc = λ ρ1 Θ ρ2 → Refl

  extend-id-once-lemma : ∀ {Γ τ τ'} → (x : τ ∈ τ' :: Γ) → _==_ {_} {τ' :: Γ |- τ}
                       (ids {τ' :: Γ} {τ} x) (s-extend {Γ} {Γ} {τ'} (ids {Γ}) {τ} x)
  extend-id-once-lemma i0 = Refl
  extend-id-once-lemma (iS x) = Refl

  extend-id-once : ∀ {Γ τ} → Id {_} {sctx (τ :: Γ) (τ :: Γ)} (ids {τ :: Γ}) (s-extend ids)
  extend-id-once = λ=i (λ τ → λ= (λ x → extend-id-once-lemma x))

  extend-id-twice : ∀ {Γ τ1 τ2} → Id {_} {sctx (τ1 :: τ2 :: Γ) (τ1 :: τ2 :: Γ)} (ids {τ1 :: τ2 :: Γ}) (s-extend (s-extend ids))
  extend-id-twice = ap s-extend extend-id-once ∘ extend-id-once

  subst-id : ∀ {Γ τ} (e : Γ |- τ) → e == subst e ids
  subst-id unit = Refl
  subst-id 0C = Refl
  subst-id 1C = Refl
  subst-id (plusC e e₁) = ap2 plusC (subst-id e) (subst-id e₁)
  subst-id (var x) = svar-id x
  subst-id z = Refl
  subst-id (suc e) = ap suc (subst-id e)
  subst-id (rec e e₁ e₂) = ap3 rec (subst-id e) (subst-id e₁) (ap (subst e₂) extend-id-twice ∘ subst-id e₂)
  subst-id (lam e) = ap lam (ap (subst e) extend-id-once ∘ subst-id e)
  subst-id (app e e₁) = ap2 app (subst-id e) (subst-id e₁)
  subst-id (prod e e₁) = ap2 prod (subst-id e) (subst-id e₁)
  subst-id (l-proj e) = ap l-proj (subst-id e)
  subst-id (r-proj e) = ap r-proj (subst-id e)
  subst-id nil = Refl
  subst-id (e ::c e₁) = ap2 _::c_ (subst-id e) (subst-id e₁)
  subst-id true = Refl
  subst-id false = Refl
  subst-id (listrec e e₁ e₂) = ap3 listrec (subst-id e) (subst-id e₁) (ap (subst e₂) (ap s-extend (ap s-extend extend-id-once) ∘ extend-id-twice) ∘ subst-id e₂)

  extend-rs-once-lemma : ∀ {A B C τ τ'} → (x : τ ∈ τ' :: B) (ρ : rctx C A) (Θ : sctx A B) → _==_ {_} {τ' :: C |- τ}
                       (_rs_ {τ' :: C} {τ' :: A} {τ' :: B} (r-extend {C} {A} {τ'} ρ)
                         (s-extend {A} {B} {τ'} Θ) {τ} x)
                         (s-extend {C} {B} {τ'} (_rs_ {C} {A} {B} ρ Θ) {τ} x)
  extend-rs-once-lemma i0 ρ Θ = Refl
  extend-rs-once-lemma (iS x) ρ Θ = ! (ren-comp iS ρ (Θ x)) ∘ ren-comp (r-extend ρ) iS (Θ x)

  extend-rs-once : ∀ {A B C τ} → (ρ : rctx C A) (Θ : sctx A B)
                 → Id {_} {sctx (τ :: C) (τ :: B)} (r-extend ρ rs s-extend Θ) (s-extend (ρ rs Θ))
  extend-rs-once ρ Θ = λ=i (λ τ → λ= (λ x → extend-rs-once-lemma x ρ Θ))

  extend-rs-twice : ∀ {A B C τ τ'} → (ρ : rctx C A) (Θ : sctx A B)
                  → Id {_} {sctx (τ :: τ' :: C) (τ :: τ' :: B)} ((r-extend (r-extend ρ)) rs (s-extend (s-extend Θ))) ((s-extend (s-extend (ρ rs Θ))))
  extend-rs-twice ρ Θ = ap s-extend (extend-rs-once ρ Θ) ∘ extend-rs-once (r-extend ρ) (s-extend Θ)

  subst-rs : ∀ {A B C τ} → (ρ : rctx C A) (Θ : sctx A B) (e : B |- τ)
           → ren (subst e Θ) ρ == subst e (ρ rs Θ)
  subst-rs ρ Θ unit = Refl
  subst-rs ρ Θ 0C = Refl
  subst-rs ρ Θ 1C = Refl
  subst-rs ρ Θ (plusC e e₁) = ap2 plusC (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
  subst-rs ρ Θ (var x) = svar-rs ρ Θ x
  subst-rs ρ Θ z = Refl
  subst-rs ρ Θ (suc e) = ap suc (subst-rs ρ Θ e)
  subst-rs ρ Θ (rec e e₁ e₂) = ap3 rec (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
                                 (ap (subst e₂) (extend-rs-twice ρ Θ) ∘
                                 subst-rs (r-extend (r-extend ρ)) (s-extend (s-extend Θ)) e₂)
  subst-rs ρ Θ (lam e) = ap lam (ap (subst e) (extend-rs-once ρ Θ) ∘ subst-rs (r-extend ρ) (s-extend Θ) e)
  subst-rs ρ Θ (app e e₁) = ap2 app (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
  subst-rs ρ Θ (prod e e₁) = ap2 prod (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
  subst-rs ρ Θ (l-proj e) = ap l-proj (subst-rs ρ Θ e)
  subst-rs ρ Θ (r-proj e) = ap r-proj (subst-rs ρ Θ e)
  subst-rs ρ Θ nil = Refl
  subst-rs ρ Θ (e ::c e₁) = ap2 _::c_ (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
  subst-rs ρ Θ true = Refl
  subst-rs ρ Θ false = Refl
  subst-rs ρ Θ (listrec e e₁ e₂) = ap3 listrec (subst-rs ρ Θ e) (subst-rs ρ Θ e₁)
                                       (ap (subst e₂) (ap s-extend (ap s-extend (extend-rs-once ρ Θ)) ∘
                                       extend-rs-twice (r-extend ρ) (s-extend Θ)) ∘
                                       subst-rs (r-extend (r-extend (r-extend ρ))) (s-extend (s-extend (s-extend Θ))) e₂)

  rs-comp : ∀ {Γ Γ' Γ'' τ} → (ρ : rctx Γ Γ') → (Θ : sctx Γ' Γ'') → (e : Γ'' |- τ)
          → (ren (subst e Θ) ρ) == subst e (ρ rs Θ)
  rs-comp ρ Θ unit = Refl
  rs-comp ρ Θ 0C = Refl
  rs-comp ρ Θ 1C = Refl
  rs-comp ρ Θ (plusC e e₁) = ap2 plusC (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
  rs-comp ρ Θ (var x) = svar-rs ρ Θ x
  rs-comp ρ Θ z = Refl
  rs-comp ρ Θ (suc e) = ap suc (rs-comp ρ Θ e)
  rs-comp ρ Θ (rec e e₁ e₂) = ap3 rec (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
                              (ap (subst e₂) (extend-rs-twice ρ Θ) ∘ rs-comp (r-extend (r-extend ρ)) (s-extend (s-extend Θ)) e₂)
  rs-comp ρ Θ (lam e) = ap lam (ap (subst e) (extend-rs-once ρ Θ) ∘ rs-comp (r-extend ρ) (s-extend Θ) e)
  rs-comp ρ Θ (app e e₁) = ap2 app (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
  rs-comp ρ Θ (prod e e₁) = ap2 prod (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
  rs-comp ρ Θ (l-proj e) = ap l-proj (rs-comp ρ Θ e)
  rs-comp ρ Θ (r-proj e) = ap r-proj (rs-comp ρ Θ e)
  rs-comp ρ Θ nil = Refl
  rs-comp ρ Θ (e ::c e₁) = ap2 _::c_ (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
  rs-comp ρ Θ (listrec e e₁ e₂) = ap3 listrec (rs-comp ρ Θ e) (rs-comp ρ Θ e₁)
                                    (ap (subst e₂) (ap s-extend (ap s-extend (extend-rs-once ρ Θ)) ∘
                                    extend-rs-twice (r-extend ρ) (s-extend Θ)) ∘
                                    rs-comp (r-extend (r-extend (r-extend ρ)))
                                    (s-extend (s-extend (s-extend Θ))) e₂)
  rs-comp ρ Θ true = Refl
  rs-comp ρ Θ false = Refl

  extend-sr-once-lemma : ∀ {A B C τ τ'} → (Θ : sctx A B) (ρ : rctx B C) (x : τ ∈ τ' :: C)
                       → _==_ {_} {τ' :: A |- τ} (s-extend (_sr_ Θ ρ) x) (_sr_ (s-extend Θ) (r-extend ρ) x)
  extend-sr-once-lemma Θ ρ i0 = Refl
  extend-sr-once-lemma Θ ρ (iS x) = Refl

  extend-sr-once : ∀ {A B C τ} → (Θ : sctx A B) (ρ : rctx B C)
                 → Id {_} {sctx (τ :: A) (τ :: C)} (s-extend Θ sr r-extend ρ) (s-extend (Θ sr ρ))
  extend-sr-once Θ ρ = λ=i (λ τ → λ= (λ x → ! (extend-sr-once-lemma Θ ρ x)))

  extend-sr-twice : ∀ {A B C τ τ'} → (Θ : sctx A B) (ρ : rctx B C)
                 → Id {_} {sctx (τ' :: τ :: A) (τ' :: τ :: C)}
                   (s-extend (s-extend Θ) sr r-extend (r-extend ρ)) (s-extend (s-extend (Θ sr ρ)))
  extend-sr-twice Θ ρ = ap s-extend (extend-sr-once Θ ρ) ∘ extend-sr-once (s-extend Θ) (r-extend ρ)

  sr-comp : ∀ {Γ Γ' Γ'' τ} → (Θ : sctx Γ Γ') → (ρ : rctx Γ' Γ'') → (e : Γ'' |- τ)
          → (subst (ren e ρ) Θ) == subst e (Θ sr ρ)
  sr-comp Θ ρ unit = Refl
  sr-comp Θ ρ 0C = Refl
  sr-comp Θ ρ 1C = Refl
  sr-comp Θ ρ (plusC e e₁) = ap2 plusC (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
  sr-comp Θ ρ (var x) = svar-sr Θ ρ x
  sr-comp Θ ρ z = Refl
  sr-comp Θ ρ (suc e) = ap suc (sr-comp Θ ρ e)
  sr-comp Θ ρ (rec e e₁ e₂) = ap3 rec (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
                                      (ap (subst e₂) (ap s-extend (extend-sr-once Θ ρ) ∘
                                      extend-sr-once (s-extend Θ) (r-extend ρ)) ∘
                                      sr-comp (s-extend (s-extend Θ)) (r-extend (r-extend ρ)) e₂)
  sr-comp Θ ρ (lam e) = ap lam (ap (subst e) (extend-sr-once Θ ρ) ∘ sr-comp (s-extend Θ) (r-extend ρ) e)
  sr-comp Θ ρ (app e e₁) = ap2 app (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
  sr-comp Θ ρ (prod e e₁) = ap2 prod (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
  sr-comp Θ ρ (l-proj e) = ap l-proj (sr-comp Θ ρ e)
  sr-comp Θ ρ (r-proj e) = ap r-proj (sr-comp Θ ρ e)
  sr-comp Θ ρ nil = Refl
  sr-comp Θ ρ (e ::c e₁) = ap2 _::c_ (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
  sr-comp Θ ρ (listrec e e₁ e₂) = ap3 listrec (sr-comp Θ ρ e) (sr-comp Θ ρ e₁)
                                              (ap (subst e₂) (ap s-extend (ap s-extend (extend-sr-once Θ ρ)) ∘
                                              extend-sr-twice (s-extend Θ) (r-extend ρ)) ∘
                                                 sr-comp (s-extend (s-extend (s-extend Θ)))
                                                 (r-extend (r-extend (r-extend ρ))) e₂)

  sr-comp Θ ρ true = Refl
  sr-comp Θ ρ false = Refl

  extend-ss-once-lemma : ∀ {A B C τ τ'} → (Θ1 : sctx A B) (Θ2 : sctx B C) (x : τ ∈ τ' :: C)
                       → _==_ {_} {τ' :: A |- τ} (s-extend (_ss_ Θ1 Θ2) x) (_ss_ (s-extend Θ1) (s-extend Θ2) x)
  extend-ss-once-lemma Θ1 Θ2 i0 = Refl
  extend-ss-once-lemma Θ1 Θ2 (iS x) = ! (sr-comp (s-extend Θ1) iS (Θ2 x)) ∘ rs-comp iS Θ1 (Θ2 x)

  extend-ss-once : ∀ {A B C τ} → (Θ1 : sctx A B) (Θ2 : sctx B C)
              → _==_ {_} {sctx (τ :: A) (τ :: C)} (s-extend (Θ1 ss Θ2))
              ((s-extend Θ1) ss
              (s-extend Θ2))
  extend-ss-once Θ1 Θ2 = λ=i (λ τ → λ= (λ x → extend-ss-once-lemma Θ1 Θ2 x))

  subst-ss : ∀ {A B C τ} → (Θ1 : sctx A B) (Θ2 : sctx B C) (e : C |- τ)
           → subst e (Θ1 ss Θ2) == subst (subst e Θ2) Θ1
  subst-ss Θ1 Θ2 unit = Refl
  subst-ss Θ1 Θ2 0C = Refl
  subst-ss Θ1 Θ2 1C = Refl
  subst-ss Θ1 Θ2 (plusC e e₁) = ap2 plusC (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
  subst-ss Θ1 Θ2 (var x) = svar-ss Θ1 Θ2 x
  subst-ss Θ1 Θ2 z = Refl
  subst-ss Θ1 Θ2 (suc e) = ap suc (subst-ss Θ1 Θ2 e)
  subst-ss Θ1 Θ2 (rec e e₁ e₂) = ap3 rec (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
                                 (subst-ss (s-extend (s-extend Θ1)) (s-extend (s-extend Θ2)) e₂ ∘
                                 ap (subst e₂) (extend-ss-once (s-extend Θ1) (s-extend Θ2) ∘
                                 ap s-extend (extend-ss-once Θ1 Θ2)))
  subst-ss Θ1 Θ2 (lam e) = ap lam (subst-ss (s-extend Θ1) (s-extend Θ2) e ∘ ap (subst e) (extend-ss-once Θ1 Θ2))
  subst-ss Θ1 Θ2 (app e e₁) = ap2 app (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
  subst-ss Θ1 Θ2 (prod e e₁) = ap2 prod (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
  subst-ss Θ1 Θ2 (l-proj e) = ap l-proj (subst-ss Θ1 Θ2 e)
  subst-ss Θ1 Θ2 (r-proj e) = ap r-proj (subst-ss Θ1 Θ2 e)
  subst-ss Θ1 Θ2 nil = Refl
  subst-ss Θ1 Θ2 (e ::c e₁) = ap2 _::c_ (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
  subst-ss Θ1 Θ2 true = Refl
  subst-ss Θ1 Θ2 false = Refl
  subst-ss Θ1 Θ2 (listrec e e₁ e₂) = ap3 listrec (subst-ss Θ1 Θ2 e) (subst-ss Θ1 Θ2 e₁)
                                     (subst-ss (s-extend (s-extend (s-extend Θ1))) (s-extend (s-extend (s-extend Θ2))) e₂ ∘
                                     ap (subst e₂) (extend-ss-once (s-extend (s-extend Θ1)) (s-extend (s-extend Θ2)) ∘
                                     ap s-extend (extend-ss-once (s-extend Θ1) (s-extend Θ2) ∘
                                     ap s-extend (extend-ss-once Θ1 Θ2))))

  throw : ∀ {Γ Γ' τ} → sctx Γ (τ :: Γ') → sctx Γ Γ'
  throw Θ x = Θ (iS x)

  fuse1 : ∀ {Γ Γ' τ τ'} (v : Γ |- τ') (Θ : sctx Γ Γ') (x : τ ∈ Γ') → (q v ss q∙ Θ) x == Θ x
  fuse1 v Θ x = subst (ren (Θ x) iS) (q v) =⟨ sr-comp (q v) iS (Θ x) ⟩
                subst (Θ x) (q v sr iS) =⟨ Refl ⟩
                subst (Θ x) ids =⟨ ! (subst-id (Θ x)) ⟩
                (Θ x ∎)

  subst-compose-lemma-lemma : ∀ {Γ Γ' τ τ'} (v : Γ |- τ') (Θ : sctx Γ Γ') (x : τ ∈ τ' :: Γ')
                            → _==_ {_} {Γ |- τ} (_ss_ (q v) (s-extend Θ) x) (lem3' Θ v x)
  subst-compose-lemma-lemma v Θ i0 = Refl
  subst-compose-lemma-lemma v Θ (iS x) = fuse1 v Θ x

  subst-compose-lemma : ∀ {Γ Γ' τ} (v : Γ |- τ) (Θ : sctx Γ Γ')
                      → _==_ {_} {sctx Γ (τ :: Γ')} ((q v) ss (s-extend Θ)) (lem3' Θ v)
  subst-compose-lemma v Θ = λ=i (λ τ → λ= (λ x → subst-compose-lemma-lemma v Θ x))

  subst-compose : ∀ {Γ Γ' τ τ1} (Θ : sctx Γ Γ') (v : Γ |- τ) (e : (τ :: Γ' |- τ1) )
                → subst (subst e (s-extend Θ)) (q v) == subst e (lem3' Θ v)
  subst-compose Θ v e = ap (subst e) (subst-compose-lemma v Θ) ∘ (! (subst-ss (q v) (s-extend Θ) e))

  fuse2 : ∀ {Γ Γ' τ τ1 τ2} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (Θ : sctx Γ Γ') (x : τ ∈ τ2 :: Γ')
        → (lem4 v1 v2 ss throw (s-extend (s-extend Θ))) x == (lem3' Θ v2) x
  fuse2 v1 v2 Θ x = subst (ren (s-extend Θ x) iS) (lem4 v1 v2) =⟨ sr-comp (lem4 v1 v2) iS (s-extend Θ x) ⟩
                    subst (s-extend Θ x) (lem4 v1 v2 sr iS) =⟨ Refl ⟩
                    subst (s-extend Θ x) (lem3' ids v2) =⟨ subst-compose-lemma-lemma v2 Θ x ⟩
                    (lem3' Θ v2 x ∎)

  subst-compose2-lemma-lemma : ∀ {Γ Γ' τ τ1 τ2 τ'} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (e1 : τ1 :: τ2 :: Γ' |- τ) (Θ : sctx Γ Γ') (x : τ' ∈ τ1 :: τ2 :: Γ')
                             → _==_ {_} {_} ((lem4 v1 v2 ss s-extend (s-extend Θ)) x) (lem4' Θ v1 v2 x)
  subst-compose2-lemma-lemma v1 v2 e1 Θ i0 = Refl
  subst-compose2-lemma-lemma v1 v2 e1 Θ (iS x) = fuse2 v1 v2 Θ x

  subst-compose2-lemma : ∀ {Γ Γ' τ τ1 τ2} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (e1 : τ1 :: τ2 :: Γ' |- τ) (Θ : sctx Γ Γ')
                       → _==_ {_} {sctx Γ (τ1 :: τ2 :: Γ')} (lem4 v1 v2 ss s-extend (s-extend Θ)) (lem4' Θ v1 v2)
  subst-compose2-lemma v1 v2 e1 Θ = λ=i (λ τ → λ= (λ x → subst-compose2-lemma-lemma v1 v2 e1 Θ x))

  fuse3 : ∀ {Γ Γ' τ1 τ2 τ'} (Θ : sctx Γ Γ') (v1 : Γ' |- τ1) (v2 : Γ' |- τ2) (x : τ' ∈ τ2 :: Γ')
          → subst (lem3' ids v2 x) Θ == lem3' Θ (subst v2 Θ) x
  fuse3 Θ v1 v2 i0 = Refl
  fuse3 Θ v1 v2 (iS x) = Refl

  subst-compose3-lemma-lemma : ∀ {Γ Γ' τ τ1 τ2 τ'} (Θ : sctx Γ Γ') (e1 : (τ1 :: (τ2 :: Γ')) |- τ) (v1 : Γ' |- τ1) (v2 : Γ' |- τ2) (x : τ' ∈ τ1 :: τ2 :: Γ')
                             → _==_ {_} {_} ((Θ ss lem4 v1 v2) x) (lem4' Θ (subst v1 Θ) (subst v2 Θ) x)
  subst-compose3-lemma-lemma Θ e1 v1 v2 i0 = Refl
  subst-compose3-lemma-lemma Θ e1 v1 v2 (iS x) = fuse3 Θ v1 v2 x

  subst-compose3-lemma : ∀ {Γ Γ' τ τ1 τ2} (Θ : sctx Γ Γ') (e1 : (τ1 :: (τ2 :: Γ')) |- τ) (v1 : Γ' |- τ1) (v2 : Γ' |- τ2)
                      → _==_ {_} {sctx Γ (τ1 :: τ2 :: Γ')} (Θ ss lem4 v1 v2) (lem4' Θ (subst v1 Θ) (subst v2 Θ))
  subst-compose3-lemma Θ e1 v1 v2 = λ=i (λ τ → λ= (λ x → subst-compose3-lemma-lemma Θ e1 v1 v2 x))

  subst-compose2 : ∀ {Γ Γ' τ τ1 τ2} (Θ : sctx Γ Γ') (e1 : (τ1 :: (τ2 :: Γ')) |- τ) (v1 : Γ |- τ1) (v2 : Γ |- τ2)
                 → subst (subst e1 (s-extend (s-extend Θ))) (lem4 v1 v2) == subst e1 (lem4' Θ v1 v2)
  subst-compose2 Θ e1 v1 v2 = ap (subst e1) (subst-compose2-lemma v1 v2 e1 Θ) ∘
                           ! (subst-ss (lem4 v1 v2) (s-extend (s-extend Θ)) e1)

  subst-compose3 : ∀ {Γ Γ' τ τ1 τ2} (Θ : sctx Γ Γ') (e1 : (τ1 :: (τ2 :: Γ')) |- τ) (v1 : Γ' |- τ1) (v2 : Γ' |- τ2)
                 → subst (subst e1 (lem4 v1 v2)) Θ == subst e1 (lem4' Θ (subst v1 Θ) (subst v2 Θ))
  subst-compose3 Θ e1 v1 v2 = ap (subst e1) (subst-compose3-lemma Θ e1 v1 v2) ∘ ! (subst-ss Θ (lem4 v1 v2) e1)

  subst-compose4 : ∀ {Γ Γ' τ} (Θ : sctx Γ Γ') (v' : Γ |- nat) (r : Γ |- τ) (e2 : (nat :: (τ :: Γ')) |- τ)
                 → subst (subst e2 (s-extend (s-extend Θ))) (lem4 v' r) == subst e2 (lem4' Θ v' r)
  subst-compose4 Θ v' r e2 = subst-compose2 Θ e2 v' r

  fuse4-lemma : ∀ {Γ Γ' τ τ1 τ2 τ3} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (v3 : Γ |- τ3) (Θ : sctx Γ Γ') (x : τ ∈ Γ')
              → (lem3' (lem3' ids v3) v2 ss q∙ (q∙ Θ)) x == Θ x
  fuse4-lemma v1 v2 v3 Θ x = subst (ren (wkn (Θ x)) iS) (lem3' (q v3) v2) =⟨ sr-comp (lem3' (q v3) v2) iS (wkn (Θ x)) ⟩
                             subst (wkn (Θ x)) (lem3' (q v3) v2 sr iS) =⟨ Refl ⟩
                             subst (ren (Θ x) iS) (lem3' (q v3) v2 sr iS) =⟨ sr-comp (lem3' (q v3) v2 sr iS) iS (Θ x) ⟩
                             subst (Θ x) ((lem3' (q v3) v2 sr iS) sr iS) =⟨ Refl ⟩
                             subst (Θ x) ids =⟨ ! (subst-id (Θ x)) ⟩
                             (Θ x ∎)

  fuse4 : ∀ {Γ Γ' τ τ1 τ2 τ3} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (v3 : Γ |- τ3) (Θ : sctx Γ Γ') (x : τ ∈ τ2 :: τ3 :: Γ')
        → subst (s-extend (s-extend Θ) x) (lem3' (lem3' ids v3) v2) == lem3' (lem3' Θ v3) v2 x
  fuse4 v1 v2 v3 Θ i0 = Refl
  fuse4 v1 v2 v3 Θ (iS i0) = Refl
  fuse4 v1 v2 v3 Θ (iS (iS x)) = subst (wkn (wkn (Θ x))) (lem3' (lem3' ids v3) v2) =⟨ subst-ss (lem3' (lem3' ids v3) v2) (q∙ (q∙ Θ)) (var x) ⟩
                                 subst (var x) (lem3' (lem3' ids v3) v2 ss q∙ (q∙ Θ)) =⟨ fuse4-lemma v1 v2 v3 Θ x ⟩
                                 subst (var x) Θ =⟨ Refl ⟩
                                 (Θ x ∎)

  subst-compose5-lemma-lemma : ∀ {Γ Γ' τ τ1 τ2 τ3 τ'} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (v3 : Γ |- τ3) (e1 : τ1 :: τ2 :: τ3 :: Γ' |- τ) (Θ : sctx Γ Γ') (x : τ' ∈ τ1 :: τ2 :: τ3 :: Γ')
                             → _==_ {_} {_} ((lem5 v1 v2 v3 ss s-extend (s-extend (s-extend Θ))) x) (lem5' Θ v1 v2 v3 x)
  subst-compose5-lemma-lemma v1 v2 v3 e Θ i0 = Refl
  subst-compose5-lemma-lemma v1 v2 v3 e Θ (iS x) = (lem5 v1 v2 v3 ss s-extend (s-extend (s-extend Θ))) (iS x) =⟨ sr-comp (lem5 v1 v2 v3) iS (s-extend (s-extend Θ) x) ⟩
                                                   subst (s-extend (s-extend Θ) x) (lem3' (lem3' ids v3) v2) =⟨ fuse4 v1 v2 v3 Θ x ⟩
                                                   (lem3' (lem3' Θ v3) v2 x ∎)

  subst-compose5-lemma : ∀ {Γ Γ' τ τ1 τ2 τ3} (v1 : Γ |- τ1) (v2 : Γ |- τ2) (v3 : Γ |- τ3) (e : τ1 :: τ2 :: τ3 :: Γ' |- τ) (Θ : sctx Γ Γ')
                       → _==_ {_} {sctx Γ (τ1 :: τ2 :: τ3 :: Γ')} (lem5 v1 v2 v3 ss (s-extend (s-extend (s-extend Θ)))) (lem5' Θ v1 v2 v3)
  subst-compose5-lemma v1 v2 v3 e Θ = λ=i (λ τ → λ= (λ x → subst-compose5-lemma-lemma v1 v2 v3 e Θ x))

  subst-compose5 : ∀ {Γ Γ' τ τ1 τ2 τ3} (Θ : sctx Γ Γ') (e : (τ1 :: (τ2 :: (τ3 :: Γ'))) |- τ) (v1 : Γ |- τ1) (v2 : Γ |- τ2) (v3 : Γ |- τ3)
                 → subst (subst e (s-extend (s-extend (s-extend (Θ))))) (lem5 v1 v2 v3) == subst e (lem5' Θ v1 v2 v3)
  subst-compose5 Θ e v1 v2 v3 = ap (subst e) (subst-compose5-lemma v1 v2 v3 e Θ) ∘
                                ! (subst-ss (lem5 v1 v2 v3) (s-extend (s-extend (s-extend Θ))) e)

-------

  -- define 'stepping' as a datatype (fig. 1 of proof)
  data _≤s_ : ∀ {Γ T} → Γ |- T → Γ |- T → Set where
    refl-s : ∀ {Γ T}
           → {e : Γ |- T}
           → e ≤s e
    trans-s : ∀ {Γ T}
            → {e e' e'' : Γ |- T}
            → e ≤s e' → e' ≤s e''
            → e ≤s e''
    plus-s : ∀ {Γ}
           → {e1 e2 n1 n2 : Γ |- C}
           → e1 ≤s n1 → e2 ≤s n2
           → (plusC e1 e2) ≤s (plusC n1 n2)
    cong-refl : ∀ {Γ τ} {e e' : Γ |- τ} → e == e' → e ≤s e'
    +-unit-l : ∀ {Γ} {e : Γ |- C} → (plusC 0C e) ≤s e
    +-unit-l' : ∀ {Γ} {e : Γ |- C} → e ≤s (plusC 0C e)
    +-unit-r : ∀ {Γ} {e : Γ |- C} → (plusC e 0C) ≤s e
    +-unit-r' : ∀ {Γ} {e : Γ |- C} → e ≤s (plusC e 0C)
    +-1-r : ∀ {Γ} {e : Γ |- C} → e ≤s (plusC e 1C)
    +-assoc : ∀ {Γ} {e1 e2 e3 : Γ |- C} → (plusC e1 (plusC e2 e3)) ≤s (plusC (plusC e1 e2) e3)
    +-assoc' : ∀ {Γ} {e1 e2 e3 : Γ |- C} → (plusC e1 (plusC e2 e3)) ≤s (plusC (plusC e1 e2) e3)
    refl-+ : ∀ {Γ} {e0 e1 : Γ |- C} → (plusC e0 e1) ≤s (plusC e1 e0)
    cong-+ : ∀ {Γ} {e0 e1 e0' e1' : Γ |- C} → e0 ≤s e0' → e1 ≤s e1' → (plusC e0 e1) ≤s (plusC e0' e1')
    cong-lproj : ∀ {Γ τ τ'} {e e' : Γ |- (τ ×c τ')} → e ≤s e' → (l-proj e) ≤s (l-proj e')
    cong-rproj : ∀ {Γ τ τ'} {e e' : Γ |- (τ ×c τ')} → e ≤s e' → (r-proj e) ≤s (r-proj e')
    cong-app   : ∀ {Γ τ τ'} {e e' : Γ |- (τ ->c τ')} {e1 : Γ |- τ} → e ≤s e' → (app e e1) ≤s (app e' e1)
    cong-rec : ∀ {Γ τ} {e e' : Γ |- nat} {e0 : Γ |- τ} {e1 : (nat :: (τ :: Γ)) |- τ}
             → e ≤s e'
             → rec e e0 e1 ≤s rec e' e0 e1
    cong-listrec : ∀ {Γ τ τ'} {e e' : Γ |- list τ} {e0 : Γ |- τ'} {e1 : (τ :: (list τ :: (τ' :: Γ))) |- τ'}
                 → e ≤s e'
                 → listrec e e0 e1 ≤s listrec e' e0 e1
    lam-s : ∀ {Γ T T'}
          → {e : (T :: Γ) |- T'}
          → {e2 : Γ |- T}
          → subst e (q e2) ≤s app (lam e) e2
    l-proj-s : ∀ {Γ T1 T2}
             → {e1 : Γ |- T1}  {e2 : Γ |- T2}
             → e1 ≤s (l-proj (prod e1 e2))
    r-proj-s : ∀ {Γ T1 T2}
             → {e1 : Γ |- T1} → {e2 : Γ |- T2}
             → e2 ≤s (r-proj (prod e1 e2))
    rec-steps-z : ∀ {Γ T}
                → {e0 : Γ |- T}
                → {e1 : (nat :: (T :: Γ)) |- T}
                → e0 ≤s (rec z e0 e1)
    rec-steps-s : ∀ {Γ T}
                → {e : Γ |- nat}
                → {e0 : Γ |- T}
                → {e1 : (nat :: (T :: Γ)) |- T}
                → subst e1 (lem4 e (rec e e0 e1)) ≤s (rec (suc e) e0 e1)
    listrec-steps-nil : ∀ {Γ τ τ'}
                      → {e0 : Γ |- τ'}
                      → {e1 : (τ :: (list τ :: (τ' :: Γ))) |- τ'}
                      → e0 ≤s (listrec nil e0 e1)
    listrec-steps-cons : ∀ {Γ τ τ'}
                       → {h : Γ |- τ} {t : Γ |- list τ}
                       → {e0 : Γ |- τ'}
                       → {e1 : (τ :: (list τ :: (τ' :: Γ))) |- τ'}
                       → subst e1 (lem5 h t (listrec t e0 e1)) ≤s (listrec (h ::c t) e0 e1)

  _trans_ : ∀ {Γ T}
            → {e e' e'' : Γ |- T}
            → e ≤s e' → e' ≤s e''
            → e ≤s e''
  _trans_ = trans-s
  infixr 10 _trans_


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

module CombiningProofs.CommDisjunctionSchema where

open import Common.FOL.FOL

postulate ∨-comm : {A B : Set} → A ∨ B → B ∨ A
{-# ATP prove ∨-comm #-}


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

module Dodo.Binary.Product where

-- Stdlib imports
open import Level using (Level; _⊔_)
open import Function using (flip)
open import Data.Product using (_×_; _,_; map₁; map₂)
open import Relation.Unary using (Pred; _∈_)
open import Relation.Binary using (REL; Rel)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Binary.Equality
open import Dodo.Binary.Domain
open import Dodo.Binary.Composition

infix 40 _×₂_

_×₂_ : ∀ {a b ℓ₁ ℓ₂} {A : Set a} {B : Set b}
  → Pred A ℓ₁
  → Pred B ℓ₂
    -----------------
  → REL A B (ℓ₁ ⊔ ℓ₂)
_×₂_ P Q x y = P x × Q y

-- ## Operations: ×₂ ##

module _ {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
    {d : Pred A ℓ₁} {r : Pred B ℓ₂} where

  ×₂-dom : ∀ {x : A} {y : B} → ( d ×₂ r ) x y → d x
  ×₂-dom (dx , ry) = dx

  ×₂-codom : ∀ {x : A} {y : B} → ( d ×₂ r ) x y → r y
  ×₂-codom (dx , ry) = ry

  ×₂-flip : ∀ {x : A} {y : B} → ( d ×₂ r ) x y → ( r ×₂ d ) y x
  ×₂-flip (dx , ry) = (ry , dx)

module _ {a b ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} {A : Set a} {B : Set b}
    {d₁ : Pred A ℓ₁} {d₂ : Pred A ℓ₂} {r₁ : Pred B ℓ₃} {r₂ : Pred B ℓ₄} where

  ×₂-lift : ( d₁ ⊆₁ d₂ ) → ( r₁ ⊆₁ r₂ ) → d₁ ×₂ r₁ ⊆₂ d₂ ×₂ r₂
  ×₂-lift f g = ⊆: lemma
    where
    lemma : d₁ ×₂ r₁ ⊆₂' d₂ ×₂ r₂
    lemma x y (d₁x , r₁y) = (⊆₁-apply f d₁x , ⊆₁-apply g r₁y)

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b} {R : REL A B ℓ₁}
    {d : Pred A ℓ₂} {r : Pred B ℓ₃} where

  ×₂-applyˡ : R ⊆₂ ( d ×₂ r ) → {x : A} {y : B} → R x y → d x
  ×₂-applyˡ R⊆₂d×r Rxy = ×₂-dom {d = d} {r = r} (⊆₂-apply R⊆₂d×r Rxy)

  ×₂-apply-dom : R ⊆₂ (d ×₂ r) → {x : A} → x ∈ dom R → d x
  ×₂-apply-dom R⊆d×r (y , Rxy) = ×₂-applyˡ R⊆d×r Rxy

  ×₂-applyʳ : R ⊆₂ ( d ×₂ r ) → {x : A} {y : B} → R x y → r y
  ×₂-applyʳ R⊆₂d×r Rxy = ×₂-codom {d = d} {r = r} (⊆₂-apply R⊆₂d×r Rxy)

  ×₂-apply-codom : R ⊆₂ (d ×₂ r) → {y : B} → y ∈ codom R → r y
  ×₂-apply-codom R⊆d×r (x , Rxy) = ×₂-applyʳ R⊆d×r Rxy

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {Q : REL A B ℓ₁} {d : A → Set ℓ₂} {r : B → Set ℓ₃} where

  ×₂-flip-⊆₂ : Q ⊆₂ d ×₂ r → flip Q ⊆₂ r ×₂ d
  ×₂-flip-⊆₂ (⊆: Q⊆×) = ⊆: lemma
    where
    lemma : flip Q ⊆₂' r ×₂ d
    lemma x y Qyx with Q⊆× y x Qyx
    ... | (dy , rx) = (rx , dy)

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a}
    {R : Rel A ℓ₁} {P : Pred A ℓ₂} where

  ×₂-lift-udr :
      udr R ⊆₁ P
      -----------
    → R ⊆₂ P ×₂ P
  ×₂-lift-udr udrR⊆P = ⊆: lemma
    where
    lemma : R ⊆₂' P ×₂ P
    lemma x y Rxy = ⊆₁-apply udrR⊆P (take-udrˡ R Rxy) , ⊆₁-apply udrR⊆P (take-udrʳ R Rxy)

module _ {a b ℓ₁ ℓ₂ ℓ₃ : Level} {A : Set a} {B : Set b}
    {R : REL A B ℓ₁} {P : Pred A ℓ₂} {Q : Pred B ℓ₃} where

  ×₂-lift-dom :
      dom R ⊆₁ P
    → codom R ⊆₁ Q
      ------------
    → R ⊆₂ P ×₂ Q
  ×₂-lift-dom (⊆: dom⊆P) (⊆: codom⊆Q) = ⊆: lemma
    where
    lemma : R ⊆₂' P ×₂ Q
    lemma x y Rxy = (dom⊆P x (take-dom R Rxy) , codom⊆Q y (take-codom R Rxy))

module _ {a b ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} {A : Set a} {B : Set b}
    {Q : REL A B ℓ₁} {d₁ : Pred A ℓ₂} {d₂ : Pred A ℓ₃} {r : B → Set ℓ₄} where

  ×₂-⊆ˡ :
      d₁ ⊆₁ d₂
      ------------------
    → d₁ ×₂ r ⊆₂ d₂ ×₂ r
  ×₂-⊆ˡ d₁⊆d₂ = ⊆: lemma
    where
    lemma : d₁ ×₂ r ⊆₂' d₂ ×₂ r
    lemma x y = map₁ (⊆₁-apply d₁⊆d₂)

module _ {a b ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} {A : Set a} {B : Set b}
    {Q : REL A B ℓ₁} {d : Pred A ℓ₂} {r₁ : Pred B ℓ₃} {r₂ : Pred B ℓ₄} where

  ×₂-⊆ʳ :
      r₁ ⊆₁ r₂
      ------------------
    → d ×₂ r₁ ⊆₂ d ×₂ r₂
  ×₂-⊆ʳ r₁⊆r₂ = ⊆: lemma
    where
    lemma : d ×₂ r₁ ⊆₂' d ×₂ r₂
    lemma x y = map₂ (⊆₁-apply r₁⊆r₂)

module _ {a b c ℓ₁ ℓ₂ ℓ₃ ℓ₄ : Level} {A : Set a} {B : Set b} {C : Set c}
    {d₁ : Pred A ℓ₁} {r₁ : Pred B ℓ₂} {d₂ : Pred B ℓ₃} {r₂ : Pred C ℓ₄} where

  ×₂-combine-⨾ : ( d₁ ×₂ r₁ ) ⨾ ( d₂ ×₂ r₂ ) ⊆₂ d₁ ×₂ r₂
  ×₂-combine-⨾ = ⊆: lemma
    where
    lemma : ( d₁ ×₂ r₁ ) ⨾ ( d₂ ×₂ r₂ ) ⊆₂' d₁ ×₂ r₂
    lemma x y ((d₁x , r₁z) ⨾[ z ]⨾ (d₂z , r₂y)) = (d₁x , r₂y)


-- 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: ???

{-# OPTIONS --allow-exec #-}

open import Vehicle
open import Data.Rational as ℝ using () renaming (ℚ to ℝ)

module monotonicity-output where

private
  VEHICLE_PROJECT_FILE = "TODO_projectFile"

f : ℝ → ℝ
f = evaluate record
  { projectFile = VEHICLE_PROJECT_FILE
  ; networkUUID = "TODO_networkUUID"
  }

abstract
  monotonic : ∀ (x1 : ℝ) → ∀ (x2 : ℝ) → x1 ℝ.≤ x2 → f x1 ℝ.≤ f x2
  monotonic = checkProperty record
    { projectFile  = VEHICLE_PROJECT_FILE
    ; propertyUUID = "TODO_propertyUUID"
    }


module main where

{- unsized Versions omitted in talk -}
import interactiveProgramsAgdaUnsized
import objectsInAgdaUnsized
{- end unsized Versions omitted in talk -}

import interactiveProgramsAgda
import objectsInAgda

{- Probably omit because of time -}
import interfaceExtensionAndDelegation
{- End Probably omit because of time -}

{- Omit later parts about proofs -}
import stateDependentObjects
{- End Omit later parts about proofs -}

import stateDependentIO

import drawingProgram

import objectOrientedGui
import spaceShipSimpleVar
import spaceShipCell
import spaceShipAdvanced


------------------------------------------------------------------------------
-- Group theory properties using Agsy
------------------------------------------------------------------------------

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

-- Tested with the development version of the Agda standard library on
-- 02 February 2012.

module Agsy.GroupTheory where

open import Data.Product

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

infix  8 _⁻¹
infixl 7 _·_

------------------------------------------------------------------------------
-- Group theory axioms

postulate
  G   : Set        -- The universe.
  ε   : G          -- The identity element.
  _·_ : G → G → G  -- The binary operation.
  _⁻¹ : G → G      -- The inverse function.

  assoc         : ∀ x y z → x · y · z    ≡ x · (y · z)
  leftIdentity  : ∀ x     →     ε · x    ≡ x
  rightIdentity : ∀ x     →     x · ε    ≡ x
  leftInverse   : ∀ x     →  x ⁻¹ · x    ≡ ε
  rightInverse  : ∀ x     →  x    · x ⁻¹ ≡ ε

-- Properties

y≡x⁻¹[xy] : ∀ a b → b ≡ a ⁻¹ · (a · b)
y≡x⁻¹[xy] a b = {!-t 20 -m!}  -- Agsy fails

x≡[xy]y⁻¹ : ∀ a b → a ≡ (a · b) · b ⁻¹
x≡[xy]y⁻¹ a b = {!-t 20 -m!}  -- Agsy fails

rightIdentityUnique : Σ G λ u → (∀ x → x · u ≡ x) ×
                                (∀ u' → (∀ x → x · u' ≡ x) → u ≡ u')
rightIdentityUnique = {!-t 20 -m!}  -- Agsy fails
  -- ε
  -- , rightIdentity
  -- , λ x x' → begin
  --              ε     ≡⟨ sym (x' ε) ⟩
  --              ε · x ≡⟨ leftIdentity x ⟩
  --              x
  --            ∎

rightIdentityUnique' : ∀ x u → x · u ≡ x → ε ≡ u
rightIdentityUnique' x u xu≡x = {!-t 20 -m!}  -- Agsy fails

leftIdentityUnique : Σ G λ u → (∀ x → u · x ≡ x) ×
                               (∀ u' → (∀ x → u' · x ≡ x) → u ≡ u')
leftIdentityUnique = {!-t 20 -m!}  -- Agsy fails
  -- ε
  -- , leftIdentity
  -- , λ x x' → begin
  --              ε     ≡⟨ sym (x' ε) ⟩
  --              x · ε ≡⟨ rightIdentity x ⟩
  --              x
  --            ∎

leftIdentityUnique' : ∀ x u → u · x ≡ x → ε ≡ u
leftIdentityUnique' x u ux≡x = {!-t 20 -m!}

rightCancellation : ∀ x y z → y · x ≡ z · x → y ≡ z
rightCancellation x y z = λ hyp → {!-t 20 -m!} -- Agsy fails

leftCancellation : ∀ x y z → x · y ≡ x · z → y ≡ z
leftCancellation x y z = λ hyp → {!-t 20 -m!}  -- Agsy fails

leftCancellationER : (x y z : G) → x · y ≡ x · z → y ≡ z
leftCancellationER x y z x·y≡x·z =
  begin
    y              ≡⟨ sym (leftIdentity y) ⟩
    ε · y          ≡⟨ subst (λ t → ε · y ≡ t · y) (sym (leftInverse x)) refl ⟩
    x ⁻¹ · x · y   ≡⟨ assoc (x ⁻¹) x y ⟩
    x ⁻¹ · (x · y) ≡⟨ subst (λ t → x ⁻¹ · (x · y) ≡ x ⁻¹ · t) x·y≡x·z refl ⟩
    x ⁻¹ · (x · z) ≡⟨ sym (assoc (x ⁻¹) x z) ⟩
    x ⁻¹ · x · z   ≡⟨ subst (λ t → x ⁻¹ · x · z ≡ t · z) (leftInverse x) refl ⟩
    ε · z          ≡⟨ leftIdentity z ⟩
    z
  ∎

rightInverseUnique : ∀ x → Σ G λ r → (x · r ≡ ε) ×
                                     (∀ r' → x · r' ≡ ε → r ≡ r')
rightInverseUnique x = {!-t 20 -m!}  -- Agsy fails

rightInverseUnique' : ∀ x r → x · r ≡ ε → x ⁻¹ ≡ r
rightInverseUnique' x r = λ hyp → {!-t 20 -m!}  -- Agsy fails

leftInverseUnique : ∀ x → Σ G λ l → (l · x ≡ ε) ×
                                    (∀ l' → l' · x ≡ ε → l ≡ l')
leftInverseUnique x = {!-t 20 -m!}  -- Agsy fails

⁻¹-involutive : ∀ x  → x ⁻¹ ⁻¹ ≡ x
⁻¹-involutive x = {!-t 20 -m!}  -- Agsy fails

inverseDistribution : ∀ x y → (x · y) ⁻¹ ≡ y ⁻¹ · x ⁻¹
inverseDistribution x y = {!-t 20 -m!}  -- Agsy fails

-- If the square of every element is the identity, the system is
-- commutative. From: TPTP 6.4.0. File: Problems/GRP/GRP001-2.p
x²≡ε→comm : (∀ a → a · a ≡ ε) → ∀ {b c d} → b · c ≡ d → c · b ≡ d
x²≡ε→comm hyp {b} {c} {d} bc≡d = {!-t 20 -m!}  -- Agsy fails


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

open import HoTT
open import cohomology.Theory
open import groups.Exactness
open import groups.ExactSequence

open import cw.CW

module cw.cohomology.HigherCoboundaryGrid {i} (OT : OrdinaryTheory i)
  {n} (⊙skel : ⊙Skeleton {i} (S (S n))) (ac : ⊙has-cells-with-choice 0 ⊙skel i) where

open OrdinaryTheory OT
open import cw.cohomology.WedgeOfCells OT
open import cw.cohomology.HigherCoboundary OT ⊙skel
open import cw.cohomology.GridPtdMap (⊙cw-incl-last (⊙cw-init ⊙skel)) (⊙cw-incl-last ⊙skel)
import cw.cohomology.GridLongExactSequence
private
  module GLES n = cw.cohomology.GridLongExactSequence
    cohomology-theory n (⊙cw-incl-last (⊙cw-init ⊙skel)) (⊙cw-incl-last ⊙skel)

{-
  Xn --> X(n+1) -----> X(n+2)
   |       |             |
   v       v             v
   1 -> X(n+1)/n ---> X(n+2)/n
           |    this     |
           v      one    v
           1 -----> X(n+2)/(n+1)
-}

private
  n≤SSn : n ≤ S (S n)
  n≤SSn = inr (ltSR ltS)

private
  -- separate lemmas to speed up the type checking
  abstract
    lemma₀-exact₀ : is-exact
      (C-fmap (ℕ-to-ℤ (S n)) Z/X-to-Z/Y)
      (C-fmap (ℕ-to-ℤ (S n)) Y/X-to-Z/X)
    lemma₀-exact₀ = exact-seq-index 2 $ GLES.C-grid-cofiber-exact-seq (ℕ-to-ℤ n)

    lemma₀-exact₁ : is-exact (C-fmap (ℕ-to-ℤ (S n)) Y/X-to-Z/X) cw-co∂-last
    lemma₀-exact₁ = exact-seq-index 0 $ GLES.C-grid-cofiber-exact-seq (ℕ-to-ℤ (S n))

    lemma₀-trivial : is-trivialᴳ (C (ℕ-to-ℤ (S n)) Z/Y)
    lemma₀-trivial = CXₙ/Xₙ₋₁-<-is-trivial ⊙skel ltS ac

Ker-cw-co∂-last : C (ℕ-to-ℤ (S n)) (⊙Cofiber (⊙cw-incl-tail n≤SSn ⊙skel))
               ≃ᴳ Ker.grp cw-co∂-last
Ker-cw-co∂-last = Exact2.G-trivial-implies-H-iso-ker
  lemma₀-exact₀ lemma₀-exact₁ lemma₀-trivial

private
  -- separate lemmas to speed up the type checking
  abstract
    lemma₁-exact₀ : is-exact cw-co∂-last (C-fmap (ℕ-to-ℤ (S (S n))) Z/X-to-Z/Y)
    lemma₁-exact₀ = exact-seq-index 1 $ GLES.C-grid-cofiber-exact-seq (ℕ-to-ℤ (S n))

    lemma₁-exact₁ : is-exact
      (C-fmap (ℕ-to-ℤ (S (S n))) Z/X-to-Z/Y)
      (C-fmap (ℕ-to-ℤ (S (S n))) Y/X-to-Z/X)
    lemma₁-exact₁ = exact-seq-index 2 $ GLES.C-grid-cofiber-exact-seq (ℕ-to-ℤ (S n))

    lemma₁-trivial : is-trivialᴳ (C (ℕ-to-ℤ (S (S n))) Y/X)
    lemma₁-trivial = CXₙ/Xₙ₋₁->-is-trivial (⊙cw-init ⊙skel) ltS
      (⊙init-has-cells-with-choice ⊙skel ac)

Coker-cw-co∂-last : CokerCo∂ ≃ᴳ C (ℕ-to-ℤ (S (S n))) (⊙Cofiber (⊙cw-incl-tail n≤SSn ⊙skel))
Coker-cw-co∂-last = Exact2.L-trivial-implies-coker-iso-K
  lemma₁-exact₀ lemma₁-exact₁ (CXₙ/Xₙ₋₁-is-abelian ⊙skel (ℕ-to-ℤ (S (S n)))) lemma₁-trivial


module _ where

open import Common.IO
  renaming (then to _>>_
           )
open import Agda.Builtin.Unit
open import Agda.Builtin.Bool
open import Agda.Builtin.Equality using (_≡_; refl)
open import Agda.Builtin.Float
  renaming ( primFloatEquality       to _≡ᵇ_
           ; primFloatInequality     to _≤ᵇ_
           ; primFloatLess           to _<ᵇ_
           ; primFloatPlus           to infixl 6 _+_
           ; primFloatMinus          to infixl 6 _-_
           ; primFloatTimes          to infixl 7 _*_
           ; primFloatDiv            to infixl 7 _÷_
           ; primFloatPow            to infix  8 _**_
           ; primFloatNegate         to infix  9 -_
           ; primFloatSqrt           to sqrt
           ; primFloatExp            to e^_
           ; primFloatLog            to log
           ; primFloatSin            to sin
           ; primFloatCos            to cos
           ; primFloatTan            to tan
           ; primFloatASin           to asin
           ; primFloatACos           to acos
           ; primFloatATan           to atan
           ; primFloatATan2          to atan2
           ; primFloatSinh           to sinh
           ; primFloatCosh           to cosh
           ; primFloatTanh           to tanh
           ; primFloatASinh          to asinh
           ; primFloatACosh          to acosh
           ; primFloatATanh          to atanh
           ; primFloatRound          to round
           ; primFloatFloor          to floor
           ; primFloatCeiling        to ceiling
           ; primShowFloat           to showF
           ; primFloatToWord64       to toWord
           ; primFloatToRatio        to toRatio
           ; primRatioToFloat        to fromRatio
           ; primFloatDecode         to decode
           ; primFloatEncode         to encode
           ; primFloatIsInfinite     to isInfinite
           ; primFloatIsNaN          to isNaN
           ; primFloatIsNegativeZero to isNegativeZero
           ; primFloatIsSafeInteger  to isSafeInteger
           )
open import Agda.Builtin.Int
  using (Int; pos; negsuc)
  renaming ( primShowInteger         to showI
           )
open import Agda.Builtin.Nat
  using (Nat)
  renaming ( _==_                    to _==N_
           )
open import Agda.Builtin.Maybe
open import Agda.Builtin.Sigma
open import Agda.Builtin.String
  using (String)
  renaming ( primStringEquality      to _==S_
           ; primShowNat             to showN
           ; primStringAppend        to _++_
           )
open import Agda.Builtin.Word
  using (Word64)
  renaming ( primWord64ToNat         to toℕ
           )

-- Prelude

data ⊥ : Set where

_≢_ : {A : Set} (P Q : A) → Set
P ≢ Q = P ≡ Q → ⊥

NaN : Float
NaN = 0.0 ÷ 0.0

-NaN : Float
-NaN = - NaN

Infinity : Float
Infinity = 1.0 ÷ 0.0

-Infinity : Float
-Infinity = - Infinity

MaxFloat : Float
MaxFloat = 1.7976931348623157e308

MinFloat : Float
MinFloat = 2.2250738585072014e-308

MaxSafeIntF : Float
MaxSafeIntF = 9007199254740991.0

MaxSafeIntZ : Int
MaxSafeIntZ = pos 9007199254740991

-- * Tests

showB : Bool → String
showB false = "false"
showB true  = "true"

maybeShow : {A : Set} (show : A → String) → Maybe A → String
maybeShow show (just x) = "(just (" ++ (show x ++ "))")
maybeShow show nothing  = "nothing"

pairShow : {A B : Set} (showA : A → String) (showB : B → String) → Σ A (λ _ → B) → String
pairShow showA showB (x , y) = "(" ++ (showA x ++ (" , " ++ (showB y ++ ")")))

showR = pairShow showI showI

newline : IO ⊤
newline = putStr "\n"

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

_==F_ : Float → Float → Bool
x ==F y = toℕ (toWord x) ==N toℕ (toWord x)

_==B_ : Bool → Bool → Bool
false ==B false = true
false ==B true  = false
true  ==B false = false
true  ==B true  = true

_==I_ : Int → Int → Bool
pos    n ==I pos    m = n ==N m
pos    n ==I negsuc m = false
negsuc n ==I pos    m = false
negsuc n ==I negsuc m = n ==N m

maybeEq : {A : Set} (eq : A → A → Bool) → Maybe A → Maybe A → Bool
maybeEq eq (just x) (just y) = eq x y
maybeEq eq (just x) nothing  = false
maybeEq eq nothing  (just y) = false
maybeEq eq nothing  nothing  = true

pairEq : {A B : Set} (eqA : A → A → Bool) (eqB : B → B → Bool) → Σ A (λ _ → B) → Σ A (λ _ → B) → Bool
pairEq eqA eqB (x , y) (z , w) = eqA x z && eqB y w
  where
    _&&_ : Bool → Bool → Bool
    true && true = true
    x    && y    = false

_==R_  = pairEq _==I_ _==I_

check : {A : Set} (show : A → String) (eq : A → A → Bool) (str : String) (exp act : A) {p : T (eq act exp)} → IO ⊤
check show eq str exp act = do
  putStr str; putStr " = "; putStr (show exp); putStr " = "; putStr (show act); newline

checkB  = check showB _==B_
checkS  = check (λ x → x) _==S_
checkN  = check showN _==N_
checkI  = check showI _==I_
checkMI = check (maybeShow showI) (maybeEq _==I_)
checkR  = check showR _==R_
checkF  = check showF _==F_
checkMR = check (maybeShow showR) (maybeEq _==R_)
checkMF = check (maybeShow showF) (maybeEq _==F_)

-- ** Relations

main : IO ⊤
main = do
  -- ** Relations
  checkB " NaN      ≡ᵇ  NaN     " false ( NaN      ≡ᵇ  NaN     )
  checkB "-NaN      ≡ᵇ  NaN     " false (-NaN      ≡ᵇ  NaN     )
  checkB " NaN      ≡ᵇ -NaN     " false ( NaN      ≡ᵇ -NaN     )
  checkB "-NaN      ≡ᵇ -NaN     " false (-NaN      ≡ᵇ -NaN     )
  checkB " Infinity ≡ᵇ  Infinity" true  ( Infinity ≡ᵇ  Infinity)
  checkB "-Infinity ≡ᵇ  Infinity" false (-Infinity ≡ᵇ  Infinity)
  checkB " Infinity ≡ᵇ -Infinity" false ( Infinity ≡ᵇ -Infinity)
  checkB "-Infinity ≡ᵇ -Infinity" true  (-Infinity ≡ᵇ -Infinity)
  checkB " MaxFloat ≡ᵇ  MaxFloat" true  ( MaxFloat ≡ᵇ  MaxFloat)
  checkB " MinFloat ≡ᵇ  MinFloat" true  ( MinFloat ≡ᵇ  MinFloat)
  checkB " 1.0      ≡ᵇ  1.5     " false ( 1.0      ≡ᵇ  1.5     )
  checkB " 1.0      ≡ᵇ  1.0     " true  ( 1.0      ≡ᵇ  1.0     )
  checkB " 1.5      ≡ᵇ  1.5     " true  ( 1.5      ≡ᵇ  1.5     )

  checkB " NaN      ≤ᵇ  NaN     " false ( NaN      ≤ᵇ  NaN     )
  checkB "-NaN      ≤ᵇ  NaN     " false (-NaN      ≤ᵇ  NaN     )
  checkB " NaN      ≤ᵇ -NaN     " false ( NaN      ≤ᵇ -NaN     )
  checkB "-NaN      ≤ᵇ -NaN     " false (-NaN      ≤ᵇ -NaN     )
  checkB " NaN      ≤ᵇ  5.0     " false ( NaN      ≤ᵇ  5.0     )
  checkB "-NaN      ≤ᵇ  5.0     " false (-NaN      ≤ᵇ  5.0     )
  checkB " 5.0      ≤ᵇ -NaN     " false ( 5.0      ≤ᵇ -NaN     )
  checkB "-5.0      ≤ᵇ -NaN     " false (-5.0      ≤ᵇ -NaN     )
  checkB " NaN      ≤ᵇ  Infinity" false ( NaN      ≤ᵇ  Infinity)
  checkB "-NaN      ≤ᵇ  Infinity" false (-NaN      ≤ᵇ  Infinity)
  checkB " Infinity ≤ᵇ -NaN     " false ( Infinity ≤ᵇ -NaN     )
  checkB "-Infinity ≤ᵇ -NaN     " false (-Infinity ≤ᵇ -NaN     )
  checkB " Infinity ≤ᵇ  Infinity" true  ( Infinity ≤ᵇ  Infinity)
  checkB "-Infinity ≤ᵇ  Infinity" true  (-Infinity ≤ᵇ  Infinity)
  checkB " Infinity ≤ᵇ -Infinity" false ( Infinity ≤ᵇ -Infinity)
  checkB "-Infinity ≤ᵇ -Infinity" true  (-Infinity ≤ᵇ -Infinity)
  checkB " MaxFloat ≤ᵇ  MaxFloat" true  ( MaxFloat ≤ᵇ  MaxFloat)
  checkB " MinFloat ≤ᵇ  MinFloat" true  ( MinFloat ≤ᵇ  MinFloat)
  checkB " 1.0      ≤ᵇ  1.5     " true  ( 1.0      ≤ᵇ  1.5     )
  checkB " 1.0      ≤ᵇ  1.0     " true  ( 1.0      ≤ᵇ  1.0     )
  checkB " 1.5      ≤ᵇ  1.5     " true  ( 1.5      ≤ᵇ  1.5     )

  checkB " NaN      <ᵇ  NaN     " false ( NaN      <ᵇ  NaN     )
  checkB "-NaN      <ᵇ  NaN     " false (-NaN      <ᵇ  NaN     )
  checkB " NaN      <ᵇ -NaN     " false ( NaN      <ᵇ -NaN     )
  checkB "-NaN      <ᵇ -NaN     " false (-NaN      <ᵇ -NaN     )
  checkB " NaN      <ᵇ  5.0     " false ( NaN      <ᵇ  5.0     )
  checkB "-NaN      <ᵇ  5.0     " false (-NaN      <ᵇ  5.0     )
  checkB " 5.0      <ᵇ -NaN     " false ( 5.0      <ᵇ -NaN     )
  checkB "-5.0      <ᵇ -NaN     " false (-5.0      <ᵇ -NaN     )
  checkB " NaN      <ᵇ  Infinity" false ( NaN      <ᵇ  Infinity)
  checkB "-NaN      <ᵇ  Infinity" false (-NaN      <ᵇ  Infinity)
  checkB " Infinity <ᵇ -NaN     " false ( Infinity <ᵇ -NaN     )
  checkB "-Infinity <ᵇ -NaN     " false (-Infinity <ᵇ -NaN     )
  checkB " Infinity <ᵇ  Infinity" false ( Infinity <ᵇ  Infinity)
  checkB "-Infinity <ᵇ  Infinity" true  (-Infinity <ᵇ  Infinity)
  checkB " Infinity <ᵇ -Infinity" false ( Infinity <ᵇ -Infinity)
  checkB "-Infinity <ᵇ -Infinity" false (-Infinity <ᵇ -Infinity)
  checkB " MaxFloat <ᵇ  MaxFloat" false ( MaxFloat <ᵇ  MaxFloat)
  checkB " MinFloat <ᵇ  MinFloat" false ( MinFloat <ᵇ  MinFloat)
  checkB " 1.0      <ᵇ  1.5     " true  ( 1.0      <ᵇ  1.5     )
  checkB " 1.0      <ᵇ  1.0     " false ( 1.0      <ᵇ  1.0     )
  checkB " 1.5      <ᵇ  1.5     " false ( 1.5      <ᵇ  1.5     )

  checkB "isNaN  NaN                " true  (isNaN  NaN                )
  checkB "isNaN -NaN                " true  (isNaN -NaN                )
  checkB "isNaN  Infinity           " false (isNaN  Infinity           )
  checkB "isNaN -Infinity           " false (isNaN -Infinity           )
  checkB "isNaN  0.0                " false (isNaN  0.0                )
  checkB "isNaN -0.0                " false (isNaN -0.0                )
  checkB "isNaN  1.0                " false (isNaN  1.0                )
  checkB "isNaN  1.5                " false (isNaN  1.5                )
  checkB "isInfinite  NaN           " false (isInfinite  NaN           )
  checkB "isInfinite -NaN           " false (isInfinite -NaN           )
  checkB "isInfinite  Infinity      " true  (isInfinite  Infinity      )
  checkB "isInfinite -Infinity      " true  (isInfinite -Infinity      )
  checkB "isInfinite  0.0           " false (isInfinite  0.0           )
  checkB "isInfinite -0.0           " false (isInfinite -0.0           )
  checkB "isInfinite  1.0           " false (isInfinite  1.0           )
  checkB "isInfinite  1.5           " false (isInfinite  1.5           )

  -- Depends on optimisation settings:
  --
  --   - with -O0 the test succeeds
  --   - with -O  the test fails
  --
  -- checkB "isInfinite ((MaxFloat * MaxFloat) ÷ MaxFloat)"
  --        true
  --        (isInfinite ((MaxFloat * MaxFloat) ÷ MaxFloat))

  checkB "isNegativeZero  NaN       " false (isNegativeZero  NaN       )
  checkB "isNegativeZero -NaN       " false (isNegativeZero -NaN       )
  checkB "isNegativeZero  Infinity  " false (isNegativeZero  Infinity  )
  checkB "isNegativeZero -Infinity  " false (isNegativeZero -Infinity  )
  checkB "isNegativeZero  0.0       " false (isNegativeZero  0.0       )
  checkB "isNegativeZero -0.0       " true  (isNegativeZero -0.0       )
  checkB "isNegativeZero  1.0       " false (isNegativeZero  1.0       )
  checkB "isNegativeZero  1.5       " false (isNegativeZero  1.5       )
  checkB "isSafeInteger 1.0         " true  (isSafeInteger 1.0         )
  checkB "isSafeInteger 1.5         " false (isSafeInteger 1.5         )
  checkB "isSafeInteger MaxFloat    " false (isSafeInteger MaxFloat    )
  checkB "isSafeInteger MinFloat    " false (isSafeInteger MinFloat    )
  checkB "isSafeInteger MaxSafeIntF " true  (isSafeInteger MaxSafeIntF )

  -- ** Conversions

  checkS "show  NaN     " "NaN"       (showF  NaN     )
  checkS "show -NaN     " "NaN"       (showF -NaN     )
  checkS "show  0.0     " "0.0"       (showF  0.0     )
  checkS "show -0.0     " "-0.0"      (showF -0.0     )
  checkS "show  Infinity" "Infinity"  (showF  Infinity)
  checkS "show -Infinity" "-Infinity" (showF -Infinity)
  checkS "show  1.0     " "1.0"       (showF  1.0     )
  checkS "show  1.5     " "1.5"       (showF  1.5     )

  -- Breaks the JavaScript backend, on account of it being... too big:
  --
  -- checkN "toℕ (toWord 1.0)      " 4607182418800017408  (toℕ (toWord 1.0)      )
  -- checkN "toℕ (toWord 1.5)      " 4609434218613702656  (toℕ (toWord 1.5)      )
  -- checkN "toℕ (toWord 0.0)      " 0                    (toℕ (toWord 0.0)      )
  -- checkN "toℕ (toWord -0.0)     " 9223372036854775808  (toℕ (toWord -0.0)     )
  -- checkN "toℕ (toWord NaN)      " 18444492273895866368 (toℕ (toWord NaN)      )
  -- checkN "toℕ (toWord -NaN)     " 18444492273895866368 (toℕ (toWord -NaN)     )
  -- checkN "toℕ (toWord Infinity) " 9218868437227405312  (toℕ (toWord Infinity) )
  -- checkN "toℕ (toWord -Infinity)" 18442240474082181120 (toℕ (toWord -Infinity))

  checkMI "round 1.0      " (just (pos 1)) (round 1.0      )
  checkMI "round 1.5      " (just (pos 2)) (round 1.5      )
  checkMI "round NaN      " (nothing     ) (round NaN      )
  checkMI "round -NaN     " (nothing     ) (round -NaN     )
  checkMI "round Infinity " (nothing     ) (round Infinity )
  checkMI "round -Infinity" (nothing     ) (round -Infinity)
  checkMI "round MinFloat " (just (pos 0)) (round MinFloat )
  --
  -- Breaks the JavaScript backend, on account of it being... too big:
  --
  -- checkMI "round MaxFloat " (just (pos 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368)) (round MaxFloat )

  checkMI "floor 1.0      " (just (pos 1)) (floor 1.0      )
  checkMI "floor 1.5      " (just (pos 1)) (floor 1.5      )
  checkMI "floor NaN      " (nothing     ) (floor NaN      )
  checkMI "floor -NaN     " (nothing     ) (floor -NaN     )
  checkMI "floor Infinity " (nothing     ) (floor Infinity )
  checkMI "floor -Infinity" (nothing     ) (floor -Infinity)
  checkMI "floor MinFloat " (just (pos 0)) (floor MinFloat )
  --
  -- Breaks the JavaScript backend, on account of it being... too big:
  --
  -- checkMI "floor MaxFloat " (just (pos 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368)) (floor MaxFloat )

  checkMI "ceiling 1.0      " (just (pos 1)) (ceiling 1.0      )
  checkMI "ceiling 1.5      " (just (pos 2)) (ceiling 1.5      )
  checkMI "ceiling NaN      " (nothing     ) (ceiling NaN      )
  checkMI "ceiling -NaN     " (nothing     ) (ceiling -NaN     )
  checkMI "ceiling Infinity " (nothing     ) (ceiling Infinity )
  checkMI "ceiling -Infinity" (nothing     ) (ceiling -Infinity)
  checkMI "ceiling MinFloat " (just (pos 1)) (ceiling MinFloat )
  --
  -- Breaks the JavaScript backend, on account of it being... too big:
  --
  -- checkMI "ceiling MaxFloat " (just (pos 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368)) (ceiling MaxFloat )

  checkMR "decode  NaN     " (nothing                         ) (decode  NaN     )
  checkMR "decode  Infinity" (nothing                         ) (decode  Infinity)
  checkMR "decode -Infinity" (nothing                         ) (decode -Infinity)
  checkMR "decode  1.0     " (just (pos       1 , pos       0)) (decode  1.0     )
  checkMR "decode  1.5     " (just (pos       3 , negsuc    0)) (decode  1.5     )
  checkMR "decode  MinFloat" (just (pos       1 , negsuc 1021)) (decode  MinFloat)
  --
  -- Breaks the JavaScript backend, on account of it being... too big:
  --
  -- checkMR "decode  MaxFloat" (just (MaxSafeIntZ , pos     971)) (decode  MaxFloat)

  checkMF "encode  (pos     1) (pos       0)" (just 1.0        ) (encode  (pos     1) (pos       0))
  checkMF "encode  (pos     3) (negsuc    0)" (just 1.5        ) (encode  (pos     3) (negsuc    0))
  --
  -- Breaks the JavaScript backend, on account of it being... too big:
  --
  -- checkMF "encode  MaxSafeIntZ (pos       0)" (just MaxSafeIntF) (encode  MaxSafeIntZ (pos       0))
  -- checkMF "encode  MaxSafeIntZ (pos     971)" (just MaxFloat   ) (encode  MaxSafeIntZ (pos     971))
  -- checkMF "encode  MaxSafeIntZ (pos     972)" (nothing         ) (encode  MaxSafeIntZ (pos     972))
  -- checkMF "encode  (pos     1) (negsuc 1021)" (just MinFloat   ) (encode  (pos     1) (negsuc 1021))
  -- checkMF "encode  MaxSafeIntZ (negsuc 1075)" (nothing         ) (encode  MaxSafeIntZ (negsuc 1075))

  checkR "toRatio  NaN     " (pos 0    , pos 0) (toRatio  NaN     )
  checkR "toRatio  Infinity" (pos 1    , pos 0) (toRatio  Infinity)
  checkR "toRatio -Infinity" (negsuc 0 , pos 0) (toRatio -Infinity)
  checkR "toRatio  1.0     " (pos 1    , pos 1) (toRatio  1.0     )
  checkR "toRatio  1.5     " (pos 3    , pos 2) (toRatio  1.5     )

  checkF "fromRatio (pos 0)    (pos 0)" ( NaN     ) (fromRatio (pos 0)    (pos 0))
  checkF "fromRatio (pos 1)    (pos 0)" ( Infinity) (fromRatio (pos 1)    (pos 0))
  checkF "fromRatio (negsuc 0) (pos 0)" (-Infinity) (fromRatio (negsuc 0) (pos 0))
  checkF "fromRatio (pos 1)    (pos 1)" ( 1.0     ) (fromRatio (pos 1)    (pos 1))
  checkF "fromRatio (pos 3)    (pos 2)" ( 1.5     ) (fromRatio (pos 3)    (pos 2))

  checkF "e^ 1.0             " 2.718281828459045 (e^ 1.0             )
  checkF "sin (asin 0.6)     " 0.6               (sin (asin 0.6)     )
  checkF "cos (acos 0.6)     " 0.6               (cos (acos 0.6)     )
  checkF "tan (atan 0.4)     " 0.4               (tan (atan 0.4)     )
  checkF "tan (atan2 0.4 1.0)" 0.4               (tan (atan2 0.4 1.0))


-- Andreas, 2016-02-16, issue 1777, reported by Martin Stone Davis

data D : Set where
  c : D

record R : Set where
  field f : D

test : R → D
test record { f = x } with x
... | y = {!y!}

-- Splitting on y should give
-- test record { f = x } | c = ?


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

-- setup

infixl 5 _>>=_
_>>=_ = bindTC

defToTerm : Name → Definition → List (Arg Term) → Term
defToTerm _ (function cs) as = pat-lam cs as
defToTerm _ (data-cons d) as = con d as
defToTerm _ _ _ = unknown

data Tm : Set where
  tm : Term → Tm

macro
  unfold : Name → Term → TC ⊤
  unfold x a = getDefinition x >>= λ d → unify a (defToTerm x d [])

data Vec (A : Set) : Nat → Set where
  [] : Vec A zero
  _∷_ : ∀ {n} → A → Vec A n → Vec A (suc n)

Point = Vec Nat 3

renderBuffer : List Point → List Nat
renderBuffer [] = []
renderBuffer ((x ∷ y ∷ z ∷ []) ∷ xs) = x ∷ y ∷ z ∷ renderBuffer xs

renderBuffer' : List Point → List Nat
renderBuffer' = unfold renderBuffer

ps : List Point
ps = (1 ∷ 2 ∷ 3 ∷ []) ∷ (4 ∷ 5 ∷ 6 ∷ []) ∷ []

open import Agda.Builtin.Equality

check : renderBuffer' ps ≡ 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ 6 ∷ []
check = refl


module Array.Properties where

open import Array.Base
open import Data.Fin using (Fin; zero; suc; raise; fromℕ≤; fromℕ<; fromℕ)
open import Data.Nat
open import Data.Nat.Properties
open import Data.Vec
open import Data.Vec.Properties
open import Relation.Binary.PropositionalEquality
open import Function using (_$_; _∘_; case_of_)

open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Relation.Nullary.Negation
open import Relation.Binary using (Decidable; Rel)

open import Data.Maybe
open import Data.Sum

sel-ext : ∀ {a}{X : Set a}{d s} → (f : Ix d s → X)
        → (iv jv : Ix d s)
        → iv =ix jv
        → f iv ≡ f jv
sel-ext {d = zero}  f [] [] pf = refl
sel-ext {d = suc d} f (i ∷ iv) (j ∷ jv) pf rewrite (pf zero) = sel-ext (f ∘ (j ∷_)) iv jv (pf ∘ suc)

s→a∘a→s : ∀ {n} → (a : Ar ℕ 1 (n ∷ [])) → s→a (a→s a) =a a
s→a∘a→s (imap x) (i ∷ []) = lookup∘tabulate _ i

a→s∘s→a : ∀ {n} → (v : Vec ℕ n) → a→s (s→a v) =s v
a→s∘s→a v i = lookup∘tabulate _ i

refl-=a : ∀ {a}{X : Set a}{d s}{x : Ar X d s}
        → x =a x
refl-=a {x = imap x} iv = refl

sym-=a : ∀ {a}{X : Set a}{d s}{l r : Ar X d s}
       → l =a r → r =a l
sym-=a {l = imap f} {imap g} l=r = sym ∘ l=r

trans-=a : ∀ {a}{X : Set a}{d s}{x y z : Ar X d s}
         → x =a y → y =a z → x =a z
trans-=a {x = imap x} {imap y} {imap z} x=y y=z iv
  = trans (x=y iv) (y=z iv)

_<v?_ : ∀ {n} → Decidable (_<s_ {n = n})
[] <v? [] = yes λ ()
(x ∷ xs) <v? (y ∷ ys) = case _,_ {B = λ x₂ → Dec (xs <s ys) }(x <? y) (xs <v? ys) of λ where
                         (yes pf-xy , yes pf-xsys) → yes λ where
                                                         zero    → pf-xy
                                                         (suc i) → pf-xsys i
                         (no pf-xy , _) → no (not-head pf-xy)
                         (_ , no pf-xsys) → no (not-tail pf-xsys)
  where
    p1 : ∀ {n}{x y}{xs ys : Vec ℕ n} → (x ∷ xs) <s (y ∷ ys) → x < y
    p1 pf = pf zero

    p2 : ∀ {n}{x y}{xs ys : Vec ℕ n} → (x ∷ xs) <s (y ∷ ys) → xs <s ys
    p2 pf = pf ∘ (raise 1)

    not-head : ∀ {n}{x y}{xs ys : Vec ℕ n} → ¬ (x < y) → ¬ ((x ∷ xs) <s (y ∷ ys))
    not-head pf-xy pf-xxs-yys = contradiction (p1 pf-xxs-yys) pf-xy

    not-tail : ∀ {n}{x y}{xs ys : Vec ℕ n} → ¬ (xs <s ys) → ¬ ((x ∷ xs) <s (y ∷ ys))
    not-tail pf-xsys pf-xxs-yys = contradiction (p2 pf-xxs-yys) pf-xsys

-- Index curry makes it possible to fix the first position of
-- the index vector and select a sub-array.
ix-curry : ∀ {a}{X : Set a}{d s ss} → (f : Ix (suc d) (s ∷ ss) → X) → (Fin s) → (Ix d ss → X)
ix-curry f x xs = f (x ∷ xs)

ARel : ∀ {a}{A : Set a} → (P : Rel A a) -- → Decidable P
     → ∀ {d s} → Ar A d s → Ar A d s → Set a
ARel p (imap x) (imap y) = ∀ iv → p (x iv) (y iv)

--test = ARel _≥_

-- If a < b, then sub-arays a[i] < b[i], where a[i] and b[i]
-- is non-scalar selection where the head of index-vector is
-- fixed to i.
all-subarrays : ∀ {d s ss}{a}{X : Set a}{_~_ : Rel X a}
              → let _~a_ = ARel _~_ in
                (a b : Ix (suc d) (suc s ∷ ss) → X)
              → imap a ~a imap b
              → ∀ i → (imap (ix-curry a i) ~a imap (ix-curry b i))
all-subarrays a b pf i iv = pf (i ∷ iv)

-- If all a[i] < b[i], then a < b.
from-subarrays : ∀ {d s ss}{a}{X : Set a}{_~_ : Rel X a}
               → let _~a_ = ARel _~_ in
                 (a b : Ix (suc d) (suc s ∷ ss) → X)
               → (∀ i → (imap (ix-curry a i) ~a imap (ix-curry b i)))
               → imap a ~a imap b
from-subarrays a b pf (x ∷ iv) = pf x iv

-- If there exists i such that ¬ a[i] < b[i], then ¬ a < b.
not-subarrays : ∀ {d s ss}{a}{X : Set a}{_~_ : Rel X a}
              → let _~a_ = ARel _~_ in
                (a b : Ix (suc d) (suc s ∷ ss) → X)
              → (i : Fin (suc s))
              → ¬ imap (ix-curry a i) ~a imap (ix-curry b i)
              → ¬ imap a ~a imap b
not-subarrays a b i ¬p pp = contradiction pp λ z → ¬p (λ iv → z (i ∷ iv))

module not-needed where
  unmaybe : ∀ {a}{X : Set a}{n}
          → (x : Vec (Maybe X) n)
          → (∀ i → lookup x i ≢ nothing)
          → Vec X n
  unmaybe {n = zero} x pf = []
  unmaybe {n = suc n} (just x ∷ xs) pf = x ∷ unmaybe xs (pf ∘ suc)
  unmaybe {n = suc n} (nothing ∷ x₁) pf = contradiction refl $ pf zero

  check-all-nothing : ∀ {a}{X : Set a}{n}
                    → (x : Vec (Maybe X) n)
                    → Maybe ((i : Fin n) → lookup x i ≢ nothing)
  check-all-nothing {n = zero} x = nothing
  check-all-nothing {n = suc n} (just x  ∷ xs) with check-all-nothing xs
  check-all-nothing {n = suc n} (just x ∷ xs) | just f = just λ { zero → λ () ; (suc k) → f k }
  check-all-nothing {n = suc n} (just x ∷ xs) | nothing = nothing
  check-all-nothing {n = suc n}  _  = nothing

check-all-subarrays : ∀ {d s ss}{a}{X : Set a}{_~_ : Rel X a}
                    → let _~a_ = ARel _~_ in
                      (a b : Ix (suc d) (suc s ∷ ss) → X)
                    → (∀ i → Dec (imap (ix-curry a i) ~a imap (ix-curry b i)))
                    → (Σ (Fin (suc s)) λ i → ¬ (imap (ix-curry a i) ~a imap (ix-curry b i)))
                    ⊎ (∀ i → (imap (ix-curry a i) ~a imap (ix-curry b i)))
check-all-subarrays {s = zero}  a b pf with (pf zero)
check-all-subarrays {_} {zero}  a b pf | yes p = inj₂ λ { zero → p }
check-all-subarrays {_} {zero}  a b pf | no ¬p = inj₁ (zero , ¬p)
check-all-subarrays {s = suc s} {_~_ = _~_} a b pf with check-all-subarrays {_~_ = _~_}
                                                                (λ { (i ∷ iv) → a (suc i ∷ iv)})
                                                                (λ { (i ∷ iv) → b (suc i ∷ iv)})
                                                                (pf ∘ suc)
                                         -- If we have a subarray that is not <
                                         -- simply propagate it further, updating the index
check-all-subarrays {_} {suc s} a b pf | inj₁ (i , a≁b) = inj₁ (suc i , a≁b)
check-all-subarrays {_} {suc s} a b pf | inj₂ y with (pf zero)
check-all-subarrays {_} {suc s} a b pf | inj₂ y | yes p = inj₂ λ { zero → p ; (suc k) → y k }
check-all-subarrays {_} {suc s} a b pf | inj₂ y | no ¬p = inj₁ (zero , ¬p)

{-
-- For arrays a and b, if f : ∀ i → Dec (a[i] < b[i]),
-- check whether:
--   1. There exists i, for which ¬ a[i] < b[i]
--   2. Otherwise construct a function of type ∀ i → a[i] < b[i]
check-all-subarrays : ∀ {d s ss}
                    → (a b : Ix (suc d) (suc s ∷ ss) → ℕ)
                    → (∀ i → Dec (imap (ix-curry a i) <a imap (ix-curry b i)))
                    → (Σ (Fin (suc s)) λ i → ¬ (imap (ix-curry a i) <a imap (ix-curry b i)))
                    ⊎ (∀ i → (imap (ix-curry a i) <a imap (ix-curry b i)))
check-all-subarrays {s = zero}  a b pf with (pf zero)
check-all-subarrays {_} {zero}  a b pf | yes p = inj₂ λ { zero → p }
check-all-subarrays {_} {zero}  a b pf | no ¬p = inj₁ (zero , ¬p)
check-all-subarrays {s = suc s} a b pf with check-all-subarrays (λ { (i ∷ iv) → a (suc i ∷ iv)})
                                                                (λ { (i ∷ iv) → b (suc i ∷ iv)})
                                                                (pf ∘ suc)
                                         -- If we have a subarray that is not <
                                         -- simply propagate it further, updating the index
check-all-subarrays {_} {suc s} a b pf | inj₁ (i , a≮b) = inj₁ (suc i , a≮b)
check-all-subarrays {_} {suc s} a b pf | inj₂ y with (pf zero)
check-all-subarrays {_} {suc s} a b pf | inj₂ y | yes p = inj₂ λ { zero → p ; (suc k) → y k }
check-all-subarrays {_} {suc s} a b pf | inj₂ y | no ¬p = inj₁ (zero , ¬p)
-}

mk-dec-arel : ∀ {a}{X : Set a} → (p : Rel X a) → Decidable p → ∀ {d s} → Decidable (ARel p {d = d} {s = s})
mk-dec-arel _~_ _~?_ {zero} {[]} (imap x) (imap x₁) with x [] ~? x₁ []
mk-dec-arel _~_ _~?_ {zero} {[]} (imap x) (imap x₁) | yes p = yes λ { [] → p }
mk-dec-arel _~_ _~?_ {zero} {[]} (imap x) (imap x₁) | no ¬p =  no λ p → contradiction (p []) ¬p
mk-dec-arel _~_ _~?_ {suc d} {zero  ∷ ss} (imap x) (imap x₁) = yes λ iv → magic-fin $ ix-lookup iv zero
mk-dec-arel _~_ _~?_ {suc d} {suc s ∷ ss} (imap x) (imap x₁) = case-analysis
  where
    case-analysis : _ -- Dec ((i : Ix (suc d) (suc s ∷ ss)) → suc (x i) ≤ x₁ i)
    case-analysis = let _~a?_ = mk-dec-arel _~_ _~?_
                    in case check-all-subarrays {_~_ = _~_}
                          x x₁ (λ i → imap (ix-curry x i)
                                      ~a? imap (ix-curry x₁ i)) of λ where
                       -- In this case we have an index and a proof that
                       -- subarray at this index is not <
                       (inj₁ (i , x≁x₁)) → no $ not-subarrays {_~_ = _~_} x x₁ i x≁x₁
                       -- In this case we have a function that for every index
                       -- returns a proof that sub-arrays are <
                       (inj₂ f) → yes (from-subarrays {_~_ = _~_} x x₁ f)

_<a?_ = mk-dec-arel _<_ _<?_
_≥a?_ = mk-dec-arel _≥_ _≥?_

{-
_<a?_ : ∀ {d s} → Decidable (_<a_ {d = d} {s = s})
_<a?_ {zero} {[]} (imap x) (imap x₁) with x [] <? x₁ []
_<a?_ {zero} {[]} (imap x) (imap x₁) | yes p = yes λ { [] → p }
_<a?_ {zero} {[]} (imap x) (imap x₁) | no ¬p = no λ p → contradiction (p []) ¬p
_<a?_ {suc d} {0 ∷ ss} (imap x) (imap x₁) = yes λ iv → magic-fin $ ix-lookup iv zero
_<a?_ {suc d} {(suc s) ∷ ss} (imap x) (imap x₁) = case-analysis
  where
    case-analysis : _ -- Dec ((i : Ix (suc d) (suc s ∷ ss)) → suc (x i) ≤ x₁ i)
    case-analysis =  case check-all-subarrays {_~_ = _<_}
                          x x₁ (λ i → imap (ix-curry x i)
                                      <a? imap (ix-curry x₁ i)) of λ where
                       -- In this case we have an index and a proof that
                       -- subarray at this index is not <
                       (inj₁ (i , x≮x₁)) → no $ not-subarrays {_~_ = _<_} x x₁ i x≮x₁
                       -- In this case we have a function that for every index
                       -- returns a proof that sub-arrays are <
                       (inj₂ f) → yes (from-subarrays {_~_ = _<_} x x₁ f)

_≥a?_ : ∀ {d s} → Decidable (_≥a_ {d = d} {s = s})
_≥a?_ {zero} {[]} (imap x) (imap x₁) with x [] ≥? x₁ []
_≥a?_ {zero} {[]} (imap x) (imap x₁) | yes p = yes λ { [] → p }
_≥a?_ {zero} {[]} (imap x) (imap x₁) | no ¬p = no λ p → contradiction (p []) ¬p
_≥a?_ {suc d} {s} (imap x) (imap x₁) = {!!}
-}

private
  thm : ∀ { i s } → i < s → s ∸ i ∸ 1 + suc i ≡ s
  thm {i} {s} pf = begin
                      s ∸ i ∸ 1 + suc i ≡⟨ cong (_+ (suc i)) (∸-+-assoc s i 1) ⟩
                      s ∸ (i + 1) + suc i ≡⟨ cong (_+ (suc i)) (cong (s ∸_) (+-comm i 1))  ⟩
                      s ∸ suc i + suc i ≡⟨ m∸n+n≡m pf ⟩
                      s
                   ∎
                 where open ≡-Reasoning

-- XXX can we do this simpler?
≮a⇒∃ : ∀ {d s}{a b : Ar _ d s} → ¬ a <a b → Σ (Ix d s) λ iv → ¬ (unimap a iv < unimap b iv)
≮a⇒∃ {zero} {[]} {imap f} {imap g} ¬a<b with f [] <? g []
≮a⇒∃ {zero} {[]} {imap f} {imap g} ¬a<b | yes p = contradiction (λ { [] → p}) ¬a<b
≮a⇒∃ {zero} {[]} {imap f} {imap g} ¬a<b | no ¬p = [] , ¬p
≮a⇒∃ {suc d} {zero ∷ ss} {imap f} {imap g} ¬a<b = contradiction (λ iv → magic-fin $ ix-lookup iv zero) ¬a<b
≮a⇒∃ {suc d} {suc s ∷ ss} {imap f} {imap g} ¬a<b = case-analysis
  where
    case-analysis : _
    case-analysis =  case check-all-subarrays {_~_ = _<_}
                          f g (λ i → imap (ix-curry f i)
                                      <a? imap (ix-curry g i)) of λ where
                          (inj₁ (i , f≮g)) → let
                                               iv , pf = ≮a⇒∃ f≮g
                                             in (i ∷ iv) , λ pp → contradiction pp pf
                          (inj₂ pf) → contradiction (from-subarrays {_~_ = _<_} f g pf) ¬a<b

module try-irrelevant where
  -- XXX this shouldn't be here, this is for now to avoid
  -- dependencies in the modules.
  -- Inverse of the above
  a→ix : ∀ {d} --{s : Fin d → ℕ}
       → (ax sh : Ar ℕ 1 (d ∷ []))
       -- XXX we can make this inequality irrelevant
       -- and recompute it when it is needed, as <a
       -- is decideable.
       → .(ax <a sh)
       → Ix d (a→s sh)
  a→ix {d} (imap axf) (imap shf) ax<sh = ix-tabulate from-pf
    where
      pf : _
      pf = recompute (imap axf <a? imap shf) ax<sh

      from-pf : _
      from-pf i rewrite (lookup∘tabulate (shf ∘ (_∷ [])) i)
        = let
            ix : Ix 1 (d ∷ [])
            ix = i ∷ []
            r = raise (shf ix ∸ axf ix ∸ 1) $ fromℕ (axf ix)

           in subst Fin (thm (pf ix)) r --fromℕ≤ (ax<sh (i ∷ []))

a→ix : ∀ {d} --{s : Fin d → ℕ}
     → (ax sh : Ar ℕ 1 (d ∷ []))
     → (ax <a sh)
     → Ix d (a→s sh)
a→ix {d} (imap axf) (imap shf) ax<sh = ix-tabulate from-pf
  where
    from-pf : _
    from-pf i rewrite (lookup∘tabulate (shf ∘ (_∷ [])) i)
      = fromℕ< (ax<sh (i ∷ []))


module Issue857 where

-- From the Agda mailing list, 2013-05-24, question raised by Martin Escardo.
-- 2013-05-24 reported by Martin Escardo, test case by Andrea Vezzosi

{- The crucial point is that λ() is not equal to λ(), so e.g. the
ones appearing in the body of main-closed-ground' don't match the ones
in its own type.

To be concrete we can use a simplified version of what happens in
main-closed-ground': -}

data ⊥ : Set where

postulate
    X : Set
    P : (⊥ → X) → Set
    lemma : (f : ⊥ → X) → P f

-- Given the context above we attempt to feed agda code using λ():

main : P λ()
main = lemma λ()

{- Before we can check the type of main we have to translate λ()
away into toplevel definitions, because internally only those are
allowed pattern-matching. But each use of λ() is translated
separately, so we get:

absurd1 : ⊥ → X
absurd1 ()

absurd2 : ⊥ → X
absurd2 ()

main : P absurd1
main = lemma absurd2

Now we can proceed typechecking and find that (lemma absurd2 : P
absurd2), i.e. applications of lemma only care about the type of its
argument, but for main to typecheck we need the type of the body (P
absurd2) to equal the declared type (P absurd1), and so we'd need
absurd2 = absurd1 which unfortunately we can't deduce because those
are different definitions.  -}

-- 2013-05-24 example by Martin Escardo

open import Common.Equality

absurd-equality : _≡_ {A = ⊥ → ⊥} (λ()) λ()
absurd-equality = refl

-- λ() is not translated as λ() → () (identity with variable name ())
-- thus, these examples should type check now.


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

open import lib.Basics

module lib.types.Empty where

Empty-rec : ∀ {i} {A : Type i} → (Empty → A)
Empty-rec = Empty-elim

⊥-rec : ∀ {i} {A : Type i} → (⊥ → A)
⊥-rec = Empty-rec

abstract
  Empty-is-prop : is-prop Empty
  Empty-is-prop = Empty-elim

  Empty-is-set : is-set Empty
  Empty-is-set = raise-level -1 Empty-is-prop

  Empty-level = Empty-is-prop
  ⊥-is-prop = Empty-is-prop
  ⊥-is-set = Empty-is-set
  ⊥-level = Empty-level


{-# OPTIONS --rewriting #-}

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

module _ (Form : Set) where  -- FAILS
-- postulate Form : Set -- WORKS

data Cxt : Set where
  ε : Cxt
  _∙_ : (Γ : Cxt) (A : Form) → Cxt

data _≤_ : (Γ Δ : Cxt) → Set where
  id≤ : ∀{Γ} → Γ ≤ Γ
  weak : ∀{A Γ Δ} (τ : Γ ≤ Δ) → (Γ ∙ A) ≤ Δ
  lift : ∀{A Γ Δ} (τ : Γ ≤ Δ) → (Γ ∙ A) ≤ (Δ ∙ A)

postulate lift-id≤ : ∀{Γ A} → lift id≤ ≡ id≤ {Γ ∙ A}
{-# REWRITE lift-id≤ #-}


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

open import Agda.Primitive
open import Agda.Builtin.Nat
open import Agda.Builtin.Equality

data ⊥ : Set where

record Σ {a} {b} (A : Set a) (B : A → Set b) : Set (a ⊔ b) where
  constructor _,_
  field
    fst : A
    snd : B fst

no : _≡_ {A = Σ Set (λ X → X)} (Nat , 0) (Nat , 1) → ⊥
no ()