------------------------------------------------------------------------
-- Well-typed substitutions
-- From
------------------------------------------------------------------------

module Extensions.Fin.TypedSubstitution where

import Category.Applicative.Indexed as Applicative
open import Data.Fin using (Fin; zero; suc)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Nat using (ℕ; zero; suc; _+_)
open import Data.Vec as Vec using (Vec; []; _∷_; map)
open import Data.Vec.All using (All₂; []; _∷_; map₂; gmap₂; gmap₂₁; gmap₂₂)
open import Data.Vec.Properties using (lookup-morphism)
open import Function using (_∘_; flip)
open import Relation.Binary.PropositionalEquality as PropEq hiding (trans)
open PropEq.≡-Reasoning

------------------------------------------------------------------------
-- Abstract typing contexts and well-typedness relations

-- Abstract typing contexts over T-types.
--
-- A typing context Ctx n maps n free variables to types containing up
-- to n free variables each.
module Context where

  infixr 5 _∷_

  -- Typing contexts.
  data Ctx (T : ℕ → Set) : ℕ → Set where
    []  :                               Ctx T 0
    _∷_ : ∀ {n} → T (1 + n) → Ctx T n → Ctx T (1 + n)

  -- Operations on context that require weakening of types.
  record WeakenOps (T : ℕ → Set) : Set where

    -- Weakening of types.
    field weaken : ∀ {n} → T n → T (1 + n)

    infixr 5 _i∷_

    -- Convert a context to its vector representation.
    toVec : ∀ {n} → Ctx T n → Vec (T n) n
    toVec []      = []
    toVec (a ∷ Γ) = a ∷ map weaken (toVec Γ)

    -- Shorthand for extending contexts with variables that are typed
    -- independently of themselves.
    _i∷_ : ∀ {n} → T n → Ctx T n → Ctx T (1 + n)
    a i∷ Γ = weaken a ∷ Γ

    -- Lookup the type of a variable in a context.
    lookup : ∀ {n} → Fin n → Ctx T n → T n
    lookup x = Vec.lookup x ∘ toVec

open Context

-- Abstract typings.
--
-- An abtract typing _⊢_∈_ : Typing Tp₁ Tm Tp₂ is a ternary relation
-- which, in a given Tp₂-context, relates Tm-terms to their Tp₁-types.
Typing : (ℕ → Set) → (ℕ → Set) → (ℕ → Set) → Set₁
Typing Tp₁ Tm Tp₂ = ∀ {n} → Ctx Tp₁ n → Tm n → Tp₂ n → Set

------------------------------------------------------------------------
-- Abstract well-typed substitutions (i.e. substitution lemmas)

-- Abstract typed substitutions.
record TypedSub (Tp₁ Tp₂ Tm : ℕ → Set) : Set₁ where

  infix 4 _⊢_∈_

  field
    _⊢_∈_ : Typing Tp₂ Tm Tp₁   -- the associated typing

    -- Application of Tm-substitutions to (source) Tp₁-types
    application : Application Tp₁ Tm

    -- Operations on the (source) Tp₁-context.
    weakenOps : WeakenOps Tp₁

  open Application application   public using (_/_)
  open WeakenOps   weakenOps            using (toVec)

  infix 4 _⇒_⊢_

  -- Typed substitutions.
  --
  -- A typed substitution Γ ⇒ Δ ⊢ σ is a substitution σ which, when
  -- applied to something that is well-typed in a source context Γ,
  -- yields something well-typed in a target context Δ.
  _⇒_⊢_ : ∀ {m n} → Ctx Tp₁ m → Ctx Tp₂ n → Sub Tm m n → Set
  Γ ⇒ Δ ⊢ σ = All₂ (λ t a → Δ ⊢ t ∈ (a / σ)) σ (toVec Γ)

-- Abstract extensions of substitutions.
record ExtensionTyped {Tp₁ Tp₂ Tm} (simple : Simple Tm)
                      (typedSub : TypedSub Tp₁ Tp₂ Tm) : Set where

  open TypedSub typedSub
  private
    module S  = SimpleExt simple
    module L₀ = Lemmas₀   (record { simple = simple })
    module C  = WeakenOps weakenOps
  open C using (_i∷_)

  field

    -- Weakens well-typed Ts.
    weaken : ∀ {n} {Δ : Ctx Tp₂ n} {t a b} → Δ ⊢ t ∈ a →
             b ∷ Δ ⊢ S.weaken t ∈ C.weaken a

    -- Weakening commutes with other substitutions.
    wk-commutes : ∀ {m n} {σ : Sub Tm m n} {t} a →
                  a / σ / S.wk ≡ a / S.wk / (t S./∷ σ)

    -- Relates weakening of types to weakening of Ts.
    /-wk : ∀ {n} {a : Tp₁ n} → a / S.wk ≡ C.weaken a

  -- A helper lemma.
  weaken-/ : ∀ {m n} {σ : Sub Tm m n} {t} a →
             C.weaken (a / σ) ≡ C.weaken a / (t S./∷ σ)
  weaken-/ {σ = σ} {t} a = begin
    C.weaken (a / σ)          ≡⟨ sym /-wk ⟩
    a / σ / S.wk              ≡⟨ wk-commutes a ⟩
    a / S.wk / (t S./∷ σ)     ≡⟨ cong₂ _/_ /-wk refl ⟩
    C.weaken a / (t S./∷ σ)   ∎

  infixr 5 _/∷_ _/i∷_

  -- Extension.
  _/∷_ : ∀ {m n} {Γ : Ctx Tp₁ m} {Δ : Ctx Tp₂ n} {t a b σ} →
         b ∷ Δ ⊢ t ∈ a / (t S./∷ σ) → Γ ⇒ Δ ⊢ σ → a ∷ Γ ⇒ b ∷ Δ ⊢ (t S./∷ σ)
  t∈a/t∷σ /∷ σ-wt =
    t∈a/t∷σ ∷ gmap₂ (subst (_⊢_∈_ _ _) (weaken-/ _) ∘ weaken) σ-wt

  -- A variant of extension tailored to _i∷_.
  _/i∷_ : ∀ {m n} {Γ : Ctx Tp₁ m} {Δ : Ctx Tp₂ n} {t a b σ} →
          b ∷ Δ ⊢ t ∈ C.weaken (a / σ) → Γ ⇒ Δ ⊢ σ → a i∷ Γ ⇒ b ∷ Δ ⊢ (t S./∷ σ)
  t∈a/σ /i∷ σ-wt =
    (subst (_⊢_∈_ _ _) (weaken-/ _) t∈a/σ) /∷ σ-wt

-- Abstract simple typed substitutions.
record SimpleTyped {Tp Tm} (simple : Simple Tm)
                   (typedSub : TypedSub Tp Tp Tm) : Set where

  field extensionTyped : ExtensionTyped simple typedSub

  open TypedSub typedSub
  open ExtensionTyped extensionTyped public
  private
    module S  = SimpleExt simple
    module L₀ = Lemmas₀ (record { simple = simple })
    module C  = WeakenOps weakenOps
  open C using (_i∷_)

  field

    -- Takes variables to well-typed Ts.
    var : ∀ {n} {Γ : Ctx Tp n} (x : Fin n) → Γ ⊢ S.var x ∈ C.lookup x Γ

    -- Types are invariant under the identity substitution.
    id-vanishes : ∀ {n} (a : Tp n) → a / S.id ≡ a

    -- Single-variable substitution is a left-inverse of weakening.
    wk-sub-vanishes : ∀ {n b} (a : Tp n) → a / S.wk / S.sub b ≡ a

  infix 10 _↑ _↑i

  -- Lifting.
  _↑ : ∀ {m n} {Γ : Ctx Tp m} {Δ : Ctx Tp n} {σ} → Γ ⇒ Δ ⊢ σ → ∀ {a} →
       a ∷ Γ ⇒ a / σ S.↑ ∷ Δ ⊢ (σ S.↑)
  σ-wt ↑ = var zero /∷ σ-wt

  -- A variant of lifting tailored to _i∷_.
  _↑i : ∀ {m n} {Γ : Ctx Tp m} {Δ : Ctx Tp n} {σ} → Γ ⇒ Δ ⊢ σ → ∀ {a} →
        a i∷ Γ ⇒ a / σ i∷ Δ ⊢ σ S.↑
  σ-wt ↑i = var zero /i∷ σ-wt

  -- The identity substitution.
  id : ∀ {n} {Γ : Ctx Tp n} → Γ ⇒ Γ ⊢ S.id
  id {zero}          = []
  id {suc n} {a ∷ Γ} =
    subst₂ (λ Δ σ → a ∷ Γ ⇒ Δ ⊢ σ)
           (cong (flip _∷_ Γ) (id-vanishes a)) (L₀.id-↑⋆ 1) (id ↑)
    where
      id-vanishes′ : ∀ {n} (a : Tp (1 + n)) → a / S.id S.↑ ≡ a
      id-vanishes′ a = begin
        a / S.id S.↑  ≡⟨ cong (_/_ a) (L₀.id-↑⋆ 1) ⟩
        a / S.id      ≡⟨ id-vanishes a ⟩
        a             ∎

  -- Weakening.
  wk : ∀ {n} {Γ : Ctx Tp n} {a} → Γ ⇒ a ∷ Γ ⊢ S.wk
  wk {n} {Γ = Γ} {a = a} =
    gmap₂₁ (weaken′ ∘ subst (_⊢_∈_ _ _) (id-vanishes _)) id
    where
      weaken′ : ∀ {n} {Γ : Ctx Tp n} {t a b} → Γ ⊢ t ∈ a →
                b ∷ Γ ⊢ S.weaken t ∈ a / S.wk
      weaken′ = subst (_⊢_∈_ _ _) (sym /-wk) ∘ weaken

  private
    wk-sub-vanishes′ : ∀ {n a} {t : Tm n} → a ≡ C.weaken a / S.sub t
    wk-sub-vanishes′ {a = a} {t} = begin
      a                      ≡⟨ sym (wk-sub-vanishes a) ⟩
      a / S.wk / S.sub t     ≡⟨ cong (flip _/_ _) /-wk ⟩
      C.weaken a / S.sub t   ∎

    id-wk-sub-vanishes : ∀ {n a} {t : Tm n} →
                         a / S.id ≡ C.weaken a / S.sub t
    id-wk-sub-vanishes {a = a} {t} = begin
      a / S.id               ≡⟨ id-vanishes a ⟩
      a                      ≡⟨ wk-sub-vanishes′ ⟩
      C.weaken a / S.sub t   ∎

  -- A substitution which only replaces the first variable.
  sub : ∀ {n} {Γ : Ctx Tp n} {t a} → Γ ⊢ t ∈ a → a i∷ Γ ⇒ Γ ⊢ S.sub t
  sub t∈a = t∈a′ ∷ gmap₂₂ (subst (_⊢_∈_ _ _) id-wk-sub-vanishes) id
    where
      t∈a′ = subst (_⊢_∈_ _ _) wk-sub-vanishes′ t∈a

  -- A variant of single-variable substitution that handles
  -- self-dependently typed variables.
  sub′ : ∀ {n} {Γ : Ctx Tp n} {t a} → Γ ⊢ t ∈ a / S.sub t →
         a ∷ Γ ⇒ Γ ⊢ S.sub t
  sub′ t∈a[/t] = t∈a[/t] ∷ gmap₂₂ (subst (_⊢_∈_ _ _) id-wk-sub-vanishes) id

  -- A substitution which only changes the type of the first variable.
  tsub : ∀ {n} {Γ : Ctx Tp n} {a b} → b ∷ Γ ⊢ S.var zero ∈ a →
         a ∷ Γ ⇒ b ∷ Γ ⊢ S.id
  tsub z∈a = z∈a′ ∷ gmap₂ (subst (_⊢_∈_ _ _) (weaken-/ _) ∘ weaken) id
    where
      z∈a′ = subst (_⊢_∈_ _ _) (sym (id-vanishes _)) z∈a

-- Abstract typed liftings from Tm₁ to Tm₂.
record LiftTyped {Tp Tm₁ Tm₂} (l : Lift Tm₁ Tm₂)
                 (typedSub : TypedSub Tp Tp Tm₁)
                 (_⊢₂_∈_   : Typing Tp Tm₂ Tp)   : Set where

  open TypedSub typedSub renaming (_⊢_∈_ to _⊢₁_∈_)
  private module L = Lift l

  -- The underlying well-typed simple Tm₁-substitutions.
  field simpleTyped : SimpleTyped L.simple typedSub

  open SimpleTyped simpleTyped public

  -- Lifts well-typed Tm₁-terms to well-typed Tm₂-terms.
  field lift : ∀ {n} {Γ : Ctx Tp n} {t a} → Γ ⊢₁ t ∈ a → Γ ⊢₂ (L.lift t) ∈ a

-- Abstract variable typings.
module VarTyping {Tp} (weakenOps : Context.WeakenOps Tp) where
  open WeakenOps weakenOps

  infix 4 _⊢Var_∈_

  -- Abstract variable typings.
  data _⊢Var_∈_ {n} (Γ : Ctx Tp n) : Fin n → Tp n → Set where
    var : ∀ x → Γ ⊢Var x ∈ lookup x Γ

-- Abstract typed variable substitutions (α-renamings).
record TypedVarSubst (Tp : ℕ → Set) : Set where
  field
    application : Application Tp Fin
    weakenOps   : WeakenOps Tp

  open VarTyping weakenOps public

  typedSub : TypedSub Tp Tp Fin
  typedSub = record
    { _⊢_∈_       = _⊢Var_∈_
    ; application = application
    ; weakenOps   = weakenOps
    }

  open TypedSub typedSub public using () renaming (_⇒_⊢_ to _⇒_⊢α_)

  open Application application       using (_/_)
  open Lemmas₄     VarLemmas.lemmas₄ using (id; wk; _⊙_)
  private module C = WeakenOps weakenOps

  field
    /-wk        : ∀ {n} {a : Tp n} → a / wk ≡ C.weaken a
    id-vanishes : ∀ {n} (a : Tp n) → a / id ≡ a
    /-⊙         : ∀ {m n k} {σ₁ : Sub Fin m n} {σ₂ : Sub Fin n k} a →
                  a / σ₁ ⊙ σ₂ ≡ a / σ₁ / σ₂

  appLemmas : AppLemmas Tp Fin
  appLemmas = record
    { application = application
    ; lemmas₄     = VarLemmas.lemmas₄
    ; id-vanishes = id-vanishes
    ; /-⊙         = /-⊙
    }

  open ExtAppLemmas appLemmas hiding (var; weaken; /-wk; id-vanishes; subst)

  -- Extensions of renamings.
  extensionTyped : ExtensionTyped VarLemmas.simple typedSub
  extensionTyped = record
    { weaken          = weaken
    ; wk-commutes     = wk-commutes
    ; /-wk            = /-wk
    }
    where
      open Applicative.Morphism using (op-<$>)

      weaken : ∀ {n} {Γ : Ctx Tp n} {x a b} → Γ ⊢Var x ∈ a →
               b ∷ Γ ⊢Var suc x ∈ C.weaken a
      weaken (var x) =
        subst (_⊢Var_∈_ _ _) (op-<$> (lookup-morphism x) _ _) (var (suc x))

  -- Simple typed renamings.
  simpleTyped : SimpleTyped VarLemmas.simple typedSub
  simpleTyped = record
    { extensionTyped  = extensionTyped
    ; var             = var
    ; id-vanishes     = id-vanishes
    ; wk-sub-vanishes = wk-sub-vanishes
    }

  open SimpleTyped simpleTyped public
    hiding (extensionTyped; var; /-wk; id-vanishes; wk-sub-vanishes)

-- Context-replacing substitutions.
record ContextSub (Tp₁ Tp₂ Tm : ℕ → Set) : Set₁ where
  infix 4 _⊢_∈_

  field
    _⊢_∈_ : Typing Tp₂ Tm Tp₁   -- the associated typing

    -- Simple Tm-substitutions (e.g. id).
    simple : Simple Tm

    -- Operations on the (source) Tp₁-context.
    weakenOps : WeakenOps Tp₁

  open Simple    simple    using (id)
  open WeakenOps weakenOps using (toVec)

  infix 4 _⇒_⊢-id

  -- Context-replacing substitutions.
  --
  -- An alternative representation for substitutions that only change
  -- the context of a well-typed Tm-term, i.e. where the underlying
  -- untyped substitution is the identity.
  _⇒_⊢-id : ∀ {n} → Ctx Tp₁ n → Ctx Tp₂ n → Set
  Γ ⇒ Δ ⊢-id = All₂ (λ t a → Δ ⊢ t ∈ a) id (toVec Γ)

-- Equivalences between (simple) typed substitutions and their
-- context-replacing counterparts.
record Equivalence {Tp₁ Tp₂ Tm} (simple : Simple Tm)
                   (typedSub : TypedSub Tp₁ Tp₂ Tm) : Set where

  open Simple     simple
  open TypedSub   typedSub

  -- The type of context substitutions participating in this
  -- equivalence.
  contextSub : ContextSub Tp₁ Tp₂ Tm
  contextSub = record
    { _⊢_∈_     = _⊢_∈_
    ; simple    = simple
    ; weakenOps = weakenOps
    }

  open ContextSub contextSub hiding (_⊢_∈_; simple)

  -- Types are invariant under the identity substitution.
  field id-vanishes : ∀ {n} (a : Tp₁ n) → a / id ≡ a

  -- There is a context substitution for every typed identity
  -- substitution.
  sound : ∀ {n} {Γ : Ctx Tp₁ n} {Δ : Ctx Tp₂ n} → Γ ⇒ Δ ⊢-id → Γ ⇒ Δ ⊢ id
  sound ρ = map₂ (subst (_⊢_∈_ _ _) (sym (id-vanishes _))) ρ

  -- There is a context substitution for every typed identity
  -- substitution.
  complete : ∀ {n} {Γ : Ctx Tp₁ n} {Δ : Ctx Tp₂ n} → Γ ⇒ Δ ⊢ id → Γ ⇒ Δ ⊢-id
  complete σ-wt = map₂ (subst (_⊢_∈_ _ _) (id-vanishes _)) σ-wt

