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

open import canonical-value-forms

module canonical-boxed-forms where
  canonical-boxed-forms-b : ∀{Δ d} →
                            Δ , ∅ ⊢ d :: b →
                            d boxedval →
                            d == c
  canonical-boxed-forms-b (TAVar _) (BVVal ())
  canonical-boxed-forms-b wt (BVVal v) = canonical-value-forms-b wt v

  -- this type gives somewhat nicer syntax for the output of the canonical
  -- forms lemma for boxed values at arrow type
  data cbf-arr : (Δ : hctx) (d : iexp) (τ1 τ2 : typ) → Set where
    CBFLam : ∀{Δ d τ1 τ2} →
      (Σ[ x ∈ Nat ] Σ[ d' ∈ iexp ]
         (d == (·λ x [ τ1 ] d') × Δ , ■ (x , τ1) ⊢ d' :: τ2))
      → cbf-arr Δ d τ1 τ2
    CBFCastArr : ∀{Δ d τ1 τ2} →
      (Σ[ d' ∈ iexp ] Σ[ τ1' ∈ typ ] Σ[ τ2' ∈ typ ]
         (d == (d' ⟨ τ1' ==> τ2' ⇒ τ1 ==> τ2 ⟩) ×
         (τ1' ==> τ2' ≠ τ1 ==> τ2) ×
         (Δ , ∅ ⊢ d' :: τ1' ==> τ2')))
      → cbf-arr Δ d τ1 τ2

  data cbf-prod : (Δ : hctx) (d : iexp) (τ1 τ2 : typ) → Set where
    CBFPairVal : ∀{Δ d τ1 τ2} →
              (Σ[ d1 ∈ iexp ] Σ[ d2 ∈ iexp ]
               (d == ⟨ d1 , d2 ⟩ ×
                Δ , ∅ ⊢ d1 :: τ1 ×
                Δ , ∅ ⊢ d2 :: τ2 ×
                d1 val ×
                d2 val))
              → cbf-prod Δ d τ1 τ2
    CBFPairBV : ∀{Δ d τ1 τ2} →
              (Σ[ d1 ∈ iexp ] Σ[ d2 ∈ iexp ]
               (d == ⟨ d1 , d2 ⟩ ×
                Δ , ∅ ⊢ d1 :: τ1 ×
                Δ , ∅ ⊢ d2 :: τ2 ×
                d1 boxedval ×
                d2 boxedval  ))
              → cbf-prod Δ d τ1 τ2
    CBFCastProd : ∀{Δ d τ1 τ2} →
                  (Σ[ d' ∈ iexp ] Σ[ τ1' ∈ typ ] Σ[ τ2' ∈ typ ]
                   (d == (d' ⟨ τ1' ⊗ τ2' ⇒ τ1 ⊗ τ2 ⟩) ×
                   (τ1' ⊗ τ2' ≠ τ1 ⊗ τ2) ×
                   (τ1' ⊗ τ2' ~ τ1 ⊗ τ2) ×
                   (d' boxedval) ×
                   (Δ , ∅ ⊢ d' :: τ1' ⊗ τ2')))
                  → cbf-prod Δ d τ1 τ2

  canonical-boxed-forms-arr : ∀{Δ d τ1 τ2 } →
                            Δ , ∅ ⊢ d :: (τ1 ==> τ2)  →
                            d boxedval →
                            cbf-arr Δ d τ1 τ2
  canonical-boxed-forms-arr (TAVar x₁) (BVVal ())
  canonical-boxed-forms-arr (TALam f wt) (BVVal v) = CBFLam (canonical-value-forms-arr (TALam f wt) v)
  canonical-boxed-forms-arr (TAAp wt wt₁) (BVVal ())
  canonical-boxed-forms-arr (TAEHole x x₁) (BVVal ())
  canonical-boxed-forms-arr (TANEHole x wt x₁) (BVVal ())
  canonical-boxed-forms-arr (TACast wt x) (BVVal ())
  canonical-boxed-forms-arr (TACast wt x) (BVArrCast x₁ bv) = CBFCastArr (_ , _ , _ , refl , x₁ , wt)
  canonical-boxed-forms-arr (TAFailedCast x x₁ x₂ x₃) (BVVal ())
  canonical-boxed-forms-arr (TAFst wt) (BVVal ())
  canonical-boxed-forms-arr (TASnd wt) (BVVal ())

  canonical-boxed-forms-hole : ∀{Δ d} →
                               Δ , ∅ ⊢ d :: ⦇·⦈ →
                               d boxedval →
                               Σ[ d' ∈ iexp ] Σ[ τ' ∈ typ ]
                                 ((d == d' ⟨ τ' ⇒ ⦇·⦈ ⟩) ×
                                  (τ' ground) ×
                                  (Δ , ∅ ⊢ d' :: τ'))
  canonical-boxed-forms-hole (TAVar x₁) (BVVal ())
  canonical-boxed-forms-hole (TAAp wt wt₁) (BVVal ())
  canonical-boxed-forms-hole (TAEHole x x₁) (BVVal ())
  canonical-boxed-forms-hole (TANEHole x wt x₁) (BVVal ())
  canonical-boxed-forms-hole (TACast wt x) (BVVal ())
  canonical-boxed-forms-hole (TACast wt x) (BVHoleCast x₁ bv) = _ , _ , refl , x₁ , wt
  canonical-boxed-forms-hole (TAFailedCast x x₁ x₂ x₃) (BVVal ())
  canonical-boxed-forms-hole (TAFst wt) (BVVal ())
  canonical-boxed-forms-hole (TASnd wt) (BVVal ())

  canonical-boxed-forms-prod : ∀{Δ d τ1 τ2 } →
                               Δ , ∅ ⊢ d :: (τ1 ⊗ τ2)  →
                               d boxedval →
                               cbf-prod Δ d τ1 τ2
  canonical-boxed-forms-prod (TAVar x₁) (BVVal ())
  canonical-boxed-forms-prod (TAAp wt wt₁) (BVVal ())
  canonical-boxed-forms-prod (TAEHole x x₁) (BVVal ())
  canonical-boxed-forms-prod (TANEHole x wt x₁) (BVVal ())
  canonical-boxed-forms-prod (TACast wt x) (BVVal ())
  canonical-boxed-forms-prod (TACast wt x) (BVProdCast x₁ bv) = CBFCastProd (_ , _ , _ , refl , x₁ , x , bv , wt)
  canonical-boxed-forms-prod (TAFailedCast wt x x₁ x₂) (BVVal ())
  canonical-boxed-forms-prod (TAFst wt) (BVVal ())
  canonical-boxed-forms-prod (TASnd wt) (BVVal ())
  canonical-boxed-forms-prod (TAPair wt wt₁) (BVVal (VPair x x₁)) = CBFPairVal (_ , _ , refl , wt , wt₁ , x , x₁)
  canonical-boxed-forms-prod (TAPair wt wt₁) (BVPair bv bv₁) = CBFPairBV (_ , _ , refl , wt , wt₁ , bv , bv₁)

  canonical-boxed-forms-coverage : ∀{Δ d τ} →
                                   Δ , ∅ ⊢ d :: τ →
                                   d boxedval →
                                   τ ≠ b →
                                   ((τ1 : typ) (τ2 : typ) → τ ≠ (τ1 ==> τ2)) →
                                   τ ≠ ⦇·⦈ →
                                   ((τ1 : typ) (τ2 : typ) → τ ≠ (τ1 ⊗ τ2)) →
                                   ⊥
  canonical-boxed-forms-coverage TAConst (BVVal x) nb na nh = λ _ → nb refl
  canonical-boxed-forms-coverage (TAVar x₁) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TALam _ wt) (BVVal x₁) nb na nh = λ _ → na _ _ refl
  canonical-boxed-forms-coverage (TAAp wt wt₁) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TAEHole x x₁) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TANEHole x wt x₁) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TACast wt x) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TACast wt x) (BVArrCast x₁ bv) nb na nh = λ _ → na _ _ refl
  canonical-boxed-forms-coverage (TACast wt x) (BVHoleCast x₁ bv) nb na nh = λ _ → nh refl
  canonical-boxed-forms-coverage (TAFailedCast x x₁ x₂ x₃) (BVVal ())
  canonical-boxed-forms-coverage (TACast wt x) (BVProdCast x₁ bv) nb na nh = λ z → z _ _ refl
  canonical-boxed-forms-coverage (TAFst wt) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TASnd wt) (BVVal ()) nb na nh
  canonical-boxed-forms-coverage (TAPair wt wt₁) (BVVal x) nb na nh = λ z → z _ _ refl
  canonical-boxed-forms-coverage (TAPair wt wt₁) (BVPair bv bv₁) nb na nh = λ z → z _ _ refl


{-# OPTIONS --universe-polymorphism #-}

-- Should give some unsolved metas
module Issue203b where

open import Imports.Level

-- Should work but give unsolved metas (type of b)
data ↓ {a b} (A : Set a) : Set a where
  [_] : (x : A) → ↓ A

-- Shouldn't instantiate the level of Σ to a
data Σ {a b} (A : Set a) (B : A → Set b) : Set _ where
  _,_ : (x : A) (y : B x) → Σ A B


-- Andreas, 2019-07-11, issue #3843, reported by shinji-kono
-- recordExpressionToCopattern translation invalidates projection-likeness.

-- {-# OPTIONS -v tc.proj.like:100 -v impossible:10 #-}

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

postulate
  ANY  : ∀{a} {A : Set a} → A
  Nat  : Set
  suc  : Nat → Nat
  diag : (x : Nat) → x ≡ x
  P    : Nat → Set
  Foo  : {x : Nat} (px : P x) → Set

record Pack (n : Nat) : Set where
  constructor pack
  field
    lv  : Nat
    ord : P lv
open Pack

-- Projection-like, because eta-contracted to  pidproj x = x
pidproj : ∀ {n} (x : Pack n) → Pack n
pidproj x = record { lv = lv x; ord = ord x }

-- Not considered projection-like, since
-- `pidpc (pack l o)` is stuck, but the `n` cannot be inferred.
pidpc : ∀ {n} (x : Pack n) → Pack n
pidpc x .lv = lv x
pidpc x .ord = ord x

-- Not considered projection-like, since
-- `pidcop (pack l o)` is stuck, but the `n` cannot be inferred.
pidcop : ∀ {n} (x : Pack n) → Pack n
pidcop (pack lx ox) .lv  = lx
pidcop (pack lx ox) .ord = ox

-- WAS: Projection-like function,
-- but since is translated to pidcop by recordExpressionsToCopatterns
-- projection-likeness is unsound here.
pid : ∀ {n} (x : Pack n) → Pack n
pid (pack lx ox) = record { lv = lx ; ord = ox }
-- pid record { lv = lx ; ord = ox } = record { lv = lx ; ord = ox }
-- pid (pack lx ox) = pack lx ox  -- no error
-- pid x = x  -- Error disappears with record pattern matching

test : ∀ {n} (x : Pack (suc n)) → x ≡ pid x
test {n} x@(pack lx ox) with diag (lv x)  -- The @-pattern is needed for 2.5.2 and 2.5.3
... | refl with Foo (ord x) -- with needed
... | _ = ANY

-- WAS: internal error

-- Should succeed.


------------------------------------------------------------------------
-- Application of substitutions to normal and neutral terms
------------------------------------------------------------------------

open import Level using (zero)
open import Data.Universe

module README.DependentlyTyped.NormalForm.Substitution
  (Uni₀ : Universe zero zero) where

open import Data.Product as Prod renaming (curry to c; uncurry to uc)
open import deBruijn.Substitution.Data
open import Function.Base as F renaming (const to k)
import README.DependentlyTyped.NormalForm as NF; open NF Uni₀
import README.DependentlyTyped.Term.Substitution as S
open S Uni₀ using (module Apply)
import README.DependentlyTyped.Term as Term; open Term Uni₀
import Relation.Binary.PropositionalEquality as P

open P.≡-Reasoning

-- Code for applying substitutions containing terms which can be
-- transformed into /neutral/ terms.

module Apply-n {T : Term-like Level.zero} (T↦Ne : T ↦ Tm-n ne) where

  open _↦_ T↦Ne hiding (var)

  T↦Tm : T ↦ Tm
  T↦Tm = record
    { trans  = forget-n [∘] trans
    ; simple = simple
    }

  open Apply T↦Tm using (_/⊢_; _/⊢t_; app)

  -- Applies a substitution to an atomic type.

  infixl 8 _/⊢a_

  _/⊢a_ : ∀ {Γ Δ σ} {ρ̂ : Γ ⇨̂ Δ} →
          Γ ⊢ σ atomic-type → (ρ : Sub T ρ̂) → Δ ⊢ σ / ρ atomic-type
  ⋆  /⊢a ρ = ⋆
  el /⊢a ρ = el

  mutual

    -- Applies a renaming to a normal or neutral term.

    infixl 8 _/⊢n_ _/⊢n-lemma_

    _/⊢n_ : ∀ {Γ Δ σ k} {ρ̂ : Γ ⇨̂ Δ} →
            Γ ⊢ σ ⟨ k ⟩ → (ρ : Sub T ρ̂) → Δ ⊢ σ / ρ ⟨ k ⟩
    ne σ′ t /⊢n ρ = ne (σ′ /⊢a ρ) (t /⊢n ρ)
    var x   /⊢n ρ = trans ⊙ (x /∋ ρ)
    ƛ t     /⊢n ρ = ƛ (t /⊢n ρ ↑)
    t₁ · t₂ /⊢n ρ = [ t₁ · t₂ ]/⊢n ρ

    -- The body of the last case above. (At the time of writing the
    -- termination checker complains if [ t₁ · t₂ ]/⊢n ρ is replaced
    -- by t₁ · t₂ /⊢n ρ in the type signature of ·-/⊢n below.)

    [_·_]/⊢n :
      ∀ {Γ Δ sp₁ sp₂ σ} {ρ̂ : Γ ⇨̂ Δ}
      (t₁ : Γ ⊢ π sp₁ sp₂ , σ ⟨ ne ⟩) (t₂ : Γ ⊢ fst σ ⟨ no ⟩)
      (ρ : Sub T ρ̂) →
      Δ ⊢ snd σ /̂ ŝub ⟦ t₂ ⟧n /̂ ρ̂ ⟨ ne ⟩
    [_·_]/⊢n {σ = σ} t₁ t₂ ρ =
      P.subst (λ v → _ ⊢ snd σ /̂ ⟦ ρ ⟧⇨ ↑̂ /̂ ŝub v ⟨ ne ⟩)
              (≅-Value-⇒-≡ $ P.sym (t₂ /⊢n-lemma ρ))
              ((t₁ /⊢n ρ) · (t₂ /⊢n ρ))

    abstract

      -- An unfolding lemma.

      ·-/⊢n :
        ∀ {Γ Δ sp₁ sp₂ σ} {ρ̂ : Γ ⇨̂ Δ}
        (t₁ : Γ ⊢ π sp₁ sp₂ , σ ⟨ ne ⟩) (t₂ : Γ ⊢ fst σ ⟨ no ⟩)
        (ρ : Sub T ρ̂) →
        [ t₁ · t₂ ]/⊢n ρ ≅-⊢n (t₁ /⊢n ρ) · (t₂ /⊢n ρ)
      ·-/⊢n {σ = σ} t₁ t₂ ρ =
        drop-subst-⊢n (λ v → snd σ /̂ ⟦ ρ ⟧⇨ ↑̂ /̂ ŝub v)
                      (≅-Value-⇒-≡ $ P.sym $ t₂ /⊢n-lemma ρ)

      -- The application operation is well-behaved.

      _/⊢n-lemma_ : ∀ {Γ Δ σ k} {ρ̂ : Γ ⇨̂ Δ}
                    (t : Γ ⊢ σ ⟨ k ⟩) (ρ : Sub T ρ̂) →
                    ⟦ t ⟧n /Val ρ ≅-Value ⟦ t /⊢n ρ ⟧n
      ne σ′ t /⊢n-lemma ρ = begin
        [ ⟦ t ⟧n /Val ρ ]  ≡⟨ t /⊢n-lemma ρ ⟩
        [ ⟦ t /⊢n ρ ⟧n  ]  ∎
      var x /⊢n-lemma ρ = /̂∋-⟦⟧⇨ x ρ
      ƛ t   /⊢n-lemma ρ = begin
        [ c ⟦ t ⟧n /Val ρ     ]  ≡⟨ P.refl ⟩
        [ c (⟦ t ⟧n /Val ρ ↑) ]  ≡⟨ curry-cong (t /⊢n-lemma (ρ ↑)) ⟩
        [ c ⟦ t /⊢n ρ ↑ ⟧n    ]  ∎
      t₁ · t₂ /⊢n-lemma ρ = begin
        [ ⟦ t₁ · t₂ ⟧n /Val ρ                 ]  ≡⟨ P.refl ⟩
        [ (⟦ t₁ ⟧n /Val ρ) ˢ (⟦ t₂ ⟧n /Val ρ) ]  ≡⟨ ˢ-cong (t₁ /⊢n-lemma ρ) (t₂ /⊢n-lemma ρ) ⟩
        [ ⟦ t₁ /⊢n ρ ⟧n ˢ ⟦ t₂ /⊢n ρ ⟧n       ]  ≡⟨ P.refl ⟩
        [ ⟦ (t₁ /⊢n ρ) · (t₂ /⊢n ρ) ⟧n        ]  ≡⟨ ⟦⟧n-cong (P.sym $ ·-/⊢n t₁ t₂ ρ) ⟩
        [ ⟦ t₁ · t₂ /⊢n ρ ⟧n                  ]  ∎

  app-n : ∀ {Γ Δ} {ρ̂ : Γ ⇨̂ Δ} → Sub T ρ̂ → [ Tm-n ne ⟶ Tm-n ne ] ρ̂
  app-n ρ = record
    { function    = λ _ t → t /⊢n ρ
    ; corresponds = λ _ t → t /⊢n-lemma ρ
    }

substitution₁-n : Substitution₁ (Tm-n ne)
substitution₁-n = record
  { var      = record { function    = λ _ → var
                      ; corresponds = λ _ _ → P.refl
                      }
  ; app′     = Apply-n.app-n
  ; app′-var = λ _ _ _ → P.refl
  }

open Substitution₁ substitution₁-n public hiding (var)

-- Let us make _/⊢n_ and friends immediately available for use with
-- /renamings/.

open Apply-n (Translation-from.translation Var-↦) public


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

open import lib.Base

module lib.Coinduction where

infix 1000 ♯_

postulate  -- Coinduction
  ∞  : ∀ {i} (A : Type i) → Type i
  ♯_ : ∀ {i} {A : Type i} → A → ∞ A
  ♭  : ∀ {i} {A : Type i} → ∞ A → A

{-# BUILTIN INFINITY ∞  #-}
{-# BUILTIN SHARP    ♯_ #-}
{-# BUILTIN FLAT     ♭  #-}


data ⊥ : Set where

module M₁ where

  postulate
    ∥_∥ : Set → Set

  {-# POLARITY ∥_∥ ++ #-}

  data D : Set where
    c : ∥ D ∥ → D

module M₂ where

  postulate
    _⇒_    : Set → Set → Set
    lambda : {A B : Set} → (A → B) → A ⇒ B
    apply  : {A B : Set} → A ⇒ B → A → B

  {-# POLARITY _⇒_ ++ #-}

  data D : Set where
    c : D ⇒ ⊥ → D

  not-inhabited : D → ⊥
  not-inhabited (c f) = apply f (c f)

  d : D
  d = c (lambda not-inhabited)

  bad : ⊥
  bad = not-inhabited d

postulate
  F₁ : Set → Set → Set₁ → Set₁ → Set₁ → Set

{-# POLARITY F₁ _ ++ + - * #-}

data D₁ : Set where
  c : F₁ (D₁ → ⊥) D₁ Set Set Set → D₁

postulate
  F₂ : ∀ {a} → Set a → Set a → Set a

{-# POLARITY F₂ * * ++ #-}

data D₂ (A : Set) : Set where
  c : F₂ A (D₂ A) → D₂ A

module _ (A : Set₁) where

  postulate
    F₃ : Set → Set

  {-# POLARITY F₃ ++ #-}

data D₃ : Set where
  c : F₃ Set D₃ → D₃

postulate
  F₄ : ∀ {a} → Set a → Set a → Set a

{-# POLARITY F₄ * ++ #-}

data D₄ (A : Set) : Set where
  c : F₄ (D₄ A) A → D₄ A

postulate
  F₅ : ⦃ _ : Set ⦄ → Set

{-# POLARITY F₅ ++ #-}

data D₅ : Set where
  c : F₅ ⦃ D₅ ⦄ → D₅


module InstanceArgumentsConstraintsModule where

data Bool : Set where
  true false : Bool

module M (A1 A2 B C : Set) (a1 : A1) (a2 : A2) where

  record Class (R : Bool → Set) : Set where
    field f : (t : Bool) → R t

  open Class {{...}} public

  instance
    class1 : Class (λ _ → A1)
    class1 = record { f = λ _ → a1 }

    class2 : Class (λ _ → A2)
    class2 = record { f = λ _ → a2 }

module N (A1 A2 B C : Set) (a1 : A1) (a2 : A2) where

  postulate someF : A1 → C

  open M A1 A2 B C a1 a2

  test : C
  test = someF (f true)


------------------------------------------------------------------------
-- "Lenses" defined using bijections
------------------------------------------------------------------------

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

import Equality.Path as P

module Lens.Non-dependent.Bijection
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq hiding (univ)
open import Equivalence equality-with-J as Eq using (_≃_)
open import Function-universe equality-with-J as F
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional eq
open import Surjection equality-with-J using (_↠_)
open import Univalence-axiom equality-with-J

open import Lens.Non-dependent eq
import Lens.Non-dependent.Higher      eq as Higher
import Lens.Non-dependent.Traditional eq as Traditional

private
  variable
    a b : Level

-- A "naive" definition of lenses using a bijection.
--
-- This definition is not in general isomorphic to Higher.Lens A B,
-- not even if A and B are sets (consider the case in which A and B
-- are empty; see ¬Higher-lens↠Lens below).

Lens : Set a → Set b → Set (lsuc (a ⊔ b))
Lens {a = a} {b = b} A B =
  ∃ λ (R : Set (a ⊔ b)) → A ↔ (R × B)

instance

  -- The lenses defined above have getters and setters.

  has-getter-and-setter :
    Has-getter-and-setter (Lens {a = a} {b = b})
  has-getter-and-setter = record
    { get = λ (_ , bij) a → proj₂ (_↔_.to bij a)
    ; set = λ (_ , bij) a b → _↔_.from bij (proj₁ (_↔_.to bij a) , b)
    }

-- Lens ⊥ ⊥ is isomorphic to Set something.

Lens-⊥-⊥↔Set :
  Lens (⊥ {ℓ = a}) (⊥ {ℓ = b}) ↔ Set (a ⊔ b)
Lens-⊥-⊥↔Set =
  Lens ⊥ ⊥               ↔⟨ (∃-cong λ _ → Eq.↔↔≃ ext (mono₁ 1 ⊥-propositional)) ⟩
  (∃ λ R → ⊥ ≃ (R × ⊥))  ↔⟨ (∃-cong λ _ → Eq.≃-preserves-bijections ext F.id ×-right-zero) ⟩
  (∃ λ R → ⊥ ≃ ⊥₀)       ↔⟨ (∃-cong λ _ → ≃⊥≃¬ ext) ⟩
  (∃ λ R → ¬ ⊥)          ↔⟨ drop-⊤-right (λ _ → ¬⊥↔⊤ {k = bijection} ext) ⟩□
  Set _                  □

-- There is a split surjection from Lens A B to Higher.Lens A B
-- (assuming univalence).

Lens↠Higher-lens :
  {A : Set a} {B : Set b} →
  Univalence (a ⊔ b) →
  Lens A B ↠ Higher.Lens A B
Lens↠Higher-lens {A = A} {B} univ = record
  { logical-equivalence = record
    { to   = λ { (R , A↔R×B) → Higher.isomorphism-to-lens A↔R×B }
    ; from = λ { l → R l , _≃_.bijection (equiv l) }
    }
  ; right-inverse-of = λ { l →
      _↔_.from (Higher.equality-characterisation₂ univ)
        ( (R l × ∥ B ∥  ↔⟨ drop-⊤-right (λ r → inhabited⇒∥∥↔⊤ (inhabited l r)) ⟩□
           R l          □)
        , λ _ → refl _
        ) }
  }
  where
  open Higher.Lens

-- However, there is in general no split surjection in the other
-- direction, not even for sets (assuming univalence).

¬Higher-lens↠Lens :
  Univalence (a ⊔ b) →
  ¬ ({A : Set a} {B : Set b} →
     Is-set A → Is-set B →
     Higher.Lens A B ↠ Lens A B)
¬Higher-lens↠Lens univ surj =
  ⊥-elim (subst F.id ⊤≡⊥ _)
  where
  ⊥-is-set : ∀ {ℓ} → Is-set (⊥ {ℓ = ℓ})
  ⊥-is-set = mono₁ 1 ⊥-propositional

  ⊤↠Set =
    ⊤                ↔⟨ inverse $ Higher.lens-from-⊥↔⊤ univ ⟩
    Higher.Lens ⊥ ⊥  ↝⟨ surj ⊥-is-set ⊥-is-set ⟩
    Lens ⊥ ⊥         ↔⟨ Lens-⊥-⊥↔Set ⟩□
    Set _            □

  ⊤≡⊥ : ↑ _ ⊤ ≡ ⊥
  ⊤≡⊥ =
    ↑ _ ⊤              ≡⟨ sym $ right-inverse-of _ ⟩
    to (from (↑ _ ⊤))  ≡⟨⟩
    to (from ⊥)        ≡⟨ right-inverse-of _ ⟩∎
    ⊥                  ∎
    where
    open _↠_ ⊤↠Set

-- The split surjection Lens↠Higher-lens preserves getters and
-- setters.

Lens↠Higher-lens-preserves-getters-and-setters :
  {A : Set a} {B : Set b}
  (univ : Univalence (a ⊔ b)) →
  Preserves-getters-and-setters-⇔ A B
    (_↠_.logical-equivalence (Lens↠Higher-lens univ))
Lens↠Higher-lens-preserves-getters-and-setters univ =
    (λ _ → refl _ , refl _)
  , (λ _ → refl _ , refl _)


------------------------------------------------------------------------------
-- Testing Agda internal term: @Con@
------------------------------------------------------------------------------

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

-- The following hint uses the internal Agda term @Con@.

module AgdaInternalTerms.ConTerm where

-- We add 3 to the fixities of the standard library.
infixl 9 _+_
infix  7 _≡_

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

data ℕ : Set where
  zero :     ℕ
  succ : ℕ → ℕ

data _≡_ (n : ℕ) : ℕ → Set where
  refl : n ≡ n

_+_ : ℕ → ℕ → ℕ
zero   + n = n
succ m + n = succ (m + n)

+-0x : ∀ n → zero + n ≡ n
+-0x n = refl
{-# ATP hint +-0x #-}

postulate foo : ∀ n → zero + n ≡ n
{-# ATP prove foo #-}


module Function.Domains.Proofs where


------------------------------------------------------------------------
-- A parser for PBM images; illustrates essential use of bind
------------------------------------------------------------------------

-- Note that I am using the simple "Plain PBM" format, and I try to
-- adhere to the following statement from the pbm man page:
--
--   "Programs that read this format should be as lenient as possible,
--   accepting anything that looks remotely like a bitmap."

-- The idea to write this particular parser was taken from "The Power
-- of Pi" by Oury and Swierstra.

module RecursiveDescent.Hybrid.PBM where

import Data.Vec as Vec
open Vec using (Vec; _++_; [_])
import Data.List as List
open import Data.Nat
import Data.String as String
open String using (String) renaming (_++_ to _<+>_)
import Data.Char as Char
open Char using (Char; _==_)
open import Data.Product.Record
open import Data.Function
open import Data.Bool
open import Data.Unit
open import Data.Maybe
import Data.Nat.Show as N
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality using (_≡_; refl)

open import RecursiveDescent.Index
open import RecursiveDescent.Hybrid
open import RecursiveDescent.Hybrid.Lib
open Token Char.decSetoid
open import RecursiveDescent.Hybrid.Simple

------------------------------------------------------------------------
-- The PBM type

data Colour : Set where
  white : Colour
  black : Colour

Matrix : Set -> ℕ -> ℕ -> Set
Matrix a rows cols = Vec (Vec a cols) rows

record PBM : Set where
  field
    rows   : ℕ
    cols   : ℕ
    matrix : Matrix Colour rows cols

open PBM

makePBM : forall {rows cols} -> Matrix Colour rows cols -> PBM
makePBM m = record { rows = _; cols = _; matrix = m }

------------------------------------------------------------------------
-- Showing PBM images

showColour : Colour -> Char
showColour white = '0'
showColour black = '1'

show : PBM -> String
show i = "P1 # Generated using Agda.\n" <+>
         N.show (cols i) <+> " " <+> N.show (rows i) <+> "\n" <+>
         showMatrix (matrix i)
  where
  showMatrix = String.fromList ∘
               Vec.toList ∘
               Vec.concat ∘
               Vec.map ((\xs -> xs ++ [ '\n' ]) ∘ Vec.map showColour)

------------------------------------------------------------------------
-- Parsing PBM images

data NT : ParserType where
  comment : NT _ ⊤
  colour  : NT _ Colour
  pbm     : NT _ PBM

grammar : Grammar Char NT
grammar comment  = tt <$ sym '#' <⊛ sat' (not ∘ _==_ '\n') ⋆ <⊛ sym '\n'
grammar colour   = white <$ sym '0'
                 ∣ black <$ sym '1'
grammar pbm      =
  w∣c ⋆ ⊛>
  string (String.toVec "P1") ⊛>
  w∣c ⋆ ⊛>
  number !>>= \cols ->  -- _>>=_ works just as well.
  w∣c + ⊛>
  number >>=  \rows ->  -- _!>>=_ works just as well.
  w∣c ⊛>
  (makePBM <$> exactly rows (exactly cols (w∣c ⋆ ⊛> ! colour))) <⊛
  any ⋆
  where w∣c = whitespace ∣ ! comment

module Example where

  open Vec

  image = makePBM ((white ∷ black ∷ []) ∷
                   (black ∷ white ∷ []) ∷
                   (black ∷ black ∷ []) ∷ [])

  ex₁ : parse-complete (! pbm) grammar (String.toList (show image)) ≡
        List.[_] image
  ex₁ = refl


{-# OPTIONS --safe #-}
{-
This file has been split in two due to slow type checking
combined with insufficient reductions when the
experimental-lossy-unification flag is included.
Part 2: Cubical.Homotopy.Group.Pi4S3.S3PushoutIso2

The goal of these two files is to show that
π₄(S³) ≅ π₃((S² × S²) ⊔ᴬ S²) where A = S² ∨ S².
This is proved in Brunerie (2016) using the James construction and
via (S² × S²) ⊔ᴬ S² ≃ J₂(S²).

In this file, we prove it directly using the encode-decode method. For
the statement of the isomorphism, see part 2.
-}
module Cubical.Homotopy.Group.Pi4S3.S3PushoutIso where

open import Cubical.Homotopy.Loopspace

open import Cubical.Homotopy.Group.Base
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed
open import Cubical.Foundations.Pointed.Homogeneous
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.GroupoidLaws renaming (assoc to ∙assoc)
open import Cubical.Foundations.Path
open import Cubical.Foundations.Isomorphism
open Iso
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Univalence
open import Cubical.Functions.Morphism

open import Cubical.HITs.SetTruncation
  renaming (rec to sRec ; rec2 to sRec2
          ; elim to sElim ; elim2 to sElim2 ; elim3 to sElim3
          ; map to sMap)
open import Cubical.HITs.Sn
open import Cubical.HITs.Susp renaming (toSusp to σ)
open import Cubical.HITs.S1 hiding (decode ; encode)

open import Cubical.Data.Sigma
open import Cubical.Data.Nat
open import Cubical.Data.Bool

open import Cubical.Algebra.Group
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid

open import Cubical.HITs.Join
open import Cubical.HITs.Pushout
open import Cubical.HITs.Wedge
open import Cubical.Homotopy.Freudenthal hiding (Code ; encode)
open import Cubical.Homotopy.Connected
open import Cubical.HITs.Truncation renaming
  (rec to trRec ; elim to trElim ; elim2 to trElim2 ; map to trMap)
open import Cubical.Foundations.Function
open import Cubical.HITs.S2

Pushout⋁↪fold⋁ : ∀ {ℓ} (A : Pointed ℓ) → Type ℓ
Pushout⋁↪fold⋁ A = Pushout {A = A ⋁ A} ⋁↪ fold⋁

Pushout⋁↪fold⋁∙ : ∀ {ℓ} (A : Pointed ℓ) → Pointed ℓ
fst (Pushout⋁↪fold⋁∙ A) = Pushout⋁↪fold⋁ A
snd (Pushout⋁↪fold⋁∙ A) = inl (pt A , pt A)

-- The type of interest -- ''almost`` equivalent to ΩS³
Pushout⋁↪fold⋁S₊2 = Pushout {A = S₊∙ 2 ⋁ S₊∙ 2} ⋁↪ fold⋁
-- Same type, using base/surf definition of S² (easier to work with)
Pushout⋁↪fold⋁S² = Pushout⋁↪fold⋁ S²∙
-- Truncated version, to be proved equivalent to ∥ ΩS³ ∥₅
∥Pushout⋁↪fold⋁S²∥₅ = hLevelTrunc 5 Pushout⋁↪fold⋁S²

Ω∥S³∥₆ = Path (hLevelTrunc 6 (Susp S²)) ∣ north ∣ ∣ north ∣

-- Elimination into sets for Pushout⋁↪fold⋁S²
module _ {ℓ : Level} {P : Pushout⋁↪fold⋁S² → Type ℓ}
         (hlev : ((x : Pushout⋁↪fold⋁S²) → isSet (P x)))
         (b : P (inl (base , base))) where
  private
    ×fun : (x y : S²) → P (inl (x , y))
    ×fun = S²ToSetElim (λ _ → isSetΠ (λ _ → hlev _))
            (S²ToSetElim (λ _ → hlev _) b)

    inrfun : (x : S²) → P (inr x)
    inrfun = S²ToSetElim (λ _ → hlev _) (subst P (push (inl base)) b)

    inl-pp : (x : S²) → PathP (λ i → P (push (inl x) i)) (×fun x base) (inrfun x)
    inl-pp = S²ToSetElim (λ _ → isOfHLevelPathP 2 (hlev _) _ _)
              λ j → transp (λ i → P (push (inl base) (i ∧ j))) (~ j) b

    inr-pp : (x : S²) → PathP (λ i → P (push (inr x) i)) (×fun base x) (inrfun x)
    inr-pp = S²ToSetElim (λ _ → isOfHLevelPathP 2 (hlev _) _ _)
              (transport (λ j → PathP (λ i → P (push (push tt j) i)) (×fun base base)
                                       (inrfun base))
              (inl-pp base))

  Pushout⋁↪fold⋁S²→Set : (x : Pushout⋁↪fold⋁S²) → P x
  Pushout⋁↪fold⋁S²→Set (inl x) = ×fun (fst x) (snd x)
  Pushout⋁↪fold⋁S²→Set (inr x) = inrfun x
  Pushout⋁↪fold⋁S²→Set (push (inl x) i) = inl-pp x i
  Pushout⋁↪fold⋁S²→Set (push (inr x) i) = inr-pp x i
  Pushout⋁↪fold⋁S²→Set (push (push a j) i) = help j i
    where
    help : SquareP (λ j i → P (push (push tt j) i))
                   (λ i → inl-pp base i)
                   (λ i → inr-pp base i)
                   (λ _ → ×fun base base)
                   (λ _ → inrfun base)
    help = toPathP (isProp→PathP (λ _ → isOfHLevelPathP' 1 (hlev _) _ _) _ _)

{- A wedge connectivity lemma for Pushout⋁↪fold⋁S². It can be
stated for general dependent types, but it's easier to work with
in the special case of path types -}
module Pushout⋁↪fold⋁S²WedgeCon {ℓ : Level } {A : Type ℓ}
  (f g : Pushout⋁↪fold⋁S² → A)
  (h : isOfHLevel 5 A)
  (lp : (x : S²) → f (inl (x , base)) ≡ g (inl (x , base)))
  (rp : (x : S²) → f (inl (base , x)) ≡ g (inl (base , x)))
  (r≡l : (x : S²)
       → (sym (cong f (push (inl x))) ∙∙ lp x ∙∙ cong g (push (inl x)))
        ≡ (sym (cong f (push (inr x))) ∙∙ rp x ∙∙ cong g (push (inr x))))
  where
  btm-filler : I → I → I → A
  btm-filler k i j =
    hfill (λ k → λ {(i = i0)
                   → doubleCompPath-filler (sym (cong f (push (inl base))))
                                            (lp base)
                                            (cong g (push (inl base))) (~ k) j
                   ; (i = i1)
                   → doubleCompPath-filler (sym (cong f (push (inr base))))
                                            (rp base)
                                            (cong g (push (inr base))) (~ k) j
                   ; (j = i0) → f (push (push tt i) (~ k))
                   ; (j = i1) → g (push (push tt i) (~ k))})
      (inS (r≡l base i j))
      k

  lp-base≡rp-base : lp base ≡ rp base
  lp-base≡rp-base = (λ i j → btm-filler i1 i j)

  f∘inl≡g∘inl : (x y : S²) → f (inl (x , y)) ≡ g (inl (x , y))
  f∘inl≡g∘inl = wedgeconFunS² (λ _ _ → h _ _) lp rp lp-base≡rp-base

  f∘inl≡g∘inl-base : (x : S²) → f∘inl≡g∘inl x base ≡ lp x
  f∘inl≡g∘inl-base = wedgeconFunS²Id (λ _ _ → h _ _) lp rp lp-base≡rp-base

  f∘inr≡g∘inr : (x : S²) → f (inr x) ≡ g (inr x)
  f∘inr≡g∘inr x = cong f (sym (push (inl x))) ∙∙ lp x ∙∙ cong g (push (inl x))

  inlfill : (x : S²) → I → I → I → A
  inlfill x k i j =
    hfill (λ k → λ { (i = i0) → f∘inl≡g∘inl-base x (~ k) j
                    ; (i = i1) → doubleCompPath-filler
                                   (cong f (sym (push (inl x))))
                                   (lp x)
                                   (cong g (push (inl x))) k j
                    ; (j = i0) → f (push (inl x) (i ∧ k))
                    ; (j = i1) → g (push (inl x) (i ∧ k))})
          (inS (lp x j))
          k

  inrfill : (x : S²) → I → I → I → A
  inrfill x k i j =
    hfill (λ k → λ { (i = i0) → doubleCompPath-filler
                                   (cong f (sym (push (inr x))))
                                   (rp x)
                                   (cong g (push (inr x))) (~ k) j
                    ; (i = i1) → f∘inr≡g∘inr x j
                    ; (j = i0) → f (push (inr x) (i ∨ ~ k))
                    ; (j = i1) → g (push (inr x) (i ∨ ~ k))})
                      (inS (r≡l x (~ i) j))
                      k

  main : (x : Pushout⋁↪fold⋁S²) → f x ≡ g x
  main (inl x) = f∘inl≡g∘inl (fst x) (snd x)
  main (inr x) = f∘inr≡g∘inr x
  main (push (inl x) i) j = inlfill x i1 i j
  main (push (inr x) i) j = inrfill x i1 i j
  main (push (push a i) j) k =
    hcomp (λ r → λ {(i = i0) → inlfill base i1 j k
                   ; (i = i1) → inrfill-side r j k
                   ; (j = i0) → rp base k
                   ; (j = i1) → r≡l base (~ r ∧ i) k
                   ; (k = i0) → f (push (push a i) j)
                   ; (k = i1) → g (push (push a i) j)})
      (hcomp (λ r → λ {(i = i0) → inlfill base r j k
                   ; (i = i1) → doubleCompPath-filler
                                  (cong f (sym (push (inr base))))
                                  (rp base)
                                  (cong g (push (inr base))) (j ∧ r) k
                   ; (j = i0) → lp-base≡rp-base (r ∨ i) k
                   ; (j = i1) → inlfill-side r i k
                   ; (k = i0) → f (push (push a i) (j ∧ r))
                   ; (k = i1) → g (push (push a i) (j ∧ r))})
              (lp-base≡rp-base i k))
    where
    inlfill-side : I → I → I → A
    inlfill-side r i k =
      hcomp (λ j → λ { (r = i0) → btm-filler j i k
                      ; (r = i1) → r≡l base i k
                      ; (i = i0) → doubleCompPath-filler
                                  (cong f (sym (push (inl base))))
                                  (lp base)
                                  (cong g (push (inl base))) (r ∨ ~ j) k
                      ; (i = i1) → doubleCompPath-filler
                                  (cong f (sym (push (inr base))))
                                  (rp base)
                                  (cong g (push (inr base))) (r ∨ ~ j) k
                      ; (k = i0) → f (push (push a i) (r ∨ ~ j))
                      ; (k = i1) → g (push (push a i) (r ∨ ~ j))})
            (r≡l base i k)

    inrfill-side : I → I → I → A
    inrfill-side r j k =
      hcomp (λ i → λ { (r = i0)
                       → (doubleCompPath-filler
                           (cong f (sym (push (inr base))))
                           (rp base)
                           (cong g (push (inr base)))) (j ∨ ~ i)  k
                      ; (r = i1) → inrfill base i j k
                      ; (j = i0) → inrfill base i i0 k
                      ; (j = i1) → r≡l base (~ r) k
                      ; (k = i0) → f (push (inr base) (j ∨ ~ i))
                      ; (k = i1) → g (push (inr base) (j ∨ ~ i))})
            (r≡l base (~ r ∨ ~ j) k)

{-
Goal: Prove Ω ∥ SuspS² ∥₆ ≃ ∥ Pushout⋁↪fold⋁S² ∥₅
This will by done via the encode-decode method. For this, we nede a family
of equivalences ∥ Pushout⋁↪fold⋁S² ∥₅ ≃ ∥ Pushout⋁↪fold⋁S² ∥₅, indexed by S².
In order to define this, we need the following cubes/coherences in
∥ Pushout⋁↪fold⋁S² ∥₅:
-}

→Ω²∥Pushout⋁↪fold⋁S²∥₅ : (x y : S²)
  → Square {A = ∥Pushout⋁↪fold⋁S²∥₅} (λ _ → ∣ inl (x , y) ∣ₕ)
                            (λ _ → ∣ inl (x , y) ∣ₕ)
                            (λ _ → ∣ inl (x , y) ∣ₕ)
                            (λ _ → ∣ inl (x , y) ∣ₕ)
→Ω²∥Pushout⋁↪fold⋁S²∥₅ =
  wedgeconFunS²
    (λ _ _ → isOfHLevelPath 4 (isOfHLevelTrunc 5 _ _) _ _)
    (λ x → λ i j → ∣ inl (x , surf i j) ∣ₕ)
    (λ x → λ i j → ∣ inl (surf i j , x) ∣ₕ)
    λ r i j → ∣ hcomp (λ k → λ { (i = i0) → push (push tt (~ r)) (~ k)
                               ; (i = i1) → push (push tt (~ r)) (~ k)
                               ; (j = i1) → push (push tt (~ r)) (~ k)
                               ; (j = i0) → push (push tt (~ r)) (~ k)
                               ; (r = i0) → push (inr (surf i j)) (~ k)
                               ; (r = i1) → push (inl (surf i j)) (~ k)})
                     (inr (surf i j)) ∣ₕ

→Ω²∥Pushout⋁↪fold⋁S²∥₅Id : (x : S²)
  → →Ω²∥Pushout⋁↪fold⋁S²∥₅ x base ≡  λ i j → ∣ inl (x , surf i j) ∣ₕ
→Ω²∥Pushout⋁↪fold⋁S²∥₅Id =
  wedgeconFunS²Id
    (λ _ _ → isOfHLevelPath 4 (isOfHLevelTrunc 5 _ _) _ _)
    (λ x → λ i j → ∣ inl (x , surf i j) ∣ₕ)
    (λ x → λ i j → ∣ inl (surf i j , x) ∣ₕ)
    λ r i j → ∣ hcomp (λ k → λ { (i = i0) → push (push tt (~ r)) (~ k)
                               ; (i = i1) → push (push tt (~ r)) (~ k)
                               ; (j = i1) → push (push tt (~ r)) (~ k)
                               ; (j = i0) → push (push tt (~ r)) (~ k)
                               ; (r = i0) → push (inr (surf i j)) (~ k)
                               ; (r = i1) → push (inl (surf i j)) (~ k)})
                     (inr (surf i j)) ∣ₕ

push-inl∙push-inr⁻ : (y : S²) → Path Pushout⋁↪fold⋁S² (inl (y , base)) (inl (base , y))
push-inl∙push-inr⁻ y i = (push (inl y) ∙ sym (push (inr y))) i

push-inl∙push-inr⁻∙ : push-inl∙push-inr⁻ base ≡ refl
push-inl∙push-inr⁻∙ =
    (λ k i → (push (inl base) ∙ sym (push (push tt (~ k)))) i)
  ∙ rCancel (push (inl base))

push-inl∙push-inr⁻-filler : I → I → I → I → Pushout⋁↪fold⋁S²
push-inl∙push-inr⁻-filler r i j k =
  hfill (λ r → λ { (i = i0) → push-inl∙push-inr⁻∙ (~ r) k
                  ; (i = i1) → push-inl∙push-inr⁻∙ (~ r) k
                  ; (j = i0) → push-inl∙push-inr⁻∙ (~ r) k
                  ; (j = i1) → push-inl∙push-inr⁻∙ (~ r) k
                  ; (k = i0) → inl (surf i j , base)
                  ; (k = i1) → inl (surf i j , base)})
        (inS (inl (surf i j , base)))
        r

push-inl∙push-inr⁻-hLevFiller : (y : S²)
        → Cube {A = ∥Pushout⋁↪fold⋁S²∥₅}
                (λ j k → ∣ push-inl∙push-inr⁻ y k ∣)
                (λ j k → ∣ push-inl∙push-inr⁻ y k ∣)
                (λ j k → ∣ push-inl∙push-inr⁻ y k ∣)
                (λ j k → ∣ push-inl∙push-inr⁻ y k ∣)
                (→Ω²∥Pushout⋁↪fold⋁S²∥₅ y (pt (S² , base)))
                λ i j → ∣ inl (surf i j , y) ∣
push-inl∙push-inr⁻-hLevFiller =
  S²ToSetElim (λ _ → isOfHLevelPathP' 2
              (isOfHLevelPathP' 3
                (isOfHLevelPathP' 4 (isOfHLevelTrunc 5) _ _) _ _) _ _)
   λ i j k → ∣ push-inl∙push-inr⁻-filler i1 i j k ∣ₕ

{-
We combine the above definitions. The equivalence
∥Pushout⋁↪fold⋁S²∥₅ ≃ ∥Pushout⋁↪fold⋁S²∥₅ (w.r.t. S²) is induced
by the following function
-}
S²→Pushout⋁↪fold⋁S²↺' : (x : S²) → Pushout⋁↪fold⋁S² → ∥Pushout⋁↪fold⋁S²∥₅
S²→Pushout⋁↪fold⋁S²↺' base (inl (x , y)) = ∣ inl (x , y) ∣
S²→Pushout⋁↪fold⋁S²↺' (surf i j) (inl (x , y)) = →Ω²∥Pushout⋁↪fold⋁S²∥₅ x y i j
S²→Pushout⋁↪fold⋁S²↺' base (inr z) = ∣ inl (base , z) ∣ₕ
S²→Pushout⋁↪fold⋁S²↺' (surf i i₁) (inr z) = ∣ inl (surf i i₁ , z) ∣ₕ
S²→Pushout⋁↪fold⋁S²↺' base (push (inl y) k) =
  ∣ (push (inl y) ∙ sym (push (inr y))) k ∣
S²→Pushout⋁↪fold⋁S²↺' (surf i j) (push (inl y) k) =
  push-inl∙push-inr⁻-hLevFiller y i j k
S²→Pushout⋁↪fold⋁S²↺' base (push (inr y) i) = ∣ inl (base , y) ∣
S²→Pushout⋁↪fold⋁S²↺' (surf i j) (push (inr y) k) = ∣ inl (surf i j , y) ∣
S²→Pushout⋁↪fold⋁S²↺' base (push (push a i₁) i) = ∣ push-inl∙push-inr⁻∙ i₁ i ∣
S²→Pushout⋁↪fold⋁S²↺' (surf i j) (push (push a k) l) =
  ∣ hcomp (λ r → λ { (i = i0) → push-inl∙push-inr⁻∙ (k ∨ ~ r) l
                   ; (i = i1) → push-inl∙push-inr⁻∙ (k ∨ ~ r) l
                   ; (j = i0) → push-inl∙push-inr⁻∙ (k ∨ ~ r) l
                   ; (j = i1) → push-inl∙push-inr⁻∙ (k ∨ ~ r) l
                   ; (k = i0) → push-inl∙push-inr⁻-filler r i j l
                   ; (k = i1) → inl (surf i j , base)
                   ; (l = i0) → inl (surf i j , base)
                   ; (l = i1) → inl (surf i j , base)})
         (inl (surf i j , base)) ∣ₕ

{- For easier treatment later, we state its inverse explicitly -}
S²→Pushout⋁↪fold⋁S²↺'⁻ : (x : S²) → Pushout⋁↪fold⋁S² → ∥Pushout⋁↪fold⋁S²∥₅
S²→Pushout⋁↪fold⋁S²↺'⁻ base y = S²→Pushout⋁↪fold⋁S²↺' base y
S²→Pushout⋁↪fold⋁S²↺'⁻ (surf i j) y = S²→Pushout⋁↪fold⋁S²↺' (surf (~ i) j) y

S²→Pushout⋁↪fold⋁S²↺'≡idfun : (x : _) → S²→Pushout⋁↪fold⋁S²↺' base x ≡ ∣ x ∣
S²→Pushout⋁↪fold⋁S²↺'≡idfun (inl x) = refl
S²→Pushout⋁↪fold⋁S²↺'≡idfun (inr x) = cong ∣_∣ₕ (push (inr x))
S²→Pushout⋁↪fold⋁S²↺'≡idfun (push (inl x) i) j =
  ∣ compPath-filler (push (inl x)) (λ i₁ → push (inr x) (~ i₁)) (~ j) i  ∣ₕ
S²→Pushout⋁↪fold⋁S²↺'≡idfun (push (inr x) i) j = ∣ push (inr x) (j ∧ i) ∣
S²→Pushout⋁↪fold⋁S²↺'≡idfun (push (push a i) j) k =
  ∣ coh-lem {A = Pushout⋁↪fold⋁S²}
    (push (inl base)) (push (inr base)) (λ k → push (push tt k)) i j k ∣ₕ
  where
  coh-lem : ∀ {ℓ} {A : Type ℓ} {x y : A} (p q : x ≡ y) (r : p ≡ q)
       → Cube {A = A}
               (λ j k → compPath-filler p (sym q) (~ k) j) (λ k j → q (k ∧ j))
               (λ i k → x) (λ i k → q k)
               (((λ k → p ∙ sym (r (~ k))) ∙ rCancel p))
               r
  coh-lem {A = A} {x = x} {y = y} =
    J (λ y p → (q : x ≡ y) (r : p ≡ q)
             → Cube {A = A}
                     (λ j k → compPath-filler p (sym q) (~ k) j) (λ k j → q (k ∧ j))
                     (λ i k → x) (λ i k → q k)
                     (((λ k → p ∙ sym (r (~ k))) ∙ rCancel p))
                     r)
      λ q → J (λ q r → Cube (λ j k → compPath-filler refl (λ i → q (~ i)) (~ k) j)
                              (λ k j → q (k ∧ j)) (λ i k → x) (λ i k → q k)
                              ((λ k → refl ∙ (λ i → r (~ k) (~ i))) ∙ rCancel refl) r)
               ((λ z j k → lUnit (sym (rUnit (λ _ → x))) z k j)
               ◁ (λ i j k → (refl ∙ (λ i₁ → rUnit (λ _ → x) (~ i₁))) (k ∨ i) j))

S²→Pushout⋁↪fold⋁S²↺ : (x : S²) → ∥Pushout⋁↪fold⋁S²∥₅ → ∥Pushout⋁↪fold⋁S²∥₅
S²→Pushout⋁↪fold⋁S²↺ x = trRec (isOfHLevelTrunc 5) (S²→Pushout⋁↪fold⋁S²↺' x)

isEq-S²→Pushout⋁↪fold⋁S²↺' : (x : _) → isEquiv (S²→Pushout⋁↪fold⋁S²↺ x)
isEq-S²→Pushout⋁↪fold⋁S²↺' =
  S²ToSetElim (λ _ → isProp→isSet (isPropIsEquiv _))
    (subst isEquiv (funExt id≡) (idIsEquiv _))
  where
  id≡ : (x : _) → x ≡ S²→Pushout⋁↪fold⋁S²↺ base x
  id≡ = trElim (λ _ → isOfHLevelPath 5 (isOfHLevelTrunc 5) _ _)
               (sym ∘ S²→Pushout⋁↪fold⋁S²↺'≡idfun)

S²→Pushout⋁↪fold⋁S²↺⁻¹ : (x : S²) → ∥Pushout⋁↪fold⋁S²∥₅ → ∥Pushout⋁↪fold⋁S²∥₅
S²→Pushout⋁↪fold⋁S²↺⁻¹ x = trRec (isOfHLevelTrunc 5) (S²→Pushout⋁↪fold⋁S²↺'⁻ x)

{- S²→Pushout⋁↪fold⋁S²↺⁻¹ is a section of S²→Pushout⋁↪fold⋁S²↺ -}
secS²→Pushout⋁↪fold⋁S²↺ : (x : S²) (y : ∥Pushout⋁↪fold⋁S²∥₅)
  → S²→Pushout⋁↪fold⋁S²↺ x (S²→Pushout⋁↪fold⋁S²↺⁻¹ x y) ≡ y
secS²→Pushout⋁↪fold⋁S²↺ x =
  trElim (λ _ → isOfHLevelPath 5 (isOfHLevelTrunc 5) _ _)
         (h x)
  where
  h : (x : S²) (a : Pushout⋁↪fold⋁S²)
    → S²→Pushout⋁↪fold⋁S²↺ x
        (S²→Pushout⋁↪fold⋁S²↺⁻¹ x ∣ a ∣) ≡ ∣ a ∣
  h base a = cong (S²→Pushout⋁↪fold⋁S²↺ base)
                  (S²→Pushout⋁↪fold⋁S²↺'≡idfun a)
           ∙ S²→Pushout⋁↪fold⋁S²↺'≡idfun a
  h (surf i j) a k = main a k i j
    where
    side : (a : Pushout⋁↪fold⋁S²) → _
    side a = cong (S²→Pushout⋁↪fold⋁S²↺ base) (S²→Pushout⋁↪fold⋁S²↺'≡idfun a)
          ∙ S²→Pushout⋁↪fold⋁S²↺'≡idfun a

    refl-b : Path ∥Pushout⋁↪fold⋁S²∥₅ _ _
    refl-b = (refl {x = ∣ inl (base , base) ∣ₕ})

    main : (a : Pushout⋁↪fold⋁S²)
      → Cube (λ i j → S²→Pushout⋁↪fold⋁S²↺ (surf i j)
                 (S²→Pushout⋁↪fold⋁S²↺⁻¹ (surf i j) ∣ a ∣))
              (λ _ _ → ∣ a ∣)
              (λ i _ → side a i) (λ i _ → side a i)
              (λ i _ → side a i) (λ i _ → side a i)
    main =
      Pushout⋁↪fold⋁S²→Set (λ _ → isOfHLevelPathP' 2
                  (isOfHLevelPathP' 3 (isOfHLevelTrunc 5 _ _) _ _) _ _)
       λ k i j →
         hcomp (λ r → λ { (i = i0) → rUnit refl-b r k
                         ; (i = i1) → rUnit refl-b r k
                         ; (j = i0) → rUnit refl-b r k
                         ; (j = i1) → rUnit refl-b r k
                         ; (k = i0) → →Ω²∥Pushout⋁↪fold⋁S²∥₅Id
                                        (surf (~ i) j) (~ r) i j
                         ; (k = i1) → μ base base})
               (μ-coh k i j)
      where
      μ : (x y : S²) → ∥Pushout⋁↪fold⋁S²∥₅
      μ x y = ∣ inl (x , y) ∣ₕ

      μUnit : (x : S²) → μ x base ≡ μ base x
      μUnit base = refl
      μUnit (surf i j) k = ∣
        hcomp (λ r → λ {(i = i0) → push (push tt k) (~ r)
                       ; (i = i1) → push (push tt k) (~ r)
                       ; (j = i0) → push (push tt k) (~ r)
                       ; (j = i1) → push (push tt k) (~ r)
                       ; (k = i0) → push (inl (surf i j)) (~ r)
                       ; (k = i1) → push (inr (surf i j)) (~ r)})
               (inr (surf i j)) ∣ₕ

      μ-coh : Path (Square {A = ∥Pushout⋁↪fold⋁S²∥₅}
             (λ _ → ∣ inl (base , base) ∣) (λ _ → ∣ inl (base , base) ∣)
             (λ _ → ∣ inl (base , base) ∣) (λ _ → ∣ inl (base , base) ∣))
             (λ i j → ∣ inl (surf (~ i) j , surf i j) ∣ₕ)
             refl
      μ-coh =
            (cong₂Funct (λ (x y : (Path S² base base)) → cong₂ μ x y) (sym surf) surf
           ∙ cong (_∙ cong (cong (μ base)) surf) (λ i → cong (cong (λ x → μUnit x i)) (sym surf))
           ∙ lCancel (cong (cong (μ base)) surf))

retrS²→Pushout⋁↪fold⋁S²↺ : (x : S²) (y : ∥Pushout⋁↪fold⋁S²∥₅)
  → S²→Pushout⋁↪fold⋁S²↺⁻¹ x (S²→Pushout⋁↪fold⋁S²↺ x y) ≡ y
retrS²→Pushout⋁↪fold⋁S²↺ x =
  trElim (λ _ → isOfHLevelPath 5 (isOfHLevelTrunc 5) _ _)
    (main x)
    where
    main : (x : S²) (a : Pushout⋁↪fold⋁S²)
      → S²→Pushout⋁↪fold⋁S²↺⁻¹ x (S²→Pushout⋁↪fold⋁S²↺ x ∣ a ∣) ≡ ∣ a ∣
    main base a = secS²→Pushout⋁↪fold⋁S²↺ base ∣ a ∣
    main (surf i j) a l = secS²→Pushout⋁↪fold⋁S²↺ (surf (~ i) j) ∣ a ∣ l

∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅ : (x : S²)
  → Iso ∥Pushout⋁↪fold⋁S²∥₅ ∥Pushout⋁↪fold⋁S²∥₅
fun (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅ x) = S²→Pushout⋁↪fold⋁S²↺ x
inv (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅ x) = S²→Pushout⋁↪fold⋁S²↺⁻¹ x
rightInv (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅ x) = secS²→Pushout⋁↪fold⋁S²↺ x
leftInv (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅ x) = retrS²→Pushout⋁↪fold⋁S²↺ x

PreCode : (x : Susp S²) → Type
PreCode north = ∥Pushout⋁↪fold⋁S²∥₅
PreCode south = ∥Pushout⋁↪fold⋁S²∥₅
PreCode (merid a i) = isoToPath (∥Pushout⋁↪fold⋁S²∥₅≃∥Pushout⋁↪fold⋁S²∥₅ a) i

hLevPreCode : (x : Susp S²) → isOfHLevel 5 (PreCode x)
hLevPreCode =
  suspToPropElim base (λ _ → isPropIsOfHLevel 5) (isOfHLevelTrunc 5)

Code : (hLevelTrunc 6 (Susp S²)) → Type ℓ-zero
Code =
  fst ∘ trRec {B = TypeOfHLevel ℓ-zero 5} (isOfHLevelTypeOfHLevel 5)
    λ x → (PreCode x) , (hLevPreCode x)

private
  cong-coherence : ∀ {ℓ} {A : Type ℓ} {x : A} (p : x ≡ x) (r : refl ≡ p)
                  → cong (p ∙_) (sym r) ∙ sym (rUnit p)
                  ≡ cong (_∙ p) (sym r) ∙ sym (lUnit p)
  cong-coherence p = J (λ p r → cong (p ∙_) (sym r) ∙ sym (rUnit p)
                    ≡ cong (_∙ p) (sym r) ∙ sym (lUnit p)) refl

{- The function Pushout⋁↪fold⋁S² → Ω∥S³∥₆ will be the obvious one -}
Pushout⋁↪fold⋁S²→Ω∥S³∥₆ : Pushout⋁↪fold⋁S² → Ω∥S³∥₆
Pushout⋁↪fold⋁S²→Ω∥S³∥₆ (inl x) = cong ∣_∣ₕ (σ S²∙ (fst x) ∙ σ S²∙ (snd x))
Pushout⋁↪fold⋁S²→Ω∥S³∥₆ (inr x) = cong ∣_∣ₕ (σ S²∙ x)
Pushout⋁↪fold⋁S²→Ω∥S³∥₆ (push (inl x) i) j =
  ∣ (cong (σ S²∙ x ∙_) (rCancel (merid base)) ∙ sym (rUnit (σ S²∙ x))) i j ∣ₕ
Pushout⋁↪fold⋁S²→Ω∥S³∥₆ (push (inr x) i) j =
  ∣ (cong (_∙ σ S²∙ x) (rCancel (merid base)) ∙ sym (lUnit (σ S²∙ x))) i j ∣ₕ
Pushout⋁↪fold⋁S²→Ω∥S³∥₆ (push (push a k) i) j =
  ∣ cong-coherence (σ S²∙ base) (sym (rCancel (merid base))) k i j ∣ₕ

{- Truncated version (the equivalence) -}
∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ : ∥Pushout⋁↪fold⋁S²∥₅ → Ω∥S³∥₆
∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ =
  trRec (isOfHLevelTrunc 6 _ _) Pushout⋁↪fold⋁S²→Ω∥S³∥₆

decode' : (x : Susp S²) → Code ∣ x ∣
      → Path (hLevelTrunc 6 (Susp S²)) ∣ north ∣ ∣ x ∣
decode' north p = ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ p
decode' south p = ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ p ∙ cong ∣_∣ₕ (merid base)
decode' (merid a i) = main a i
  where
  baseId : (x : Pushout⋁↪fold⋁S²)
     → ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ (S²→Pushout⋁↪fold⋁S²↺' base x)
      ≡ ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ ∣ x ∣
  baseId x =
    cong ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ (S²→Pushout⋁↪fold⋁S²↺'≡idfun x)

  mainLemma : (a : S²) (x : Pushout⋁↪fold⋁S²)
     → ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ (S²→Pushout⋁↪fold⋁S²↺'⁻ a x)
       ∙ (λ i → ∣ merid a i ∣)
     ≡ ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ ∣ x ∣ ∙ cong ∣_∣ₕ (merid base)
  mainLemma base x = cong (_∙ cong ∣_∣ₕ (merid base)) (baseId x)
  mainLemma (surf i j) x k = surf-filler x k i j
    where
    ∙ΩbaseId :
      (q : typ (Ω (Susp∙ (typ S²∙)))) → q ≡ q ∙ σ S²∙ base
    ∙ΩbaseId q = rUnit q ∙ cong (q ∙_) (sym (rCancel (merid base)))

    cubeCoherence :
      ∀ {ℓ} {A : Type ℓ} {x : A} {p : x ≡ x}
      → (refl ≡ p)
      → (q : Square {A = x ≡ x} (λ _ → p) (λ _ → p) (λ _ → p) (λ _ → p))
      → Cube {A = Path A x x}
              (λ i j → q i j ∙ q (~ i) j) (λ _ _ → p ∙ p)
              (λ k j → p ∙ p) (λ _ _ → p ∙ p)
              (λ _ _ → p ∙ p) λ _ _ → p ∙ p
    cubeCoherence {A = A} {x = x} {p = p} =
      J (λ p _ → (q : Square {A = x ≡ x}
                        (λ _ → p) (λ _ → p) (λ _ → p) (λ _ → p))
               → Cube {A = Path A x x}
                       (λ i j → q i j ∙ q (~ i) j) (λ _ _ → p ∙ p)
                       (λ k j → p ∙ p) (λ _ _ → p ∙ p)
                       (λ _ _ → p ∙ p) λ _ _ → p ∙ p)
      (λ q →
        (cong₂Funct (λ (x y : Path (x ≡ x) refl refl) → cong₂ _∙_ x y) q (sym q)
      ∙ transport
         (λ i → cong (λ (p : (refl {x = x}) ≡ refl) k → rUnit (p k) i) q
               ∙ cong (λ (p : (refl {x = x}) ≡ refl) k → lUnit (p k) i) (sym q)
               ≡ refl {x = refl {x = lUnit (refl {x = x}) i}})
         (rCancel q)))

    surf-side : (i j r l : I) → hLevelTrunc 6 (Susp S²)
    surf-side i j r l =
      ((cong ∣_∣ₕ (∙ΩbaseId (σ S²∙ (surf (~ i) j)) r))
      ∙ cong ∣_∣ₕ (compPath-filler (merid (surf i j))
                  (sym (merid base)) (~ r))) l

    side : (r l : I) → hLevelTrunc 6 (Susp S²)
    side r l =
      ((cong ∣_∣ₕ (∙ΩbaseId (σ S²∙ base) r))
      ∙ cong ∣_∣ₕ (compPath-filler (merid base)
                  (sym (merid base)) (~ r))) l

    surf-filler : (x : Pushout⋁↪fold⋁S²)
      → Cube {A = Path (hLevelTrunc 6 (Susp S²)) ∣ north ∣ ∣ south ∣}
              (λ i j → ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆
                         (S²→Pushout⋁↪fold⋁S²↺' (surf (~ i) j) x)
                       ∙ (λ k → ∣ merid (surf i j) k ∣))
              (λ _ _ → ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ ∣ x ∣
                      ∙ cong ∣_∣ₕ (merid base))
              (λ k j → baseId x k ∙ (λ i₂ → ∣ merid base i₂ ∣))
              (λ k j → baseId x k ∙ (λ i₂ → ∣ merid base i₂ ∣))
              (λ k i → baseId x k ∙ (λ i₂ → ∣ merid base i₂ ∣))
              (λ k i → baseId x k ∙ (λ i₂ → ∣ merid base i₂ ∣))
    surf-filler =
      Pushout⋁↪fold⋁S²→Set
       (λ _ → isOfHLevelPathP' 2
        (isOfHLevelPathP' 3 (isOfHLevelTrunc 6 _ _ _ _) _ _) _ _)
         (λ k i j l → hcomp (λ r
           → λ {(i = i0) → surf-side i0 i0 r l
               ; (i = i1) → surf-side i0 i0 r l
               ; (j = i0) → surf-side i0 i0 r l
               ; (j = i1) → surf-side i0 i0 r l
               ; (k = i0) → surf-side i j r l
               ; (k = i1) → surf-side i0 i0 r l
               ; (l = i0) → ∣ north ∣ₕ
               ; (l = i1) → ∣ merid base r ∣ₕ})
      (cubeCoherence {p = cong ∣_∣ₕ (σ (S²∙) base)}
        (cong (cong ∣_∣ₕ) (sym (rCancel (merid base))))
        (λ i j k → ∣ σ S²∙ (surf (~ i) j) k ∣ₕ) k i j l))

  main : (a : S²)
    → PathP (λ i → Code ∣ merid a i ∣
                  → Path (hLevelTrunc 6 (Susp S²)) ∣ north ∣ ∣ merid a i ∣)
                        ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆
                        λ x → ∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆ x
                             ∙ cong ∣_∣ₕ (merid base)
  main a =
    toPathP (funExt
      (trElim (λ _ → isOfHLevelSuc 4 (isOfHLevelTrunc 6 _ _ _ _))
       (λ x
      → (λ j → transp (λ i → Path
                 (hLevelTrunc 6 (Susp S²)) ∣ north ∣ ∣ merid a (i ∨ j) ∣) j
                  (compPath-filler
                   (∥Pushout⋁↪fold⋁S²∥₅→Ω∥S³∥₆
                    (S²→Pushout⋁↪fold⋁S²↺'⁻ a (transportRefl x j)))
                     (cong ∣_∣ₕ (merid a)) j))
      ∙ mainLemma a x)))

decode : (x : hLevelTrunc 6 (Susp S²))
  → Code x → Path (hLevelTrunc 6 (Susp S²)) ∣ north ∣ x
decode =
  trElim (λ _ → isOfHLevelΠ 6 λ _ → isOfHLevelPath 6 (isOfHLevelTrunc 6) _ _)
         decode'

decode∙ : decode ∣ north ∣ ∣ inl (base , base) ∣ ≡ refl
decode∙ =
  cong (cong ∣_∣ₕ) (cong (λ x → x ∙ x) (rCancel (merid base)) ∙ sym (rUnit refl))

encode : (x : hLevelTrunc 6 (Susp S²))
  → Path (hLevelTrunc 6 (Susp S²)) ∣ north ∣ x → Code x
encode x p = subst Code p ∣ inl (base , base) ∣

encode-decode : (x : hLevelTrunc 6 (Susp S²))
  → (p : ∣ north ∣ ≡ x) → decode x (encode x p) ≡ p
encode-decode x = J (λ x p → decode x (encode x p) ≡ p)
              (cong (decode ∣ north ∣) (transportRefl ∣ inl (base , base) ∣ₕ)
             ∙ decode∙)

decode-encode : (p : Code ∣ north ∣) → encode ∣ north ∣ (decode ∣ north ∣ p) ≡ p
decode-encode =
  trElim (λ _ → isOfHLevelPath 5 (isOfHLevelTrunc 5) _ _)
    (Pushout⋁↪fold⋁S²WedgeCon.main ((λ a → encode ∣ north ∣ (decode ∣ north ∣ ∣ a ∣))) ∣_∣ₕ
      (isOfHLevelTrunc 5)
      (λ x → cong (encode ∣ north ∣) (cong (cong ∣_∣ₕ) (cong (σ S²∙ x ∙_)
               (rCancel (merid base)) ∙ sym (rUnit (σ S²∙ x))))
             ∙ surf-filler x)
      (λ x → (cong (encode ∣ north ∣) (cong (cong ∣_∣ₕ) (cong (_∙ σ S²∙ x)
               (rCancel (merid base)) ∙ sym (lUnit (σ S²∙ x))))
             ∙ surf-filler x
             ∙ cong ∣_∣ₕ (push (inl x)) ∙ cong ∣_∣ₕ (sym (push (inr x)))))
      λ x → lem (encode ∣ north ∣)
                (cong (decode ∣ north ∣) (cong ∣_∣ₕ (push (inl x))))
                ((cong (decode ∣ north ∣) (cong ∣_∣ₕ (push (inr x)))))
                (surf-filler x) (cong ∣_∣ₕ (push (inl x))) (cong ∣_∣ₕ (sym (push (inr x)))))
  where
  subber = transport (λ j → Code ∣ merid base (~ j) ∣ₕ)

  lem : ∀ {ℓ} {A B : Type ℓ} {x x' y : A} {l w u : B}
       (f : A → B) (p : x ≡ y) (p' : x' ≡ y) (q : f y ≡ l)
       (r : l ≡ w) (r' : w ≡ u)
     → cong f (sym p) ∙∙ cong f p ∙ q ∙∙ r
     ≡ (cong f (sym p') ∙∙ (cong f p' ∙ q ∙ (r ∙ r')) ∙∙ sym r')
  lem {x = x} {x' = x'} {y = y'} {l = l} {w = w} {u = u} f p p' q r r' =
      (λ i → (λ j → f (p (~ j ∨ i))) ∙∙ (λ j → f (p (j ∨ i))) ∙ q ∙∙ r)
   ∙∙ (λ i → (λ j → f (p' (~ j ∨ ~ i))) ∙∙ (λ j → f (p' (j ∨ ~ i)))
            ∙ compPath-filler q r i ∙∙ λ j → r (i ∨ j))
   ∙∙ λ i → cong f (sym p') ∙∙ cong f p' ∙ q
            ∙ compPath-filler r r' i ∙∙ λ j → r' (~ j ∧ i)

  mainId : (x : S²)
    → (S²→Pushout⋁↪fold⋁S²↺' x (inl (base , base))) ≡ ∣ inl (x , base) ∣ₕ
  mainId base = refl
  mainId (surf i i₁) = refl

  surf-filler : (x : S²)
    → encode ∣ north ∣ (λ i → ∣ σ S²∙ x i ∣) ≡ ∣ inl (x , base) ∣
  surf-filler x =
       (λ i → transp (λ j →  Code (∣ merid base (i ∧ ~ j) ∣ₕ)) (~ i)
                   (encode ∣ merid base i ∣
                    λ j → ∣ compPath-filler
                             (merid x) (sym (merid base)) (~ i) j ∣ₕ))
     ∙ cong subber
        (transportRefl (S²→Pushout⋁↪fold⋁S²↺' x (inl (base , base)))
       ∙ mainId x)

IsoΩ∥SuspS²∥₅∥Pushout⋁↪fold⋁S²∥₅ :
  Iso (hLevelTrunc 5 (typ (Ω (Susp∙ S²))))
      (hLevelTrunc 5 Pushout⋁↪fold⋁S²)
IsoΩ∥SuspS²∥₅∥Pushout⋁↪fold⋁S²∥₅ =
  compIso (invIso (PathIdTruncIso _)) is
  where
  is : Iso _ _
  fun is = encode ∣ north ∣
  inv is = decode ∣ north ∣
  rightInv is = decode-encode
  leftInv is = encode-decode ∣ north ∣


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

open import Categories.Category using (Category)
open import Categories.Category.Monoidal using (Monoidal)
open import Categories.Category.Monoidal.Closed using (Closed)

module Categories.Category.Monoidal.Closed.IsClosed.L
  {o ℓ e} {C : Category o ℓ e} {M : Monoidal C} (Cl : Closed M) where

open import Data.Product using (_,_)
open import Function using (_$_) renaming (_∘_ to _∙_)
open import Function.Equality as Π using (Π)

open import Categories.Morphism.Reasoning C
  using (pull-last; pull-first; pullˡ; pushˡ; center; center⁻¹; pullʳ)
open import Categories.Functor using (Functor)
open import Categories.Functor.Bifunctor.Properties

open Closed Cl
open Category C
open HomReasoning

private
  module ℱ = Functor
  α⇒ = associator.from
  α⇐ = associator.to
  module ⊗ = Functor ⊗

open Π.Π
open adjoint renaming (unit to η; counit to ε; Ladjunct to 𝕃; Ladjunct-comm′ to 𝕃-comm′;
 Ladjunct-resp-≈ to 𝕃-resp-≈)

L : (X Y Z : Obj) → [ Y , Z ]₀ ⇒ [ [ X , Y ]₀ , [ X , Z ]₀ ]₀
L X Y Z = 𝕃 (𝕃 (ε.η Z ∘ (id ⊗₁ ε.η Y) ∘ α⇒))

private
  [g]₁         : {W Z Z′ : Obj} {g : Z ⇒ Z′} → [ W , Z ]₀ ⇒ [ W , Z′ ]₀
  [g]₁ {g = g} = [ id , g ]₁

  push-α⇒-right : {X Y Z Z′ : Obj} {g : Z ⇒ Z′} → (ε.η Z′ ∘ (id ⊗₁ ε.η {X} Y) ∘ α⇒) ∘ ([g]₁ ⊗₁ id) ⊗₁ id ≈ (g ∘ ε.η Z) ∘ (id ⊗₁ ε.η Y) ∘ α⇒
  push-α⇒-right {X} {Y} {Z} {Z′} {g} = begin
   (ε.η Z′ ∘ (id ⊗₁ ε.η {X} Y) ∘ α⇒) ∘ ([g]₁ ⊗₁ id) ⊗₁ id   ≈⟨ pull-last assoc-commute-from ⟩
   ε.η Z′ ∘ (id ⊗₁ ε.η {X} Y) ∘ ([g]₁ ⊗₁ (id ⊗₁ id)) ∘ α⇒   ≈⟨ refl⟩∘⟨ refl⟩∘⟨ ℱ.F-resp-≈ ⊗ (refl , ⊗.identity) ⟩∘⟨refl ⟩
   ε.η Z′ ∘ (id ⊗₁ ε.η Y) ∘ [g]₁ ⊗₁ id ∘ α⇒                 ≈⟨ refl⟩∘⟨ pullˡ [ ⊗ ]-commute ⟩
   ε.η Z′ ∘ ([g]₁ ⊗₁ id ∘ (id ⊗₁ ε.η Y)) ∘ α⇒               ≈⟨ pull-first (ε.commute g) ⟩
   (g ∘ ε.η Z) ∘ (id ⊗₁ ε.η Y) ∘ α⇒                          ∎

L-g-swap : {X Y Z Z′ : Obj} {g : Z ⇒ Z′} → L X Y Z′ ∘  [ id , g ]₁ ≈ [ [ id , id ]₁ , [ id , g ]₁ ]₁ ∘ L X Y Z
L-g-swap {X} {Y} {Z} {Z′} {g} = begin
  L X Y Z′ ∘  [g]₁                                              ≈˘⟨ 𝕃-comm′ ⟩
  𝕃 (𝕃 (ε.η Z′ ∘ (id ⊗₁ ε.η Y) ∘ α⇒) ∘ [g]₁ ⊗₁ id)             ≈˘⟨ 𝕃-resp-≈ 𝕃-comm′ ⟩
  𝕃 (𝕃 $ (ε.η Z′ ∘ (id ⊗₁ ε.η Y) ∘ α⇒) ∘ ([g]₁ ⊗₁ id) ⊗₁ id)  ≈⟨ 𝕃-resp-≈ $ 𝕃-resp-≈ push-α⇒-right ⟩
  𝕃 (𝕃 $ (g ∘ ε.η Z) ∘ (id ⊗₁ ε.η Y) ∘ α⇒)                     ≈⟨ 𝕃-resp-≈ $ pushˡ $ X-resp-≈ assoc ○ ℱ.homomorphism [ X ,-] ⟩
  𝕃 ([ id , g ]₁ ∘ 𝕃 (ε.η Z ∘ (id ⊗₁ ε.η Y) ∘ α⇒))             ≈⟨ pushˡ (ℱ.homomorphism [ XY ,-]) ⟩
  [ id , [g]₁ ]₁ ∘ L X Y Z                                      ≈˘⟨ [-,-].F-resp-≈ ([-,-].identity , refl) ⟩∘⟨refl ⟩
  [ [ id , id ]₁ , [g]₁ ]₁ ∘ L X Y Z                            ∎
  where
  XY        = [ X , Y ]₀
  X-resp-≈  = ℱ.F-resp-≈ [ X ,-]

L-f-swap : {X Y Y′ Z : Obj} {f : Y′ ⇒ Y} → L X Y′ Z ∘ [ f , id ]₁ ≈ [ [ id , f ]₁ , [ id , id ]₁ ]₁ ∘ L X Y Z
L-f-swap {X} {Y} {Y′} {Z} {f} = begin
  L X Y′ Z ∘ [fˡ]₁                                        ≈˘⟨ 𝕃-comm′ ⟩
  𝕃 (𝕃 inner-L ∘ [fˡ]₁ ⊗₁ id)                             ≈˘⟨ 𝕃-resp-≈ 𝕃-comm′ ⟩
  𝕃 (𝕃 (inner-L ∘ ([fˡ]₁ ⊗₁ id) ⊗₁ id))                  ≈⟨ 𝕃-resp-≈ $ 𝕃-resp-≈ fˡ⇒fʳ ⟩
  𝕃 (𝕃 $ inner-L ∘ (id ⊗₁ [fʳ]₁) ⊗₁ id)                  ≈⟨ 𝕃-resp-≈ $ ∘-resp-≈ˡ $ ℱ.homomorphism [ X ,-] ⟩
  𝕃 (([ id , inner-L ]₁ ∘ [ id , (id ⊗₁ [fʳ]₁) ⊗₁ id ]₁)
           ∘ η.η (YZ ⊗₀ XY′))                             ≈⟨ 𝕃-resp-≈ $ pullʳ (⟺ (η.commute _)) ○ (⟺ assoc) ⟩
  𝕃 (𝕃 inner-L ∘ id ⊗₁ [fʳ]₁)                             ≈⟨ ℱ.homomorphism [ XY′ ,-] ⟩∘⟨refl ⟩
  ([ id , 𝕃 inner-L ]₁ ∘ [ id , id ⊗₁ [fʳ]₁ ]₁) ∘ η.η YZ  ≈⟨ pullʳ (mate.commute₁ [fʳ]₁) ⟩
  [ id , 𝕃 inner-L ]₁ ∘ [ [fʳ]₁ , id ]₁ ∘ η.η YZ          ≈⟨ pullˡ [ [-,-] ]-commute ○ assoc ○ ∘-resp-≈ˡ ([-,-].F-resp-≈ (refl , ⟺ [-,-].identity)) ⟩
  [ [fʳ]₁ , [ id , id ]₁ ]₁ ∘ L X Y Z                           ∎
  where
  XY′        = [ X , Y′ ]₀
  YZ         = [ Y , Z ]₀
  [fʳ]₁      : ∀ {W} → [ W , Y′ ]₀ ⇒ [ W , Y ]₀
  [fʳ]₁      = [ id , f ]₁
  [fˡ]₁      : ∀ {W} → [ Y , W ]₀ ⇒ [ Y′ , W ]₀
  [fˡ]₁      = [ f , id ]₁
  inner-L     : ∀ {W} → ([ W , Z ]₀ ⊗₀ [ X , W ]₀) ⊗₀ X ⇒ Z
  inner-L {W} = ε.η Z ∘ id ⊗₁ ε.η {X} W ∘ α⇒

  fˡ⇒fʳ : inner-L {Y′} ∘ ([fˡ]₁ ⊗₁ id) ⊗₁ id ≈ inner-L {Y} ∘ (id ⊗₁ [fʳ]₁) ⊗₁ id
  fˡ⇒fʳ = begin
    inner-L ∘ ([fˡ]₁ ⊗₁ id) ⊗₁ id                      ≈⟨ pull-last assoc-commute-from ⟩
    ε.η Z ∘ (id ⊗₁ ε.η Y′) ∘ [fˡ]₁ ⊗₁ id ⊗₁ id ∘ α⇒   ≈⟨ ∘-resp-≈ʳ $ pullˡ
                                                          (∘-resp-≈ʳ (ℱ.F-resp-≈ ⊗ (refl , ⊗.identity)) ○ [ ⊗ ]-commute) ⟩
    ε.η Z ∘ ([fˡ]₁ ⊗₁ id ∘ id ⊗₁ ε.η Y′) ∘ α⇒          ≈⟨ pull-first (mate.commute₂ f) ⟩
    (ε.η Z ∘ id ⊗₁ f) ∘ id ⊗₁ ε.η Y′ ∘ α⇒              ≈⟨ center $ ⟺ (ℱ.homomorphism (YZ ⊗-)) ⟩
    ε.η Z ∘ id ⊗₁ (f ∘ ε.η Y′) ∘ α⇒                    ≈⟨ ∘-resp-≈ʳ $ ∘-resp-≈ˡ $ ℱ.F-resp-≈ (YZ ⊗-) $ ⟺ (ε.commute f) ⟩
    ε.η Z ∘ id ⊗₁ (ε.η Y ∘ [fʳ]₁ ⊗₁ id) ∘ α⇒           ≈⟨ ∘-resp-≈ʳ $ ∘-resp-≈ˡ $ ℱ.homomorphism (YZ ⊗-) ⟩
    ε.η Z ∘ (id ⊗₁ ε.η Y ∘ id ⊗₁ [fʳ]₁ ⊗₁ id) ∘ α⇒     ≈⟨ (center⁻¹ refl (⟺ assoc-commute-from)) ○ pullˡ assoc ⟩
    inner-L ∘ (id ⊗₁ [fʳ]₁) ⊗₁ id ∎


{-# OPTIONS --cubical #-}

module Demos.Printf where

open import Data.List
open import Data.String
open import Prelude
open import Data.Nat.Show

data Fstr : Type where
  [] : Fstr
  %s_ : Fstr → Fstr
  %i_ : Fstr → Fstr
  _∷_ : Char → Fstr → Fstr

parse : String → Fstr
parse = go ∘ unpack
  where
  go : List Char → Fstr
  go ('%' ∷ 's' ∷ xs) = %s go xs
  go ('%' ∷ 'i' ∷ xs) = %i go xs
  go [] = []
  go (x ∷ xs) = x ∷ go xs

Format : Fstr → Type
Format [] = String
Format (%s xs) = String → Format xs
Format (%i xs) = ℕ → Format xs
Format (x ∷ xs) = Format xs

format : (xs : Fstr) → Format xs
format = go pack
  where
  go : (List Char → String) → (xs : Fstr) → Format xs
  go k [] = k []
  go k (%s xs) s = go (k ∘ (unpack s ++_)) xs
  go k (%i xs) i = go (k ∘ (unpack (showℕ i) ++_)) xs
  go k (x ∷ xs)  = go (k ∘ (x ∷_)) xs

printf : (fstr : String) → Format (parse fstr)
printf fstr = format (parse fstr)

-- Example:
--
-- >>> printf "%s, %i: %s" "hello" 2 "you"
-- "hello, 2: you"


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommRing.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP
open import Cubical.Foundations.Powerset

open import Cubical.Data.Sigma
open import Cubical.Data.Nat renaming ( _+_ to _+ℕ_ ; _·_ to _·ℕ_
                                      ; ·-assoc to ·ℕ-assoc ; ·-comm to ·ℕ-comm)

open import Cubical.Structures.Axioms
open import Cubical.Structures.Auto
open import Cubical.Structures.Macro
open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing.Base

private
  variable
    ℓ : Level

module Units (R' : CommRing ℓ) where
 open CommRingStr (snd R')
 open RingTheory (CommRing→Ring R')
 private R = fst R'

 inverseUniqueness : (r : R) → isProp (Σ[ r' ∈ R ] r · r' ≡ 1r)
 inverseUniqueness r (r' , rr'≡1) (r'' , rr''≡1) = Σ≡Prop (λ _ → is-set _ _) path
  where
  path : r' ≡ r''
  path = r'             ≡⟨ sym (·Rid _) ⟩
         r' · 1r        ≡⟨ cong (r' ·_) (sym rr''≡1) ⟩
         r' · (r · r'') ≡⟨ ·Assoc _ _ _ ⟩
         (r' · r) · r'' ≡⟨ cong (_· r'') (·Comm _ _) ⟩
         (r · r') · r'' ≡⟨ cong (_· r'') rr'≡1 ⟩
         1r · r''       ≡⟨ ·Lid _ ⟩
         r''            ∎

 Rˣ : ℙ R
 Rˣ r = (Σ[ r' ∈ R ] r · r' ≡ 1r) , inverseUniqueness r

 -- some notation using instance arguments
 _⁻¹ : (r : R) → ⦃ r ∈ Rˣ ⦄ → R
 _⁻¹ r ⦃ r∈Rˣ ⦄ = r∈Rˣ .fst

 infix 9 _⁻¹

 -- some results about inverses
 ·-rinv : (r : R) ⦃ r∈Rˣ : r ∈ Rˣ ⦄ → r · r ⁻¹ ≡ 1r
 ·-rinv r ⦃ r∈Rˣ ⦄ = r∈Rˣ .snd

 ·-linv : (r : R) ⦃ r∈Rˣ : r ∈ Rˣ ⦄ → r ⁻¹ · r ≡ 1r
 ·-linv r ⦃ r∈Rˣ ⦄ = ·Comm _ _ ∙ r∈Rˣ .snd

 RˣMultClosed : (r r' : R) ⦃ r∈Rˣ : r ∈ Rˣ ⦄ ⦃ r'∈Rˣ : r' ∈ Rˣ ⦄
              → (r · r') ∈ Rˣ
 RˣMultClosed r r' = (r ⁻¹ · r' ⁻¹) , path
  where
  path : r · r' · (r ⁻¹ · r' ⁻¹) ≡ 1r
  path = r · r' · (r ⁻¹ · r' ⁻¹) ≡⟨ cong (_· (r ⁻¹ · r' ⁻¹)) (·Comm _ _) ⟩
         r' · r · (r ⁻¹ · r' ⁻¹) ≡⟨ ·Assoc _ _ _ ⟩
         r' · r · r ⁻¹ · r' ⁻¹   ≡⟨ cong (_· r' ⁻¹) (sym (·Assoc _ _ _)) ⟩
         r' · (r · r ⁻¹) · r' ⁻¹ ≡⟨ cong (λ x → r' · x · r' ⁻¹) (·-rinv _) ⟩
         r' · 1r · r' ⁻¹         ≡⟨ cong (_· r' ⁻¹) (·Rid _) ⟩
         r' · r' ⁻¹              ≡⟨ ·-rinv _ ⟩
         1r ∎

 RˣContainsOne : 1r ∈ Rˣ
 RˣContainsOne = 1r , ·Lid _

 RˣInvClosed : (r : R) ⦃ _ : r ∈ Rˣ ⦄ → r ⁻¹ ∈ Rˣ
 RˣInvClosed r = r , ·-linv _

 UnitsAreNotZeroDivisors : (r : R) ⦃ _ : r ∈ Rˣ ⦄
                         → ∀ r' → r' · r ≡ 0r → r' ≡ 0r
 UnitsAreNotZeroDivisors r r' p = r'              ≡⟨ sym (·Rid _) ⟩
                                  r' · 1r         ≡⟨ cong (r' ·_) (sym (·-rinv _)) ⟩
                                  r' · (r · r ⁻¹) ≡⟨ ·Assoc _ _ _ ⟩
                                  r' · r · r ⁻¹   ≡⟨ cong (_· r ⁻¹) p ⟩
                                  0r · r ⁻¹       ≡⟨ 0LeftAnnihilates _ ⟩
                                  0r ∎

 -- laws keeping the instance arguments
 1⁻¹≡1 : ⦃ 1∈Rˣ' : 1r ∈ Rˣ ⦄ → 1r ⁻¹ ≡ 1r
 1⁻¹≡1 ⦃ 1∈Rˣ' ⦄ = (sym (·Lid _)) ∙ 1∈Rˣ' .snd

 ⁻¹-dist-· : (r r' : R) ⦃ r∈Rˣ : r ∈ Rˣ ⦄ ⦃ r'∈Rˣ : r' ∈ Rˣ ⦄ ⦃ rr'∈Rˣ : (r · r') ∈ Rˣ ⦄
           → (r · r') ⁻¹ ≡ r ⁻¹ · r' ⁻¹
 ⁻¹-dist-· r r' ⦃ r∈Rˣ ⦄ ⦃ r'∈Rˣ ⦄ ⦃ rr'∈Rˣ ⦄ =
                 sym path ∙∙ cong (r ⁻¹ · r' ⁻¹ ·_) (rr'∈Rˣ .snd) ∙∙ (·Rid _)
  where
  path : r ⁻¹ · r' ⁻¹ · (r · r' · (r · r') ⁻¹) ≡ (r · r') ⁻¹
  path = r ⁻¹ · r' ⁻¹ · (r · r' · (r · r') ⁻¹)
       ≡⟨ ·Assoc _ _ _ ⟩
         r ⁻¹ · r' ⁻¹ · (r · r') · (r · r') ⁻¹
       ≡⟨ cong (λ x → r ⁻¹ · r' ⁻¹ · x · (r · r') ⁻¹) (·Comm _ _) ⟩
         r ⁻¹ · r' ⁻¹ · (r' · r) · (r · r') ⁻¹
       ≡⟨ cong (_· (r · r') ⁻¹) (sym (·Assoc _ _ _)) ⟩
         r ⁻¹ · (r' ⁻¹ · (r' · r)) · (r · r') ⁻¹
       ≡⟨ cong (λ x → r ⁻¹ · x · (r · r') ⁻¹) (·Assoc _ _ _) ⟩
         r ⁻¹ · (r' ⁻¹ · r' · r) · (r · r') ⁻¹
       ≡⟨ cong (λ x → r ⁻¹ · (x · r) · (r · r') ⁻¹) (·-linv _) ⟩
         r ⁻¹ · (1r · r) · (r · r') ⁻¹
       ≡⟨ cong (λ x → r ⁻¹ · x · (r · r') ⁻¹) (·Lid _) ⟩
         r ⁻¹ · r · (r · r') ⁻¹
       ≡⟨ cong (_· (r · r') ⁻¹) (·-linv _) ⟩
         1r · (r · r') ⁻¹
       ≡⟨ ·Lid _ ⟩
         (r · r') ⁻¹ ∎

 unitCong : {r r' : R} → r ≡ r' → ⦃ r∈Rˣ : r ∈ Rˣ ⦄ ⦃ r'∈Rˣ : r' ∈ Rˣ ⦄ → r ⁻¹ ≡ r' ⁻¹
 unitCong {r = r} {r' = r'} p ⦃ r∈Rˣ ⦄ ⦃ r'∈Rˣ ⦄ =
          PathPΣ (inverseUniqueness r' (r ⁻¹ , subst (λ x → x · r ⁻¹ ≡ 1r) p (r∈Rˣ .snd)) r'∈Rˣ) .fst

 ⁻¹-eq-elim : {r r' r'' : R} ⦃ r∈Rˣ : r ∈ Rˣ ⦄ → r' ≡ r'' · r → r' · r ⁻¹ ≡ r''
 ⁻¹-eq-elim {r = r} {r'' = r''} p = cong (_· r ⁻¹) p
                                  ∙ sym (·Assoc _ _ _)
                                  ∙ cong (r'' ·_) (·-rinv _)
                                  ∙ ·Rid _

-- some convenient notation
_ˣ : (R' : CommRing ℓ) → ℙ (R' .fst)
R' ˣ = Units.Rˣ R'

module CommRingHoms where
  open RingHoms

  idCommRingHom : (R : CommRing ℓ) → CommRingHom R R
  idCommRingHom R = idRingHom (CommRing→Ring R)

  compCommRingHom : (R S T : CommRing ℓ)
                  → CommRingHom R S → CommRingHom S T → CommRingHom R T
  compCommRingHom R S T = compRingHom {R = CommRing→Ring R} {CommRing→Ring S} {CommRing→Ring T}

  compIdCommRingHom : {R S : CommRing ℓ} (f : CommRingHom R S) → compCommRingHom R R S (idCommRingHom R) f ≡ f
  compIdCommRingHom = compIdRingHom

  idCompCommRingHom : {R S : CommRing ℓ} (f : CommRingHom R S) → compCommRingHom R S S f (idCommRingHom S) ≡ f
  idCompCommRingHom = idCompRingHom

  compAssocCommRingHom : {R S T U : CommRing ℓ} (f : CommRingHom R S) (g : CommRingHom S T) (h : CommRingHom T U) →
                         compCommRingHom R T U (compCommRingHom R S T f g) h ≡
                         compCommRingHom R S U f (compCommRingHom S T U g h)
  compAssocCommRingHom = compAssocRingHom

module CommRingHomTheory {A' B' : CommRing ℓ} (φ : CommRingHom A' B') where
 open Units A' renaming (Rˣ to Aˣ ; _⁻¹ to _⁻¹ᵃ ; ·-rinv to ·A-rinv ; ·-linv to ·A-linv)
 private A = fst A'
 open CommRingStr (snd A') renaming (_·_ to _·A_ ; 1r to 1a)
 open Units B' renaming (Rˣ to Bˣ ; _⁻¹ to _⁻¹ᵇ ; ·-rinv to ·B-rinv)
 open CommRingStr (snd B') renaming  ( _·_ to _·B_ ; 1r to 1b
                                     ; ·Lid to ·B-lid ; ·Rid to ·B-rid
                                     ; ·Assoc to ·B-assoc)

 private
   f = fst φ
 open IsRingHom (φ .snd)

 RingHomRespInv : (r : A) ⦃ r∈Aˣ : r ∈ Aˣ ⦄ → f r ∈ Bˣ
 RingHomRespInv r = f (r ⁻¹ᵃ) , (sym (pres· r (r ⁻¹ᵃ)) ∙∙ cong (f) (·A-rinv r) ∙∙ pres1)

 φ[x⁻¹]≡φ[x]⁻¹ : (r : A) ⦃ r∈Aˣ : r ∈ Aˣ ⦄ ⦃ φr∈Bˣ : f r ∈ Bˣ ⦄
               → f (r ⁻¹ᵃ) ≡ (f r) ⁻¹ᵇ
 φ[x⁻¹]≡φ[x]⁻¹ r ⦃ r∈Aˣ ⦄ ⦃ φr∈Bˣ ⦄ =
  f (r ⁻¹ᵃ)                         ≡⟨ sym (·B-rid _) ⟩
  f (r ⁻¹ᵃ) ·B 1b                   ≡⟨ cong (f (r ⁻¹ᵃ) ·B_) (sym (·B-rinv _)) ⟩
  f (r ⁻¹ᵃ) ·B ((f r) ·B (f r) ⁻¹ᵇ) ≡⟨ ·B-assoc _ _ _ ⟩
  f (r ⁻¹ᵃ) ·B (f r) ·B (f r) ⁻¹ᵇ   ≡⟨ cong (_·B (f r) ⁻¹ᵇ) (sym (pres· _ _)) ⟩
  f (r ⁻¹ᵃ ·A r) ·B (f r) ⁻¹ᵇ       ≡⟨ cong (λ x → f x ·B (f r) ⁻¹ᵇ) (·A-linv _) ⟩
  f 1a ·B (f r) ⁻¹ᵇ                 ≡⟨ cong (_·B (f r) ⁻¹ᵇ) (pres1) ⟩
  1b ·B (f r) ⁻¹ᵇ                   ≡⟨ ·B-lid _ ⟩
  (f r) ⁻¹ᵇ                         ∎

module Exponentiation (R' : CommRing ℓ) where
 open CommRingStr (snd R')
 private R = fst R'

 -- introduce exponentiation
 _^_ : R → ℕ → R
 f ^ zero = 1r
 f ^ suc n = f · (f ^ n)

 infix 9 _^_

 -- and prove some laws
 1ⁿ≡1 : (n : ℕ) → 1r ^ n ≡ 1r
 1ⁿ≡1 zero = refl
 1ⁿ≡1 (suc n) = ·Lid _ ∙ 1ⁿ≡1 n

 ·-of-^-is-^-of-+ : (f : R) (m n : ℕ) → (f ^ m) · (f ^ n) ≡ f ^ (m +ℕ n)
 ·-of-^-is-^-of-+ f zero n = ·Lid _
 ·-of-^-is-^-of-+ f (suc m) n = sym (·Assoc _ _ _) ∙ cong (f ·_) (·-of-^-is-^-of-+ f m n)

 ^-ldist-· : (f g : R) (n : ℕ) → (f · g) ^ n ≡ (f ^ n) · (g ^ n)
 ^-ldist-· f g zero = sym (·Lid 1r)
 ^-ldist-· f g (suc n) = path
  where
  path : f · g · ((f · g) ^ n) ≡ f · (f ^ n) · (g · (g ^ n))
  path = f · g · ((f · g) ^ n)       ≡⟨ cong (f · g ·_) (^-ldist-· f g n) ⟩
         f · g · ((f ^ n) · (g ^ n)) ≡⟨ ·Assoc _ _ _ ⟩
         f · g · (f ^ n) · (g ^ n)   ≡⟨ cong (_· (g ^ n)) (sym (·Assoc _ _ _)) ⟩
         f · (g · (f ^ n)) · (g ^ n) ≡⟨ cong (λ r → (f · r) · (g ^ n)) (·Comm _ _) ⟩
         f · ((f ^ n) · g) · (g ^ n) ≡⟨ cong (_· (g ^ n)) (·Assoc _ _ _) ⟩
         f · (f ^ n) · g · (g ^ n)   ≡⟨ sym (·Assoc _ _ _) ⟩
         f · (f ^ n) · (g · (g ^ n)) ∎

 ^-rdist-·ℕ : (f : R) (n m : ℕ) → f ^ (n ·ℕ m) ≡ (f ^ n) ^ m
 ^-rdist-·ℕ f zero m = sym (1ⁿ≡1 m)
 ^-rdist-·ℕ f (suc n) m =  sym (·-of-^-is-^-of-+ f m (n ·ℕ m))
                        ∙∙ cong (f ^ m ·_) (^-rdist-·ℕ f n m)
                        ∙∙ sym  (^-ldist-· f (f ^ n) m)

-- like in Ring.Properties we provide helpful lemmas here
module CommRingTheory (R' : CommRing ℓ) where
 open CommRingStr (snd R')
 private R = fst R'

 ·CommAssocl : (x y z : R) → x · (y · z) ≡ y · (x · z)
 ·CommAssocl x y z = ·Assoc x y z ∙∙ cong (_· z) (·Comm x y) ∙∙ sym (·Assoc y x z)

 ·CommAssocr : (x y z : R) → x · y · z ≡ x · z · y
 ·CommAssocr x y z = sym (·Assoc x y z) ∙∙ cong (x ·_) (·Comm y z) ∙∙ ·Assoc x z y

 ·CommAssocr2 : (x y z : R) → x · y · z ≡ z · y · x
 ·CommAssocr2 x y z = ·CommAssocr _ _ _ ∙∙ cong (_· y) (·Comm _ _) ∙∙ ·CommAssocr _ _ _

 ·CommAssocSwap : (x y z w : R) → (x · y) · (z · w) ≡ (x · z) · (y · w)
 ·CommAssocSwap x y z w =
   ·Assoc (x · y) z w ∙∙ cong (_· w) (·CommAssocr x y z) ∙∙ sym (·Assoc (x · z) y w)


module Issue1280 where

open import Common.Prelude
open import Common.Reflection

infixr 5 _∷_

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

test : Vec _ _
test = 0 ∷ []

quoteTest : Term
quoteTest = quoteTerm test

unquoteTest = unquote (give quoteTest)

data Foo (A : Set) : Set where
  foo : Foo A

ok : Foo Nat
ok = unquote (give (quoteTerm (foo {Nat})))

-- This shouldn't type-check. The term `bad` is type-checked because
-- the implicit argument of `foo` is missing when using quoteTerm.
bad : Foo Bool
bad = unquote (give (quoteTerm (foo {Nat})))


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.PropositionalTruncation where

open import Cubical.HITs.PropositionalTruncation.Base public
open import Cubical.HITs.PropositionalTruncation.Properties public


module Sane where

import Data.Fin as F
--
-- open import Data.Empty
open import Data.Unit
-- open import Data.Unit.Core
open import Data.Nat using (ℕ ; zero ; suc ; _+_ ; _>_ )
open import Data.Sum using (inj₁ ; inj₂ )
-- open import Data.Product renaming (map to _×→_)
open import Data.Vec
open import Function using ( id ) renaming (_∘_ to _○_)
open import Relation.Binary.PropositionalEquality using ( _≡_ ; refl ; sym ; cong ; module ≡-Reasoning )
open ≡-Reasoning

-- start re-splitting things up, as this is getting out of hand
open import FT -- Finite Types
open import VecHelpers
open import NatSimple
open import Eval

-- not sure where else to put this [Z][A]
hetType : {A B : Set} → (a : A) → A ≡ B → B
hetType a refl = a

-- construct a combinator which represents the swapping of the i-th and
-- (i+1)-th 'bit' of a finite type.
-- Best to think of this as an 'elementary permutation', in the same way
-- we have 'elementary matrices' (which turn out to be permutations when they
-- are unitary).
swapi : {n : ℕ} → F.Fin n → (fromℕ (suc n)) ⇛ (fromℕ (suc n))
swapi {zero}  ()
swapi {suc n} F.zero    = assocl₊⇛ ◎ swap₊⇛ ⊕ id⇛ ◎ assocr₊⇛
swapi {suc n} (F.suc i) = id⇛ ⊕ swapi {n} i

-- swapUpTo i permutes the combinator left by one up to i
-- if possible values are X a b c Y d e, swapUpTo 3's possible outputs
-- are a b c X Y d e
swapUpTo : {n : ℕ} → F.Fin n → (fromℕ (suc n)) ⇛ (fromℕ (suc n))
swapUpTo F.zero    = id⇛
swapUpTo (F.suc i) = (id⇛ ⊕ swapUpTo i) ◎ swapi F.zero

-- swapDownFrom i permutes the combinator right by one up to i (the reverse
-- of swapUpTo)
swapDownFrom : {n : ℕ} → F.Fin n → (fromℕ (suc n)) ⇛ (fromℕ (suc n))
swapDownFrom F.zero    = id⇛
swapDownFrom (F.suc i) = swapi F.zero ◎ (id⇛ ⊕ swapDownFrom i)

-- TODO: verify that this is actually correct
-- Idea: To swap n < m with each other, swap n, n + 1, ... , m - 1, m, then
-- go back down, so that m and n are swapped and everything else is in the
-- same spot
-- makeSingleComb {combinator size} (arrayElement) (arrayIndex),
-- gives a combinator which 'does' that, assuming i<j, else id⇛
makeSingleComb : {n : ℕ} → F.Fin n → F.Fin n → (fromℕ n) ⇛ (fromℕ n)
makeSingleComb F.zero   F.zero     = id⇛
makeSingleComb F.zero   (F.suc i)  = id⇛
makeSingleComb (F.suc j) F.zero   = swapDownFrom j ◎ swapi j ◎ swapUpTo j
makeSingleComb (F.suc j) (F.suc i) = id⇛ ⊕ makeSingleComb j i

-- swapm i returns a combinator that swaps 0 and i
swapm : {n : ℕ} → F.Fin n → (fromℕ n) ⇛ (fromℕ n)
swapm F.zero = id⇛
swapm (F.suc i) = swapUpTo i ◎ swapi i ◎ swapDownFrom i

-- Correctness: after putting together i indices, the partial combinator c' is
-- represented by the vector [1, 2, ... , n - (i +1)] ++ (last i v)
--
-- Might want to bake in the correctness proof here---have the output be a
-- combinator c, a vector v, and a proof that vecRep c v, then we just prove
-- that the vector at the end is just the vector from the beginning
--
-- Or just put them together and prove that they're related by vecRep with
-- foldrWorks and that the end vector is the input vector; this is probably simpler
-- (and is the approach currently reflected in the code below)

-- swapInd i j returns a vector v′ where v′[i] = j, v′[j] = i, and v′[k] = k
-- where k != j and k != i

zeroIfEq : {n n′ : ℕ} → F.Fin n → F.Fin n → F.Fin (suc n′) → F.Fin (suc n′)
zeroIfEq F.zero    F.zero   ret = F.zero
zeroIfEq F.zero   (F.suc j) ret = ret
zeroIfEq (F.suc i) F.zero   ret = ret
zeroIfEq (F.suc i) (F.suc j) ret = zeroIfEq i j ret

swapIndFn : {n : ℕ} → F.Fin n → F.Fin n → (F.Fin n → F.Fin n)
swapIndFn               F.zero     j          F.zero   = j
swapIndFn               (F.suc i)  F.zero     F.zero   = F.suc i
swapIndFn               (F.suc i) (F.suc j)   F.zero   = F.zero
swapIndFn               F.zero     F.zero    (F.suc x) = F.suc x
swapIndFn {suc zero}    F.zero   (F.suc ()) (F.suc x)
swapIndFn {suc (suc n)} F.zero   (F.suc j)  (F.suc x) = zeroIfEq j x (F.suc x)
swapIndFn               (F.suc i)  F.zero    (F.suc x) = zeroIfEq i x (F.suc x)
swapIndFn               (F.suc i) (F.suc j)  (F.suc x) = F.suc (swapIndFn i j x)

swapInd : {n : ℕ} → F.Fin n → F.Fin n → Vec (F.Fin n) n
swapInd i j = tabulate (swapIndFn i j)

swapIndVec : {n : ℕ} → F.Fin n → F.Fin n → Vec (F.Fin n) n → Vec (F.Fin n) n
swapIndVec i j v = tabulate (λ k → v !! swapIndFn i j k)

-- useful abbreviations
2+ : ℕ → ℕ
2+ n = suc (suc n)

3+ : ℕ → ℕ
3+ n = suc (2+ n)

F2+ : {n : ℕ} → F.Fin n → F.Fin (2+ n)
F2+ i = F.suc (F.suc i)

F3+ : {n : ℕ} → F.Fin n → F.Fin (3+ n)
F3+ i = F.suc (F2+ i)

swap01 : {n : ℕ} → Vec (F.Fin (2+ n)) (2+ n)
swap01 = F.suc F.zero ∷ F.zero ∷ tabulate F2+

swapIndIdAfterOne : {n : ℕ} → (i : F.Fin n) →
                    (F2+ i) ≡ swapIndFn F.zero (F.suc F.zero) (F2+ i)
swapIndIdAfterOne i = refl -- yesss finally it just works!

swapIndSucDist : {n : ℕ} → (i j x : F.Fin n) →
                 (F.suc (swapIndFn i j x)) ≡
                 (swapIndFn (F.suc i) (F.suc j) (F.suc x))
swapIndSucDist i j x = refl

-- more useful abbreviations
F1+swap : {n : ℕ} → (i : F.Fin n) → Vec (F.Fin (2+ n)) (suc n)
F1+swap i = vmap F.suc (swapInd (F.inject₁ i) (F.suc i))

swapIndFn+ : {n : ℕ} → (i : F.Fin n) → F.Fin (suc n) → F.Fin (suc n)
swapIndFn+ i = swapIndFn (F.inject₁ i) (F.suc i)

swapInd++ : {n : ℕ} → (i : F.Fin n) → Vec (F.Fin (2+ n)) (2+ n)
swapInd++ i = swapInd (F.inject₁ (F.suc i)) (F2+ i)

swap≡ind₁ : {n : ℕ} → (i : F.Fin n) → F.zero ∷ F1+swap i ≡ swapInd++ i
swap≡ind₁ {n} i = begin
  F.zero ∷ F1+swap i
    ≡⟨ cong (_∷_ F.zero)
      (begin
          F1+swap i
        ≡⟨ mapTab F.suc (swapIndFn+ i) ⟩
          tabulate (F.suc ○ swapIndFn+ i)
        ≡⟨ tabf∼g _ _ (swapIndSucDist (F.inject₁ i) (F.suc i)) ⟩
          (tabulate (swapIndFn+ (F.suc i) ○ F.suc)
          ∎)) ⟩
  swapInd++ i ∎

-- vecRep c v relates a combinator c over normal types to the output
-- vector it results in. This works only over a subset of combinators
-- used in decompilation.
data vecRep : {n : ℕ} → (fromℕ n) ⇛ (fromℕ n) → Vec (F.Fin n) n → Set where
  vr-id    : {n : ℕ} → vecRep (id⇛ {fromℕ n}) (upTo n)
  vr-swap  : {n : ℕ} → vecRep {suc (suc n)} (swapi {suc n} F.zero) swap01
  vr-comp  : {n : ℕ} {c₁ c₂ : (fromℕ n) ⇛ (fromℕ n)} {v₁ v₂ : Vec (F.Fin n) n} →
    vecRep c₁ v₁ → vecRep c₂ v₂ →
    vecRep (c₁ ◎ c₂) (v₁ ∘̬ v₂)
  vr-plus : {n : ℕ} → {c : (fromℕ n) ⇛ (fromℕ n)} → {v : Vec (F.Fin n) n} →
    vecRep {n} c v →
    vecRep {suc n} (id⇛ ⊕ c) (F.zero ∷ (vmap F.suc v))

-- Record for keeping a combinator, a vector, and a proof that they compute
-- the same function.
record Compiled (n : ℕ) : Set where
  constructor
    _►_⟨_⟩
  field
    comb   : (fromℕ n) ⇛ (fromℕ n)
    vec    : Vec (F.Fin n) n
    proof  : vecRep comb vec

-- TODO: there might be a better vector to put in the vecRep here
-- we'll need to see what's most amenable to proving swapUpToWorks
swapiWorks : {n : ℕ} → (i : F.Fin n) → vecRep (swapi i) (swapInd (F.inject₁ i) (F.suc i))
swapiWorks {zero} ()
swapiWorks {suc n} F.zero = vr-swap
swapiWorks {suc n} (F.suc i) =
    hetType (vr-plus (swapiWorks i)) (cong (vecRep (id⇛ ⊕ swapi i)) (swap≡ind₁ i))

-- permutations on vectors for specifying swapUpTo/DownFrom

data _<F_ : {n : ℕ} → F.Fin n → F.Fin n → Set where
  zero-leq : {n : ℕ} → {i : F.Fin n} → F.zero <F (F.suc i)
  suc-leq  : {n : ℕ} → {i j : F.Fin n} → i <F j → (F.suc i) <F (F.suc j)

<suc : {n : ℕ} → (i j : F.Fin n) → (F.suc i) <F (F.suc j) → i <F j
<suc i j (suc-leq p) = p

dec<F : {n : ℕ} → (i j : F.Fin n) → Dec (i <F j)
dec<F F.zero    F.zero   = no (λ ())
dec<F F.zero   (F.suc j) = yes zero-leq
dec<F (F.suc i) F.zero   = no (λ ())
dec<F (F.suc i) (F.suc j) with dec<F i j
dec<F (F.suc i) (F.suc j) | yes x = yes (suc-leq x)
dec<F (F.suc i) (F.suc j) | no x = no (λ p → x (<suc i j p))

-- swap args of F.inject+
inj+ : {m n : ℕ} → F.Fin m → F.Fin (n + m)
inj+ {m} {n} i = hetType (F.inject+ n i) (cong F.Fin (+-comm m n))

-- the library definition of + on Fin isn't what we want here, ugh
_+F_ : {m n : ℕ} → F.Fin (suc m) → F.Fin n → F.Fin (m + n)
_+F_ {m} {zero} F.zero ()
_+F_ {m} {suc n} F.zero j = inj+ {suc n} {m} j
_+F_ {zero} {n} (F.suc ()) _
_+F_ {suc m} {n} (F.suc i) j = F.suc (i +F j)

data _h≡_ {A : Set} : {B : Set} → A → B → Set₁ where
  hrefl : (x : A) → _h≡_ {A} {A} x x

hetTypeIsID : {A B : Set} → (x : A) → (p : A ≡ B) → (hetType x p) h≡ x
hetTypeIsID x refl = hrefl x

-- Permute the first i elements of v to the right one (and i^th down to 0)
-- Should correspond with swapDownFrom
-- permuteRight : {n : ℕ} → (i : F.Fin n) → Vec (F.Fin n) n → Vec (F.Fin n) n
-- permuteRight i v = tabulate (permRightFn v i)

permuteRight : {n : ℕ} → (i : F.Fin n) → Vec (F.Fin n) n
permuteRight {zero} ()
permuteRight {suc n} F.zero = upTo _
permuteRight {suc zero} (F.suc ())
permuteRight {suc (suc n)} (F.suc i) =
  F.suc (head (permuteRight i)) ∷ F.zero ∷ vmap F.suc (tail (permuteRight i))

-- redundant helper
permRightID : {n : ℕ} → F.Fin n → Vec (F.Fin n) n
permRightID i = permuteRight i

-- The opposite of permuteRight; should correspond with swapUpTo
pl′ : {m : ℕ} {A : Set} → F.Fin m → Vec A m → A → Vec A (suc m)
pl′ {m = zero} () _ _
pl′ {m = suc m} F.zero (x ∷ xs) first = x ∷ first ∷ xs
pl′ (F.suc i) (x ∷ xs) first = x ∷ (pl′ i xs first)

permuteLeft : {n : ℕ} {A : Set} → (i : F.Fin n) → Vec A n → Vec A n
permuteLeft {zero} () _
permuteLeft {suc n} F.zero v = v
permuteLeft {suc zero} (F.suc ()) _
permuteLeft {suc (suc n)} (F.suc i) (a ∷ b ∷ rest) = pl′ i (b ∷ rest) a

permLeftID : {n : ℕ} → F.Fin n → Vec (F.Fin n) n
permLeftID i = permuteLeft i (upTo _)

permLeftId₀ : {n : ℕ} → (upTo (suc n)) ≡ permuteLeft F.zero (upTo (suc n))
permLeftId₀ {n} = refl

permLeftIdPasti : {n : ℕ} → (v : Vec (F.Fin (2+ n)) (2+ n)) →
                  (i : F.Fin n) →
                  permuteLeft (F.suc F.zero) v !! (F2+ i) ≡ v !! F2+ i
permLeftIdPasti (x ∷ x₁ ∷ x₂ ∷ v) F.zero = refl
permLeftIdPasti (x ∷ x₁ ∷ x₂ ∷ v) (F.suc i) = refl

-- it should actually be possible to recur on this!
-- and as an added bonus, it should actually be true! [Z]
plCorr : {m n : ℕ} (v : Vec (F.Fin m) n) (i : F.Fin n) →
         vmap F.suc (pl′ i (vmap F.suc v) F.zero) ∘̬′ swap01 ≡
         pl′ i (vmap F.suc (vmap F.suc v)) F.zero
plCorr [] ()
plCorr (x ∷ v) F.zero =
  begin
  vmap F.suc (pl′ F.zero (vmap F.suc (x ∷ v)) F.zero) ∘̬′ swap01
    ≡⟨ refl ⟩
  (F.suc (F.suc x) ∷ F.suc F.zero ∷ vmap F.suc (vmap F.suc v)) ∘̬′ swap01
    ≡⟨ refl ⟩
  ((tabulate (F.suc ○ F.suc)) !! x) ∷ (F.suc F.zero ∷ vmap F.suc (vmap F.suc v)) ∘̬′ swap01
    ≡⟨ cong (λ x → x ∷ (F.suc F.zero ∷ vmap F.suc (vmap F.suc v)) ∘̬′ swap01)
            (lookupTab x) ⟩
  (F.suc (F.suc x)) ∷ ((F.suc F.zero ∷ vmap F.suc (vmap F.suc v)) ∘̬′ swap01)
    ≡⟨ refl ⟩
  (F.suc (F.suc x)) ∷ F.zero ∷ ((vmap F.suc (vmap F.suc v)) ∘̬′ swap01)
    ≡⟨ cong (λ q → F.suc (F.suc x) ∷ F.zero ∷ q) (map2+id v) ⟩
  F.suc (F.suc x) ∷ F.zero ∷ vmap F.suc (vmap F.suc v)
    ≡⟨ refl ⟩
  pl′ F.zero (vmap F.suc (vmap F.suc (x ∷ v))) F.zero ∎
plCorr (x ∷ v) (F.suc i) =
  begin
  vmap F.suc (pl′ (F.suc i) (vmap F.suc (x ∷ v)) F.zero) ∘̬′ swap01
    ≡⟨ refl ⟩
  (tabulate (F.suc ○ F.suc) !! x) ∷
    ((vmap F.suc (pl′ i (vmap F.suc v) F.zero)) ∘̬′ swap01)
    ≡⟨ cong (λ q → q ∷ ((vmap F.suc (pl′ i (vmap F.suc v) F.zero)) ∘̬′ swap01))
            (lookupTab x) ⟩
  F.suc (F.suc x) ∷
    ((vmap F.suc (pl′ i (vmap F.suc v) F.zero)) ∘̬′ swap01)
    ≡⟨ cong (_∷_ (F.suc (F.suc x))) (plCorr v i) ⟩
  F.suc (F.suc x) ∷ pl′ i (vmap F.suc (vmap F.suc v)) F.zero
    ≡⟨ refl ⟩
  pl′ (F.suc i) (vmap F.suc (vmap F.suc (x ∷ v))) F.zero ∎

fzero : F.Fin 7
fzero = F.zero

fone : F.Fin 7
fone = F.suc F.zero

ftwo : F.Fin 7
ftwo = F.suc (F.suc F.zero)

fthree : F.Fin 7
fthree = F.suc (F.suc (F.suc F.zero))

ffour : F.Fin 7
ffour = F.suc (F.suc (F.suc (F.suc F.zero)))

ffive : F.Fin 7
ffive = F.suc (F.suc (F.suc (F.suc (F.suc F.zero))))

fsix : F.Fin 7
fsix = F.suc (F.suc (F.suc (F.suc (F.suc (F.suc F.zero)))))

--

gzero : F.Fin 6
gzero = F.zero

gone : F.Fin 6
gone = F.suc F.zero

gtwo : F.Fin 6
gtwo = F.suc (F.suc F.zero)

gthree : F.Fin 6
gthree = F.suc (F.suc (F.suc F.zero))

gfour : F.Fin 6
gfour = F.suc (F.suc (F.suc (F.suc F.zero)))

gfive : F.Fin 6
gfive = F.suc (F.suc (F.suc (F.suc (F.suc F.zero))))

-- i=3
-- n=5

test1 : Vec (F.Fin 7) 7
test1 = permuteLeft
          ffour
          (fzero ∷ fone ∷ ftwo ∷ fthree ∷ ffour ∷ ffive ∷ fsix ∷ [])

{--
test1 = (0 1)
        (1 2)
        (2 3)
        (3 4)
        (4 0)
        (5 5)
        (6 6)
--}

test2 : Vec (F.Fin 6) 6
test2 = permuteLeft
          gthree
          (gzero ∷ gone ∷ gtwo ∷ gthree ∷ gfour ∷ gfive ∷ [])

{--
test2 = (0 1)
        (1 2)
        (2 3)
        (3 0)
        (4 4)
        (5 5)

vmap F.suc test2 =
        (0 2)
        (1 3)
        (2 4)
        (3 1)
        (4 5)
        (5 6)

F.zero ∷ vmap F.suc test2 =
        (0 0)
        (1 2)
        (2 3)
        (3 4)
        (4 1)
        (5 5)
        (6 6)

swap01 =
        (0 1)
        (1 0)
        (2 2)
        (3 3)
        (4 4)
        (5 5)
        (6 6)

(F.zero ∷ vmap F.suc test2) ∘̬ swap01 =
        (0 1)
        (1 2)
        (2 3)
        (3 4)
        (4 0)
        (5 5)
        (6 6)

test1 = (0 1)
        (1 2)
        (2 3)
        (3 4)
        (4 0)
        (5 5)
        (6 6)

--}

-- glue lemma between plCorr and swapUpToWorks to deal with the difference between
-- the result type of swapUpToWorks and the result type of the VecRep combinators
-- We need this glue here to get from swapUpToWorks (which has two calls to permuteLeft)
-- to plCorr (which has two calls to pl′), since permuteLeft is a wrapper around pl′.
-- Once we've removed the wrapper, we can eat the delicious candy^W^W^W^Wactually do
-- induction; hopefully the type of plCorr is general enough for this but not too general
-- to, er, be true. [Z]
sucWorks : {n : ℕ} → (i : F.Fin n) →
                  (F.zero ∷ vmap F.suc (permuteLeft (F.inject₁ i) (upTo (suc n))))
                  ∘̬ swap01
                  ≡ pl′ {suc n} (F.inject₁ i) (tail (upTo (suc (suc n)))) F.zero
sucWorks {suc n} F.zero =
  begin
    (F.zero ∷ vmap F.suc (permuteLeft F.zero (upTo (suc (suc n)))))
    ∘̬ swap01
      ≡⟨ cong (λ x → (F.zero ∷ vmap F.suc x) ∘̬ swap01)
               (sym (permLeftId₀)) ⟩
    (F.zero ∷ vmap F.suc (upTo (suc (suc n))))
    ∘̬ swap01
       ≡⟨ cong (λ x → (F.zero ∷ x) ∘̬ swap01) ((mapTab F.suc id)) ⟩
    upTo (suc (suc (suc n))) ∘̬ swap01
      ≡⟨ ∘̬simpleid swap01 ⟩
    swap01
      ≡⟨ refl ⟩
    pl′ F.zero (tail (upTo (suc (suc (suc n))))) F.zero ∎
sucWorks {suc zero} (F.suc ())
sucWorks {suc (suc n)} (F.suc i) =
  begin
    (F.zero ∷ vmap F.suc (permuteLeft (F.inject₁ (F.suc i)) (upTo (suc (suc (suc n))))))
    ∘̬ swap01
      ≡⟨ ∘̬≡∘̬′
           (F.zero ∷
            vmap F.suc
            (permuteLeft (F.inject₁ (F.suc i)) (upTo (suc (suc (suc n))))))
           swap01 ⟩
    (F.zero ∷ vmap F.suc (permuteLeft (F.inject₁ (F.suc i)) (upTo (suc (suc (suc n))))))
    ∘̬′ swap01
      ≡⟨ refl ⟩
    (F.zero ∷ vmap F.suc (pl′ (F.inject₁ i) (tail (upTo (suc (suc (suc n))))) F.zero))
    ∘̬′ swap01
      ≡⟨ refl ⟩
    (F.suc F.zero) ∷
      ((vmap F.suc (pl′ (F.inject₁ i) (tabulate F.suc) F.zero))
      ∘̬′ swap01)
      ≡⟨ cong
           (λ q →
              F.suc F.zero ∷ vmap F.suc (pl′ (F.inject₁ i) q F.zero) ∘̬′ swap01)
           (sym (mapTab F.suc id)) ⟩
    (F.suc F.zero) ∷
      ((vmap F.suc (pl′ (F.inject₁ i) (vmap F.suc (tabulate id)) F.zero))
      ∘̬′ swap01)
      ≡⟨ cong (_∷_ (F.suc F.zero)) (plCorr (tabulate id) (F.inject₁ i)) ⟩
    (F.suc F.zero) ∷
      (pl′ (F.inject₁ i) (vmap F.suc (vmap F.suc (tabulate id))) F.zero)
      ≡⟨ cong (λ q → F.suc F.zero ∷ pl′ (F.inject₁ i) (vmap F.suc q) F.zero)
           (mapTab F.suc id) ⟩
    (F.suc F.zero) ∷ pl′ (F.inject₁ i) (vmap F.suc (tail (upTo (suc (suc (suc n)))))) F.zero
      ≡⟨ cong (λ x → (F.suc F.zero) ∷ pl′ (F.inject₁ i) x F.zero)
               (sym (upToTail (suc (suc n)))) ⟩
    F.suc F.zero ∷ pl′ (F.inject₁ i) (tail (tail (upTo (suc (suc (suc (suc n))))))) F.zero
      ≡⟨ refl ⟩
    pl′ (F.inject₁ (F.suc i)) (tail (upTo (suc (suc (suc (suc n)))))) F.zero ∎

-- NB: I added the F.inject₁ in calls to permuteLeft/Right to get it to work
-- with swapUpTo/DownFrom; I'm not sure that this is correct? It might
-- be a sign that the type of the swap functions is too specific, instead.
-- (though now it looks like it will at least make the type of shuffle a bit nicer) [Z]
swapUpToWorks : {n : ℕ} → (i : F.Fin n) →
                vecRep (swapUpTo i) (permuteLeft (F.inject₁ i) (upTo (suc n)))
swapUpToWorks F.zero = vr-id
swapUpToWorks (F.suc i) = hetType (vr-comp (vr-plus (swapUpToWorks i)) vr-swap)
                         (cong (vecRep (swapUpTo (F.suc i))) (sucWorks i))

sdfWorks : {n : ℕ} → (i : F.Fin (suc n)) →
           swap01 ∘̬ (F.zero ∷ vmap F.suc (permuteRight i)) ≡
           permuteRight (F.suc i)
sdfWorks i =
  begin
  swap01 ∘̬ (F.zero ∷ vmap F.suc (permuteRight i))
    ≡⟨ ∘̬≡∘̬′ swap01 (F.zero ∷ vmap F.suc (permuteRight i)) ⟩
  swap01 ∘̬′ (F.zero ∷ vmap F.suc (permuteRight i))
    ≡⟨ refl ⟩
  (vmap F.suc (permuteRight i) !! F.zero) ∷ F.zero ∷
    (tabulate (F.suc ○ F.suc) ∘̬′ (F.zero ∷ vmap F.suc (permuteRight i)))
    ≡⟨ cong
         (λ q →
            q ∷
            F.zero ∷
            tabulate (F.suc ○ F.suc) ∘̬′
            (F.zero ∷ vmap F.suc (permuteRight i)))
         (head!!0 (vmap F.suc (permuteRight i))) ⟩
  (head (vmap F.suc (permuteRight i))) ∷ F.zero ∷
    (tabulate (F.suc ○ F.suc) ∘̬′ (F.zero ∷ vmap F.suc (permuteRight i)))
    ≡⟨ cong
         (λ q →
            q ∷
            F.zero ∷
            tabulate (F.suc ○ F.suc) ∘̬′
            (F.zero ∷ vmap F.suc (permuteRight i)))
         (headmap (permuteRight i)) ⟩
  (F.suc (head (permuteRight i))) ∷ F.zero ∷
    (tabulate (F.suc ○ F.suc) ∘̬′ (F.zero ∷ vmap F.suc (permuteRight i)))
    ≡⟨ cong (λ q → F.suc (head (permuteRight i)) ∷ F.zero ∷ q)
         (sym
          (∘̬≡∘̬′ (tabulate (F.suc ○ F.suc))
           (F.zero ∷ vmap F.suc (permuteRight i)))) ⟩
  (F.suc (head (permuteRight i))) ∷ F.zero ∷
    (tabulate (F.suc ○ F.suc) ∘̬ (F.zero ∷ vmap F.suc (permuteRight i)))
    ≡⟨ cong (λ q → F.suc (head (permuteRight i)) ∷ F.zero ∷ q)
         (2suc∘̬2tail (F.zero ∷ vmap F.suc (permuteRight i))) ⟩
  (F.suc (head (permuteRight i))) ∷ F.zero ∷
    (tail (vmap F.suc (permuteRight i)))
    ≡⟨ cong (λ q → F.suc (head (permuteRight i)) ∷ F.zero ∷ q)
         (tailmap (permuteRight i)) ⟩
  (F.suc (head (permuteRight i))) ∷ F.zero ∷ (vmap F.suc (tail (permuteRight i)))
    ≡⟨ refl ⟩
  permuteRight (F.suc i) ∎

swapDownFromWorks : {n : ℕ} → (i : F.Fin n) →
                    vecRep (swapDownFrom i) (permuteRight (F.inject₁ i))
swapDownFromWorks F.zero = vr-id
swapDownFromWorks (F.suc i) =
  hetType (vr-comp vr-swap (vr-plus (swapDownFromWorks i)))
          (cong (vecRep (swapDownFrom (F.suc i))) (sdfWorks (F.inject₁ i)))

_◎∘̬_ : {n : ℕ} → Compiled n → Compiled n → Compiled n
(c₁ ► v₁ ⟨ p₁ ⟩) ◎∘̬ (c₂ ► v₂ ⟨ p₂ ⟩) = ((c₁ ◎ c₂) ► v₁ ∘̬ v₂ ⟨ vr-comp p₁ p₂ ⟩ )

vecToComb : {n : ℕ} → Vec (F.Fin n) n → (fromℕ n) ⇛ (fromℕ n)
vecToComb {n} vec =
  foldr (λ i → fromℕ n ⇛ fromℕ n) _◎_ id⇛ (map (λ i → makeSingleComb (vec !! i) i) (upTo n))

finToVal : {n : ℕ} → F.Fin n → ⟦ fromℕ n ⟧
finToVal F.zero = inj₁ tt
finToVal (F.suc n) = inj₂ (finToVal n)

valToFin : {n : ℕ} → ⟦ fromℕ n ⟧ → F.Fin n
valToFin {zero} ()
valToFin {suc n} (inj₁ tt) = F.zero
valToFin {suc n} (inj₂ v) = F.suc (valToFin v)

finToValToFin : {n : ℕ} → (v : ⟦ fromℕ n ⟧) → finToVal (valToFin v) ≡ v
finToValToFin {zero} ()
finToValToFin {suc n} (inj₁ tt)  = refl -- (inj₁ tt)
finToValToFin {suc n} (inj₂ v) = cong inj₂ (finToValToFin v)

valToFinToVal : {n : ℕ} → (i : F.Fin n) → valToFin (finToVal i) ≡ i
valToFinToVal F.zero = refl -- F.zero
valToFinToVal (F.suc i) = cong F.suc (valToFinToVal i)

combToVec : {n : ℕ} → (fromℕ n) ⇛ (fromℕ n) → Vec (F.Fin n) n
combToVec c = tabulate (valToFin ○ (evalComb c) ○ finToVal)

twoF4 : F.Fin four
twoF4 = F.suc (F.suc F.zero)

fourF5 : F.Fin five
fourF5 = F.suc (F.suc F.zero)

swapUpToTest : Vec (F.Fin five) five
swapUpToTest = combToVec (swapUpTo twoF4)

pltest : (n : ℕ) → (i : F.Fin n) → Vec (F.Fin n) n
pltest n i = permuteLeft i (upTo n)

prtest : Vec (F.Fin five) five
prtest = permuteRight fourF5 -- (F.suc (F.suc (F.suc (F.suc F.zero))))

sdftest : Vec (F.Fin five) five
sdftest = combToVec (swapDownFrom twoF4)

sucomptest : {n : ℕ} → (i : F.Fin n) → Vec (F.Fin (suc (suc n))) (suc (suc n))
sucomptest {n} i = (F.zero ∷ vmap F.suc (permuteLeft (F.inject₁ i) (upTo (suc n))))
                   ∘̬ (F.suc F.zero ∷ F.zero ∷ vmap (F.suc ○ F.suc) (upTo n))

sit : Vec (F.Fin five) five
sit = combToVec (swapi (F.suc (F.suc F.zero)))

mntest : Vec (F.Fin five) five
mntest = combToVec (makeSingleComb (F.suc (F.suc (F.suc F.zero))) F.zero)

evalVec : {n : ℕ} → Vec (F.Fin n) n → F.Fin n → ⟦ fromℕ n ⟧
evalVec vec i = finToVal (lookup i vec)

permLeftTest : F.Fin four
permLeftTest = valToFin (evalVec (permLeftID (F.suc (F.suc F.zero))) (F.zero))

lookupToEvalVec : {n : ℕ} → (i : F.Fin n) → (v : Vec (F.Fin n) n) → lookup i v ≡ valToFin (evalVec v i)
lookupToEvalVec i v = sym (valToFinToVal (lookup i v) )

--  Might want to take a ⟦ fromℕ n ⟧ instead of a Fin n as the second
--  argument here?
combToVecWorks : {n : ℕ} → (c : (fromℕ n) ⇛ (fromℕ n)) →
  (i : F.Fin n) → (evalComb c (finToVal i)) ≡ evalVec (combToVec c) i
combToVecWorks c i = (sym (finToValToFin _)) ∘ (cong finToVal (sym (lookupTab i)))

-- This lemma is the hammer that will let us use vecRep to (hopefully) simply
-- prove some lemmas about the helper functions used in vecToComb, then apply
-- vecRepWorks at the end to make sure they all "do the right thing"
vecRepWorks : {n : ℕ} → {c : (fromℕ n) ⇛ (fromℕ n)} → {v : Vec (F.Fin n) n} →
  vecRep c v → (i : F.Fin n) → (evalVec v i) ≡ (evalComb c (finToVal i))
vecRepWorks vr-id i = cong finToVal (lookupTab i)
vecRepWorks vr-swap F.zero = refl -- (inj₂ (inj₁ tt))
vecRepWorks vr-swap (F.suc F.zero) = refl -- (inj₁ tt)
vecRepWorks {suc (suc n)} vr-swap (F.suc (F.suc i)) = cong finToVal (lookupTab i)
vecRepWorks (vr-comp {n} {c₁} {c₂} {v₁} {v₂} vr vr₁) i = begin
  finToVal (lookup i (tabulate (λ j → lookup (lookup j v₁) v₂)))
 ≡⟨ cong finToVal (lookup∘tabulate i (λ j → lookup (lookup j v₁) v₂)) ⟩
  finToVal (lookup (lookup i v₁) v₂)
 ≡⟨ cong (λ x → finToVal (lookup x v₂)) (lookupToEvalVec i v₁) ⟩
  finToVal (lookup (valToFin (evalVec v₁ i)) v₂)
 ≡⟨ cong (λ x → finToVal (lookup (valToFin x) v₂)) (vecRepWorks vr i) ⟩
  finToVal (lookup (valToFin (evalComb c₁ (finToVal i))) v₂)
 ≡⟨ cong finToVal (lookupToEvalVec (valToFin (evalComb c₁ (finToVal i))) v₂) ⟩
  finToVal (valToFin (evalVec v₂ (valToFin (evalComb c₁ (finToVal i)))))
 ≡⟨ finToValToFin (evalVec v₂ (valToFin (evalComb c₁ (finToVal i)))) ⟩
 evalVec v₂ (valToFin (evalComb c₁ (finToVal i)))
 ≡⟨ vecRepWorks vr₁ (valToFin (evalComb c₁ (finToVal i))) ⟩
 evalComb c₂ (finToVal (valToFin (evalComb c₁ (finToVal i))))
 ≡⟨ cong (evalComb c₂) (finToValToFin (evalComb c₁ (finToVal i))) ⟩
 evalComb (c₁ ◎ c₂) (finToVal i) ∎
vecRepWorks {suc n} (vr-plus vr) F.zero = refl -- (inj₁ tt)
vecRepWorks (vr-plus {c = c} {v = v} vr) (F.suc i) = begin
  evalVec (F.zero ∷ vmap F.suc v) (F.suc i)  ≡⟨ cong finToVal (map!! F.suc v i) ⟩
  inj₂ (finToVal (v !! i))                  ≡⟨ cong inj₂ (vecRepWorks vr i) ⟩
  (evalComb (id⇛ ⊕ c) (finToVal (F.suc i)) ∎)

record Permut (n : ℕ) : Set where
  constructor per
  field
    vec : Vec (F.Fin n) n
    uniq : ∀ {i j : F.Fin n} → (vec !! i) ≡ (vec !! j) → i ≡ j

-- this should also take a proof that i>0.
pred′ : {n : ℕ} (i : F.Fin (suc (suc n))) → F.Fin (suc n)
pred′ F.zero = F.zero
pred′ (F.suc i) = i

record NormComb (n : ℕ) : Set where
  constructor ⟪_,_⟫
  field
    v : Vec (F.Fin n) n
    -- We can't actually have it be the stronger condition and still be
    -- able to properly recur on it as in vtc′.
    p : ∀ (i : F.Fin n) (j : F.Fin′ i) → (v !! (F.inject j) ≡ i) → (v !! i ≡ (F.inject j))

predToSuc : {n : ℕ} (i : F.Fin (suc n)) (j : F.Fin′ i) (x : F.Fin (suc (suc n)))
            (v : Vec (F.Fin (suc (suc n))) (suc n)) →
            vmap pred′ v !! F.inject j ≡ i →
            (∀ (i : F.Fin (suc (suc n))) (j : F.Fin′ i) →
              ((x ∷ v) !! (F.inject j) ≡ i) → ((x ∷ v) !! i ≡ (F.inject j))) →
            (x ∷ v) !! F.inject (F.suc j) ≡ F.suc i
predToSuc i j x v p p₁ =
  begin
    (x ∷ v) !! F.inject (F.suc j)
      ≡⟨ refl ⟩
    v !! F.inject j
      ≡⟨ {!refl!} ⟩
    F.suc i ∎

nctail : {n : ℕ} → NormComb (suc n) → NormComb n
nctail {zero}  ⟪ x ∷ [] , p ⟫ = ⟪ [] , (λ ()) ⟫
nctail {suc n} ⟪ x ∷ v , p ⟫ = ⟪ vmap pred′ v , {!!} ⟫

vtc′ : {n : ℕ} (v : Vec (F.Fin n) n) → (fromℕ n) ⇛ (fromℕ n)
vtc′ {zero} [] = id⇛
vtc′ {suc zero} (x ∷ []) = id⇛ -- can only swap with itself
vtc′ {suc (suc n)} (F.zero ∷ v) = id⇛ ⊕ (vtc′ (vmap pred′ v))
vtc′ {suc (suc n)} ((F.suc i) ∷ v) =
  (id⇛ ⊕ (vtc′ (vmap pred′ v))) ◎ (swapm (F.suc i))

testvtc : {n : ℕ} → Vec (F.Fin n) n → Vec (F.Fin n) n
testvtc v = combToVec (vtc′ v)

testvtc0 : {n : ℕ} → Vec (F.Fin n) n → Vec (F.Fin n) n
testvtc0 v = combToVec (vecToComb v)

pl2 : Vec (F.Fin 5) 5
pl2 = permuteLeft (F.suc (F.suc F.zero)) (upTo 5)

pr2 : Vec (F.Fin 5) 5
pr2 = permuteRight (F.suc (F.suc F.zero))

pred∘suc : {n : ℕ} (x : F.Fin (suc (suc n))) → ((F.toℕ x) > zero) → F.suc (pred′ x) ≡ x
pred∘suc F.zero ()
pred∘suc (F.suc _)  _ = refl

-- Assumptions we need so far:
-- - If the first element of a vec is zero, no other element is zero
--   (to prove that "vmap F.suc (vmap pred′ v) == v")
-- - Probably something for the last case, too
magic1 : {n : ℕ} (v : Vec (F.Fin n) n) → vecRep (vtc′ v) v
magic1 {zero} [] = vr-id
magic1 {suc zero} (F.zero ∷ []) = vr-id
magic1 {suc zero} (F.suc () ∷ [])
-- this will need something reminiscent of LeftCancellation?
magic1 {suc (suc n)} (F.zero ∷ v) = hetType
    (vr-plus (magic1 {suc n} (vmap pred′ v)))
    (cong (λ x → vecRep (id⇛ ⊕ vtc′ (vmap pred′ v)) (F.zero ∷ x))
    ((vmap∘vmap F.suc pred′ v) ∘ (vmap∘id {!!}) ))
-- swap and recurse?
magic1 {suc (suc n)} (F.suc x ∷ v) = {!!}

-- [JC] flip the conclusion around, as 'evalVec v i' is trivial.  Makes
-- equational reasoning easier
vecToCombWorks : {n : ℕ} →
  (v : Vec (F.Fin n) n) → (i : F.Fin n) →
  (evalComb (vtc′ v) (finToVal i)) ≡ (evalVec v i)
vecToCombWorks v i = sym (vecRepWorks (magic1 v) i)

------------------------------------------------------------------
-- Goal:

lemma1 : {n : ℕ} (v : Vec (F.Fin n) n) → (i : F.Fin n) →
    (evalVec v i) ≡ (evalComb (vtc′ v) (finToVal i))
lemma1 v i = sym (vecToCombWorks v i)

lemma2 : {n : ℕ} (c : (fromℕ n) ⇛ (fromℕ n)) → (i : F.Fin n) →
    (evalComb c (finToVal i)) ≡ evalVec (combToVec c) i
lemma2 c i = combToVecWorks c i

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


open import Prelude

module RW.Data.RTrie.Decl where

  open import RW.Language.RTerm public
  open import RW.Language.RTermIdx public
  open import RW.Data.PMap (RTermᵢ ⊥) as IdxMap

  data Rule : Set where
    Gr : ℕ     → Rule
    Tr : ℕ → ℕ → Rule
    Fr : ℕ → Name → Rule

  mutual
    Cell : Set
    Cell = IdxMap.to RTrie default     -- Map from indexes to tries,
         × List (ℕ × List Rule) -- Binding symbols,

    data RTrie : Set where
        Fork : List Cell → RTrie
        Leaf : List Rule → RTrie

  BTrieEmpty : RTrie
  BTrieEmpty = Fork $ []


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

module library.Basics where

open import library.Base public
open import library.PathGroupoid public
open import library.PathFunctor public
open import library.NType public
open import library.Equivalences public
open import library.Univalence public
open import library.Funext public
open import library.PathOver public