-- Variants of some simple typed substitutions.
record ContextSimple {Tp Tm} (simple : Simple Tm)
                     (typedSub : TypedSub Tp Tp Tm) : Set where

  field simpleTyped : SimpleTyped simple typedSub

  open TypedSub typedSub hiding (_⊢_∈_)
  private
    module U = SimpleExt simple
    module C = WeakenOps weakenOps
    module S = SimpleTyped simpleTyped
  open C using (_i∷_)

  equivalence : Equivalence simple typedSub
  equivalence = record { id-vanishes = S.id-vanishes }

  open Equivalence equivalence public
  open ContextSub  contextSub  public

  infixr 5 _/∷_
  infix 10 _↑

  -- Extension.
  _/∷_ : ∀ {n} {Γ : Ctx Tp n} {Δ : Ctx Tp n} {a b} →
         b ∷ Δ ⊢ U.var zero ∈ a → Γ ⇒ Δ ⊢-id → a ∷ Γ ⇒ b ∷ Δ ⊢-id
  z∈a /∷ σ-wt = z∈a ∷ gmap₂ S.weaken σ-wt

  -- Lifting.
  _↑ : ∀ {n} {Γ : Ctx Tp n} {Δ : Ctx Tp n} → Γ ⇒ Δ ⊢-id → ∀ {a} →
       a ∷ Γ ⇒ a ∷ Δ ⊢-id
  ρ ↑ = S.var zero /∷ ρ

  -- The identity substitution.
  id : ∀ {n} {Γ : Ctx Tp n} → Γ ⇒ Γ ⊢-id
  id = complete S.id


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

open import HoTT
open import homotopy.Bouquet
open import homotopy.SphereEndomorphism
open import groups.SphereEndomorphism
open import groups.CoefficientExtensionality
open import cw.CW
open import cw.WedgeOfCells

module cw.DegreeByProjection {i} where

  module DegreeAboveOne {n : ℕ} (skel : Skeleton {i} (S (S n)))
    (dec : has-cells-with-dec-eq skel)
    -- the cells at the upper and lower dimensions
    (upper : cells-last skel)
    (lower : cells-last (cw-init skel))
    where

    private
      lower-skel = cw-init skel
      lower-cells = cells-nth lteS skel
      lower-dec = cells-nth-has-dec-eq lteS skel dec

    degree-map : Sphere (S n) → Sphere (S n)
    degree-map = bwproj lower-dec lower
               ∘ <– (Bouquet-equiv-Xₙ/Xₙ₋₁ lower-skel)
               ∘ cfcod
               ∘ attaching-last skel upper

    degree : ℤ
    degree = Trunc-⊙SphereS-endo-degree n (Trunc-⊙SphereS-endo-in n [ degree-map ])

  module DegreeAtOne (skel : Skeleton {i} 1)
    (dec : has-cells-with-dec-eq skel)
    -- the cells at the upper and lower dimensions
    (line : cells-last skel)
    (point : cells-last (cw-init skel)) where

    private
      points-dec-eq = cells-nth-has-dec-eq (inr ltS) skel dec
      endpoint = attaching-last skel

    -- When [true] matches, [true] will be sent to [false],
    -- which is bad.
    degree-true : ℤ
    degree-true with points-dec-eq point (endpoint line true)
    degree-true | inl _ = -1
    degree-true | inr _ = 0

    -- When [false] matches, [false] will be sent to [false],
    -- which is good.
    degree-false : ℤ
    degree-false with points-dec-eq point (endpoint line false)
    degree-false | inl _ = 1
    degree-false | inr _ = 0

    degree : ℤ
    degree = degree-true ℤ+ degree-false

  degree-last : ∀ {n} (skel : Skeleton {i} (S n))
    → has-cells-with-dec-eq skel
    → cells-last skel → cells-last (cw-init skel) → ℤ
  degree-last {n = O} = DegreeAtOne.degree
  degree-last {n = S _} = DegreeAboveOne.degree

  degree-nth : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n)
    → has-cells-with-dec-eq skel
    → cells-nth Sm≤n skel → cells-last (cw-init (cw-take Sm≤n skel)) → ℤ
  degree-nth Sm≤n skel dec = degree-last (cw-take Sm≤n skel) (take-has-cells-with-dec-eq Sm≤n skel dec)

  has-degrees-with-finite-support : ∀ {n} (skel : Skeleton {i} n)
    → has-cells-with-dec-eq skel → Type i
  has-degrees-with-finite-support {n = O} _ _ = Lift ⊤
  has-degrees-with-finite-support {n = S n} skel dec =
    has-degrees-with-finite-support (cw-init skel) (init-has-cells-with-dec-eq skel dec) ×
    ∀ upper → has-finite-support (cells-nth-has-dec-eq (inr ltS) skel dec) (degree-last skel dec upper)

  init-has-degrees-with-finite-support : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → has-degrees-with-finite-support (cw-init skel) (init-has-cells-with-dec-eq skel dec)
  init-has-degrees-with-finite-support skel dec fin-sup = fst fin-sup

  take-has-degrees-with-finite-support : ∀ {m n} (m≤n : m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → has-degrees-with-finite-support (cw-take m≤n skel) (take-has-cells-with-dec-eq m≤n skel dec)
  take-has-degrees-with-finite-support (inl idp) skel dec fin-sup = fin-sup
  take-has-degrees-with-finite-support (inr ltS) skel dec fin-sup =
    init-has-degrees-with-finite-support skel dec fin-sup
  take-has-degrees-with-finite-support (inr (ltSR lt)) skel dec fin-sup =
    take-has-degrees-with-finite-support (inr lt) (cw-init skel)
      (init-has-cells-with-dec-eq skel dec)
      (init-has-degrees-with-finite-support skel dec fin-sup)

  degree-last-has-finite-support : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → ∀ upper → has-finite-support
        (cells-last-has-dec-eq (cw-init skel) (init-has-cells-with-dec-eq skel dec))
        (degree-last skel dec upper)
  degree-last-has-finite-support skel dec fin-sup = snd fin-sup

  degree-nth-has-finite-support : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → ∀ upper → has-finite-support
        (cells-last-has-dec-eq
          (cw-init (cw-take Sm≤n skel))
          (init-has-cells-with-dec-eq (cw-take Sm≤n skel) (take-has-cells-with-dec-eq Sm≤n skel dec)))
        (degree-nth Sm≤n skel dec upper)
  degree-nth-has-finite-support Sm≤n skel dec fin-sup =
    degree-last-has-finite-support (cw-take Sm≤n skel)
      (take-has-cells-with-dec-eq Sm≤n skel dec)
      (take-has-degrees-with-finite-support Sm≤n skel dec fin-sup)

  -- the following are named [boundary'] because it is not extended to the free groups

  boundary'-last : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → cells-last skel → FreeAbGroup.El (cells-last (cw-init skel))
  boundary'-last skel dec fin-sup upper = fst ((snd fin-sup) upper)

  boundary-last : ∀ {n} (skel : Skeleton {i} (S n)) dec
    → has-degrees-with-finite-support skel dec
    → FreeAbGroup.grp (cells-last skel) →ᴳ FreeAbGroup.grp (cells-last (cw-init skel))
  boundary-last skel dec fin-sup =
    FreeAbGroup-extend (FreeAbGroup (cells-last (cw-init skel))) (boundary'-last skel dec fin-sup)

  boundary'-nth : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    → cells-nth Sm≤n skel → FreeAbGroup.El (cells-last (cw-init (cw-take Sm≤n skel)))
  boundary'-nth Sm≤n skel dec fin-sup =
    boundary'-last (cw-take Sm≤n skel)
      (take-has-cells-with-dec-eq Sm≤n skel dec)
      (take-has-degrees-with-finite-support Sm≤n skel dec fin-sup)

  boundary-nth : ∀ {m n} (Sm≤n : S m ≤ n) (skel : Skeleton {i} n) dec
    → has-degrees-with-finite-support skel dec
    →  FreeAbGroup.grp (cells-nth Sm≤n skel)
    →ᴳ FreeAbGroup.grp (cells-last (cw-init (cw-take Sm≤n skel)))
  boundary-nth Sm≤n skel dec fin-sup =
    FreeAbGroup-extend
      (FreeAbGroup (cells-last (cw-init (cw-take Sm≤n skel))))
      (boundary'-nth Sm≤n skel dec fin-sup)


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

open import HoTT
open import lib.cubical.elims.SuspSmash

module homotopy.SuspProduct where

module SuspProduct {i} {j} (X : Ptd i) (Y : Ptd j) where

  private

    {- into -}

    into-glue : fst (X ⊙× Y) → winl (north _) == winr (winr (north _))
    into-glue (x , y) =
      ap winl (σloop X x) ∙ wglue
      ∙ ap (winr ∘ winl) (σloop (⊙Smash X Y) (cfcod _ (x , y)))
      ∙ ap winr wglue ∙ ap (winr ∘ winr) (σloop Y y)

    into-glue-x : (x : fst X) →
      into-glue (x , snd Y) == ap winl (σloop X x) ∙ wglue ∙ ap winr wglue
    into-glue-x x =
      ap (λ p → ap winl (σloop X x) ∙ wglue ∙ p
                 ∙ ap winr wglue ∙ ap (winr ∘ winr) (σloop Y (snd Y)))
         (ap (ap (winr ∘ winl) ∘ σloop (⊙Smash X Y)) (! (cfglue _ (winl x)))
          ∙ ap (ap (winr ∘ winl)) σloop-pt)
      ∙
      ap (λ q → ap winl (σloop X x) ∙ wglue ∙ ap winr wglue
                ∙ ap (winr ∘ winr) q)
         σloop-pt
      ∙
      ap (λ q → ap winl (σloop X x) ∙ wglue ∙ q) (∙-unit-r _)

    into-glue-y : (y : fst Y) →
      into-glue (snd X , y)
      == wglue ∙ ap winr wglue ∙ ap (winr ∘ winr) (σloop Y y)
    into-glue-y y =
      ap (λ p → ap winl (σloop X (snd X)) ∙ wglue ∙ p
                 ∙ ap winr wglue ∙ ap (winr ∘ winr) (σloop Y y))
         (ap (ap (winr ∘ winl) ∘ σloop (⊙Smash X Y)) (! (cfglue _ (winr y)))
          ∙ ap (ap (winr ∘ winl)) σloop-pt)
      ∙
      ap (λ q → ap winl q ∙ wglue ∙ ap winr wglue
                ∙ ap (winr ∘ winr) (σloop Y y))
         σloop-pt

    into-glue-0 : into-glue (snd X , snd Y) == wglue ∙ ap winr wglue
    into-glue-0 = into-glue-x (snd X)
                  ∙ ap (λ p → ap winl p ∙ wglue ∙ ap winr wglue) σloop-pt

    module Into = SuspensionRec (fst (X ⊙× Y))
      {C = fst (⊙Susp X ⊙∨ (⊙Susp (X ⊙∧ Y) ⊙∨ ⊙Susp Y))}
      (winl (north _))
      (winr (winr (north _)))
      into-glue

    into = Into.f

    {- out -}

    out-× : fst X × fst Y → north _ == north _
    out-× (x , y) = merid _ (snd X , snd Y) ∙ ! (merid _ (x , snd Y))
                    ∙ merid _ (x , y) ∙ ! (merid _ (snd X , y))

    expand₁ : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : z == y)
      → idp == p ∙ ! q ∙ q ∙ ! p
    expand₁ idp idp = idp

    expand₂ : ∀ {i} {A : Type i} {x y z : A} (p : x == y) (q : x == z)
      → idp == p ∙ ! p ∙ q ∙ ! q
    expand₂ idp idp = idp

    shift : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A}
      {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀}
      {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == a₁₁}
      → Square p₀₋ p₋₀ p₋₁ p₁₋
      → Square p₀₋ idp p₋₁ (p₋₀ ∙ p₁₋)
    shift ids = ids

    fill : Σ (idp == idp) (λ p →
      Square (expand₁ (merid _ (snd X , snd Y)) (merid _ (snd X , snd Y))) p
             (ap (λ w → out-× (∨-in-× X Y w)) wglue)
             (expand₂ (merid _ (snd X , snd Y)) (merid _ (snd X , snd Y))))
    fill = fill-square-top _ _ _

    module OutSmash = SuspensionRec (Smash X Y)
      (north (fst (X ⊙× Y)))
      (north _)
      (CofiberRec.f _
        idp
        out-×
        (Wedge-elim
          (λ x → expand₁ (merid _ (snd X , snd Y)) (merid _ (x , snd Y)))
          (λ y → fst fill
                 ∙ expand₂ (merid _ (snd X , snd Y)) (merid _ (snd X , y)))
          (↓-cst=app-from-square $ shift (snd fill))))

    module OutWinr = WedgeRec {X = ⊙Susp (X ⊙∧ Y)} {Y = ⊙Susp Y}
      {C = fst (⊙Susp (X ⊙× Y))}
      OutSmash.f
      (susp-fmap (λ y → (snd X , y)))
      idp

    module Out = WedgeRec {X = ⊙Susp X}
      {Y = ⊙Susp (X ⊙∧ Y) ⊙∨ ⊙Susp Y}
      {C = fst (⊙Susp (X ⊙× Y))}
      (susp-fmap (λ x → (x , snd Y)))
      OutWinr.f
      idp

    out = Out.f

    {- into-out -}

    into-out-x : ∀ σx → into (out (winl σx)) == winl σx
    into-out-x = Suspension-elim _
      idp
      (! (ap winl (! (merid _ (snd X))) ∙ wglue ∙ ap winr wglue))
      (λ x → ↓-='-from-square $
        (ap-∘ into (out ∘ winl) (merid _ x)
         ∙ ap (ap into) (SuspFmap.glue-β (λ x → (x , snd Y)) x)
         ∙ Into.glue-β (x , snd Y) ∙ into-glue-x x
         ∙ ap (λ p → p ∙ wglue ∙ ap winr wglue)
              (ap-∙ winl (merid _ x) (! (merid _ (snd X))))
         ∙ ∙-assoc (ap winl (merid _ x)) (ap winl (! (merid _ (snd X))))
                   (wglue ∙ ap winr wglue))
        ∙v⊡ (vid-square {p = ap winl (merid _ x)} ⊡h
             tr-square (ap winl (! (merid _ (snd X))) ∙ wglue ∙ ap winr wglue))
        ⊡v∙ ∙-unit-r _)

    into-out-y : ∀ σy → into (out (winr (winr σy))) == winr (winr σy)
    into-out-y = Suspension-elim _
      (wglue ∙ ap winr wglue)
      (ap (winr ∘ winr) (merid _ (snd Y)))
      (λ y → ↓-='-from-square $
        (ap-∘ into (out ∘ winr ∘ winr) (merid _ y)
         ∙ ap (ap into) (SuspFmap.glue-β (λ y → (snd X , y)) y)
         ∙ Into.glue-β (snd X , y) ∙ into-glue-y y
         ∙ ap (λ p → wglue ∙ ap winr wglue ∙ p)
              (ap-∙ (winr ∘ winr) (merid _ y) (! (merid _ (snd Y)))
               ∙ ap (λ q → ap (winr ∘ winr) (merid _ y) ∙ q)
                    (ap-! (winr ∘ winr) (merid _ (snd Y)))))
        ∙v⊡ lemma wglue (ap winr wglue) (ap (winr ∘ winr) (merid _ y))
                  (ap (winr ∘ winr) (merid _ (snd Y))))
      where
      lemma : ∀ {i} {A : Type i} {a₁ a₂ a₃ a₄ : A}
        (p : a₁ == a₂) (q : a₂ == a₃) (r : a₃ == a₄) (s : a₃ == a₄)
        → Square (p ∙ q) (p ∙ q ∙ r ∙ ! s) r s
      lemma idp idp idp s = disc-to-square (! (!-inv-l s))

    into-out-s : ∀ σs → into (out (winr (winl σs))) == winr (winl σs)
    into-out-s = susp-smash-path-elim _ _
      wglue
      (wglue ∙ ap (winr ∘ winl) (merid _ (cfbase _)))
      (λ {(x , y) →
        (ap-∘ into (out ∘ winr ∘ winl) (merid _ (cfcod _ (x , y)))
         ∙ ap (ap into) (OutSmash.glue-β (cfcod _ (x , y)))
         ∙ lemma₁ into
             (Into.glue-β (snd X , snd Y) ∙ into-glue-0)
             (Into.glue-β (x , snd Y) ∙ into-glue-x x)
             (Into.glue-β (x , y))
             (Into.glue-β (snd X , y) ∙ into-glue-y y))
        ∙v⊡ lemma₂ wglue (ap winr wglue) (ap winl (σloop X x))
                    (ap (winr ∘ winl) (σloop (⊙Smash X Y) (cfcod _ (x , y))))
                    (ap (winr ∘ winr) (σloop Y y))
                    (ap (winr ∘ winl) (merid _ (cfcod _ (x , y))))
                    (ap (winr ∘ winl) (merid _ (cfbase _)))
                    (ap-∙ (winr ∘ winl) (merid _ (cfcod _ (x , y)))
                                        (! (merid _ (cfbase _)))
                     ∙ ap (λ p → ap (winr ∘ winl) (merid _ (cfcod _ (x , y)))
                                 ∙ p)
                          (ap-! (winr ∘ winl) (merid _ (cfbase _))))})
      where
      {- Let's not do these by hand -}
      lemma₁ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
        {a₀ a₁ a₂ a₃ a₄ : A}
        {p : a₀ == a₁} {q : a₂ == a₁} {r : a₂ == a₃} {s : a₄ == a₃}
        {p' : f a₀ == f a₁} {q' : f a₂ == f a₁}
        {r' : f a₂ == f a₃} {s' : f a₄ == f a₃}
        (α : ap f p == p') (β : ap f q == q')
        (γ : ap f r == r') (δ : ap f s == s')
        → ap f (p ∙ ! q ∙ r ∙ ! s) == p' ∙ ! q' ∙ r' ∙ ! s'
      lemma₁ f {p = idp} {q = idp} {r = idp} {s = idp} idp idp idp idp = idp

      lemma₂ : ∀ {i} {A : Type i} {a₀ a₁ a₂ a₃ a₄ a₅ : A}
        (p : a₀ == a₁) (q : a₁ == a₂) (r : a₃ == a₀) (s : a₁ == a₁)
        (t : a₂ == a₄) (u : a₁ == a₅) (v : a₁ == a₅)
        → s == u ∙ ! v
        → Square p ((p ∙ q) ∙ ! (r ∙ p ∙ q) ∙ (r ∙ p ∙ s ∙ q ∙ t)
                    ∙ ! (p ∙ q ∙ t))
                 u (p ∙ v)
      lemma₂ idp idp idp ._ idp idp v idp = disc-to-square $
        ! (ap (λ w → w ∙ v) (∙-unit-r _ ∙ ∙-unit-r (! v)) ∙ !-inv-l v)

    into-out-winr : ∀ r → into (out (winr r)) == winr r
    into-out-winr = Wedge-elim
      into-out-s
      into-out-y
      (↓-='-from-square $
        (ap-∘ into (out ∘ winr) wglue
         ∙ ap (ap into) OutWinr.glue-β)
        ∙v⊡ disc-to-square idp)

    into-out : ∀ w → into (out w) == w
    into-out = Wedge-elim
      into-out-x
      into-out-winr
      (↓-∘=idf-from-square into out $
        ap (ap into) Out.glue-β ∙v⊡ connection)

    out-into-merid : (s : fst (X ⊙× Y))
      → idp == merid _ (snd X , snd Y) [ (λ σ → out (into σ) == σ) ↓ merid _ s ]
    out-into-merid (x , y) = ↓-∘=idf-from-square out into $
      (ap (ap out) (Into.glue-β (x , y))
        ∙ lemma₁ out
            (∘-ap out winl (σloop X x)
             ∙ ap-∙ (out ∘ winl) (merid _ x) (! (merid _ (snd X)))
             ∙ SuspFmap.glue-β (λ x → (x , snd Y)) x
               ∙2 (ap-! (out ∘ winl) (merid _ (snd X))
                   ∙ ap ! (SuspFmap.glue-β (λ x → (x , snd Y)) (snd X))))
            Out.glue-β
            (∘-ap out (winr ∘ winl) (σloop _ (cfcod _ (x , y)))
             ∙ ap-∙ OutSmash.f (merid _ (cfcod _ (x , y)))
                               (! (merid _ (cfbase _)))
             ∙ OutSmash.glue-β (cfcod _ (x , y))
               ∙2 (ap-! OutSmash.f (merid _ (cfbase _))
                   ∙ ap ! (OutSmash.glue-β (cfbase _))))
            (∘-ap out winr wglue ∙ OutWinr.glue-β)
            (∘-ap out (winr ∘ winr) (σloop Y y)
             ∙ ap-∙ (out ∘ winr ∘ winr) (merid _ y) (! (merid _ (snd Y)))
             ∙ SuspFmap.glue-β (λ y → (snd X , y)) y
               ∙2 (ap-! (out ∘ winr ∘ winr) (merid _ (snd Y))
                   ∙ ap ! (SuspFmap.glue-β (λ y → (snd X , y)) (snd Y)))))
      ∙v⊡ lemma₂ (merid _ (x , snd Y)) (merid _ (snd X , snd Y))
                  (merid _ (x , y)) (merid _ (snd X , y))
                  (merid _ (snd X , snd Y))
      where
      lemma₁ : ∀ {i j} {A : Type i} {B : Type j} (f : A → B)
        {a₀ a₁ a₂ a₃ a₄ a₅ : A}
        {p : a₀ == a₁} {q : a₁ == a₂} {r : a₂ == a₃}
        {s : a₃ == a₄} {t : a₄ == a₅}
        {p' : f a₀ == f a₁} {q' : f a₁ == f a₂} {r' : f a₂ == f a₃}
        {s' : f a₃ == f a₄} {t' : f a₄ == f a₅}
        (α : ap f p == p') (β : ap f q == q') (γ : ap f r == r')
        (δ : ap f s == s') (ε : ap f t == t')
        → ap f (p ∙ q ∙ r ∙ s ∙ t) == p' ∙ q' ∙ r' ∙ s' ∙ t'
      lemma₁ f {p = idp} {q = idp} {r = idp} {s = idp} {t = idp}
        idp idp idp idp idp = idp

      lemma₂ : ∀ {i} {A : Type i} {a₀ a₁ a₂ a₃ a₄ a₅ : A}
        (p : a₀ == a₁) (q : a₂ == a₁) (r : a₀ == a₃)
        (s : a₄ == a₃) (t : a₅ == a₃)
        → Square idp ((p ∙ ! q) ∙ ((q ∙ ! p ∙ r ∙ ! s) ∙ idp) ∙ (s ∙ ! t)) r t
      lemma₂ idp idp idp idp idp = ids

    out-into : ∀ σ → out (into σ) == σ
    out-into = Suspension-elim _
      idp
      (merid _ (snd X , snd Y))
      out-into-merid

  abstract
    eq : fst (⊙Susp (X ⊙× Y)) ≃ fst (⊙Susp X ⊙∨ (⊙Susp (X ⊙∧ Y) ⊙∨ ⊙Susp Y))
    eq = equiv into out into-out out-into

    ⊙path : ⊙Susp (X ⊙× Y) == ⊙Susp X ⊙∨ (⊙Susp (X ⊙∧ Y) ⊙∨ ⊙Susp Y)
    ⊙path = ⊙ua eq idp


-- Occurs there are several ways to parse an operator application.
module AmbiguousParseForApplication where

postulate
  X             : Set
  if_then_else_ : X -> X -> X -> X
  if_then_      : X -> X -> X

bad : X -> X
bad x = if x then if x then x else x


open import Common.Level

postulate
  ℓ : Level

data D : Set (lsuc ℓ) where
  c : (ℓ : Level) → Set ℓ → D

-- Bad error:
-- The type of the constructor does not fit in the sort of the
-- datatype, since Set (lsuc ℓ) is not less or equal than Set (lsuc ℓ)
-- when checking the constructor c in the declaration of D

-- Jesper, 2018-12-09: new, better error:
-- Set (lsuc ℓ₁) is not less or equal than Set (lsuc ℓ)
-- when checking that the type (ℓ₁ : Level) → Set ℓ₁ → D of the
-- constructor c fits in the sort Set (lsuc ℓ) of the datatype.


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

open import Fragment.Algebra.Signature

module Fragment.Algebra.Properties where

open import Fragment.Algebra.Algebra
open import Fragment.Algebra.Free

open import Level using (Level)

open import Data.Nat using (ℕ)
open import Data.Vec using (Vec; []; _∷_)

private
  variable
    a ℓ : Level

mutual
  map-extend : ∀ {Σ O a n} → {A : Set a}
               → Vec (Term Σ A) n
               → Vec (Term (Σ ⦅ O ⦆) A) n
  map-extend []       = []
  map-extend (x ∷ xs) = extend x ∷ map-extend xs

  extend : ∀ {Σ O} → {A : Set a}
           → Term Σ A → Term (Σ ⦅ O ⦆) A
  extend (atom x)    = atom x
  extend (term f xs) = term (oldₒ f) (map-extend xs)

forgetₒ : ∀ {Σ O} → Algebra (Σ ⦅ O ⦆) {a} {ℓ} → Algebra Σ {a} {ℓ}
forgetₒ {Σ = Σ} A = record { ∥_∥/≈           = ∥ A ∥/≈
                           ; ∥_∥/≈-isAlgebra = forget-isAlgebra
                           }
  where forget-⟦_⟧ : Interpretation Σ ∥ A ∥/≈
        forget-⟦ f ⟧ x = A ⟦ oldₒ f ⟧ x

        forget-⟦⟧-cong : Congruence Σ ∥ A ∥/≈ forget-⟦_⟧
        forget-⟦⟧-cong f x = (A ⟦ oldₒ f ⟧-cong) x

        forget-isAlgebra : IsAlgebra Σ ∥ A ∥/≈
        forget-isAlgebra = record { ⟦_⟧     = forget-⟦_⟧
                                  ; ⟦⟧-cong = forget-⟦⟧-cong
                                  }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Printf
------------------------------------------------------------------------

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

module Text.Printf where

open import Level using (0ℓ; Lift)
open import Data.List.Base as List using (List; []; _∷_)
open import Data.Nat.Base using (ℕ)
open import Data.Product
open import Data.Product.Nary.NonDependent
open import Data.String.Base
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Data.Unit using (⊤)
open import Function.Nary.NonDependent
open import Function
open import Strict

import Data.Char.Base as Cₛ
import Data.Integer   as ℤₛ
import Data.Float     as Fₛ
import Data.Nat.Show  as ℕₛ

open import Text.Format as Format hiding (Error)

assemble : ∀ fmt → Product⊤ _ ⟦ fmt ⟧ → List String
assemble []              vs       = []
assemble (`ℕ      ∷ fmt) (n , vs) = ℕₛ.show n  ∷ assemble fmt vs
assemble (`ℤ      ∷ fmt) (z , vs) = ℤₛ.show z  ∷ assemble fmt vs
assemble (`Float  ∷ fmt) (f , vs) = Fₛ.show f  ∷ assemble fmt vs
assemble (`Char   ∷ fmt) (c , vs) = fromChar c ∷ assemble fmt vs
assemble (`String ∷ fmt) (s , vs) = s          ∷ assemble fmt vs
assemble (Raw str ∷ fmt) vs       = str ∷ assemble fmt vs

record Error (e : Format.Error) : Set where

private

  Size : Format.Error ⊎ Format → ℕ
  Size (inj₁ err) = 0
  Size (inj₂ fmt) = size fmt

  Printf : ∀ pr → Set (⨆ (Size pr) 0ℓs)
  Printf (inj₁ err) = Error err
  Printf (inj₂ fmt) = Arrows _ ⟦ fmt ⟧ String

  printf' : ∀ pr → Printf pr
  printf' (inj₁ err) = _
  printf' (inj₂ fmt) = curry⊤ₙ _ (concat ∘′ assemble fmt)

printf : (input : String) → Printf (lexer input)
printf input = printf' (lexer input)


-- 2013-02-21 Andreas
-- ensure that constructor-headedness works also for abstract things
module Issue796 where

data U : Set where
  a b : U

data A : Set where
data B : Set where

abstract
  A' B' : Set

  A' = A
  B' = B  -- fails if changed to A.

  [_] : U → Set
  [_] a = A'
  [_] b = B'

  f : ∀ u → [ u ] → U
  f u _ = u

  postulate x : A'

  zzz = f _ x
  -- succeeds since [_] is constructor headed


open import Common.Prelude hiding (tt)
open import Common.Reflection
open import Common.Equality

tt : ⊤
tt = record{}

NoConf : Nat → Nat → Set
NoConf zero zero = ⊤
NoConf zero (suc n) = ⊥
NoConf (suc m) zero = ⊥
NoConf (suc m) (suc n) = m ≡ n

pattern `Nat = def (quote Nat) []

infixr 0 Π
syntax Π x a b = [ x ∈ a ]→ b
Π : String → Type → Type → Type
Π x a b = pi (vArg a) (abs x b)

-- noConf : (m n : ℕ) → m ≡ n → NoConfusion-ℕ m n
-- noConf zero .zero refl = tt
-- noConf (suc m) .(suc m) refl = refl

noConf : FunDef
noConf = funDef
  ([ "A" ∈ `Nat ]→ [ "B" ∈ `Nat ]→
   [ "C" ∈ def (quote _≡_) (vArg (var 1 []) ∷ vArg (var 0 []) ∷ []) ]→
   def (quote NoConf) (vArg (var 2 []) ∷ vArg (var 1 []) ∷ []))
  ( clause (vArg (con (quote zero) []) ∷ vArg dot ∷ vArg (con (quote refl) []) ∷ [])
           (def (quote tt) [])
  ∷ clause (vArg (con (quote suc) (vArg (var "m") ∷ [])) ∷ vArg dot ∷ vArg (con (quote refl) []) ∷ [])
           (def (quote refl) [])
  ∷ [])

unquoteDecl test = define (vArg test) noConf


------------------------------------------------------------------------
-- Universe levels
------------------------------------------------------------------------

module Common.Level where

postulate
  Level : Set
  lzero : Level
  lsuc  : (i : Level) → Level
  _⊔_   : Level -> Level -> Level

{-# IMPORT Common.FFI #-}
{-# COMPILED_TYPE Level Common.FFI.Level #-}
{-# COMPILED lzero Common.FFI.Zero #-}
{-# COMPILED lsuc Common.FFI.Suc #-}

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO lzero  #-}
{-# BUILTIN LEVELSUC  lsuc   #-}
{-# BUILTIN LEVELMAX  _⊔_ #-}

infixl 6 _⊔_

-- Lifting.

record Lift {a ℓ} (A : Set a) : Set (a ⊔ ℓ) where
  constructor lift
  field lower : A

open Lift public


------------------------------------------------------------------------
-- Definition of the size of an expression, along with some properties
------------------------------------------------------------------------

module Expression-size where

open import Equality.Propositional
open import Prelude hiding (const)

open import List equality-with-J
open import Nat equality-with-J

-- To simplify the development, let's work with actual natural numbers
-- as variables and constants (see
-- Atom.one-can-restrict-attention-to-χ-ℕ-atoms).

open import Atom

open import Chi            χ-ℕ-atoms
open import Combinators
open import Free-variables χ-ℕ-atoms
open import Termination    χ-ℕ-atoms

open χ-atoms χ-ℕ-atoms

------------------------------------------------------------------------
-- A definition

mutual

  -- The size of an expression.

  size : Exp → ℕ
  size (apply e₁ e₂) = 1 + size e₁ + size e₂
  size (lambda x e)  = 1 + size e
  size (case e bs)   = 1 + size e + size-B⋆ bs
  size (rec x e)     = 1 + size e
  size (var x)       = 1
  size (const c es)  = 1 + size-⋆ es

  size-B : Br → ℕ
  size-B (branch c xs e) = 1 + length xs + size e

  size-⋆ : List Exp → ℕ
  size-⋆ []       = 1
  size-⋆ (e ∷ es) = 1 + size e + size-⋆ es

  size-B⋆ : List Br → ℕ
  size-B⋆ []       = 1
  size-B⋆ (b ∷ bs) = 1 + size-B b + size-B⋆ bs

------------------------------------------------------------------------
-- Properties

-- Every expression has size at least one.

1≤size : ∀ e → 1 ≤ size e
1≤size (apply e₁ e₂) = suc≤suc (zero≤ _)
1≤size (lambda x e)  = suc≤suc (zero≤ _)
1≤size (case e bs)   = suc≤suc (zero≤ _)
1≤size (rec x e)     = suc≤suc (zero≤ _)
1≤size (var x)       = suc≤suc (zero≤ _)
1≤size (const c es)  = suc≤suc (zero≤ _)

1≤size-⋆ : ∀ es → 1 ≤ size-⋆ es
1≤size-⋆ []      = suc≤suc (zero≤ _)
1≤size-⋆ (_ ∷ _) = suc≤suc (zero≤ _)

1≤size-B⋆ : ∀ bs → 1 ≤ size-B⋆ bs
1≤size-B⋆ []      = suc≤suc (zero≤ _)
1≤size-B⋆ (_ ∷ _) = suc≤suc (zero≤ _)

-- Closed expressions have size at least two.

closed→2≤size : ∀ e → Closed e → 2 ≤ size e
closed→2≤size (apply e₁ e₂) cl =
  2                      ≤⟨ m≤m+n _ _ ⟩
  2 + size e₂            ≤⟨ (1 ∎≤) +-mono 1≤size e₁ +-mono (size e₂ ∎≤) ⟩∎
  1 + size e₁ + size e₂  ∎≤

closed→2≤size (lambda x e) cl =
  2           ≤⟨ (1 ∎≤) +-mono 1≤size e ⟩∎
  1 + size e  ∎≤

closed→2≤size (case e bs) cl =
  2                        ≤⟨ m≤m+n _ _ ⟩
  2 + size-B⋆ bs           ≤⟨ (1 ∎≤) +-mono 1≤size e +-mono (size-B⋆ bs ∎≤) ⟩∎
  1 + size e + size-B⋆ bs  ∎≤

closed→2≤size (rec x e) cl =
  2           ≤⟨ (1 ∎≤) +-mono 1≤size e ⟩∎
  1 + size e  ∎≤

closed→2≤size (var x) cl = ⊥-elim (cl x (λ ()) (var refl))

closed→2≤size (const c es) cl =
  2              ≤⟨ (1 ∎≤) +-mono 1≤size-⋆ es ⟩∎
  1 + size-⋆ es  ∎≤

-- Closed, non-terminating expressions of size two must have the form
-- "rec x = x" (for some x).

data Is-loop : Exp → Type where
  rec : ∀ {x y} → x ≡ y → Is-loop (rec x (var y))

closed-non-terminating-size≡2→loop :
  ∀ e → Closed e → ¬ Terminates e → size e ≡ 2 → Is-loop e
closed-non-terminating-size≡2→loop (rec x e) cl _ size≡2 with e
... | apply e₁ e₂ = ⊥-elim $ +≮ 1 (4                      ≤⟨ (2 ∎≤) +-mono 1≤size e₁ +-mono 1≤size e₂ ⟩
                                   2 + size e₁ + size e₂  ≡⟨ size≡2 ⟩≤
                                   2                      ∎≤)
... | lambda _ e′ = ⊥-elim $ +≮ 0 (3            ≤⟨ (2 ∎≤) +-mono 1≤size e′ ⟩
                                   2 + size e′  ≡⟨ size≡2 ⟩≤
                                   2            ∎≤)
... | case e′ bs  = ⊥-elim $ +≮ 0 (3                         ≤⟨ (2 ∎≤) +-mono 1≤size e′ +-mono zero≤ _ ⟩
                                   2 + size e′ + size-B⋆ bs  ≡⟨ size≡2 ⟩≤
                                   2                         ∎≤)
... | rec _ e′    = ⊥-elim $ +≮ 0 (3            ≤⟨ (2 ∎≤) +-mono 1≤size e′ ⟩
                                   2 + size e′  ≡⟨ size≡2 ⟩≤
                                   2            ∎≤)
... | const _ es  = ⊥-elim $ +≮ 0 (3              ≤⟨ (2 ∎≤) +-mono 1≤size-⋆ es ⟩
                                   2 + size-⋆ es  ≡⟨ size≡2 ⟩≤
                                   2              ∎≤)
... | var y with x V.≟ y
...   | yes x≡y = rec x≡y
...   | no  x≢y = ⊥-elim (cl y (λ ()) (rec (x≢y ∘ sym) (var refl)))

closed-non-terminating-size≡2→loop (apply e₁ e₂) _ _ size≡2 =
  ⊥-elim $ +≮ 0 (3                      ≤⟨ (1 ∎≤) +-mono 1≤size e₁ +-mono 1≤size e₂ ⟩
                 1 + size e₁ + size e₂  ≡⟨ size≡2 ⟩≤
                 2                      ∎≤)

closed-non-terminating-size≡2→loop (lambda x e) _ ¬⇓ _ =
  ⊥-elim (¬⇓ (_ , lambda))

closed-non-terminating-size≡2→loop (case e bs) _ _ size≡2 =
  ⊥-elim $ +≮ 0 (3                        ≤⟨ (1 ∎≤) +-mono 1≤size e +-mono 1≤size-B⋆ bs ⟩
                 1 + size e + size-B⋆ bs  ≡⟨ size≡2 ⟩≤
                 2                        ∎≤)

closed-non-terminating-size≡2→loop (var x) cl _ _ =
  ⊥-elim (cl x (λ ()) (var refl))

closed-non-terminating-size≡2→loop (const c []) _ ¬⇓ _ =
  ⊥-elim (¬⇓ (_ , const []))

closed-non-terminating-size≡2→loop (const c (e ∷ es)) _ _ size≡2 =
  ⊥-elim $ +≮ 1 (4                       ≤⟨ (2 ∎≤) +-mono 1≤size e +-mono 1≤size-⋆ es ⟩
                 2 + size e + size-⋆ es  ≡⟨ size≡2 ⟩≤
                 2                       ∎≤)

-- Closed, non-terminating expressions of minimal size must have the
-- form "rec x = x" (for some x).

minimal-closed-non-terminating→loop :
  let P : Exp → Type
      P e = Closed e × ¬ Terminates e
  in
  ∀ e → P e → (∀ e′ → P e′ → size e ≤ size e′) → Is-loop e
minimal-closed-non-terminating→loop e (cl , ¬⇓) minimal =
  closed-non-terminating-size≡2→loop e cl ¬⇓ (
    ≤-antisymmetric
      (minimal loop (loop-closed , ¬loop⇓))
      (closed→2≤size e cl))


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use
-- Data.Vec.Relation.Unary.All.Properties directly.
------------------------------------------------------------------------

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

module Data.Vec.All.Properties where

open import Data.Vec.Relation.Unary.All.Properties public

{-# WARNING_ON_IMPORT
"Data.Vec.All.Properties was deprecated in v1.0.
Use Data.Vec.Relation.Unary.All.Properties instead."
#-}


{-# OPTIONS --without-K --safe #-}
open import Categories.Category

module Categories.Diagram.Pullback {o ℓ e} (C : Category o ℓ e) where

open Category C
open HomReasoning

open import Level
open import Data.Product using (_,_; ∃)
open import Function using (flip; _$_) renaming (_∘_ to _●_)
open import Categories.Morphism C
open import Categories.Object.Product C
open import Categories.Diagram.Equalizer C
open import Categories.Morphism.Reasoning C as Square
  renaming (glue to glue-square) hiding (id-unique)

private
  variable
    A B X Y Z : Obj
    f g h h₁ h₂ i i₁ i₂ j : A ⇒ B

-- Pullback of two arrows with a common codomain
record Pullback (f : X ⇒ Z) (g : Y ⇒ Z) : Set (o ⊔ ℓ ⊔ e) where
  field
    {P} : Obj
    p₁  : P ⇒ X
    p₂  : P ⇒ Y

  field
    commute   : f ∘ p₁ ≈ g ∘ p₂
    universal : ∀ {h₁ : A ⇒ X} {h₂ : A ⇒ Y} → f ∘ h₁ ≈ g ∘ h₂ → A ⇒ P
    unique    : ∀ {eq : f ∘ h₁ ≈ g ∘ h₂} →
                  p₁ ∘ i ≈ h₁ → p₂ ∘ i ≈ h₂ →
                  i ≈ universal eq

    p₁∘universal≈h₁  : ∀ {eq : f ∘ h₁ ≈ g ∘ h₂} →
                         p₁ ∘ universal eq ≈ h₁
    p₂∘universal≈h₂  : ∀ {eq : f ∘ h₁ ≈ g ∘ h₂} →
                         p₂ ∘ universal eq ≈ h₂

  unique′ : (eq eq′ : f ∘ h₁ ≈ g ∘ h₂) → universal eq ≈ universal eq′
  unique′ eq eq′ = unique p₁∘universal≈h₁ p₂∘universal≈h₂

  id-unique : id ≈ universal commute
  id-unique = unique identityʳ identityʳ

  unique-diagram : p₁ ∘ h ≈ p₁ ∘ i →
                   p₂ ∘ h ≈ p₂ ∘ i →
                   h ≈ i
  unique-diagram {h = h} {i = i} eq₁ eq₂ = begin
    h            ≈⟨ unique eq₁ eq₂ ⟩
    universal eq ≈˘⟨ unique refl refl ⟩
    i            ∎
    where eq = extendʳ commute

swap : Pullback f g → Pullback g f
swap p = record
  { p₁              = p₂
  ; p₂              = p₁
  ; commute        = ⟺ commute
  ; universal       = universal ● ⟺
  ; unique          = flip unique
  ; p₁∘universal≈h₁ = p₂∘universal≈h₂
  ; p₂∘universal≈h₂ = p₁∘universal≈h₁
  }
  where open Pullback p

glue : (p : Pullback f g) → Pullback h (Pullback.p₁ p) → Pullback (f ∘ h) g
glue {h = h} p q = record
  { p₁              = q.p₁
  ; p₂              = p.p₂ ∘ q.p₂
  ; commute        = glue-square p.commute q.commute
  ; universal       = λ eq → q.universal (⟺ (p.p₁∘universal≈h₁ {eq = ⟺ assoc ○ eq}))
  ; unique          = λ {_ h₁ h₂ i} eq eq′ →
    q.unique eq (p.unique (begin
      p.p₁ ∘ q.p₂ ∘ i ≈˘⟨ extendʳ q.commute ⟩
      h ∘ q.p₁ ∘ i    ≈⟨ refl⟩∘⟨ eq ⟩
      h ∘ h₁          ∎)
                          (⟺ assoc ○ eq′))
  ; p₁∘universal≈h₁ = q.p₁∘universal≈h₁
  ; p₂∘universal≈h₂ = assoc ○ ∘-resp-≈ʳ q.p₂∘universal≈h₂ ○ p.p₂∘universal≈h₂
  }
  where module p = Pullback p
        module q = Pullback q

unglue : (p : Pullback f g) → Pullback (f ∘ h) g → Pullback h (Pullback.p₁ p)
unglue {f = f} {g = g} {h = h} p q = record
  { p₁              = q.p₁
  ; p₂              = p₂′
  ; commute        = ⟺ p.p₁∘universal≈h₁
  ; universal       = λ {_ h₁ h₂} eq → q.universal $ begin
    (f ∘ h) ∘ h₁      ≈⟨ pullʳ eq ⟩
    f ∘ p.p₁ ∘ h₂     ≈⟨ extendʳ p.commute ⟩
    g ∘ p.p₂ ∘ h₂     ∎
  ; unique          = λ {_ h₁ h₂ i} eq eq′ → q.unique eq $ begin
  q.p₂ ∘ i            ≈⟨ pushˡ (⟺ p.p₂∘universal≈h₂) ⟩
  p.p₂ ∘ p₂′ ∘ i      ≈⟨ refl⟩∘⟨ eq′ ⟩
  p.p₂ ∘ h₂           ∎
  ; p₁∘universal≈h₁ = q.p₁∘universal≈h₁
  ; p₂∘universal≈h₂ = λ {_ _ _ eq} →
    p.unique-diagram ((pullˡ p.p₁∘universal≈h₁) ○ pullʳ q.p₁∘universal≈h₁ ○ eq)
                     (pullˡ p.p₂∘universal≈h₂ ○ q.p₂∘universal≈h₂)
  }
  where module p = Pullback p
        module q = Pullback q
        p₂′ = p.universal (⟺ assoc ○ q.commute) -- used twice above

Product×Equalizer⇒Pullback :
  (p : Product A B) → Equalizer (f ∘ Product.π₁ p) (g ∘ Product.π₂ p) →
  Pullback f g
Product×Equalizer⇒Pullback {f = f} {g = g} p e = record
  { p₁              = π₁ ∘ arr
  ; p₂              = π₂ ∘ arr
  ; commute        = ⟺ assoc ○ equality ○ assoc
  ; universal       = λ {_ h₁ h₂} eq → equalize $ begin
    (f ∘ π₁) ∘ ⟨ h₁ , h₂ ⟩ ≈⟨ pullʳ project₁ ⟩
    f ∘ h₁                ≈⟨ eq ⟩
    g ∘ h₂                ≈˘⟨ pullʳ project₂ ⟩
    (g ∘ π₂) ∘ ⟨ h₁ , h₂ ⟩ ∎
  ; unique          = λ eq eq′ → e.unique (p.unique (⟺ assoc ○ eq) (⟺ assoc ○ eq′))
  ; p₁∘universal≈h₁ = pullʳ (⟺ e.universal) ○ project₁
  ; p₂∘universal≈h₂ = pullʳ (⟺ e.universal) ○ project₂
  }
  where module p = Product p
        module e = Equalizer e
        open p
        open e

Product×Pullback⇒Equalizer : (p : Product A B) → Pullback f g →
  Equalizer (f ∘ Product.π₁ p) (g ∘ Product.π₂ p)
Product×Pullback⇒Equalizer {f = f} {g = g} p pu = record
  { arr       = ⟨ p₁ , p₂ ⟩
  ; equality  = begin
    (f ∘ π₁) ∘ ⟨ p₁ , p₂ ⟩ ≈⟨ pullʳ project₁ ⟩
    f ∘ p₁                 ≈⟨ commute ⟩
    g ∘ p₂                 ≈˘⟨ pullʳ project₂ ⟩
    (g ∘ π₂) ∘ ⟨ p₁ , p₂ ⟩ ∎
  ; equalize  = λ eq → pu.universal (⟺ assoc ○ eq ○ assoc)
  ; universal = λ {_ h} → begin
    h                      ≈˘⟨ p.unique (⟺ p₁∘universal≈h₁) (⟺ p₂∘universal≈h₂) ⟩
    ⟨ p₁ ∘ _ , p₂ ∘ _ ⟩    ≈⟨ p.unique (pullˡ project₁) (pullˡ project₂) ⟩
    ⟨ p₁ , p₂ ⟩ ∘ _        ∎
  ; unique    = λ eq → pu.unique (pushˡ (⟺ project₁) ○ ⟺ (∘-resp-≈ʳ eq))
                                 (pushˡ (⟺ project₂) ○ ⟺ (∘-resp-≈ʳ eq))
  }
  where module p = Product p
        module pu = Pullback pu
        open p
        open pu

module _ (p : Pullback f g) where
  open Pullback p

  Pullback-resp-≈ : h ≈ f → i ≈ g → Pullback h i
  Pullback-resp-≈ eq eq′ = record
    { p₁              = p₁
    ; p₂              = p₂
    ; commute         = ∘-resp-≈ˡ eq ○ commute ○ ⟺ (∘-resp-≈ˡ eq′)
    ; universal       = λ eq″ → universal (∘-resp-≈ˡ (⟺ eq) ○ eq″ ○ ∘-resp-≈ˡ eq′)
    ; unique          = unique
    ; p₁∘universal≈h₁ = p₁∘universal≈h₁
    ; p₂∘universal≈h₂ = p₂∘universal≈h₂
    }

  Pullback-resp-Mono : Mono g → Mono p₁
  Pullback-resp-Mono mg h i eq = unique-diagram eq (mg _ _ eq′)
    where eq′ : g ∘ p₂ ∘ h ≈ g ∘ p₂ ∘ i
          eq′ = begin
            g ∘ p₂ ∘ h ≈⟨ extendʳ (sym commute) ⟩
            f ∘ p₁ ∘ h ≈⟨ refl⟩∘⟨ eq ⟩
            f ∘ p₁ ∘ i ≈⟨ extendʳ commute ⟩
            g ∘ p₂ ∘ i ∎

  Pullback-resp-Iso : Iso g h → ∃ λ i → Iso p₁ i
  Pullback-resp-Iso {h = h} iso = universal eq
                                , record
                                { isoˡ = unique-diagram eq₁ eq₂
                                ; isoʳ = p₁∘universal≈h₁
                                }
    where open Iso iso
          eq = begin
            f ∘ id                 ≈⟨ introˡ refl ⟩
            id ∘ f ∘ id            ≈⟨ pushˡ (⟺ isoʳ) ⟩
            g ∘ h ∘ f ∘ id         ∎
          eq₁ = begin
            p₁ ∘ universal eq ∘ p₁ ≈⟨ cancelˡ p₁∘universal≈h₁ ⟩
            p₁                     ≈˘⟨ identityʳ ⟩
            p₁ ∘ id                ∎
          eq₂ = begin
            p₂ ∘ universal eq ∘ p₁ ≈⟨ extendʳ p₂∘universal≈h₂ ⟩
            h ∘ (f ∘ id) ∘ p₁      ≈⟨ refl ⟩∘⟨ identityʳ ⟩∘⟨ refl ⟩
            h ∘ f ∘ p₁             ≈⟨ refl ⟩∘⟨ commute ⟩
            h ∘ g ∘ p₂             ≈⟨ cancelˡ isoˡ ⟩
            p₂                     ≈˘⟨ identityʳ ⟩
            p₂ ∘ id                ∎


------------------------------------------------------------------------
-- The Agda standard library
--
-- Non-empty AVL trees
------------------------------------------------------------------------

-- AVL trees are balanced binary search trees.

-- The search tree invariant is specified using the technique
-- described by Conor McBride in his talk "Pivotal pragmatism".

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

open import Relation.Binary using (StrictTotalOrder)

module Data.AVL.NonEmpty
  {a ℓ₁ ℓ₂} (strictTotalOrder : StrictTotalOrder a ℓ₁ ℓ₂) where

open import Data.Bool.Base using (Bool)
open import Data.Empty
open import Data.List.NonEmpty as List⁺ using (List⁺; _∷_; _++⁺_)
open import Data.Maybe.Base hiding (map)
open import Data.Nat.Base hiding (_<_; _⊔_; compare)
open import Data.Product hiding (map)
open import Data.Unit
open import Function
open import Level using (_⊔_; Lift; lift)
open import Relation.Unary

open StrictTotalOrder strictTotalOrder renaming (Carrier to Key)
open import Data.AVL.Value Eq.setoid
import Data.AVL.Indexed strictTotalOrder as Indexed
open Indexed using (K&_ ; ⊥⁺ ; ⊤⁺; ⊥⁺<⊤⁺; ⊥⁺<[_]<⊤⁺; ⊥⁺<[_]; [_]<⊤⁺; node; toList)

------------------------------------------------------------------------
-- Types and functions with hidden indices

-- NB: the height is non-zero thus guaranteeing that the AVL tree contains
-- at least one value.

data Tree⁺ {v} (V : Value v) : Set (a ⊔ v ⊔ ℓ₂) where
  tree : ∀ {h} → Indexed.Tree V ⊥⁺ ⊤⁺ (suc h) → Tree⁺ V

module _ {v} {V : Value v} where

  private
    Val = Value.family V

  singleton : (k : Key) → Val k → Tree⁺ V
  singleton k v = tree (Indexed.singleton k v ⊥⁺<[ k ]<⊤⁺)

  insert : (k : Key) → Val k → Tree⁺ V → Tree⁺ V
  insert k v (tree t) with Indexed.insert k v t ⊥⁺<[ k ]<⊤⁺
  ... | Indexed.0# , t′ = tree t′
  ... | Indexed.1# , t′ = tree t′

  insertWith : (k : Key) → (Maybe (Val k) → Val k) → Tree⁺ V → Tree⁺ V
  insertWith k f (tree t) with Indexed.insertWith k f t ⊥⁺<[ k ]<⊤⁺
  ... | Indexed.0# , t′ = tree t′
  ... | Indexed.1# , t′ = tree t′

  delete : Key → Tree⁺ V → Maybe (Tree⁺ V)
  delete k (tree {h}     t) with Indexed.delete k t ⊥⁺<[ k ]<⊤⁺
  delete k (tree {h}     t) | Indexed.1# , t′ = just (tree t′)
  delete k (tree {0}     t) | Indexed.0# , t′ = nothing
  delete k (tree {suc h} t) | Indexed.0# , t′ = just (tree t′)

  lookup : (k : Key) → Tree⁺ V → Maybe (Val k)
  lookup k (tree t) = Indexed.lookup k t ⊥⁺<[ k ]<⊤⁺

module _ {v w} {V : Value v} {W : Value w} where

  private
    Val = Value.family V
    Wal = Value.family W

  map : ∀[ Val ⇒ Wal ] → Tree⁺ V → Tree⁺ W
  map f (tree t) = tree $ Indexed.map f t

module _ {v} {V : Value v} where

  -- The input does not need to be ordered.

  fromList⁺ : List⁺ (K& V) → Tree⁺ V
  fromList⁺ = List⁺.foldr (uncurry insert) (uncurry singleton)

  -- The output is ordered

  toList⁺ : Tree⁺ V → List⁺ (K& V)
  toList⁺ (tree (node k&v l r bal)) = toList l ++⁺ k&v ∷ toList r


module PatternSyn where

data ⊤
  : Set
  where

  tt
    : ⊤

data D
  (A : Set)
  : Set
  where

  d
    : A
    → A
    → D A

pattern p
  = tt

pattern q
  = tt

pattern _,_ x y
  = d x y

f
  : ⊤
  → ⊤
f p
  = tt

g
  : {A : Set}
  → D A
  → A
g (x , _)
  = x


module L.Base.Unit.Core where

-- Import the unit type and its only element tt : ⊤
open import Agda.Builtin.Unit renaming (tt to ⋆) public

⊤-elim : ∀{c} (C : ⊤ → Set c) → C ⋆ → (a : ⊤) → C a
⊤-elim = λ C c a → c


-- Andreas, 2016-12-30, issues #555 and #1886, reported by nad

-- Hidden parameters can be omitted in the repetition
-- of the parameter list.

record R {a} (A : Set a) : Set a

record R A where
  field f : A

data D {a} (A : Set a) : Set a

data D A where
  c : A → D A


{-# OPTIONS --cubical --no-exact-split --safe #-}
module Cubical.Data.Queue.Base where

open import Cubical.Foundations.Everything

open import Cubical.Foundations.SIP
open import Cubical.Structures.Queue

open import Cubical.Data.Unit
open import Cubical.Data.Sum
open import Cubical.Data.List
open import Cubical.Data.Prod.Base hiding (_×_) renaming (_×Σ_ to _×_)

module _ (A : Type ℓ) (Aset : isSet A) where
 open Queues-on A Aset

 -- following Cavallo we can now define 1Lists and 2Lists as Queues on A
 -- and prove that there is a queue-iso between them, this then gives us a path
 1List : Queue
 1List = (Q , emp , push , pop)
  where
   Q = List A
   emp = []
   push = _∷_
   pop : Q → Unit ⊎ (Q × A)
   pop [] = inl tt
   pop (x ∷ []) = inr ([] , x)
   pop (x ∷ x' ∷ xs) = pop-map-forward (push x) (pop (x' ∷ xs))

 -- for later convenience
 Q₁ = typ 1List
 emp₁ = str 1List .fst
 push₁ = str 1List .snd .fst
 pop₁ = str 1List .snd .snd

 -- Now for 2Lists
 data Q₂ : Set ℓ where
   Q₂⟨_,_⟩ : (xs ys : List A) → Q₂
   tilt : ∀ xs ys z → Q₂⟨ xs ++ [ z ] , ys ⟩ ≡ Q₂⟨ xs , ys ++ [ z ] ⟩
   trunc : (q q' : Q₂) (α β : q ≡ q') → α ≡ β

 multitilt : (xs ys zs : List A) → Q₂⟨ xs ++ rev zs , ys ⟩ ≡ Q₂⟨ xs , ys ++ zs ⟩
 multitilt xs ys [] = cong₂ Q₂⟨_,_⟩ (++-unit-r xs) (sym (++-unit-r ys))
 multitilt xs ys (z ∷ zs) =
   cong (λ ws → Q₂⟨ ws , ys ⟩) (sym (++-assoc xs (rev zs) [ z ]))
   ∙ tilt (xs ++ rev zs) ys z
   ∙ multitilt xs (ys ++ [ z ]) zs
   ∙ cong (λ ws → Q₂⟨ xs , ws ⟩) (++-assoc ys [ z ] zs)

  -- push into the first list, pop from the second if possible

 emp₂ : Q₂
 emp₂ = Q₂⟨ [] , [] ⟩

 push₂ : A → Q₂ → Q₂
 push₂ a Q₂⟨ xs , ys ⟩ = Q₂⟨ a ∷ xs , ys ⟩
 push₂ a (tilt xs ys z i) = tilt (a ∷ xs) ys z i
 push₂ a (trunc q q' α β i j) =
   trunc _ _ (cong (push₂ a) α) (cong (push₂ a) β) i j

 pop₂Flush : List A → Unit ⊎ (Q₂ × A)
 pop₂Flush [] = inl tt
 pop₂Flush (x ∷ xs) = inr (Q₂⟨ [] , xs ⟩ , x)

 pop₂ : Q₂ → Unit ⊎ (Q₂ × A)
 pop₂ Q₂⟨ xs , [] ⟩ = pop₂Flush (rev xs)
 pop₂ Q₂⟨ xs , y ∷ ys ⟩ = inr (Q₂⟨ xs , ys ⟩ , y)
 pop₂ (tilt xs [] z i) = path i
   where
   path : pop₂Flush (rev (xs ++ [ z ])) ≡ inr (Q₂⟨ xs , [] ⟩ , z)
   path =
     cong pop₂Flush (rev-++ xs [ z ])
     ∙ cong (λ q → inr (q , z)) (sym (multitilt [] [] (rev xs)))
     ∙ cong (λ ys → inr (Q₂⟨ ys , [] ⟩ , z)) (rev-rev xs)
 pop₂ (tilt xs (y ∷ ys) z i) = inr (tilt xs ys z i , y)
 pop₂ (trunc q q' α β i j) =
   isOfHLevelSum 0
     (isProp→isSet isPropUnit)
     (isOfHLevelΣ 2 trunc λ _ → Aset)
     (pop₂ q) (pop₂ q') (cong pop₂ α) (cong pop₂ β)
    i j

 2List : Queue
 2List = (Q₂ , emp₂ , push₂ , pop₂)

 -- We construct an equivalence Q₁≃Q₂ and prove that this is a queue-iso
 quot : Q₁ → Q₂
 quot xs = Q₂⟨ xs , [] ⟩

 eval : Q₂ → Q₁
 eval Q₂⟨ xs , ys ⟩ = xs ++ rev ys
 eval (tilt xs ys z i) = path i
   where
   path : (xs ++ [ z ]) ++ rev ys ≡ xs ++ rev (ys ++ [ z ])
   path =
     ++-assoc xs [ z ] (rev ys)
     ∙ cong (_++_ xs) (sym (rev-++ ys [ z ]))
 eval (trunc q q' α β i j) = -- truncated case
   isOfHLevelList 0 Aset (eval q) (eval q') (cong eval α) (cong eval β) i j

 quot∘eval : ∀ q → quot (eval q) ≡ q
 quot∘eval Q₂⟨ xs , ys ⟩ = multitilt xs [] ys
 quot∘eval (tilt xs ys z i) = -- truncated case
   isOfHLevelPathP'
     {A = λ i → quot (eval (tilt xs ys z i)) ≡ tilt xs ys z i}
     0
     (λ _ → trunc _ _)
     (multitilt (xs ++ [ z ]) [] ys) (multitilt xs [] (ys ++ [ z ]))
     .fst i
 quot∘eval (trunc q q' α β i j) = -- truncated case
   isOfHLevelPathP'
     {A = λ i →
       PathP (λ j → quot (eval (trunc q q' α β i j)) ≡ trunc q q' α β i j)
         (quot∘eval q) (quot∘eval q')}
     0
     (λ _ → isOfHLevelPathP' 1 (λ _ → isOfHLevelSuc 2 trunc _ _) _ _)
     (cong quot∘eval α) (cong quot∘eval β)
     .fst i j

 eval∘quot : ∀ xs → eval (quot xs) ≡ xs
 eval∘quot = ++-unit-r

 -- We get our desired equivalence
 quotEquiv : Q₁ ≃ Q₂
 quotEquiv = isoToEquiv (iso quot eval quot∘eval eval∘quot)

 -- Now it only remains to prove that this is a queue-iso
 quot∘emp : quot emp₁ ≡ emp₂
 quot∘emp = refl

 quot∘push : ∀ x xs → quot (push₁ x xs) ≡ push₂ x (quot xs)
 quot∘push x xs = refl

 quot∘pop : ∀ xs → pop-map-forward quot (pop₁ xs) ≡ pop₂ (quot xs)
 quot∘pop [] = refl
 quot∘pop (x ∷ []) = refl
 quot∘pop (x ∷ x' ∷ xs) =
   pop-map-forward-∘ quot (push₁ x) (pop₁ (x' ∷ xs))
   ∙ sym (pop-map-forward-∘ (push₂ x) quot (pop₁ (x' ∷ xs)))
   ∙ cong (pop-map-forward (push₂ x)) (quot∘pop (x' ∷ xs))
   ∙ lemma x x' (rev xs)
   where
   lemma : ∀ x x' ys
     → pop-map-forward (push₂ x) (pop₂Flush (ys ++ [ x' ]))
       ≡ pop₂Flush ((ys ++ [ x' ]) ++ [ x ])
   lemma x x' [] i = inr (tilt [] [] x i , x')
   lemma x x' (y ∷ ys) i = inr (tilt [] (ys ++ [ x' ]) x i , y)

 quotEquiv-is-queue-iso : queue-iso 1List 2List quotEquiv
 quotEquiv-is-queue-iso = quot∘emp , quot∘push , quot∘pop

 -- And we get the desired Path
 Path-1List-2List : 1List ≡ 2List
 Path-1List-2List = SIP queue-structure queue-iso  Queue-is-SNS 1List 2List .fst
                   (quotEquiv , quotEquiv-is-queue-iso)


module Category.Comma where

open import Level
open import Data.Product
open import Category.Core
open import Relation.Binary as B using ()
open import Relation.Binary.Indexed
open import Relation.Binary.Indexed.Extra
open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; refl)

_/_ : ∀ {𝒸 ℓ} → (C : Category 𝒸 ℓ) → (b : Category.Object C) → Category 𝒸 ℓ
_/_ {𝒸} {ℓ} C b = record
    { Objects = SliceObjectSetoid
    ; Morphisms = SliceMorphismStructure
    }
    where
        open Category C
        module ObjEq = B.IsEquivalence (B.Setoid.isEquivalence Objects)
        module MorphEq = IsEquivalence (MorphismStructure.isEquivalence Morphisms)

        SliceObject-≈ : B.Rel hom[-, b ] ℓ
        SliceObject-≈ (x , x→b) (y , y→b) = Σ[ x≈y ∈ x ≈o y ] x→b ≈ y→b

        SliceObject-≈-Symmetric : B.Symmetric SliceObject-≈
        SliceObject-≈-Symmetric (≈src , f≈g) = (ObjEq.sym ≈src) , MorphEq.sym f≈g

        SliceObject-≈-Transitive : B.Transitive SliceObject-≈
        SliceObject-≈-Transitive (≈src₁ , f≈g) (≈src₂ , g≈h) =
            (ObjEq.trans ≈src₁ ≈src₂) , (MorphEq.trans f≈g g≈h)

        SliceObject-≈-IsEquivalence : B.IsEquivalence SliceObject-≈
        SliceObject-≈-IsEquivalence = record
            { refl = ObjEq.refl , MorphEq.refl
            ; sym = SliceObject-≈-Symmetric
            ; trans = SliceObject-≈-Transitive
            }

        SliceObjectSetoid : B.Setoid 𝒸 ℓ
        SliceObjectSetoid = record
            { Carrier = hom[-, b ]
            ; _≈_ = SliceObject-≈
            ; isEquivalence = SliceObject-≈-IsEquivalence
            }

        record SliceMorphism (src tar : hom[-, b ]) : Set 𝒸 where

            source : Object
            source = proj₁ src

            target : Object
            target = proj₁ tar

            field
                morphism : source ⇒ target

        SliceMorphism-≈ : Rel (uncurry SliceMorphism) ℓ
        SliceMorphism-≈ {f-src , f-tar} {g-src , g-tar} f g =
            Σ[ source-≈ ∈ SliceObject-≈ f-src g-src ]
            Σ[ target-≈ ∈ SliceObject-≈ f-tar g-tar ]
            morphism f ≈ morphism g
            where
                open SliceMorphism

        module SliceObjectEq = B.IsEquivalence SliceObject-≈-IsEquivalence

        SliceMorphism-≈-Symmetric : Symmetric (uncurry SliceMorphism) SliceMorphism-≈ -- Symmetric SliceMorphism-≈ ?
        SliceMorphism-≈-Symmetric (≈src₁ , ≈src₂ , f≈g) =
            SliceObjectEq.sym ≈src₁ , SliceObjectEq.sym ≈src₂ , MorphEq.sym f≈g

        SliceMorphism-≈-Transitive : Transitive (uncurry SliceMorphism) SliceMorphism-≈ -- Symmetric SliceMorphism-≈ ?
        SliceMorphism-≈-Transitive (≈src₁ , ≈src₂ , f≈g) (≈src₃ , ≈src₄ , g≈h) =
            SliceObjectEq.trans ≈src₁ ≈src₃ ,
            SliceObjectEq.trans ≈src₂ ≈src₄ ,
            MorphEq.trans f≈g g≈h

        SliceMorphism-≈-IsEquivalence : IsEquivalence (uncurry SliceMorphism) SliceMorphism-≈
        SliceMorphism-≈-IsEquivalence = record
            { refl = SliceObjectEq.refl , SliceObjectEq.refl , MorphEq.refl
            ; sym = λ {i} {j} {f} {g} → SliceMorphism-≈-Symmetric {i} {j} {f} {g}
            ; trans = λ {i} {j} {k} {f} {g} {h} → SliceMorphism-≈-Transitive {i} {j} {k} {f} {g} {h} --
            }

        Slice-∘ : ∀ {a b c}
            → SliceMorphism b c
            → SliceMorphism a b
            → SliceMorphism a c
        Slice-∘ f g = record { morphism = morphism f ∘ morphism g }
            where   open SliceMorphism

        Slice-id : ∀ a → SliceMorphism a a
        Slice-id (a , _) = record { morphism = id a }

        SliceMorphismIsMorphism : IsMorphism SliceMorphism-≈ Slice-∘ Slice-id
        SliceMorphismIsMorphism = record
            { assoc = λ f g h → SliceObjectEq.refl , SliceObjectEq.refl , assoc (morphism f) (morphism g) (morphism h)
            ; left-identity = λ f → SliceObjectEq.refl , SliceObjectEq.refl , left-identity (morphism f)
            ; right-identity = λ f → SliceObjectEq.refl , SliceObjectEq.refl , right-identity (morphism f)
            ; cong = λ {x} {y} {u} {v} x≈y u≈v → proj₁ u≈v , proj₁ (proj₂ x≈y) , cong (proj₂ (proj₂ x≈y)) (proj₂ (proj₂ u≈v))
            }
            where
                open IsMorphism isMorphism
                open SliceMorphism
                open import Relation.Binary.Indexed.SetoidReasoning

        SliceMorphismStructure : MorphismStructure 𝒸 ℓ hom[-, b ]
        SliceMorphismStructure = record
            { Carrier = uncurry SliceMorphism
            ; _≈_ = SliceMorphism-≈
            ; isEquivalence = SliceMorphism-≈-IsEquivalence
            ; _∘_ = Slice-∘
            ; id = Slice-id
            ; isMorphism = SliceMorphismIsMorphism
            }

module Comma
    {𝒸₀ ℓ₀ 𝒸₁ ℓ₁ 𝒸₂ ℓ₂ : Level}
    {C : Category 𝒸₀ ℓ₀} {D : Category 𝒸₁ ℓ₁} {E : Category 𝒸₂ ℓ₂}
    (S : Functor C E) (T : Functor D E)
    where

    module C = Category C
    module D = Category D
    module S = Functor S
    module T = Functor T
    open Category E

    module ObjEq = B.IsEquivalence (B.Setoid.isEquivalence Objects)
    module MorphEq = IsEquivalence (MorphismStructure.isEquivalence Morphisms)

    record CommaObject : Set (𝒸₀ ⊔ 𝒸₁ ⊔ 𝒸₂ ⊔ ℓ₂) where
        field
            source : C.Object
            target : D.Object
            morphism : S.mapObject source ⇒ T.mapObject target

    open CommaObject

    CommaObject-≈ : B.Rel CommaObject ℓ₂
    CommaObject-≈ f g =
        Σ[ source-≈ ∈ S.mapObject (source f) ≈o S.mapObject (source g) ]
        Σ[ target-≈ ∈ T.mapObject (target f) ≈o T.mapObject (target g) ]
        morphism f ≈ morphism g

    CommaObject-≈-Symmetric : B.Symmetric CommaObject-≈
    CommaObject-≈-Symmetric (source-≈ , target-≈ , f≈g) =
        (ObjEq.sym source-≈) , (ObjEq.sym target-≈) , (MorphEq.sym f≈g)

    CommaObject-≈-Transitive : B.Transitive CommaObject-≈
    CommaObject-≈-Transitive (source-≈₁ , target-≈₁ , f≈g) (source-≈₂ , target-≈₂ , g≈h)
        =   (ObjEq.trans source-≈₁ source-≈₂) ,
            (ObjEq.trans target-≈₁ target-≈₂) ,
            (MorphEq.trans f≈g g≈h)

    CommaObject-≈-IsEquivalence : B.IsEquivalence CommaObject-≈
    CommaObject-≈-IsEquivalence = record
        { refl = ObjEq.refl , ObjEq.refl , MorphEq.refl
        ; sym = λ {i} {f} → CommaObject-≈-Symmetric {i} {f}
        ; trans = λ {f} {g} {h} → CommaObject-≈-Transitive {f} {g} {h}
        }

    CommaObjects : B.Setoid (𝒸₀ ⊔ 𝒸₁ ⊔ 𝒸₂ ⊔ ℓ₂) ℓ₂
    CommaObjects = record
        { Carrier = CommaObject
        ; _≈_ = CommaObject-≈
        ; isEquivalence = CommaObject-≈-IsEquivalence
        }

    record CommaMorphism (src : CommaObject) (tar : CommaObject) : Set (𝒸₀ ⊔ 𝒸₁ ⊔ 𝒸₂ ⊔ ℓ₂) where
        module SRC = CommaObject src
        module TAR = CommaObject tar
        field
            morphismBetweenSources : S.mapObject SRC.source ⇒ S.mapObject TAR.source
            morphismBetweenTargets : T.mapObject SRC.target ⇒ T.mapObject TAR.target
            commutes : TAR.morphism ∘ morphismBetweenSources ≈ morphismBetweenTargets ∘ SRC.morphism

    open CommaMorphism public

    CommaMorphism-≈ : Rel (uncurry CommaMorphism) ℓ₂
    CommaMorphism-≈ f g =
        (morphismBetweenSources f ≈ morphismBetweenSources g) ×
        (morphismBetweenTargets f ≈ morphismBetweenTargets g)

    CommaMorphism-≈-Symmetric : Symmetric (uncurry CommaMorphism) CommaMorphism-≈
    CommaMorphism-≈-Symmetric (source-≈ , target-≈) = (MorphEq.sym source-≈) , (MorphEq.sym target-≈)

    CommaMorphism-≈-Transitive : Transitive (uncurry CommaMorphism) CommaMorphism-≈
    CommaMorphism-≈-Transitive (source₁-≈ , target₁-≈) (source₂-≈ , target₂-≈) =
        (MorphEq.trans source₁-≈ source₂-≈) , (MorphEq.trans target₁-≈ target₂-≈)

    CommaMorphism-≈-IsEquivalence : IsEquivalence (uncurry CommaMorphism) CommaMorphism-≈
    CommaMorphism-≈-IsEquivalence = record
        { refl = MorphEq.refl , MorphEq.refl
        ; sym = λ {i} {j} {f} {g} → CommaMorphism-≈-Symmetric {i} {j} {f} {g}
        ; trans = λ {i} {j} {k} {f} {g} {h} → CommaMorphism-≈-Transitive {i} {j} {k} {f} {g} {h}
        }

    Comma-∘ : ∀ {a b c}
        → CommaMorphism b c
        → CommaMorphism a b
        → CommaMorphism a c
    Comma-∘ {a} {b} {c} f g = record
        { morphismBetweenSources = morphismBetweenSources f ∘ morphismBetweenSources g
        ; morphismBetweenTargets = morphismBetweenTargets f ∘ morphismBetweenTargets g
        ; commutes =
            begin⟨ setoid ⟩
                morphism c ∘ (morphismBetweenSources f ∘ morphismBetweenSources g)
            ≈⟨ sym (assoc (morphismBetweenSources g) (morphismBetweenSources f) (morphism c)) ⟩
                (morphism c ∘ morphismBetweenSources f) ∘ morphismBetweenSources g
            ≈⟨ cong (commutes f) MorphEq.refl ⟩
                (morphismBetweenTargets f ∘ morphism b) ∘ morphismBetweenSources g
            ≈⟨ assoc (morphismBetweenSources g) (morphism b) (morphismBetweenTargets f) ⟩
                morphismBetweenTargets f ∘ (morphism b ∘ morphismBetweenSources g)
            ≈⟨ cong MorphEq.refl (commutes g) ⟩
                morphismBetweenTargets f ∘ (morphismBetweenTargets g ∘ morphism a)
            ≈⟨ sym (assoc (morphism a) (morphismBetweenTargets g) (morphismBetweenTargets f)) ⟩
                (morphismBetweenTargets f ∘ morphismBetweenTargets g) ∘ morphism a
            ∎
        }
        where
            open CommaMorphism
            open import Relation.Binary.Indexed.SetoidReasoning
            open IsMorphism isMorphism
            open IsEquivalence (MorphismStructure.isEquivalence Morphisms)

    Comma-id : ∀ a → CommaMorphism a a
    Comma-id a = record
        { morphismBetweenSources = id (S.mapObject (source a))
        ; morphismBetweenTargets = id (T.mapObject (target a))
        ; commutes =
            begin⟨ setoid ⟩
                morphism a ∘ id (S.mapObject (source a))
            ≈⟨ right-identity (morphism a) ⟩
                morphism a
            ≈⟨ sym (left-identity (morphism a)) ⟩
                id (T.mapObject (target a)) ∘ morphism a
            ∎
        }
        where
            open IsMorphism isMorphism
            open import Relation.Binary.Indexed.SetoidReasoning
            open IsEquivalence (MorphismStructure.isEquivalence Morphisms)

    CommaMorphismIsMorphism : IsMorphism CommaMorphism-≈ Comma-∘ Comma-id
    CommaMorphismIsMorphism = record
        { assoc = λ f g h →
            assoc (morphismBetweenSources f) (morphismBetweenSources g) (morphismBetweenSources h) ,
            assoc (morphismBetweenTargets f) (morphismBetweenTargets g) (morphismBetweenTargets h)
        ; left-identity = λ f → (left-identity (morphismBetweenSources f)) , (left-identity (morphismBetweenTargets f))
        ; right-identity = λ f → (right-identity (morphismBetweenSources f)) , (right-identity (morphismBetweenTargets f))
        ; cong = λ x≈y u≈v → (cong (proj₁ x≈y) (proj₁ u≈v)) , (cong (proj₂ x≈y) (proj₂ u≈v))
        }
        where open IsMorphism isMorphism

    CommaMorphisms : MorphismStructure (𝒸₀ ⊔ 𝒸₁ ⊔ 𝒸₂ ⊔ ℓ₂) ℓ₂ CommaObject
    CommaMorphisms = record
        { Carrier = uncurry CommaMorphism
        ; _≈_ = CommaMorphism-≈
        ; isEquivalence = CommaMorphism-≈-IsEquivalence
        ; _∘_ = Comma-∘
        ; id = Comma-id
        ; isMorphism = CommaMorphismIsMorphism
        }

--     S     T
--  C --> E <-- D
--
_↓_ : {𝒸₀ ℓ₀ 𝒸₁ ℓ₁ 𝒸₂ ℓ₂ : Level}
    {C : Category 𝒸₀ ℓ₀} {D : Category 𝒸₁ ℓ₁} {E : Category 𝒸₂ ℓ₂}
    → (S : Functor C E) → (T : Functor D E)
    → Category (𝒸₀ ⊔ 𝒸₁ ⊔ 𝒸₂ ⊔ ℓ₂) ℓ₂
S ↓ T = record
    { Objects = Comma'.CommaObjects
    ; Morphisms = Comma'.CommaMorphisms
    }
    where
        module Comma' = Comma S T


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.S3.Base where

open import Cubical.Foundations.Prelude

data S³ : Type₀ where
  base : S³
  surf : PathP (λ j → PathP (λ i → base ≡ base) refl refl) refl refl


{-# OPTIONS --allow-unsolved-metas #-}
open import Level
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Ordinals
module partfunc {n : Level } (O : Ordinals {n})  where

open import logic
open import Relation.Binary
open import Data.Empty
open import Data.List hiding (filter)
open import Data.Maybe
open import Relation.Binary
open import Relation.Binary.Core
open import Data.Nat renaming ( zero to Zero ; suc to Suc ;  ℕ to Nat ; _⊔_ to _n⊔_ )
open import filter O

open _∧_
open _∨_
open Bool

----
--
-- Partial Function without ZF
--

record PFunc  (Dom : Set n) (Cod : Set n) : Set (suc n) where
   field
      dom : Dom → Set n
      pmap : (x : Dom ) → dom x → Cod
      meq : {x : Dom } → { p q : dom x } → pmap x p ≡ pmap x q

----
--
-- PFunc (Lift n Nat) Cod is equivalent to List (Maybe Cod)
--

data Findp : {Cod : Set n} → List (Maybe Cod) → (x : Nat) → Set where
   v0 : {Cod : Set n} → {f : List (Maybe Cod)} → ( v : Cod ) → Findp ( just v  ∷ f ) Zero
   vn : {Cod : Set n} → {f : List (Maybe Cod)} {d : Maybe Cod} → {x : Nat} → Findp f x → Findp (d ∷ f) (Suc x)

open PFunc

find : {Cod : Set n} → (f : List (Maybe Cod) ) → (x : Nat) → Findp f x → Cod
find (just v ∷ _) 0 (v0 v) = v
find (_ ∷ n) (Suc i) (vn p) = find n i p

findpeq : {Cod : Set n} → (f : List (Maybe Cod)) → {x : Nat} {p q : Findp f x } → find f x p ≡ find f x q
findpeq n {0} {v0 _} {v0 _} = refl
findpeq [] {Suc x} {()}
findpeq (just x₁ ∷ n) {Suc x} {vn p} {vn q} = findpeq n {x} {p} {q}
findpeq (nothing ∷ n) {Suc x} {vn p} {vn q} = findpeq n {x} {p} {q}

List→PFunc : {Cod : Set n} → List (Maybe Cod) → PFunc (Lift n Nat) Cod
List→PFunc fp = record { dom = λ x → Lift n (Findp fp (lower x))
                       ; pmap = λ x y → find fp (lower x) (lower y)
                       ; meq = λ {x} {p} {q} → findpeq fp {lower x} {lower p} {lower q}
                       }
----
--
-- to List (Maybe Two) is a Latice
--

_3⊆b_ : (f g : List (Maybe Two)) → Bool
[] 3⊆b [] = true
[] 3⊆b (nothing ∷ g) = [] 3⊆b g
[] 3⊆b (_ ∷ g) = true
(nothing ∷ f) 3⊆b [] = f 3⊆b []
(nothing ∷ f) 3⊆b (_ ∷ g)  = f 3⊆b g
(just i0 ∷ f) 3⊆b (just i0 ∷ g) = f 3⊆b g
(just i1 ∷ f) 3⊆b (just i1 ∷ g) = f 3⊆b g
_ 3⊆b _ = false

_3⊆_ : (f g : List (Maybe Two)) → Set
f 3⊆ g  = (f 3⊆b g) ≡ true

_3∩_ : (f g : List (Maybe Two)) → List (Maybe Two)
[] 3∩ (nothing ∷ g) = nothing ∷ ([] 3∩ g)
[] 3∩ g  = []
(nothing ∷ f) 3∩ [] = nothing ∷ f 3∩ []
f 3∩ [] = []
(just i0 ∷ f) 3∩ (just i0 ∷ g) = just i0 ∷ (  f 3∩ g )
(just i1 ∷ f) 3∩ (just i1 ∷ g) = just i1 ∷ (  f 3∩ g )
(_ ∷ f) 3∩ (_ ∷ g)   = nothing  ∷ ( f 3∩ g )

3∩⊆f : { f g : List (Maybe Two) } → (f 3∩ g ) 3⊆ f
3∩⊆f {[]} {[]} = refl
3∩⊆f {[]} {just _ ∷ g} = refl
3∩⊆f {[]} {nothing ∷ g} = 3∩⊆f {[]} {g}
3∩⊆f {just _ ∷ f} {[]} = refl
3∩⊆f {nothing ∷ f} {[]} = 3∩⊆f {f} {[]}
3∩⊆f {just i0 ∷ f} {just i0 ∷ g} = 3∩⊆f {f} {g}
3∩⊆f {just i1 ∷ f} {just i1 ∷ g} =  3∩⊆f {f} {g}
3∩⊆f {just i0 ∷ f} {just i1 ∷ g} =   3∩⊆f {f} {g}
3∩⊆f {just i1 ∷ f} {just i0 ∷ g} =    3∩⊆f {f} {g}
3∩⊆f {nothing ∷ f} {just _ ∷ g} = 3∩⊆f {f} {g}
3∩⊆f {just i0  ∷ f} {nothing ∷ g} = 3∩⊆f {f} {g}
3∩⊆f {just i1 ∷ f} {nothing ∷ g} =  3∩⊆f {f} {g}
3∩⊆f {nothing ∷ f} {nothing ∷ g} = 3∩⊆f {f} {g}

3∩sym : { f g : List (Maybe Two) } → (f 3∩ g ) ≡ (g 3∩ f )
3∩sym {[]} {[]} = refl
3∩sym {[]} {just _ ∷ g} = refl
3∩sym {[]} {nothing ∷ g} = cong (λ k → nothing ∷ k) (3∩sym {[]} {g})
3∩sym {just _ ∷ f} {[]} = refl
3∩sym {nothing ∷ f} {[]} = cong (λ k → nothing ∷ k) (3∩sym {f} {[]})
3∩sym {just i0 ∷ f} {just i0 ∷ g} = cong (λ k → just i0 ∷ k) (3∩sym {f} {g})
3∩sym {just i0 ∷ f} {just i1 ∷ g} =  cong (λ k → nothing ∷ k) (3∩sym {f} {g})
3∩sym {just i1 ∷ f} {just i0 ∷ g} =  cong (λ k → nothing ∷ k) (3∩sym {f} {g})
3∩sym {just i1 ∷ f} {just i1 ∷ g} =  cong (λ k → just i1 ∷ k) (3∩sym {f} {g})
3∩sym {just i0 ∷ f} {nothing ∷ g} =  cong (λ k → nothing ∷ k) (3∩sym {f} {g})
3∩sym {just i1 ∷ f} {nothing ∷ g} =  cong (λ k → nothing ∷ k) (3∩sym {f} {g})
3∩sym {nothing ∷ f} {just i0 ∷ g} = cong (λ k → nothing ∷ k) (3∩sym {f} {g})
3∩sym {nothing ∷ f} {just i1 ∷ g} =  cong (λ k → nothing ∷ k) (3∩sym {f} {g})
3∩sym {nothing ∷ f} {nothing ∷ g} = cong (λ k → nothing ∷ k) (3∩sym {f} {g})

3⊆-[] : { h : List (Maybe Two) } → [] 3⊆ h
3⊆-[] {[]} = refl
3⊆-[] {just _ ∷ h} = refl
3⊆-[] {nothing ∷ h} = 3⊆-[] {h}

3⊆trans : { f g h : List (Maybe Two) } → f 3⊆ g → g 3⊆ h → f 3⊆ h
3⊆trans {[]} {[]} {[]} f<g g<h = refl
3⊆trans {[]} {[]} {just _ ∷ h} f<g g<h = refl
3⊆trans {[]} {[]} {nothing ∷ h} f<g g<h = 3⊆trans {[]} {[]} {h} refl g<h
3⊆trans {[]} {nothing ∷ g} {[]} f<g g<h = refl
3⊆trans {[]} {just _ ∷ g} {just _ ∷ h} f<g g<h = refl
3⊆trans {[]} {nothing ∷ g} {just _ ∷ h} f<g g<h = refl
3⊆trans {[]} {nothing ∷ g} {nothing ∷ h} f<g g<h = 3⊆trans {[]} {g} {h} f<g g<h
3⊆trans {nothing ∷ f} {[]} {[]} f<g g<h = f<g
3⊆trans {nothing ∷ f} {[]} {just _ ∷ h} f<g g<h = 3⊆trans {f} {[]} {h} f<g (3⊆-[] {h})
3⊆trans {nothing ∷ f} {[]} {nothing ∷ h} f<g g<h = 3⊆trans {f} {[]} {h} f<g g<h
3⊆trans {nothing ∷ f} {nothing ∷ g} {[]} f<g g<h = 3⊆trans {f} {g} {[]} f<g g<h
3⊆trans {nothing ∷ f} {nothing ∷ g} {just _ ∷ h} f<g g<h =  3⊆trans {f} {g} {h} f<g g<h
3⊆trans {nothing ∷ f} {nothing ∷ g} {nothing ∷ h} f<g g<h =  3⊆trans {f} {g} {h} f<g g<h
3⊆trans {[]} {just i0 ∷ g} {[]} f<g ()
3⊆trans {[]} {just i1 ∷ g} {[]} f<g ()
3⊆trans {[]} {just x ∷ g} {nothing ∷ h} f<g g<h = 3⊆-[] {h}
3⊆trans {just i0 ∷ f} {[]} {h} () g<h
3⊆trans {just i1 ∷ f} {[]} {h} () g<h
3⊆trans {just x ∷ f} {just i0 ∷ g} {[]} f<g ()
3⊆trans {just x ∷ f} {just i1 ∷ g} {[]} f<g ()
3⊆trans {just i0 ∷ f} {just i0 ∷ g} {just i0 ∷ h} f<g g<h = 3⊆trans {f} {g} {h} f<g g<h
3⊆trans {just i1 ∷ f} {just i1 ∷ g} {just i1 ∷ h} f<g g<h = 3⊆trans {f} {g} {h} f<g g<h
3⊆trans {just x ∷ f} {just i0 ∷ g} {nothing ∷ h} f<g ()
3⊆trans {just x ∷ f} {just i1 ∷ g} {nothing ∷ h} f<g ()
3⊆trans {just i0 ∷ f} {nothing ∷ g} {_} () g<h
3⊆trans {just i1 ∷ f} {nothing ∷ g} {_} () g<h
3⊆trans {nothing ∷ f} {just i0 ∷ g} {[]} f<g ()
3⊆trans {nothing ∷ f} {just i1 ∷ g} {[]} f<g ()
3⊆trans {nothing ∷ f} {just i0 ∷ g} {just i0 ∷ h} f<g g<h =  3⊆trans {f} {g} {h} f<g g<h
3⊆trans {nothing ∷ f} {just i1 ∷ g} {just i1 ∷ h} f<g g<h =  3⊆trans {f} {g} {h} f<g g<h
3⊆trans {nothing ∷ f} {just i0 ∷ g} {nothing ∷ h} f<g ()
3⊆trans {nothing ∷ f} {just i1 ∷ g} {nothing ∷ h} f<g ()

3⊆∩f : { f g h : List (Maybe Two) }  → f 3⊆ g → f 3⊆ h → f 3⊆  (g 3∩ h )
3⊆∩f {[]} {[]} {[]} f<g f<h = refl
3⊆∩f {[]} {[]} {x ∷ h} f<g f<h = 3⊆-[] {[] 3∩ (x ∷ h)}
3⊆∩f {[]} {x ∷ g} {h} f<g f<h = 3⊆-[] {(x ∷ g) 3∩ h}
3⊆∩f {nothing ∷ f} {[]} {[]} f<g f<h = 3⊆∩f {f} {[]} {[]} f<g f<h
3⊆∩f {nothing ∷ f} {[]} {just _ ∷ h} f<g f<h = f<g
3⊆∩f {nothing ∷ f} {[]} {nothing ∷ h} f<g f<h = 3⊆∩f {f} {[]} {h} f<g f<h
3⊆∩f {just i0 ∷ f} {just i0 ∷ g} {just i0 ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {just i1 ∷ f} {just i1 ∷ g} {just i1 ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {just _ ∷ g} {[]} f<g f<h = f<h
3⊆∩f {nothing ∷ f} {just i0 ∷ g} {just i0 ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {just i0 ∷ g} {just i1 ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {just i1 ∷ g} {just i0 ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {just i1 ∷ g} {just i1 ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {just i0 ∷ g} {nothing ∷ h} f<g f<h =   3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {just i1 ∷ g} {nothing ∷ h} f<g f<h =   3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {nothing ∷ g} {[]} f<g f<h = 3⊆∩f {f} {g} {[]} f<g f<h
3⊆∩f {nothing ∷ f} {nothing ∷ g} {just _ ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h
3⊆∩f {nothing ∷ f} {nothing ∷ g} {nothing ∷ h} f<g f<h =  3⊆∩f {f} {g} {h} f<g f<h

3↑22 : (f : Nat → Two) (i j : Nat) → List (Maybe Two)
3↑22 f Zero j = []
3↑22 f (Suc i) j = just (f j) ∷ 3↑22 f i (Suc j)

_3↑_ : (Nat → Two) → Nat → List (Maybe Two)
_3↑_ f i = 3↑22 f i 0

3↑< : {f : Nat → Two} → { x y : Nat } → x ≤ y → (_3↑_ f x)  3⊆ (_3↑_ f y)
3↑< {f} {x} {y} x<y = lemma x y 0 x<y where
     lemma : (x y i : Nat) → x ≤ y → (3↑22 f x i ) 3⊆ (3↑22 f y i )
     lemma 0 y i z≤n with f i
     lemma Zero Zero i z≤n | i0 = refl
     lemma Zero (Suc y) i z≤n | i0 = 3⊆-[]  {3↑22 f (Suc y) i}
     lemma Zero Zero i z≤n | i1 = refl
     lemma Zero (Suc y) i z≤n | i1 = 3⊆-[]  {3↑22 f (Suc y) i}
     lemma (Suc x) (Suc y) i (s≤s x<y) with f i
     lemma (Suc x) (Suc y) i (s≤s x<y) | i0 = lemma x y (Suc i) x<y
     lemma (Suc x) (Suc y) i (s≤s x<y) | i1 = lemma x y (Suc i) x<y

Finite3b : (p : List (Maybe Two) ) → Bool
Finite3b [] = true
Finite3b (just _ ∷ f) = Finite3b f
Finite3b (nothing ∷ f) = false

finite3cov : (p : List (Maybe Two) ) → List (Maybe Two)
finite3cov [] = []
finite3cov (just y ∷ x) = just y ∷ finite3cov x
finite3cov (nothing ∷ x) = just i0 ∷ finite3cov x

Dense-3 : F-Dense (List (Maybe Two) ) (λ x → One) _3⊆_ _3∩_
Dense-3 = record {
       dense =  λ x → Finite3b x ≡ true
    ;  d⊆P = OneObj
    ;  dense-f = λ x → finite3cov x
    ;  dense-d = λ {p} d → lemma1 p
    ;  dense-p = λ {p} d → lemma2 p
  } where
      lemma1 : (p : List (Maybe Two) ) → Finite3b (finite3cov p) ≡ true
      lemma1 [] = refl
      lemma1 (just i0 ∷ p) = lemma1 p
      lemma1 (just i1 ∷ p) = lemma1 p
      lemma1 (nothing ∷ p) = lemma1 p
      lemma2 : (p : List (Maybe Two)) → p 3⊆ finite3cov p
      lemma2 [] = refl
      lemma2 (just i0 ∷ p) = lemma2 p
      lemma2 (just i1 ∷ p) = lemma2 p
      lemma2 (nothing ∷ p) = lemma2 p

-- min  = Data.Nat._⊓_
-- m≤m⊔n  = Data.Nat._⊔_
-- open import Data.Nat.Properties


module Let where

f
  : {A : Set}
  → A
  → A
f x
  = let
      y = x
      z = x
    in y


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Foundations.Pointed.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Pointed.Base
open import Cubical.Foundations.Function
open import Cubical.Foundations.GroupoidLaws

open import Cubical.Data.Sigma

Π∙ : ∀ {ℓ ℓ'} (A : Type ℓ) (B∙ : A → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Π∙ A B∙ = (∀ a → typ (B∙ a)) , (λ a → pt (B∙ a))

Σ∙ : ∀ {ℓ ℓ'} (A∙ : Pointed ℓ) (B∙ : typ A∙ → Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
Σ∙ A∙ B∙ = (Σ[ a ∈ typ A∙ ] typ (B∙ a)) , (pt A∙ , pt (B∙ (pt A∙)))

_×∙_ : ∀ {ℓ ℓ'} (A∙ : Pointed ℓ) (B∙ : Pointed ℓ') → Pointed (ℓ-max ℓ ℓ')
A∙ ×∙ B∙ = ((typ A∙) × (typ B∙)) , (pt A∙ , pt B∙)

{- composition of pointed maps -}
_∘∙_ : ∀ {ℓA ℓB ℓC} {A : Pointed ℓA} {B : Pointed ℓB} {C : Pointed ℓC}
       (g : B →∙ C) (f : A →∙ B) → (A →∙ C)
(g , g∙) ∘∙ (f , f∙) = (λ x → g (f  x)) , ((cong g f∙) ∙ g∙)

{- pointed identity -}
id∙ : ∀ {ℓA} (A : Pointed ℓA) → (A →∙ A)
id∙ A = ((λ x → x) , refl)

{- constant pointed map -}
const∙ : ∀ {ℓA ℓB} (A : Pointed ℓA) (B : Pointed ℓB) → (A →∙ B)
const∙ _ (_ , b) = (λ _ → b) , refl

{- left identity law for pointed maps -}
∘∙-idˡ : ∀ {ℓA ℓB} {A : Pointed ℓA} {B : Pointed ℓB} (f : A →∙ B) → f ∘∙ id∙ A ≡ f
∘∙-idˡ (_ , f∙) = ΣPathP ( refl , (lUnit f∙) ⁻¹ )

{- right identity law for pointed maps -}
∘∙-idʳ : ∀ {ℓA ℓB} {A : Pointed ℓA} {B : Pointed ℓB} (f : A →∙ B) → id∙ B ∘∙ f ≡ f
∘∙-idʳ (_ , f∙) = ΣPathP ( refl , (rUnit f∙) ⁻¹ )

{- associativity for composition of pointed maps -}
∘∙-assoc : ∀ {ℓA ℓB ℓC ℓD} {A : Pointed ℓA} {B : Pointed ℓB} {C : Pointed ℓC} {D : Pointed ℓD}
           (h : C →∙ D) (g : B →∙ C) (f : A →∙ B)
           → (h ∘∙ g) ∘∙ f ≡ h ∘∙ (g ∘∙ f)
∘∙-assoc (h , h∙) (g , g∙) (f , f∙) = ΣPathP (refl , q)
  where
    q : (cong (h ∘ g) f∙) ∙ (cong h g∙ ∙ h∙) ≡ cong h (cong g f∙ ∙ g∙) ∙ h∙
    q = ( (cong (h ∘ g) f∙) ∙ (cong h g∙ ∙ h∙)
        ≡⟨ refl ⟩
        (cong h (cong g f∙)) ∙ (cong h g∙ ∙ h∙)
        ≡⟨ assoc (cong h (cong g f∙)) (cong h g∙) h∙ ⟩
        (cong h (cong g f∙) ∙ cong h g∙) ∙ h∙
        ≡⟨ cong (λ p → p ∙ h∙) ((cong-∙ h (cong g f∙) g∙) ⁻¹) ⟩
        (cong h (cong g f∙ ∙ g∙) ∙ h∙) ∎ )


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Instance.Nat where

-- Skeleton of FinSetoid as a Category

open import Level

open import Data.Fin.Base using (Fin; inject+; raise; splitAt; join)
open import Data.Fin.Properties
open import Data.Nat.Base using (ℕ; _+_)
open import Data.Sum using (inj₁; inj₂; [_,_]′)
open import Data.Sum.Properties
open import Relation.Binary.PropositionalEquality
  using (_≗_; _≡_; refl; sym; trans; cong; module ≡-Reasoning; inspect; [_])
open import Function using (id; _∘′_)

open import Categories.Category.Cartesian.Bundle using (CartesianCategory)
open import Categories.Category.Cocartesian using (Cocartesian)
open import Categories.Category.Cocartesian.Bundle using (CocartesianCategory)
open import Categories.Category.Core using (Category)
open import Categories.Category.Duality using (Cocartesian⇒coCartesian)
open import Categories.Object.Coproduct
open import Categories.Object.Duality using (Coproduct⇒coProduct)
open import Categories.Object.Product

Nat : Category 0ℓ 0ℓ 0ℓ
Nat = record
  { Obj = ℕ
  ; _⇒_ = λ m n → (Fin m → Fin n)
  ; _≈_ = _≗_
  ; id = id
  ; _∘_ = _∘′_
  ; assoc = λ _ → refl
  ; sym-assoc = λ _ → refl
  ; identityˡ = λ _ → refl
  ; identityʳ = λ _ → refl
  ; identity² = λ _ → refl
  ; equiv = record
    { refl = λ _ → refl
    ; sym = λ x≡y z → sym (x≡y z)
    ; trans = λ x≡y y≡z w → trans (x≡y w) (y≡z w)
    }
  ; ∘-resp-≈ = λ {_ _ _ f h g i} f≗h g≗i x → trans (f≗h (g x)) (cong h (g≗i x))
  }

-- For other uses, it is important to choose coproducts
-- in theory, it should be strictly associative... but it's not, and won't be for any choice.
Coprod : (m n : ℕ) → Coproduct Nat m n
Coprod m n = record
  { A+B = m + n
  ; i₁ = inject+ n
  ; i₂ = raise m
  ; [_,_] = λ l r z → [ l , r ]′ (splitAt m z)
  ; inject₁ = λ {_ f g} x → cong [ f , g ]′ (splitAt-inject+ m n x)
  ; inject₂ = λ {_ f g} x → cong [ f , g ]′ (splitAt-raise m n x)
  ; unique = uniq
  }
  where
    open ≡-Reasoning
    uniq : {o : ℕ} {h : Fin (m + n) → Fin o} {f : Fin m → Fin o} {g : Fin n → Fin o} →
      h ∘′ inject+ n ≗ f → h ∘′ raise m ≗ g → (λ z → [ f , g ]′ (splitAt m z)) ≗ h
    uniq {_} {h} {f} {g} h≗f h≗g w = begin
      [ f , g ]′ (splitAt m w)                         ≡⟨ [,]-cong (λ x → sym (h≗f x)) (λ x → sym (h≗g x)) (splitAt m w) ⟩
      [ h ∘′ inject+ n , h ∘′ raise m ]′ (splitAt m w) ≡˘⟨ [,]-∘-distr h (splitAt m w) ⟩
      h ([ inject+ n , raise m ]′ (splitAt m w))       ≡⟨ cong h (join-splitAt m n w) ⟩
      h w                                              ∎

Nat-Cocartesian : Cocartesian Nat
Nat-Cocartesian = record
  { initial = record
    { ⊥ = 0
    ; ⊥-is-initial = record
      { ! = λ ()
      ; !-unique = λ _ ()
      }
    }
  ; coproducts = record { coproduct = λ {m} {n} → Coprod m n }
  }

-- And Natop is what is used a lot, so record some things here too
Natop : Category 0ℓ 0ℓ 0ℓ
Natop = Category.op Nat

Natop-Product : (m n : ℕ) → Product Natop m n
Natop-Product m n = Coproduct⇒coProduct Nat (Coprod m n)

Natop-Cartesian : CartesianCategory 0ℓ 0ℓ 0ℓ
Natop-Cartesian = record
  { U = Natop
  ; cartesian = Cocartesian⇒coCartesian Nat Nat-Cocartesian
  }


module Generic.Test.ReadData where

open import Generic.Main

data D {α β} (A : Set α) (B : ℕ -> Set β) : ∀ {n} -> B n -> List ℕ -> Set (α ⊔ β) where
  c₁ : ∀ {n} (y : B n) xs -> A -> D A B y xs
  c₂ : ∀ {y : B 0} -> (∀ {n} (y : B n) {{xs}} -> D A B y xs) -> .(List A) -> D A B y []

-- No longer works: Failed to solve the following constraints: Has bigger sort: Setω
-- D′ : TypeOf D
D′ : ∀ {α β} -> (A : Set α) -> (B : ℕ -> Set β) -> ∀ {n} -> B n -> List ℕ -> Set (α ⊔ β)
D′ = readData D

unquoteDecl foldD = deriveFoldTo foldD (quote D)

inj : ∀ {α β} {A : Set α} {B : ℕ -> Set β} {n xs} {y : B n} -> D A B y xs -> D′ A B y xs
inj = gcoerce foldD

outj : ∀ {α β} {A : Set α} {B : ℕ -> Set β} {n xs} {y : B n} -> D′ A B y xs -> D A B y xs
outj d = guncoerce d

pattern c₁′ {n} y xs x = #₀  (relv n , relv y , relv xs , relv x , lrefl)
pattern c₂′ {y} r ys   = !#₁ (relv y , r , irrv ys , lrefl)

inj′ : ∀ {α β} {A : Set α} {B : ℕ -> Set β} {n xs} {y : B n} -> D A B y xs -> D′ A B y xs
inj′ (c₁ y xs x) = c₁′ y xs x
inj′ (c₂ r ys)   = c₂′ (λ y -> inj′ (r y)) ys

outj′ : ∀ {α β} {A : Set α} {B : ℕ -> Set β} {n xs} {y : B n} -> D′ A B y xs -> D A B y xs
outj′ (c₁′ y xs x) = c₁ y xs x
outj′ (c₂′ r ys)   = c₂ (λ y -> outj′ (r y)) ys


-- This file tests that implicit record fields are not printed out (by
-- default).

module ImplicitRecordFields where

record R : Set₁ where
  field
    {A}         : Set
    f           : A → A
    {B C} D {E} : Set
    g           : B → C → E

postulate
  A  : Set
  r₁ : R

r₂ : R
r₂ = record
  { A = A
  ; f = λ x → x
  ; B = A
  ; C = A
  ; D = A
  ; g = λ x _ → x
  }

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

foo : r₁ ≡ r₂
foo = refl


-- Andreas, 2015-10-28 Issue 1407
-- (Issue 1023 raised its ugly head again!)

{-# OPTIONS -v term.with.inline:30 #-} --KEEP! Triggered bug on agda-2.4.2.5.
-- {-# OPTIONS -v term.with.inline:70 #-}
-- {-# OPTIONS -v tc.with.display:30 #-}

record _×_ (A B : Set) : Set where
  constructor pair
  field fst : A
        snd : B
open _×_

data Unit : Set where
  unit : Unit

data List (A : Set) : Set where
  _∷_ : A → List A → List A

map : ∀ A B → (A → B) → List A → List B
map A B f (x ∷ xs) = f x ∷ map A B f xs

record Setoid : Set₁ where
  field Carrier : Set
open Setoid

module Assoc (Key : Setoid) (_ : Set) where -- FAILS
-- module Assoc (_ : Set) (Key : Setoid) where -- WORKS

  data _∈_ (x : Carrier Key) : List (Carrier Key) → Set where
    here  : ∀ xs → Unit → x ∈ xs
    there : ∀ {xs} → x ∈ xs

  postulate
    foo : Carrier Key → Carrier Key → Unit

  lem : (p : Carrier Key × Unit)
      → (ps : List (Carrier Key × Unit))
      → fst p ∈ map (Carrier Key × Unit) (Carrier Key) fst ps
      → Set
  lem (pair k v) ((pair k' v') ∷ ps) (here .(k' ∷ map (Carrier Key × Unit) (Carrier Key) fst ps) u) with foo k k'
  ... | unit = Unit
  lem p (_ ∷ ps) there = lem p ps there -- to force termination checking

--     7   6       5 4        3  2     1              7       0
-- lem Key _ (pair k v) (pair k' v') ∷ ps) (here .(...Key...) u)
--          8   7 6 5   4         3 2  1  0
-- lem-with Key _ k k' (w = unit) v v' ps u = Unit
{-
inlinedClauses (raw)
  QNamed {qname = Issue1407.Assoc.lem, qnamed = Clause
  { clauseRange = /home/abel/agda/test/bugs/Issue1407.agda:40,3-13
  , clauseTel =
    ExtendTel (Def Issue1407.Setoid []) (Abs "Key"
    ExtendTel (Sort (Type (Max []))) (Abs "_"
    ExtendTel (Var 1 [Proj Issue1407.Setoid.Carrier]}) (Abs "k"
    ExtendTel (Var 2 [Proj Issue1407.Setoid.Carrier]}) (Abs "k'"
    ExtendTel (Def Issue1407.Unit []}) (Abs "v"
    ExtendTel (Def Issue1407.Unit []}) (Abs "v'"
    ExtendTel (Def Issue1407.List [Apply []r(Def Issue1407._×_ [Apply []r(Var 5 [Proj Issue1407.Setoid.Carrier]),Apply []r(Def Issue1407.Unit [])])]}) (Abs "ps"
    ExtendTel (Def Issue1407.Unit []}) (Abs "u"
    EmptyTel))))))))
  , clausePerm = x0,x1,x2,x3,x4,x5,x6,x7,x8 -> x0,x1,x2,x4,x3,x5,x6,x8
  , namedClausePats =
    [[]r(VarP "Key")
    ,[]r(VarP "x")
    ,[]r(ConP Issue1407._×_._,_(inductive)[Issue1407._×_.fst,Issue1407._×_.snd] (ConPatternInfo {conPRecord = Nothing, conPType = Nothing}) [[]r(VarP "k"),[]r(VarP "v")])
    ,[]r(ConP Issue1407.List._∷_(inductive)[] (ConPatternInfo {conPRecord = Nothing, conPType = Nothing}) [[]r(ConP Issue1407._×_._,_(inductive)[Issue1407._×_.fst,Issue1407._×_.snd] (ConPatternInfo {conPRecord = Nothing, conPType = Nothing}) [[]r(VarP "k'"),[]r(VarP "v'")]),[]r(VarP "ps")])
    ,[]r(ConP Issue1407.Assoc._∈_.here(inductive)[] (ConPatternInfo {conPRecord = Nothing, conPType = Nothing})
      [[]r{DotP (Con Issue1407.List._∷_(inductive)[]
        [[]r(Var 4 [])
        ,[]r(Def Issue1407.map
          [Apply []r{Def Issue1407._×_ [Apply []r(Def Issue1407.Assoc._.Carrier [Apply []r(Con Issue1407.Unit.unit(inductive)[] []),Apply []r(Var 3 [])])
                                       ,Apply []r(Def Issue1407.Unit [])]}
          ,Apply []r{Def Issue1407.Assoc._.Carrier [Apply []r(Con Issue1407.Unit.unit(inductive)[] [])
                                                   ,Apply []r(Var 3 [])]}
          ,Apply []r(Lam (ArgInfo {argInfoHiding = NotHidden, argInfoRelevance = Relevant, argInfoColors = []}) (Abs "r" Var 0 [Proj Issue1407._×_.fst]))
          ,Apply []r(Var 1 [])
          ])
        ])}
      ,[]r(VarP "u")
      ])
    ,[]r(ConP Issue1407.Unit.unit(inductive)[] (ConPatternInfo {conPRecord = Nothing, conPType = Nothing}) [])
    ]
  , clauseBody = Bind (Abs "h8" Bind (Abs "h7" Bind (Abs "h6" Bind (Abs "h5" Bind (Abs "h4" Bind (Abs "h3" Bind (Abs "h2" Bind (Abs "h1" Bind (Abs "h0" Body (Def Issue1407.Unit [])))))))))), clauseType = Nothing}}

-}


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

open import HoTT
open import homotopy.Cogroup
open import cohomology.Theory

-- H^n is a group homomorphism when the domain is (Susp X -> Y).
module cohomology.Cogroup {i} (CT : CohomologyTheory i) (n : ℤ)
  {X : Ptd i} (cogroup-struct : CogroupStructure X) (Y : Ptd i) where

  open CohomologyTheory CT
  open import cohomology.Wedge CT
  open CogroupStructure cogroup-struct
  open import cohomology.CoHSpace CT n co-h-struct

  private
    module dom = GroupStructure (cogroup⊙→-group-structure cogroup-struct Y)
    module codom = Group (hom-group (C n Y) (C-abgroup n X))

  C-fmap-preserves-comp : preserves-comp dom.comp codom.comp (C-fmap n)
  C-fmap-preserves-comp f g = group-hom= $ λ= λ y →
    CEl-fmap n (dom.comp f g) y
      =⟨ C-fmap-∘ n (⊙Wedge-rec f g) ⊙coμ y ⟩
    CEl-fmap n ⊙coμ (CEl-fmap n (⊙Wedge-rec f g) y)
      =⟨ C-fmap-coμ (CEl-fmap n (⊙Wedge-rec f g) y) ⟩
    Group.comp (C n X)
      (CEl-fmap n ⊙winl (CEl-fmap n (⊙Wedge-rec f g) y))
      (CEl-fmap n ⊙winr (CEl-fmap n (⊙Wedge-rec f g) y))
      =⟨ ap2 (Group.comp (C n X))
           ( ∘-CEl-fmap n ⊙winl (⊙Wedge-rec f g) y
           ∙ ap (λ f → CEl-fmap n f y) (⊙WedgeRec.⊙winl-β f g))
           ( ∘-CEl-fmap n ⊙winr (⊙Wedge-rec f g) y
           ∙ ap (λ f → CEl-fmap n f y) (⊙WedgeRec.⊙winr-β f g)) ⟩
    Group.comp (C n X) (CEl-fmap n f y) (CEl-fmap n g y)
      =∎


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

open import lib.Basics

module lib.types.Empty where

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

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

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

⊥-is-prop : is-prop ⊥
⊥-is-prop = Empty-is-prop

negated-equiv-Empty : ∀ {i} (A : Type i) → (¬ A) → (Empty ≃ A)
negated-equiv-Empty A notA = equiv Empty-elim
                                   notA
                                   (λ a → Empty-elim {P = λ _ → Empty-elim (notA a) == a} (notA a))
                                   (Empty-elim {P = λ e → notA (Empty-elim e) == e})


module Tactic.Nat.Subtract.Exp where

open import Prelude
open import Tactic.Nat.Exp
open import Tactic.Nat.NF
open import Container.Bag
open import Data.TreeRep

infixl 6 _⟨+⟩_ _⟨-⟩_
infixl 7 _⟨*⟩_

data SubExp : Set where
  var : (x : Var) → SubExp
  lit : (n : Nat) → SubExp
  _⟨+⟩_ _⟨-⟩_ _⟨*⟩_ : (a b : SubExp) → SubExp

infix 4 _:≡_ _:<_
data Eqn : Set where
  _:≡_ : (a b : SubExp) → Eqn
  _:<_ : (a b : SubExp) → Eqn

⟦_⟧se : SubExp → Env Var → Nat
⟦ var x ⟧se    ρ = ρ x
⟦ lit n ⟧se    ρ = n
⟦ e₁ ⟨+⟩ e₂ ⟧se ρ = ⟦ e₁ ⟧se ρ + ⟦ e₂ ⟧se ρ
⟦ e₁ ⟨-⟩ e₂ ⟧se ρ = ⟦ e₁ ⟧se ρ - ⟦ e₂ ⟧se ρ
⟦ e₁ ⟨*⟩ e₂ ⟧se ρ = ⟦ e₁ ⟧se ρ * ⟦ e₂ ⟧se ρ

⟦_⟧eqn : Eqn → Env Var → Set
⟦ e₁ :≡ e₂ ⟧eqn ρ = ⟦ e₁ ⟧se ρ ≡ ⟦ e₂ ⟧se ρ
⟦ e₁ :< e₂ ⟧eqn ρ = ⟦ e₁ ⟧se ρ < ⟦ e₂ ⟧se ρ

data SubAtom : Set

SubNF : Set
SubNF = NF SubAtom

data SubAtom where
  var   : Var → SubAtom
  _⟨-⟩_  : (a b : SubNF) → SubAtom

⟦_⟧sn : SubNF → Env Var → Nat
⟦_⟧st : Tm SubAtom → Env Var → Nat
⟦_⟧sa : SubAtom → Env Var → Nat

⟦ var x ⟧sa ρ = ρ x
⟦ a ⟨-⟩ b ⟧sa ρ = ⟦ a ⟧sn ρ - ⟦ b ⟧sn ρ

⟦ []     ⟧st ρ = 1
⟦ t ∷ ts ⟧st ρ = ⟦ t ⟧sa ρ * ⟦ ts ⟧st ρ

⟦ []           ⟧sn ρ = 0
⟦ (k , ts) ∷ n ⟧sn ρ = k * ⟦ ts ⟧st ρ + ⟦ n ⟧sn ρ

⟦_⟧sns : SubNF → Env Var → Nat
⟦_⟧sts : Tm SubAtom → Env Var → Nat
⟦_⟧sas : SubAtom → Env Var → Nat

⟦ var x ⟧sas ρ = ρ x
⟦ a ⟨-⟩ b ⟧sas ρ = ⟦ a ⟧sns ρ - ⟦ b ⟧sns ρ

⟦ []     ⟧sts ρ = 1
⟦ t ∷ [] ⟧sts ρ = ⟦ t ⟧sas ρ
⟦ t ∷ ts ⟧sts ρ = ⟦ t ⟧sas ρ * ⟦ ts ⟧sts ρ

⟦ []            ⟧sns ρ = 0
⟦ (k , ts) ∷ [] ⟧sns ρ = k * ⟦ ts ⟧sts ρ
⟦ (k , ts) ∷ n  ⟧sns ρ = k * ⟦ ts ⟧sts ρ + ⟦ n ⟧sns ρ

atomEnv : Env Var → Env SubAtom
atomEnv ρ x = ⟦ x ⟧sa ρ

atomEnvS : Env Var → Env SubAtom
atomEnvS ρ x = ⟦ x ⟧sas ρ

instance
  EncodeSubAtom : TreeEncoding SubAtom
  EncodeSubAtom = treeEncoding enc dec emb
    where
      enc    : SubAtom    → TreeRep
      encNF  : SubNF      → TreeRep
      encNFs : SubNF      → List TreeRep
      encTm  : Tm SubAtom → List TreeRep

      enc (var x)  = node x []
      enc (a ⟨-⟩ b) = node 0 (encNF a ∷ encNF b ∷ [])

      encNF n = node 0 (encNFs n)

      encNFs [] = []
      encNFs ((n , t) ∷ ns) = node n (encTm t) ∷ encNFs ns

      encTm []       = []
      encTm (x ∷ xs) = enc x ∷ encTm xs

      dec   : TreeRep → Maybe SubAtom
      decNF : TreeRep → Maybe SubNF
      decNFs : List TreeRep → Maybe SubNF
      decTm  : List TreeRep → Maybe (Tm SubAtom)

      dec (node x []) = just (var x)
      dec (node _ (t ∷ t₁ ∷ [])) = _⟨-⟩_ <$> decNF t <*> decNF t₁
      dec _ = nothing

      decNF (leaf _)    = nothing
      decNF (node _ ts) = decNFs ts

      decNFs (node n ts ∷ ts₁) = _∷_ <$> (_,_ n <$> decTm ts) <*> decNFs ts₁
      decNFs _                 = just []

      decTm []       = just []
      decTm (x ∷ ts) = _∷_ <$> dec x <*> decTm ts

      emb    : ∀ a → dec    (enc    a) ≡ just a
      embNFs : ∀ n → decNFs (encNFs n) ≡ just n
      embTm  : ∀ t → decTm  (encTm  t) ≡ just t

      emb (var x) = refl
      emb (a ⟨-⟩ b) = _⟨-⟩_ =$= embNFs a =*= embNFs b

      embNFs [] = refl
      embNFs ((n , t) ∷ ns) = _∷_ =$= (_,_ n =$= embTm t) =*= embNFs ns

      embTm []       = refl
      embTm (x ∷ xs) = _∷_ =$= emb x =*= embTm xs

  EqSubAtom : Eq SubAtom
  EqSubAtom = EqByTreeEncoding

  OrdSubAtom : Ord SubAtom
  OrdSubAtom = OrdByTreeEncoding

_-nf′_ : SubNF → SubNF → SubNF
a -nf′ b =
  case cancel a b of λ where
    (x  , []) → x
    ([] ,  _) → []
    (a′  , b′) → [ 1 , [ a′ ⟨-⟩ b′ ] ]

data IsSubtraction : SubNF → Set where
  _⟨-⟩_ : ∀ a b → IsSubtraction [ 1 , [ a ⟨-⟩ b ] ]
  no   : ∀ {a} → IsSubtraction a

is-subtraction : ∀ a → IsSubtraction a
is-subtraction [ 1 , [ a ⟨-⟩ b ] ] = a ⟨-⟩ b
is-subtraction a = no

infixl 6 _-nf_
infixl 7 _*nf₁_ _*tm_ _*ktm_ _*ktm′_
_-nf_ : SubNF → SubNF → SubNF
a  -nf b with is-subtraction a
_  -nf c | a ⟨-⟩ b = a -nf′ (b +nf c)
a  -nf b | no     = a -nf′ b

data IsSubtractionTm : Nat × Tm SubAtom → Set where
  _⟨-⟩_ : ∀ a b → IsSubtractionTm (1 , [ a ⟨-⟩ b ])
  no   : ∀ {a} → IsSubtractionTm a

is-subtraction-tm : ∀ a → IsSubtractionTm a
is-subtraction-tm (1 , [ a ⟨-⟩ b ]) = a ⟨-⟩ b
is-subtraction-tm a = no

_*nf₁_ : SubNF → SubNF → SubNF
_*ktm′_ : Nat × Tm SubAtom → SubNF → SubNF

_*tm_ : Nat × Tm SubAtom → Nat × Tm SubAtom → SubNF
s *tm t with is-subtraction-tm t
s       *tm _       | b ⟨-⟩ c = s *ktm′ b -nf s *ktm′ c
(a , x) *tm (b , y) | no     = [ a * b , merge x y ]

t *ktm′ [] = []
t *ktm′ (x ∷ a) = t *tm x +nf t *ktm′ a

_*ktm_ : Nat × Tm SubAtom → SubNF → SubNF
t *ktm a with is-subtraction-tm t
_ *ktm c | a ⟨-⟩ b = a *nf₁ c -nf b *nf₁ c
t *ktm a | no     = t *ktm′ a

[]      *nf₁ b = []
(t ∷ a) *nf₁ b = t *ktm b +nf (a *nf₁ b)

normSub : SubExp → SubNF
normSub (var x) = [ 1 , [ var x ] ]
normSub (lit 0) = []
normSub (lit n) = [ n , [] ]
normSub (e ⟨+⟩ e₁) = normSub e +nf normSub e₁
normSub (e ⟨-⟩ e₁) = normSub e -nf normSub e₁
normSub (e ⟨*⟩ e₁) = normSub e *nf₁ normSub e₁


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

module Data.Unit.Properties where

open import Data.Unit
open import Level
open import HLevels

isProp⊤ : isProp ⊤
isProp⊤ _ _ i = tt


module HiddenLambda where

postulate
  A : Set
  T : A -> Set

H : Set
H = {x : A} -> T x -> T x

-- H doesn't reduce when checking the body of h
h : H
h = \tx -> tx