module Data.List.Proofs where

import Lvl
open import Functional
open import Data.Option using (Option ; Some ; None)
open import Data.List
open import Data.List.Equiv
open import Data.List.Functions
open import Logic
open import Numeral.Natural
open import Numeral.Natural.Oper
open import Numeral.Natural.Oper.Proofs
open import Relator.Equals renaming (_≡_ to _≡ₑ_ ; _≢_ to _≢ₑ_)
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Multi
import      Structure.Function.Names as Names
import      Structure.Operator.Names as Names
open import Structure.Operator.Proofs.Util
open import Structure.Operator.Properties
open import Structure.Operator
open import Structure.Relator.Properties
open import Structure.Setoid
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₑ ℓₑₗ ℓₑₒ ℓₑ₁ ℓₑ₂ ℓₑₗ₁ ℓₑₗ₂ : Lvl.Level
private variable T A B : Type{ℓ}
private variable n : ℕ

module _ ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ equiv-List : Equiv{ℓₑₗ}(List(T)) ⦄ ⦃ extensionality : Extensionality(equiv-List) ⦄ where
  private variable l l₁ l₂ : List(T)
  private variable a b x : T
  private variable P : List(T) → Stmt{ℓ}

  open Equiv(equiv-List) using () renaming (_≡_ to _≡ₗ_)

  instance
    tail-function : Function(tail)
    Function.congruence tail-function {∅}      {∅}      p = p
    Function.congruence tail-function {∅}      {x ⊰ y}  p with () ← [∅][⊰]-unequal p
    Function.congruence tail-function {x ⊰ xl} {∅}      p with () ← [∅][⊰]-unequal (symmetry(_≡_) p)
    Function.congruence tail-function {x ⊰ xl} {y ⊰ yl} p = [⊰]-generalized-cancellationₗ p

  instance
    first-function : ⦃ equiv-Option : Equiv{ℓₑₒ}(Option(T)) ⦄ ⦃ Some-function : Function(Some) ⦄ → Function(first)
    Function.congruence first-function {∅}      {∅}      p = reflexivity(_≡_)
    Function.congruence first-function {∅}      {y ⊰ yl} p with () ← [∅][⊰]-unequal p
    Function.congruence first-function {x ⊰ xl} {∅}      p with () ← [∅][⊰]-unequal (symmetry(_≡_) p)
    Function.congruence first-function {x ⊰ xl} {y ⊰ yl} p = congruence₁(Some) ([⊰]-generalized-cancellationᵣ p)

  instance
    [⊰]-cancellationₗ : Cancellationₗ(_⊰_)
    Cancellationₗ.proof([⊰]-cancellationₗ) = [⊰]-generalized-cancellationₗ

  instance
    [⊰]-cancellationᵣ : Cancellationᵣ(_⊰_)
    Cancellationᵣ.proof([⊰]-cancellationᵣ) = [⊰]-generalized-cancellationᵣ

  [⊰]-unequal : (x ⊰ l ≢ l)
  [⊰]-unequal {l = ∅} = [∅][⊰]-unequal ∘ symmetry(_≡_)
  [⊰]-unequal {l = x ⊰ l} = [⊰]-unequal {l = l} ∘ [⊰]-generalized-cancellationₗ

  postpend-of-prepend : (postpend a (b ⊰ l) ≡ b ⊰ postpend a l)
  postpend-of-prepend = reflexivity(_≡_)

  instance
    postpend-function : BinaryOperator(postpend)
    postpend-function = intro p where
      p : Names.Congruence₂(postpend)
      p {x₂ = ∅}        {y₂ = ∅}        px pl = congruence₂(_⊰_) px pl
      p {x₂ = ∅}        {y₂ = y₂ ⊰ yl₂} px pl with () ← [∅][⊰]-unequal pl
      p {x₂ = x₂ ⊰ xl₂} {y₂ = ∅}        px pl with () ← [∅][⊰]-unequal (symmetry(_≡_) pl)
      p {x₂ = x₂ ⊰ xl₂} {y₂ = y₂ ⊰ yl₂} px pl = congruence₂(_⊰_) ([⊰]-generalized-cancellationᵣ pl) (p{x₂ = xl₂} {y₂ = yl₂} px ([⊰]-generalized-cancellationₗ pl))

  instance
    reverse-function : Function(reverse)
    reverse-function = intro p where
      p : Names.Congruence₁(reverse)
      p {∅}      {∅}      pl = reflexivity(_≡_)
      p {∅}      {y ⊰ yl} pl with () ← [∅][⊰]-unequal pl
      p {x ⊰ xl} {∅}      pl with () ← [∅][⊰]-unequal (symmetry(_≡_) pl)
      p {x ⊰ xl} {y ⊰ yl} pl = congruence₂(postpend) ([⊰]-generalized-cancellationᵣ pl) (p([⊰]-generalized-cancellationₗ pl))

  instance
    [++]-identityₗ : Identityₗ(_++_) ∅
    Identityₗ.proof([++]-identityₗ) = reflexivity(_≡_)

  instance
    [++]-identityᵣ : Identityᵣ(_++_) ∅
    Identityᵣ.proof([++]-identityᵣ) {x = l} = elim (reflexivity(_≡_)) (\x l → congruence₂ᵣ(_⊰_)(x) {l ++ ∅}{l}) l

  instance
    [++]-associativity : Associativity(_++_)
    Associativity.proof([++]-associativity) {l₁}{l₂}{l₃} = elim (reflexivity(_≡_)) (\x l → congruence₂ᵣ(_⊰_)(x) {(l ++ l₂) ++ l₃}{l ++ (l₂ ++ l₃)}) l₁

  reverse-postpend : (reverse(postpend a l) ≡ a ⊰ reverse l)
  reverse-postpend {a = a}{l = l} = elim (reflexivity(_≡ₗ_)) (\x l p → congruence₂ᵣ(postpend) ⦃ postpend-function ⦄ (x) {reverse(postpend a l)}{a ⊰ reverse l} p) l

  prepend-[++] : (a ⊰ l ≡ singleton{T = T}(a) ++ l)
  prepend-[++] = reflexivity(_≡_)

  postpend-[++] : (postpend{T = T} a l ≡ l ++ singleton(a))
  postpend-[++] {a = a}{l = l} = elim (reflexivity(_≡_)) (\x l → congruence₂ᵣ(_⊰_)(x) {postpend a l}{l ++ (singleton a)}) l

  postpend-of-[++] : (postpend{T = T} a (l₁ ++ l₂) ≡ l₁ ++ postpend a l₂)
  postpend-of-[++] {a = a} {l₁}{l₂} = elim (reflexivity(_≡_)) (\x l → congruence₂ᵣ(_⊰_)(x) {postpend a (l ++ l₂)}{l ++ (postpend a l₂)}) l₁

  reverse-[++] : (reverse(l₁ ++ l₂) ≡ reverse(l₂) ++ reverse(l₁))
  reverse-[++] {l₁ = l₁} {l₂ = l₂} = elim
    (congruence₁(reverse) (identityₗ(_++_)(∅) {l₂}) 🝖 symmetry(_≡_) (identityᵣ(_++_)(∅) {reverse l₂}))
    (\x l₁ p → congruence₂ᵣ(postpend) ⦃ postpend-function ⦄ (x) {reverse (l₁ ++ l₂)}{reverse l₂ ++ reverse l₁} p 🝖 postpend-of-[++] {l₁ = reverse l₂} {l₂ = reverse l₁})
    l₁

  [∅]-postpend-unequal : (postpend x l ≢ ∅)
  [∅]-postpend-unequal {l = ∅}     = [∅][⊰]-unequal ∘ symmetry(_≡_)
  [∅]-postpend-unequal {l = _ ⊰ l} = [∅][⊰]-unequal ∘ symmetry(_≡_)

  postpend-unequal : (postpend x l ≢ l)
  postpend-unequal {l = ∅}     = [∅][⊰]-unequal ∘ symmetry(_≡_)
  postpend-unequal {l = y ⊰ l} = postpend-unequal {l = l} ∘ cancellationₗ(_⊰_)

  [++]-middle-prepend-postpend : postpend x l₁ ++ l₂ ≡ l₁ ++ (x ⊰ l₂)
  [++]-middle-prepend-postpend {l₁ = ∅}      {l₂ = ∅} = reflexivity(_≡_)
  [++]-middle-prepend-postpend {l₁ = ∅}      {l₂ = x ⊰ l₂} = reflexivity(_≡_)
  [++]-middle-prepend-postpend {l₁ = x ⊰ l₁} {l₂ = l₂} = congruence₂ᵣ(_⊰_)(x) ([++]-middle-prepend-postpend {l₁ = l₁} {l₂ = l₂})

  instance
    [++]-cancellationₗ : Cancellationₗ(_++_)
    Cancellationₗ.proof [++]-cancellationₗ {x}{y}{z} = proof {x}{y}{z} where
      proof : Names.Cancellationₗ (_++_)
      proof {∅}     p = p
      proof {x ⊰ l} p = proof {l} (cancellationₗ(_⊰_) p)

  instance
    [++]-cancellationᵣ : Cancellationᵣ(_++_)
    Cancellationᵣ.proof([++]-cancellationᵣ) {a}{b} = proof {a}{b} where
      proof : Names.Cancellationᵣ(_++_)
      proof {z}      {∅}      {∅}      p = reflexivity(_≡_)
      proof {z}      {x ⊰ xl} {y ⊰ yl} p = congruence₂(_⊰_) ([⊰]-generalized-cancellationᵣ p) (proof {z}{xl}{yl} ([⊰]-generalized-cancellationₗ p))
      proof {∅}      {∅}      {y ⊰ yl} p with () ← [∅][⊰]-unequal {l = yl} (p 🝖 identityᵣ(_++_)(∅))
      proof {z ⊰ zl} {∅}      {y ⊰ yl} p with () ← [∅]-postpend-unequal(symmetry(_≡_) (proof{zl}{∅}{postpend z yl} ([⊰]-generalized-cancellationₗ p 🝖 symmetry(_≡_) ([++]-middle-prepend-postpend {x = z}{l₁ = yl}{l₂ = zl}))))
      proof {∅}      {x ⊰ xl} {∅}      p with () ← [∅][⊰]-unequal {l = xl} (symmetry(_≡_) p 🝖 identityᵣ(_++_)(∅))
      proof {z ⊰ zl} {x ⊰ xl} {∅}      p with () ← [∅]-postpend-unequal(proof{zl}{postpend z xl}{∅} ([++]-middle-prepend-postpend {x = z}{l₁ = xl}{l₂ = zl} 🝖 [⊰]-generalized-cancellationₗ p))

  reverse-involution-raw : Names.Involution(reverse{T = T})
  reverse-involution-raw {x = ∅}     = reflexivity(_≡_)
  reverse-involution-raw {x = x ⊰ l} = reverse-postpend {a = x}{l = reverse l} 🝖 congruence₂ᵣ(_⊰_)(x) (reverse-involution-raw {x = l})

  instance
    reverse-involution : Involution(reverse{T = T})
    Involution.proof reverse-involution = reverse-involution-raw

  initial-of-∅ : (initial(n)(∅ {T = T}) ≡ ∅)
  initial-of-∅ {n = 𝟎}    = reflexivity(_≡_)
  initial-of-∅ {n = 𝐒(n)} = reflexivity(_≡_)

  module _ where
    open import Relator.Equals.Proofs.Equiv {T = ℕ}
    foldᵣ-constant-[+]ᵣ : ∀{init step} → (foldᵣ (const(_+ step)) init l ≡ₑ (step ⋅ length(l)) + init)
    foldᵣ-constant-[+]ᵣ {l = ∅} = reflexivity(_≡ₑ_)
    foldᵣ-constant-[+]ᵣ {l = x ⊰ l} {init}{step} =
      const(_+ step) x (foldᵣ (const(_+ step)) init l) 🝖[ _≡_ ]-[]
      (foldᵣ (const(_+ step)) init l) + step           🝖[ _≡_ ]-[ congruence₁(_+ step) (foldᵣ-constant-[+]ᵣ {l = l} {init}{step}) ]
      ((step ⋅ length(l)) + init) + step               🝖[ _≡_ ]-[ One.commuteᵣ-assocₗ {a = step ⋅ length(l)}{init}{step} ]
      ((step ⋅ length(l)) + step) + init               🝖[ _≡_ ]-[ congruence₁(_+ init) (commutativity(_+_) {step ⋅ length(l)}{step}) ]
      (step + (step ⋅ length(l))) + init               🝖-end

    foldᵣ-constant-[+]ₗ : ∀{init step} → (foldᵣ (const(step +_)) init l ≡ (length(l) ⋅ step) + init)
    foldᵣ-constant-[+]ₗ {l = ∅}                  = reflexivity(_≡_)
    foldᵣ-constant-[+]ₗ {l = x ⊰ l} {init}{step} =
      foldᵣ(const(step +_)) init (x ⊰ l)  🝖[ _≡_ ]-[]
      step + foldᵣ(const(step +_)) init l 🝖[ _≡_ ]-[ congruence₂ᵣ(_+_)(step) (foldᵣ-constant-[+]ₗ {l = l} {init}{step}) ]
      step + ((length(l) ⋅ step) + init)  🝖[ _≡_ ]-[ associativity(_+_) {step}{length(l) ⋅ step}{init} ]-sym
      (step + (length(l) ⋅ step)) + init  🝖[ _≡_ ]-[ congruence₂ₗ(_+_)(init) (commutativity(_+_) {step}{length(l) ⋅ step}) ]
      ((length(l) ⋅ step) + step) + init  🝖[ _≡_ ]-[ congruence₂ₗ(_+_)(init) ([⋅]-with-[𝐒]ₗ {length(l)}{step}) ]-sym
      (𝐒(length(l)) ⋅ step) + init        🝖[ _≡_ ]-[]
      (length(x ⊰ l) ⋅ step) + init       🝖-end

open import Structure.Setoid
module _
  ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄ ⦃ equiv-List₁ : Equiv{ℓₑₗ₁}(List(A)) ⦄ ⦃ extensionality-A : Extensionality(equiv-List₁) ⦄
  ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄ ⦃ equiv-List₂ : Equiv{ℓₑₗ₂}(List(B)) ⦄ ⦃ extensionality-B : Extensionality(equiv-List₂) ⦄
  where

  private variable l l₁ l₂ : List(T)
  private variable a b x : T
  private variable P : List(T) → Stmt{ℓ}

  private variable f : A → B

  map-postpend : (map f(postpend a l) ≡ postpend (f(a)) (map f(l)))
  map-postpend {f = f} {a = a}{l = l} = elim (reflexivity(_≡_)) (\x l → congruence₂ᵣ(_⊰_)(f(x)) {map f (postpend a l)}{postpend (f(a)) (map f l)}) l

  instance
    map-preserves-[++] : Preserving₂(map f)(_++_)(_++_)
    Preserving.proof (map-preserves-[++] {f = f}) {l₁} {l₂} = elim (reflexivity(_≡_)) (\x l₁ → congruence₂ᵣ(_⊰_)(f(x)) {map f(l₁ ++ l₂)}{(map f l₁) ++ (map f l₂)}) l₁


{-# OPTIONS --universe-polymorphism #-}
module Categories.Bifunctor where

open import Level
open import Data.Product using (_,_; swap)

open import Categories.Category

open import Categories.Functor public
open import Categories.Product

Bifunctor : ∀ {o ℓ e} {o′ ℓ′ e′} {o′′ ℓ′′ e′′} → Category o ℓ e → Category o′ ℓ′ e′ → Category o′′ ℓ′′ e′′ → Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′ ⊔ o′′ ⊔ ℓ′′ ⊔ e′′)
Bifunctor C D E = Functor (Product C D) E

overlap-× : ∀ {o ℓ e} {o′₁ ℓ′₁ e′₁} {o′₂ ℓ′₂ e′₂} {C : Category o ℓ e} {D₁ : Category o′₁ ℓ′₁ e′₁} {D₂ : Category o′₂ ℓ′₂ e′₂} (H : Bifunctor D₁ D₂ C) {o″ ℓ″ e″} {E : Category o″ ℓ″ e″} (F : Functor E D₁) (G : Functor E D₂) → Functor E C
overlap-× H F G = H ∘ (F ※ G)

reduce-× : ∀ {o ℓ e} {o′₁ ℓ′₁ e′₁} {o′₂ ℓ′₂ e′₂} {C : Category o ℓ e} {D₁ : Category o′₁ ℓ′₁ e′₁} {D₂ : Category o′₂ ℓ′₂ e′₂} (H : Bifunctor D₁ D₂ C) {o″₁ ℓ″₁ e″₁} {E₁ : Category o″₁ ℓ″₁ e″₁} (F : Functor E₁ D₁) {o″₂ ℓ″₂ e″₂} {E₂ : Category o″₂ ℓ″₂ e″₂} (G : Functor E₂ D₂) → Bifunctor E₁ E₂ C
reduce-× H F G = H ∘ (F ⁂ G)

flip-bifunctor : ∀ {o ℓ e} {o′ ℓ′ e′} {o′′ ℓ′′ e′′} {C : Category o ℓ e} → {D : Category o′ ℓ′ e′} → {E : Category o′′ ℓ′′ e′′} → Bifunctor C D E → Bifunctor D C E
flip-bifunctor {C = C} {D = D} {E = E} b = _∘_ b (Swap {C = C} {D = D})


------------------------------------------------------------------------
-- Call-by-value (CBV) reduction in pure type systems (PTS)
------------------------------------------------------------------------

module Pts.Reduction.Cbv where

open import Data.Fin.Substitution
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Star using (map; gmap)
import Relation.Binary.EquivalenceClosure as EqClos
import Relation.Binary.PropositionalEquality as PropEq
open import Relation.Binary.Reduction

open import Pts.Syntax
open import Pts.Reduction.Full as Full hiding (reduction)

-- All remaining submodules are parametrized by a given set of sorts.
module _ {Sort : Set} where

  open Syntax       Sort
  open Substitution Sort using (_[_])

  ----------------------------------------------------------------------
  -- Call-by-value (CBV) reduction and equivalence relations

  -- Untyped values with up to n free variables.
  data Val {n} : Term n → Set where
    sort : ∀ s   → Val (sort s)  -- sort
    Π    : ∀ a b → Val (Π a b)   -- dependent product
    ƛ    : ∀ a b → Val (ƛ a b)   -- abstraction

  infixl 9  _·₁_ _·₂_
  infix  5  _→v_

  -- One-step CBV reduction.
  data _→v_ {n} : Term n → Term n → Set where
    cont : ∀ a b {c} (v : Val c)              → (ƛ a b) · c →v b [ c ]
    _·₁_ : ∀ {a₁ a₂} → a₁ →v a₂ → ∀ b         →      a₁ · b →v a₂ · b
    _·₂_ : ∀ {a b₁ b₂} (v : Val a) → b₁ →v b₂ →      a · b₁ →v a · b₂

  reduction : Reduction Term
  reduction = record { _→1_ = _→v_ }

  -- CBV reduction and equivalence.
  open Reduction reduction public renaming (_→*_ to _→v*_; _↔_ to _≡v_)

  ----------------------------------------------------------------------
  -- Substitutions in CBV reductions/equivalence
  --
  -- The applications _/→v_, _/→v*_ and _/≡v_ below may be considered
  -- substitution lemmas, i.e. they establish the commutativity of the
  -- respective reductions/equivalence with substitutions.

  -- Application of generic substitutions to the
  -- reductions/equivalence.
  record CbvSubstApp {T} (l : Lift T Term) : Set where
    open Lift l
    open SubstApp Sort l
    open PropEq hiding ([_])

    -- Substitutions commute.
    field /-sub-↑ : ∀ {m n} a b (σ : Sub T m n) →
                    a [ b ] / σ ≡ (a / σ ↑) [ b / σ ]

    infixl 8 _/Val_ _/→v_

    -- Application of substitutions preserves values.
    _/Val_ : ∀ {m n a} → Val a → (σ : Sub T m n) → Val (a / σ)
    sort s /Val σ = sort s
    Π a b  /Val σ = Π (a / σ) (b / σ ↑)
    ƛ a b  /Val σ = ƛ (a / σ) (b / σ ↑)

    -- Substitution commutes with one-step reduction.
    _/→v_ : ∀ {m n a b} → a →v b → (σ : Sub T m n) → a / σ →v b / σ
    cont a b c /→v σ =
      subst (_→v_ _) (sym (/-sub-↑ b _ σ)) (cont (a / σ) (b / σ ↑) (c /Val σ))
    a₁→a₂ ·₁ b /→v σ = (a₁→a₂ /→v σ) ·₁ (b / σ)
    a ·₂ b₁→b₂ /→v σ = (a /Val σ) ·₂ (b₁→b₂ /→v σ)

    redSubstApp : RedSubstApp reduction (record { _/_ = _/_ })
    redSubstApp = record { _/→1_ = _/→v_ }

    open RedSubstApp redSubstApp public
      hiding (_/→1_) renaming (_/→*_ to _/→v*_; _/↔_ to _/≡v_)

  -- Term substitutions in reductions/equivalences.
  module CbvSubstitution where
    open Substitution Sort
      using (termSubst; weaken; sub-commutes; varLiftSubLemmas)

    -- Application of renamings to reductions/equivalences.
    varSubstApp : CbvSubstApp (TermSubst.varLift termSubst)
    varSubstApp = record { /-sub-↑ = /-sub-↑ }
      where open LiftSubLemmas varLiftSubLemmas
    private module V = CbvSubstApp varSubstApp

    -- Weakening of one-step CBV reductions.
    weaken-→v : ∀ {n} {a b : Term n} → a →v b → weaken a →v weaken b
    weaken-→v a→b = a→b V./→v VarSubst.wk

    -- Weakening of CBV reductions.
    weaken-→v* : ∀ {n} {a b : Term n} → a →v* b → weaken a →v* weaken b
    weaken-→v* = gmap weaken weaken-→v

    -- Weakening of equivalences.
    weaken-≡v : ∀ {n} {a b : Term n} → a ≡v b → weaken a ≡v weaken b
    weaken-≡v = EqClos.gmap weaken weaken-→v

    -- Application of term substitutions to reductions/equivalences.
    termSubstApp : CbvSubstApp (TermSubst.termLift termSubst)
    termSubstApp = record { /-sub-↑ = λ a _ _ → sub-commutes a }
    open CbvSubstApp termSubstApp public

  ----------------------------------------------------------------------
  -- Properties of the CBV reductions/equivalence

  -- Inclusions.
  →v⇒→v* = →1⇒→* reduction
  →v*⇒≡v = →*⇒↔  reduction
  →v⇒≡v  = →1⇒↔  reduction

  -- CBV reduction is a preorder.
  →v*-predorder = →*-predorder reduction

  -- Preorder reasoning for CBV reduction.
  module →v*-Reasoning = →*-Reasoning reduction

  -- Terms together with CBV equivalence form a setoid.
  ≡v-setoid = ↔-setoid reduction

  -- Equational reasoning for CBV equivalence.
  module ≡v-Reasoning = ↔-Reasoning reduction

  ----------------------------------------------------------------------
  -- Relationships between CBV reduction and full β-reduction

  -- One-step CBV reduction implies one-step β-reduction.
  →v⇒→β : ∀ {n} {a b : Term n} → a →v b → a →β b
  →v⇒→β (cont a b c) = cont a b _
  →v⇒→β (a₁→a₂ ·₁ b) = →v⇒→β a₁→a₂ ·₁ b
  →v⇒→β (a ·₂ b₁→b₂) = _ ·₂ →v⇒→β b₁→b₂

  -- CBV reduction implies parallel reduction.
  →v*⇒→β* : ∀ {n} {a b : Term n} → a →v* b → a →β* b
  →v*⇒→β* = map →v⇒→β

  -- CBV equivalence implies parallel equivalence.
  ≡v⇒≡p : ∀ {n} {a b : Term n} → a ≡v b → a ≡β b
  ≡v⇒≡p = EqClos.map →v⇒→β


------------------------------------------------------------------------
-- The Agda standard library
--
-- Property that elements are grouped
------------------------------------------------------------------------

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

module Data.List.Relation.Unary.Grouped where

open import Data.List using (List; []; _∷_; map)
open import Data.List.Relation.Unary.All as All using (All; []; _∷_; all)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_; _,_)
open import Relation.Binary as B using (REL; Rel)
open import Relation.Unary as U using (Pred)
open import Relation.Nullary using (¬_; yes)
open import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Sum using (_⊎-dec_)
open import Relation.Nullary.Product using (_×-dec_)
open import Relation.Nullary.Negation using (¬?)
open import Level using (_⊔_)

infixr 5 _∷≉_ _∷≈_

data Grouped {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) : Pred (List A) (a ⊔ ℓ) where
  [] : Grouped _≈_ []
  _∷≉_ : ∀ {x xs} → All (λ y → ¬ (x ≈ y)) xs → Grouped _≈_ xs → Grouped _≈_ (x ∷ xs)
  _∷≈_ : ∀ {x y xs} → x ≈ y → Grouped _≈_ (y ∷ xs) → Grouped _≈_ (x ∷ y ∷ xs)

module _ {a ℓ} {A : Set a} {_≈_ : Rel A ℓ} where
  grouped? : B.Decidable _≈_ → U.Decidable (Grouped _≈_)
  grouped? _≟_ [] = yes []
  grouped? _≟_ (x ∷ []) = yes ([] ∷≉ [])
  grouped? _≟_ (x ∷ y ∷ xs) = map′ from to ((x ≟ y ⊎-dec all (λ z → ¬? (x ≟ z)) (y ∷ xs)) ×-dec (grouped? _≟_ (y ∷ xs))) where
    from : ((x ≈ y) ⊎ All (λ z → ¬ (x ≈ z)) (y ∷ xs)) × Grouped _≈_ (y ∷ xs) → Grouped _≈_ (x ∷ y ∷ xs)
    from (inj₁ x≈y          , grouped[y∷xs]) = x≈y          ∷≈ grouped[y∷xs]
    from (inj₂ all[x≉,y∷xs] , grouped[y∷xs]) = all[x≉,y∷xs] ∷≉ grouped[y∷xs]
    to : Grouped _≈_ (x ∷ y ∷ xs) → ((x ≈ y) ⊎ All (λ z → ¬ (x ≈ z)) (y ∷ xs)) × Grouped _≈_ (y ∷ xs)
    to (all[x≉,y∷xs] ∷≉ grouped[y∷xs]) = inj₂ all[x≉,y∷xs] , grouped[y∷xs]
    to (x≈y          ∷≈ grouped[y∷xs]) = inj₁ x≈y , grouped[y∷xs]


module Oscar.Data.AList where

open import Oscar.Data.Equality
open import Oscar.Data.Nat

open import Oscar.Level

module _ {a} (A : Nat → Set a) where

  data AList (n : Nat) : Nat → Set a where
    [] : AList n n
    _∷_ : ∀ {m} → A m → AList n m → AList n (suc m)

open import Oscar.Category

module Category' {a} {A : Nat → Set a} where

  _⊸_ = AList A

  infix 4 _≋_
  _≋_ : ∀ {m n} → m ⊸ n → m ⊸ n → Set a
  _≋_ = _≡_

  infixr 9 _∙_
  _∙_ : ∀ {m n} → m ⊸ n → ∀ {l} → l ⊸ m → l ⊸ n
  [] ∙ ρ = ρ
  (x ∷ σ) ∙ ρ = x ∷ (σ ∙ ρ)

  ∙-associativity : ∀ {k l} (f : k ⊸ l) {m} (g : l ⊸ m) {n} (h : m ⊸ n) → (h ∙ g) ∙ f ≋ h ∙ g ∙ f
  ∙-associativity f g [] = refl
  ∙-associativity f g (x ∷ h) = cong (x ∷_) (∙-associativity f g h)

  ε : ∀ {n} → n ⊸ n
  ε = []

  ∙-left-identity : ∀ {m n} (σ : m ⊸ n) → ε ∙ σ ≋ σ
  ∙-left-identity _ = refl

  ∙-right-identity : ∀ {m n} (σ : m ⊸ n) → σ ∙ ε ≋ σ
  ∙-right-identity [] = refl
  ∙-right-identity (x ∷ σ) = cong (x ∷_) (∙-right-identity σ)

  semigroupoidAList : Semigroupoid (AList A) (λ {x y} → ≡-setoid (AList A x y))
  Semigroupoid._∙_ semigroupoidAList = _∙_
  Semigroupoid.∙-extensionality semigroupoidAList refl refl = refl
  Semigroupoid.∙-associativity semigroupoidAList = ∙-associativity

  categoryAList : Category semigroupoidAList
  Category.ε categoryAList = ε
  Category.ε-left-identity categoryAList = ∙-left-identity _
  Category.ε-right-identity categoryAList = ∙-right-identity _

--   ∙-associativity σ _ [] = refl
--   ∙-associativity (τ asnoc t / x) ρ σ = cong (λ s → s asnoc t / x) (∙-associativity τ ρ σ)

-- -- semigroupoid : ∀ {a} (A : Nat → Set a) → Semigroupoid a a ∅̂
-- -- Semigroupoid._∙_ = semigroupoid

-- -- -- record Semigroupoid
-- -- --   {𝔬} {𝔒 :

-- -- -- -- module Oscar.Data.AList {𝔣} (FunctionName : Set 𝔣) where

-- -- -- -- open import Oscar.Data.Fin
-- -- -- -- open import Oscar.Data.Nat
-- -- -- -- open import Oscar.Data.Product
-- -- -- -- open import Oscar.Data.Term FunctionName
-- -- -- -- open import Oscar.Data.IList

-- -- -- -- pattern anil = []
-- -- -- -- pattern _asnoc_/_ σ t' x = (t' , x) ∷ σ

-- -- -- -- AList : Nat → Nat → Set 𝔣
-- -- -- -- AList m n = IList (λ m → Term m × Fin (suc m)) n m

-- -- -- -- -- data AList' (n : Nat) : Nat -> Set 𝔣 where
-- -- -- -- --   anil : AList' n n
-- -- -- -- --   _asnoc_/_ : ∀ {m} (σ : AList' n m) (t' : Term m) (x : Fin (suc m))
-- -- -- -- --                -> AList' n (suc m)

-- -- -- -- -- open import Oscar.Function
-- -- -- -- -- --AList = flip AList'

-- -- -- -- -- -- data AList : Nat -> Nat -> Set 𝔣 where
-- -- -- -- -- --   anil : ∀ {n} -> AList n n
-- -- -- -- -- --   _asnoc_/_ : ∀ {m n} (σ : AList m n) (t' : Term m) (x : Fin (suc m))
-- -- -- -- -- --                -> AList (suc m) n

-- -- -- -- -- -- -- open import Relation.Binary.PropositionalEquality renaming ([_] to [[_]])
-- -- -- -- -- -- -- open ≡-Reasoning

-- -- -- -- -- -- -- step-prop : ∀ {m n} (s t : Term (suc m)) (σ : AList m n) r z ->
-- -- -- -- -- -- --           (Unifies s t [-◇ sub (σ asnoc r / z) ]) ⇔ (Unifies ((r for z) ◃ s) ((r for z) ◃ t) [-◇ sub σ ])
-- -- -- -- -- -- -- step-prop s t σ r z f = to , from
-- -- -- -- -- -- --   where
-- -- -- -- -- -- --     lemma1 : ∀ t -> (f ◇ sub σ) ◃ ((r for z) ◃ t) ≡ (f ◇ (sub σ ◇ (r for z))) ◃ t
-- -- -- -- -- -- --     lemma1 t = bind-assoc f (sub σ) (r for z) t
-- -- -- -- -- -- --     to = λ a → begin
-- -- -- -- -- -- --                  (f ◇ sub σ) ◃ ((r for z) ◃ s) ≡⟨ lemma1 s ⟩
-- -- -- -- -- -- --                  (f ◇ (sub σ ◇ (r for z))) ◃ s ≡⟨ a ⟩
-- -- -- -- -- -- --                  (f ◇ (sub σ ◇ (r for z))) ◃ t ≡⟨ sym (lemma1 t) ⟩
-- -- -- -- -- -- --                  (f ◇ sub σ) ◃ ((r for z) ◃ t) ∎
-- -- -- -- -- -- --     from = λ a → begin
-- -- -- -- -- -- --                    (f ◇ (sub σ ◇ (r for z))) ◃ s ≡⟨ sym (lemma1 s) ⟩
-- -- -- -- -- -- --                    (f ◇ sub σ) ◃ ((r for z) ◃ s) ≡⟨ a ⟩
-- -- -- -- -- -- --                    (f ◇ sub σ) ◃ ((r for z) ◃ t) ≡⟨ lemma1 t ⟩
-- -- -- -- -- -- --                    (f ◇ (sub σ ◇ (r for z))) ◃ t ∎

-- -- -- -- -- -- -- record ⋆amgu (T : ℕ → Set) : Set where
-- -- -- -- -- -- --   field amgu : ∀ {m} (s t : T m) (acc : ∃ (AList m)) -> Maybe (∃ (AList m))

-- -- -- -- -- -- -- open ⋆amgu ⦃ … ⦄ public

-- -- -- -- -- -- -- open import Category.Monad using (RawMonad)
-- -- -- -- -- -- -- import Level
-- -- -- -- -- -- -- open RawMonad (Data.Maybe.monad {Level.zero})

-- -- -- -- -- -- -- open import Relation.Binary using (IsDecEquivalence)
-- -- -- -- -- -- -- open import Relation.Nullary using (Dec; yes; no)
-- -- -- -- -- -- -- open import Data.Nat using (ℕ; _≟_)
-- -- -- -- -- -- -- open import Data.Product using () renaming (Σ to Σ₁)
-- -- -- -- -- -- -- open Σ₁ renaming (proj₁ to π₁; proj₂ to π₂)
-- -- -- -- -- -- -- open import Data.Product using (Σ)
-- -- -- -- -- -- -- open Σ
-- -- -- -- -- -- -- open import Data.Sum
-- -- -- -- -- -- -- open import Function

-- -- -- -- -- -- -- NothingForkLeft : ∀ {m l} (s1 t1 : Term m) (ρ : AList m l) (s2 t2 : Term m) →
-- -- -- -- -- -- --                Nothing⋆ $ Unifies⋆ s1 t1 [-◇⋆ sub ρ ] →
-- -- -- -- -- -- --                Nothing⋆ $ Unifies⋆ (s1 fork s2) (t1 fork t2) [-◇⋆ sub ρ ]
-- -- -- -- -- -- -- NothingForkLeft s1 t1 ρ s2 t2 nounify = No[Q◇ρ]→No[P◇ρ] No[Q◇ρ]
-- -- -- -- -- -- --   where
-- -- -- -- -- -- --     P = Unifies⋆ (s1 fork s2) (t1 fork t2)
-- -- -- -- -- -- --     Q = (Unifies⋆ s1 t1 ∧⋆ Unifies⋆ s2 t2)
-- -- -- -- -- -- --     Q⇔P : Q ⇔⋆ P
-- -- -- -- -- -- --     Q⇔P = switch⋆ P Q (Properties.fact1' {_} {s1} {s2} {t1} {t2})
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ] : Nothing⋆ (Q [-◇⋆ sub ρ ]) -> Nothing⋆ (P [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ] = Properties.fact2⋆ (Q [-◇⋆ sub ρ ]) (P [-◇⋆ sub ρ ]) (Properties.fact5⋆ Q P (sub ρ) Q⇔P)
-- -- -- -- -- -- --     No[Q◇ρ] : Nothing⋆ (Q [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ] = failure-propagation.first⋆ (sub ρ) (Unifies⋆ s1 t1) (Unifies⋆ s2 t2) nounify

-- -- -- -- -- -- -- NothingForkRight : ∀ {m l n} (σ : AList l n)
-- -- -- -- -- -- --                   (s1 s2 : Term m)
-- -- -- -- -- -- --                   (t1 t2 : Term m) →
-- -- -- -- -- -- --                   (ρ : AList m l) →
-- -- -- -- -- -- --                   Max⋆ (Unifies⋆ s1 t1 [-◇⋆ sub ρ ]) $ sub σ →
-- -- -- -- -- -- --                   Nothing⋆ $ Unifies⋆ s2 t2 [-◇⋆ sub (σ ++ ρ) ] →
-- -- -- -- -- -- --                   Nothing⋆ $ Unifies⋆ (s1 fork s2) (t1 fork t2) [-◇⋆ sub ρ ]
-- -- -- -- -- -- -- NothingForkRight σ s1 s2 t1 t2 ρ a nounify = No[Q◇ρ]→No[P◇ρ]⋆ No[Q◇ρ]⋆
-- -- -- -- -- -- --     where
-- -- -- -- -- -- --     P⋆ = Unifies⋆ (s1 fork s2) (t1 fork t2)
-- -- -- -- -- -- --     Q⋆ = (Unifies⋆ s1 t1 ∧⋆ Unifies⋆ s2 t2)
-- -- -- -- -- -- --     Q⇔P⋆ : Q⋆ ⇔⋆ P⋆
-- -- -- -- -- -- --     Q⇔P⋆ = switch⋆ P⋆ Q⋆ (Properties.fact1'⋆ {_} {s1} {s2} {t1} {t2})
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ]⋆ : Nothing⋆ (Q⋆ [-◇⋆ sub ρ ]) -> Nothing⋆ (P⋆ [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ]⋆ = Properties.fact2⋆ (Q⋆ [-◇⋆ sub ρ ]) (P⋆ [-◇⋆ sub ρ ]) (Properties.fact5⋆ Q⋆ P⋆ (sub ρ) Q⇔P⋆)
-- -- -- -- -- -- --     No[Q◇ρ]⋆ : Nothing⋆ (Q⋆ [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ]⋆ = failure-propagation.second⋆ (sub ρ) (sub σ) (Unifies⋆ s1 t1) (Unifies s2 t2) a
-- -- -- -- -- -- --        (λ f → nounify f ∘ π₂ (Unifies s2 t2) (cong (f ◃_) ∘ sym ∘ SubList.fact1 σ ρ))

-- -- -- -- -- -- -- MaxFork : ∀ {m l n n1} (s1 s2 t1 t2 : Term m)
-- -- -- -- -- -- --                        (ρ : AList m l) (σ : AList l n) →
-- -- -- -- -- -- --                      Max⋆ (Unifies⋆ s1 t1 [-◇⋆ sub ρ ]) $ sub σ →
-- -- -- -- -- -- --                      (σ1 : AList n n1) →
-- -- -- -- -- -- --                      Max⋆ (Unifies⋆ s2 t2 [-◇⋆ sub (σ ++ ρ) ]) $ sub σ1 →
-- -- -- -- -- -- --                      Max⋆ (Unifies⋆ (s1 fork s2) (t1 fork t2) [-◇⋆ sub ρ ]) $ sub (σ1 ++ σ)
-- -- -- -- -- -- -- MaxFork s1 s2 t1 t2 ρ σ a σ1 b = Max[P∧Q◇ρ][σ1++σ]
-- -- -- -- -- -- --     where
-- -- -- -- -- -- --       P = Unifies s1 t1
-- -- -- -- -- -- --       Q = Unifies s2 t2
-- -- -- -- -- -- --       P∧Q = P ∧ Q
-- -- -- -- -- -- --       C = Unifies (s1 fork s2) (t1 fork t2)
-- -- -- -- -- -- --       Max[C◇ρ]⇔Max[P∧Q◇ρ] : Max (C [-◇ sub ρ ]) ⇔ Max (P∧Q [-◇ sub ρ ])
-- -- -- -- -- -- --       Max[C◇ρ]⇔Max[P∧Q◇ρ] = Max.fact (C [-◇ sub ρ ]) (P∧Q [-◇ sub ρ ]) (Properties.fact5 C P∧Q (sub ρ)
-- -- -- -- -- -- --                       (Properties.fact1' {_} {s1} {s2} {t1} {t2}))
-- -- -- -- -- -- --       Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] : Max (Q [-◇ sub (σ ++ ρ)]) ⇔ Max (Q [-◇ sub σ ◇ sub ρ ])
-- -- -- -- -- -- --       Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] = Max.fact (Q [-◇ sub (σ ++ ρ)]) (Q [-◇ sub σ ◇ sub ρ ]) (Properties.fact6 Q (SubList.fact1 σ ρ))
-- -- -- -- -- -- --       Max[P∧Q◇ρ][σ1++σ] : π₁ (Max (C [-◇ sub ρ ])) (sub (σ1 ++ σ))
-- -- -- -- -- -- --       Max[P∧Q◇ρ][σ1++σ] = π₂ (Max (C [-◇ sub ρ ])) (≐-sym (SubList.fact1 σ1 σ))
-- -- -- -- -- -- --                (proj₂ (Max[C◇ρ]⇔Max[P∧Q◇ρ] (sub σ1 ◇ sub σ))
-- -- -- -- -- -- --                       (optimist (sub ρ) (sub σ) (sub σ1) P Q (DClosed.fact1 s1 t1) a (proj₁ (Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] (sub σ1)) b)))

-- -- -- -- -- -- -- NothingVecHead : ∀ {m l} (t₁ t₂ : Term m) (ρ : AList m l) {N} (ts₁ ts₂ : Vec (Term m) N) →
-- -- -- -- -- -- --                Nothing⋆ $ Unifies⋆ t₁ t₂ [-◇⋆ sub ρ ] →
-- -- -- -- -- -- --                Nothing⋆ $ Unifies⋆V (t₁ ∷ ts₁) (t₂ ∷ ts₂) [-◇⋆ sub ρ ]
-- -- -- -- -- -- -- NothingVecHead t₁ t₂ ρ ts₁ ts₂ nounify = No[Q◇ρ]→No[P◇ρ] No[Q◇ρ]
-- -- -- -- -- -- --   where
-- -- -- -- -- -- --     P = Unifies⋆V (t₁ ∷ ts₁) (t₂ ∷ ts₂)
-- -- -- -- -- -- --     Q = (Unifies⋆ t₁ t₂ ∧⋆ Unifies⋆V ts₁ ts₂)
-- -- -- -- -- -- --     Q⇔P : Q ⇔⋆ P
-- -- -- -- -- -- --     Q⇔P = switch⋆ P Q (Properties.fact1'V {_} {t₁} {t₂} {_} {ts₁} {ts₂})
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ] : Nothing⋆ (Q [-◇⋆ sub ρ ]) -> Nothing⋆ (P [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ] = Properties.fact2⋆ (Q [-◇⋆ sub ρ ]) (P [-◇⋆ sub ρ ]) (Properties.fact5⋆ Q P (sub ρ) Q⇔P)
-- -- -- -- -- -- --     No[Q◇ρ] : Nothing⋆ (Q [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ] = failure-propagation.first⋆ (sub ρ) (Unifies⋆ t₁ t₂) (Unifies⋆V ts₁ ts₂) nounify

-- -- -- -- -- -- -- NothingVecTail : ∀ {m l n} (σ : AList l n)
-- -- -- -- -- -- --                   (t₁ t₂ : Term m)
-- -- -- -- -- -- --                   {N}
-- -- -- -- -- -- --                   (ts₁ ts₂ : Vec (Term m) N) →
-- -- -- -- -- -- --                   (ρ : AList m l) →
-- -- -- -- -- -- --                   Max⋆ (Unifies⋆ t₁ t₂ [-◇⋆ sub ρ ]) $ sub σ →
-- -- -- -- -- -- --                   Nothing⋆ $ Unifies⋆V ts₁ ts₂ [-◇⋆ sub (σ ++ ρ) ] →
-- -- -- -- -- -- --                   Nothing⋆ $ Unifies⋆V (t₁ ∷ ts₁) (t₂ ∷ ts₂) [-◇⋆ sub ρ ]
-- -- -- -- -- -- -- NothingVecTail σ t₁ t₂ ts₁ ts₂ ρ a nounify = No[Q◇ρ]→No[P◇ρ]⋆ No[Q◇ρ]⋆
-- -- -- -- -- -- --     where
-- -- -- -- -- -- --     P⋆ = Unifies⋆V (t₁ ∷ ts₁) (t₂ ∷ ts₂)
-- -- -- -- -- -- --     Q⋆ = (Unifies⋆ t₁ t₂ ∧⋆ Unifies⋆V ts₁ ts₂)
-- -- -- -- -- -- --     Q⇔P⋆ : Q⋆ ⇔⋆ P⋆
-- -- -- -- -- -- --     Q⇔P⋆ = switch⋆ P⋆ Q⋆ (Properties.fact1'V {_} {t₁} {t₂} {_} {ts₁} {ts₂})
-- -- -- -- -- -- -- --    Q⇔P⋆ = switch⋆ P⋆ Q⋆ (Properties.fact1'⋆ {_} {s1} {s2} {t1} {t2})
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ]⋆ : Nothing⋆ (Q⋆ [-◇⋆ sub ρ ]) -> Nothing⋆ (P⋆ [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ]→No[P◇ρ]⋆ = Properties.fact2⋆ (Q⋆ [-◇⋆ sub ρ ]) (P⋆ [-◇⋆ sub ρ ]) (Properties.fact5⋆ Q⋆ P⋆ (sub ρ) Q⇔P⋆)
-- -- -- -- -- -- --     No[Q◇ρ]⋆ : Nothing⋆ (Q⋆ [-◇⋆ sub ρ ])
-- -- -- -- -- -- --     No[Q◇ρ]⋆ = failure-propagation.second⋆ (sub ρ) (sub σ) (Unifies⋆ t₁ t₂) (UnifiesV ts₁ ts₂) a
-- -- -- -- -- -- --        (λ f → nounify f ∘ π₂ (UnifiesV ts₁ ts₂) (cong (f ◃_) ∘ sym ∘ SubList.fact1 σ ρ))

-- -- -- -- -- -- -- MaxVec : ∀ {m l n n1} (t₁ t₂ : Term m) {N} (ts₁ ts₂ : Vec (Term m) N)
-- -- -- -- -- -- --                        (ρ : AList m l) (σ : AList l n) →
-- -- -- -- -- -- --                      Max⋆ (Unifies⋆ t₁ t₂ [-◇⋆ sub ρ ]) $ sub σ →
-- -- -- -- -- -- --                      (σ1 : AList n n1) →
-- -- -- -- -- -- --                      Max⋆ (Unifies⋆V ts₁ ts₂ [-◇⋆ sub (σ ++ ρ) ]) $ sub σ1 →
-- -- -- -- -- -- --                      Max⋆ (Unifies⋆V (t₁ ∷ ts₁) (t₂ ∷ ts₂) [-◇⋆ sub ρ ]) $ sub (σ1 ++ σ)
-- -- -- -- -- -- -- MaxVec t₁ t₂ ts₁ ts₂ ρ σ a σ1 b = Max[P∧Q◇ρ][σ1++σ]
-- -- -- -- -- -- --     where
-- -- -- -- -- -- --       P = Unifies t₁ t₂
-- -- -- -- -- -- --       Q = UnifiesV ts₁ ts₂
-- -- -- -- -- -- --       P∧Q = P ∧ Q
-- -- -- -- -- -- --       C = UnifiesV (t₁ ∷ ts₁) (t₂ ∷ ts₂)
-- -- -- -- -- -- --       Max[C◇ρ]⇔Max[P∧Q◇ρ] : Max (C [-◇ sub ρ ]) ⇔ Max (P∧Q [-◇ sub ρ ])
-- -- -- -- -- -- --       Max[C◇ρ]⇔Max[P∧Q◇ρ] = Max.fact (C [-◇ sub ρ ]) (P∧Q [-◇ sub ρ ]) (Properties.fact5 C P∧Q (sub ρ)
-- -- -- -- -- -- --                       (Properties.fact1'V {_} {t₁} {t₂} {_} {ts₁} {ts₂}))
-- -- -- -- -- -- --       Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] : Max (Q [-◇ sub (σ ++ ρ)]) ⇔ Max (Q [-◇ sub σ ◇ sub ρ ])
-- -- -- -- -- -- --       Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] = Max.fact (Q [-◇ sub (σ ++ ρ)]) (Q [-◇ sub σ ◇ sub ρ ]) (Properties.fact6 Q (SubList.fact1 σ ρ))
-- -- -- -- -- -- --       Max[P∧Q◇ρ][σ1++σ] : π₁ (Max (C [-◇ sub ρ ])) (sub (σ1 ++ σ))
-- -- -- -- -- -- --       Max[P∧Q◇ρ][σ1++σ] = π₂ (Max (C [-◇ sub ρ ])) (≐-sym (SubList.fact1 σ1 σ))
-- -- -- -- -- -- --                (proj₂ (Max[C◇ρ]⇔Max[P∧Q◇ρ] (sub σ1 ◇ sub σ))
-- -- -- -- -- -- --                       (optimist (sub ρ) (sub σ) (sub σ1) P Q (DClosed.fact1 t₁ t₂) a (proj₁ (Max[Q◇σ++ρ]⇔Max[Q◇σ◇ρ] (sub σ1)) b)))

-- -- -- -- -- -- -- NothingFor→NothingComposition : ∀ {m l} (s t : Term (suc m)) (ρ : AList m l)
-- -- -- -- -- -- --              (r : Term m) (z : Fin (suc m)) →
-- -- -- -- -- -- --            Nothing⋆ (Unifies⋆ ((r for z) ◃ s) ((r for z) ◃ t) [-◇⋆ sub ρ ]) →
-- -- -- -- -- -- --            Nothing⋆ (Unifies⋆ s t [-◇⋆ sub (ρ asnoc r / z) ])
-- -- -- -- -- -- -- NothingFor→NothingComposition s t ρ r z nounify = NoQ→NoP nounify
-- -- -- -- -- -- --       where
-- -- -- -- -- -- --         P = Unifies s t [-◇ sub (ρ asnoc r / z) ]
-- -- -- -- -- -- --         Q = Unifies ((r for z) ◃ s) ((r for z) ◃ t) [-◇ sub ρ ]
-- -- -- -- -- -- --         NoQ→NoP : Nothing Q → Nothing P
-- -- -- -- -- -- --         NoQ→NoP = Properties.fact2 Q P (switch P Q (step-prop s t ρ r z))

-- -- -- -- -- -- -- MaxFor→MaxComposition : ∀ {m l n} (s t : Term (suc m)) (ρ : AList m l)
-- -- -- -- -- -- --               (r : Term m) (z : Fin (suc m)) (σ : AList l n) →
-- -- -- -- -- -- --             Max⋆ (Unifies⋆ ((r for z) ◃ s) ((r for z) ◃ t) [-◇⋆ sub ρ ]) $ sub σ →
-- -- -- -- -- -- --             Max⋆ (Unifies⋆ s t [-◇⋆ sub (ρ asnoc r / z) ]) $ sub σ
-- -- -- -- -- -- -- MaxFor→MaxComposition s t ρ r z σ a = proj₂ (MaxP⇔MaxQ (sub σ)) a
-- -- -- -- -- -- --       where
-- -- -- -- -- -- --         P = Unifies s t [-◇ sub (ρ asnoc r / z) ]
-- -- -- -- -- -- --         Q = Unifies ((r for z) ◃ s) ((r for z) ◃ t) [-◇ sub ρ ]
-- -- -- -- -- -- --         MaxP⇔MaxQ : Max P ⇔ Max Q
-- -- -- -- -- -- --         MaxP⇔MaxQ = Max.fact P Q (step-prop s t ρ r z)

-- -- -- -- -- -- -- module _ ⦃ isDecEquivalenceA : IsDecEquivalence (_≡_ {A = FunctionName}) ⦄ where

-- -- -- -- -- -- --   open IsDecEquivalence isDecEquivalenceA using () renaming (_≟_ to _≟F_)

-- -- -- -- -- -- --   mutual

-- -- -- -- -- -- --     instance ⋆amguTerm : ⋆amgu Term
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm leaf leaf acc = just acc
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm leaf (function _ _) acc = nothing
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm leaf (s' fork t') acc = nothing
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (s' fork t') leaf acc = nothing
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (s' fork t') (function _ _) acc = nothing
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (s1 fork s2) (t1 fork t2) acc =
-- -- -- -- -- -- --                       amgu s2 t2 =<< amgu s1 t1 acc
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (function fn₁ ts₁) leaf acc = nothing
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (function fn₁ {n₁} ts₁) (function fn₂ {n₂} ts₂) acc
-- -- -- -- -- -- --      with fn₁ ≟F fn₂
-- -- -- -- -- -- --     … | no _ = nothing
-- -- -- -- -- -- --     … | yes _ with n₁ ≟ n₂
-- -- -- -- -- -- --     … | no _ = nothing
-- -- -- -- -- -- --     … | yes refl = amgu ts₁ ts₂ acc
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (function fn₁ ts₁) (_ fork _) acc = nothing
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (i x) (i y) (m , anil) = just (flexFlex x y)
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm (i x) t     (m , anil) = flexRigid x t
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm t     (i x) (m , anil) = flexRigid x t
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguTerm s     t  (n , σ asnoc r / z) =
-- -- -- -- -- -- --              (λ σ -> σ ∃asnoc r / z) <$>
-- -- -- -- -- -- --                amgu ((r for z) ◃ s) ((r for z) ◃ t) (n , σ)

-- -- -- -- -- -- --     instance ⋆amguVecTerm : ∀ {N} → ⋆amgu (flip Vec N ∘ Term)
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguVecTerm [] [] acc = just acc
-- -- -- -- -- -- --     ⋆amgu.amgu ⋆amguVecTerm (t₁ ∷ t₁s) (t₂ ∷ t₂s) acc = amgu t₁s t₂s =<< amgu t₁ t₂ acc

-- -- -- -- -- -- --   mgu : ∀ {m} -> (s t : Term m) -> Maybe (∃ (AList m))
-- -- -- -- -- -- --   mgu {m} s t = amgu s t (m , anil)

-- -- -- -- -- -- --   mutual

-- -- -- -- -- -- --     -- We use a view so that we need to handle fewer cases in the main proof
-- -- -- -- -- -- --     data AmguT : {m : ℕ} -> (s t : Term m) -> ∃ (AList m) -> Maybe (∃ (AList m)) -> Set where
-- -- -- -- -- -- --       Flip : ∀ {m s t acc} -> amgu t s acc ≡ amgu s t acc ->
-- -- -- -- -- -- --         AmguT {m} t s acc (amgu t s acc) -> AmguT         s            t            acc        (amgu s t acc)
-- -- -- -- -- -- --       leaf-leaf : ∀ {m acc} ->             AmguT {m}     leaf         leaf         acc        (just acc)
-- -- -- -- -- -- --       fn-name   : ∀ {m fn₁ fn₂ N₁ N₂ acc} {ts₁ : Vec (Term m) N₁} {ts₂ : Vec (Term m) N₂} →
-- -- -- -- -- -- --                     fn₁ ≢ fn₂ →
-- -- -- -- -- -- --                                            AmguT {m}     (function fn₁ ts₁)
-- -- -- -- -- -- --                                                                      (function fn₂ ts₂)
-- -- -- -- -- -- --                                                                                acc        nothing
-- -- -- -- -- -- --       fn-size   : ∀ {m fn₁ fn₂ N₁ N₂ acc} {ts₁ : Vec (Term m) N₁} {ts₂ : Vec (Term m) N₂} →
-- -- -- -- -- -- --                     N₁ ≢ N₂ →
-- -- -- -- -- -- --                                            AmguT {m}     (function fn₁ ts₁)
-- -- -- -- -- -- --                                                                      (function fn₂ ts₂)
-- -- -- -- -- -- --                                                                                acc        nothing
-- -- -- -- -- -- --       fn-fn     : ∀ {m fn N acc} {ts₁ ts₂ : Vec (Term m) N} →
-- -- -- -- -- -- --                                            AmguT {m}     (function fn ts₁)
-- -- -- -- -- -- --                                                                      (function fn ts₂)
-- -- -- -- -- -- --                                                                                acc        (amgu ts₁ ts₂ acc)
-- -- -- -- -- -- --       leaf-fork : ∀ {m s t acc} ->         AmguT {m}     leaf         (s fork t)   acc        nothing
-- -- -- -- -- -- --       leaf-fn   : ∀ {m fn N} {ts : Vec (Term _) N} {acc} ->       AmguT {m}     leaf         (function fn ts)   acc        nothing
-- -- -- -- -- -- --       fork-fn   : ∀ {m s t fn N} {ts : Vec (Term _) N} {acc} ->   AmguT {m}     (s fork t)   (function fn ts)   acc        nothing
-- -- -- -- -- -- --       fork-fork : ∀ {m s1 s2 t1 t2 acc} -> AmguT {m}     (s1 fork s2) (t1 fork t2) acc        (amgu s2 t2 =<< amgu s1 t1 acc)
-- -- -- -- -- -- --       var-var   : ∀ {m x y} ->             AmguT         (i x)        (i y)        (m , anil) (just (flexFlex x y))
-- -- -- -- -- -- --       var-t : ∀ {m x t} -> i x ≢ t ->      AmguT         (i x)        t            (m , anil) (flexRigid x t)
-- -- -- -- -- -- --       s-t : ∀{m s t n σ r z} ->            AmguT {suc m} s            t            (n , σ asnoc r / z) ((λ σ -> σ ∃asnoc r / z) <$>
-- -- -- -- -- -- --                                                                                amgu ((r for z) ◃ s) ((r for z) ◃ t) (n , σ))

-- -- -- -- -- -- --     data AmguTV : {m : ℕ} -> ∀ {N} (ss ts : Vec (Term m) N) -> ∃ (AList m) -> Maybe (∃ (AList m)) -> Set where
-- -- -- -- -- -- --       fn0-fn0   : ∀ {m acc} →
-- -- -- -- -- -- --                                            AmguTV {m}     ([])
-- -- -- -- -- -- --                                                                      ([])
-- -- -- -- -- -- --                                                                                acc        (just acc)

-- -- -- -- -- -- --       fns-fns   : ∀ {m N acc} {t₁ t₂ : Term m} {ts₁ ts₂ : Vec (Term m) N} →
-- -- -- -- -- -- --                                            AmguTV {m}     ((t₁ ∷ ts₁))
-- -- -- -- -- -- --                                                                      ((t₂ ∷ ts₂))
-- -- -- -- -- -- --                                                                                acc        (amgu ts₁ ts₂ =<< amgu t₁ t₂ acc)

-- -- -- -- -- -- --   view : ∀ {m : ℕ} -> (s t : Term m) -> (acc : ∃ (AList m)) -> AmguT s t acc (amgu s t acc)
-- -- -- -- -- -- --   view leaf         leaf         acc        = leaf-leaf
-- -- -- -- -- -- --   view leaf         (s fork t)   acc        = leaf-fork
-- -- -- -- -- -- --   view (s fork t)   leaf         acc        = Flip refl leaf-fork
-- -- -- -- -- -- --   view (s1 fork s2) (t1 fork t2) acc        = fork-fork
-- -- -- -- -- -- --   view (function fn₁ {n₁} ts₁) (function fn₂ {n₂} ts₂) acc  with
-- -- -- -- -- -- --    fn₁ ≟F fn₂
-- -- -- -- -- -- --   … | no neq = fn-name neq
-- -- -- -- -- -- --   … | yes refl with n₁ ≟ n₂
-- -- -- -- -- -- --   … | yes refl = fn-fn
-- -- -- -- -- -- --   … | no neq = fn-size neq
-- -- -- -- -- -- --   view leaf         (function fn ts) acc    = leaf-fn
-- -- -- -- -- -- --   view (function fn ts) leaf         acc    = Flip refl leaf-fn
-- -- -- -- -- -- --   view (function fn ts) (_ fork _)   acc    = Flip refl fork-fn
-- -- -- -- -- -- --   view (s fork t)   (function fn ts) acc    = fork-fn
-- -- -- -- -- -- --   view (i x)        (i y)        (m , anil) = var-var
-- -- -- -- -- -- --   view (i x)        leaf         (m , anil) = var-t (λ ())
-- -- -- -- -- -- --   view (i x)        (s fork t)   (m , anil) = var-t (λ ())
-- -- -- -- -- -- --   view (i x)        (function fn ts)   (m , anil) = var-t (λ ())
-- -- -- -- -- -- --   view leaf         (i x)        (m , anil) = Flip refl (var-t (λ ()))
-- -- -- -- -- -- --   view (s fork t)   (i x)        (m , anil) = Flip refl (var-t (λ ()))
-- -- -- -- -- -- --   view (function fn ts) (i x)    (m , anil) = Flip refl (var-t (λ ()))
-- -- -- -- -- -- --   view (i x)        (i x')       (n , σ asnoc r / z) = s-t
-- -- -- -- -- -- --   view (i x)        leaf         (n , σ asnoc r / z) = s-t
-- -- -- -- -- -- --   view (i x)        (s fork t)   (n , σ asnoc r / z) = s-t
-- -- -- -- -- -- --   view leaf         (i x)        (n , σ asnoc r / z) = s-t
-- -- -- -- -- -- --   view (s fork t)   (i x)        (n , σ asnoc r / z) = s-t
-- -- -- -- -- -- --   view (function fn ts)   (i x)        (n , σ asnoc r / z) = s-t
-- -- -- -- -- -- --   view (i x) (function fn ts)          (n , σ asnoc r / z) = s-t

-- -- -- -- -- -- --   viewV : ∀ {m : ℕ} {N} -> (ss ts : Vec (Term m) N) -> (acc : ∃ (AList m)) -> AmguTV ss ts acc (amgu ss ts acc)
-- -- -- -- -- -- --   viewV []         []         acc        = fn0-fn0
-- -- -- -- -- -- --   viewV (t ∷ ts₁) (t₂ ∷ ts₂) acc         = fns-fns

-- -- -- -- -- -- --   amgu-Correctness : {m : ℕ} -> (s t : Term m) -> ∃ (AList m) -> Set
-- -- -- -- -- -- --   amgu-Correctness s t (l , ρ) =
-- -- -- -- -- -- --       (∃ λ n → ∃ λ σ → π₁ (Max (Unifies s t [-◇ sub ρ ])) (sub σ) × amgu s t (l , ρ) ≡ just (n , σ ++ ρ ))
-- -- -- -- -- -- --     ⊎ (Nothing ((Unifies s t) [-◇ sub ρ ]) ×  amgu s t (l , ρ) ≡ nothing)

-- -- -- -- -- -- --   amgu-Correctness⋆ : {m : ℕ} -> (s t : Term m) -> ∃ (AList m) -> Set
-- -- -- -- -- -- --   amgu-Correctness⋆ s t (l , ρ) =
-- -- -- -- -- -- --       (∃ λ n → ∃ λ σ → π₁ (Max (Unifies s t [-◇ sub ρ ])) (sub σ) × amgu s t (l , ρ) ≡ just (n , σ ++ ρ ))
-- -- -- -- -- -- --     ⊎ (Nothing ((Unifies s t) [-◇ sub ρ ]) ×  amgu s t (l , ρ) ≡ nothing)

-- -- -- -- -- -- --   amgu-Ccomm : ∀ {m} s t acc -> amgu {m = m} s t acc ≡ amgu t s acc -> amgu-Correctness s t acc -> amgu-Correctness t s acc
-- -- -- -- -- -- --   amgu-Ccomm s t (l , ρ) st≡ts = lemma
-- -- -- -- -- -- --     where
-- -- -- -- -- -- --       Unst = (Unifies s t) [-◇ sub ρ ]
-- -- -- -- -- -- --       Unts = (Unifies t s) [-◇ sub ρ ]

-- -- -- -- -- -- --       Unst⇔Unts : ((Unifies s t) [-◇ sub ρ ]) ⇔ ((Unifies t s) [-◇ sub ρ ])
-- -- -- -- -- -- --       Unst⇔Unts = Properties.fact5 (Unifies s t) (Unifies t s) (sub ρ) (Properties.fact1 {_} {s} {t})

-- -- -- -- -- -- --       lemma : amgu-Correctness s t (l , ρ) -> amgu-Correctness t s (l , ρ)
-- -- -- -- -- -- --       lemma (inj₁ (n , σ , MaxUnst , amgu≡just)) =
-- -- -- -- -- -- --         inj₁ (n , σ , proj₁ (Max.fact Unst Unts Unst⇔Unts (sub σ)) MaxUnst , trans (sym st≡ts) amgu≡just)
-- -- -- -- -- -- --       lemma (inj₂ (NoUnst , amgu≡nothing)) =
-- -- -- -- -- -- --         inj₂ ((λ {_} → Properties.fact2 Unst Unts Unst⇔Unts NoUnst) , trans (sym st≡ts) amgu≡nothing)

-- -- -- -- -- -- --   amgu-Ccomm⋆ : ∀ {m} s t acc -> amgu {m = m} s t acc ≡ amgu t s acc -> amgu-Correctness⋆ s t acc -> amgu-Correctness⋆ t s acc
-- -- -- -- -- -- --   amgu-Ccomm⋆ s t (l , ρ) st≡ts = lemma
-- -- -- -- -- -- --     where
-- -- -- -- -- -- --       Unst = (Unifies s t) [-◇ sub ρ ]
-- -- -- -- -- -- --       Unts = (Unifies t s) [-◇ sub ρ ]

-- -- -- -- -- -- --       Unst⇔Unts : ((Unifies s t) [-◇ sub ρ ]) ⇔ ((Unifies t s) [-◇ sub ρ ])
-- -- -- -- -- -- --       Unst⇔Unts = Properties.fact5 (Unifies s t) (Unifies t s) (sub ρ) (Properties.fact1 {_} {s} {t})

-- -- -- -- -- -- --       lemma : amgu-Correctness s t (l , ρ) -> amgu-Correctness t s (l , ρ)
-- -- -- -- -- -- --       lemma (inj₁ (n , σ , MaxUnst , amgu≡just)) =
-- -- -- -- -- -- --         inj₁ (n , σ , proj₁ (Max.fact Unst Unts Unst⇔Unts (sub σ)) MaxUnst , trans (sym st≡ts) amgu≡just)
-- -- -- -- -- -- --       lemma (inj₂ (NoUnst , amgu≡nothing)) =
-- -- -- -- -- -- --         inj₂ ((λ {_} → Properties.fact2 Unst Unts Unst⇔Unts NoUnst) , trans (sym st≡ts) amgu≡nothing)

-- -- -- -- -- -- --   mutual

-- -- -- -- -- -- --     amguV-c : ∀ {m N} {ss ts : Vec (Term m) N} {l ρ} -> AmguTV ss ts (l , ρ) (amgu ss ts (l , ρ)) ->
-- -- -- -- -- -- --                 (∃ λ n → ∃ λ σ → Max⋆ (Unifies⋆V ss ts [-◇⋆ sub ρ ]) (sub σ) × amgu {m = m} ss ts (l , ρ) ≡ just (n , σ ++ ρ ))
-- -- -- -- -- -- --               ⊎ (Nothing⋆ (Unifies⋆V ss ts [-◇⋆ sub ρ ])                     × amgu {m = m} ss ts (l , ρ) ≡ nothing)
-- -- -- -- -- -- --     amguV-c {m} {N} {ss} {ts} {l} {ρ} amg with amgu ss ts (l , ρ)
-- -- -- -- -- -- --     amguV-c {m} {0} {.[]} {.[]} {l} {ρ} fn0-fn0 | .(just (l , ρ)) = inj₁ (_ , anil , trivial-problemV {_} {_} {_} {[]} {sub ρ} , cong (just ∘ _,_ l) (sym (SubList.anil-id-l ρ)))
-- -- -- -- -- -- --     amguV-c {m} {.(suc _)} {(t₁ ∷ ts₁)} {(t₂ ∷ ts₂)} {l} {ρ} fns-fns | _  with amgu t₁ t₂ (l , ρ)  | amgu-c $ view t₁ t₂ (l , ρ)
-- -- -- -- -- -- --     amguV-c {m} {.(suc _)} {(t₁ ∷ ts₁)} {(t₂ ∷ ts₂)} {l} {ρ} fns-fns | _ | am | inj₂ (nounify , refl) = inj₂ ((λ {_} → NothingVecHead t₁ t₂ ρ _ _ nounify) , refl)
-- -- -- -- -- -- --     amguV-c {m} {.(suc _)} {(t₁ ∷ ts₁)} {(t₂ ∷ ts₂)} {l} {ρ} fns-fns | _ | am | inj₁ (n , σ , a , refl)
-- -- -- -- -- -- --      with amgu ts₁ ts₂ (n , σ ++ ρ) | amguV-c (viewV (ts₁) (ts₂) (n , (σ ++ ρ)))
-- -- -- -- -- -- --     … | _ | inj₂ (nounify , refl) = inj₂ ((λ {_} → NothingVecTail σ t₁ t₂ _ _ ρ a nounify) , refl)
-- -- -- -- -- -- --     … | _ | inj₁ (n1 , σ1 , a1 , refl) = inj₁ (n1 , σ1 ++ σ , MaxVec t₁ t₂ _ _ ρ σ a σ1 a1 , cong (λ σ -> just (n1 , σ)) (++-assoc σ1 σ ρ))

-- -- -- -- -- -- --     amgu-c : ∀ {m s t l ρ} -> AmguT s t (l , ρ) (amgu s t (l , ρ)) ->
-- -- -- -- -- -- --                (∃ λ n → ∃ λ σ → Max⋆ (Unifies⋆ s t [-◇⋆ sub ρ ]) (sub σ) × amgu {m = m} s t (l , ρ) ≡ just (n , σ ++ ρ ))
-- -- -- -- -- -- --              ⊎ (Nothing⋆ (Unifies⋆ s t [-◇⋆ sub ρ ])                     × amgu {m = m} s t (l , ρ) ≡ nothing)
-- -- -- -- -- -- --     amgu-c {m} {s} {t} {l} {ρ} amg with amgu s t (l , ρ)
-- -- -- -- -- -- --     amgu-c {l = l} {ρ} leaf-leaf | ._
-- -- -- -- -- -- --       = inj₁ (l , anil , trivial-problem {_} {_} {leaf} {sub ρ} , cong (λ x -> just (l , x)) (sym (SubList.anil-id-l ρ)) )
-- -- -- -- -- -- --     amgu-c (fn-name neq) | _ = inj₂ ((λ f x → neq (Term-function-inj-FunctionName x)) , refl)
-- -- -- -- -- -- --     amgu-c (fn-size neq) | _ = inj₂ ((λ f x → neq (Term-function-inj-VecSize x)) , refl)
-- -- -- -- -- -- --     amgu-c {s = function fn ts₁} {t = function .fn ts₂} {l = l} {ρ = ρ} fn-fn | _ with amgu ts₁ ts₂ | amguV-c (viewV ts₁ ts₂ (l , ρ))
-- -- -- -- -- -- --     … | _ | inj₂ (nounify , refl!) rewrite refl! = inj₂ ((λ {_} f feq → nounify f (Term-function-inj-Vector feq)) , refl)
-- -- -- -- -- -- --     … | _ | inj₁ (n , σ , (b , c) , refl!) rewrite refl! = inj₁ (_ , _ , ((cong (function fn) b) , (λ {_} f' feq → c f' (Term-function-inj-Vector feq))) , refl )
-- -- -- -- -- -- --     amgu-c leaf-fork | .nothing = inj₂ ((λ _ () ) , refl)
-- -- -- -- -- -- --     amgu-c leaf-fn | _ = inj₂ ((λ _ () ) , refl)
-- -- -- -- -- -- --     amgu-c fork-fn | _ = inj₂ ((λ _ () ) , refl)
-- -- -- -- -- -- --     amgu-c {m} {s1 fork s2} {t1 fork t2} {l} {ρ} fork-fork | ._
-- -- -- -- -- -- --      with amgu s1 t1 (l , ρ)  | amgu-c $ view s1 t1 (l , ρ)
-- -- -- -- -- -- --     … | .nothing             | inj₂ (nounify , refl) = inj₂ ((λ {_} -> NothingForkLeft s1 t1 ρ s2 t2 nounify) , refl)
-- -- -- -- -- -- --     … | .(just (n , σ ++ ρ)) | inj₁ (n , σ , a , refl)
-- -- -- -- -- -- --      with amgu s2 t2 (n , σ ++ ρ) | amgu-c (view s2 t2 (n , (σ ++ ρ)))
-- -- -- -- -- -- --     … | .nothing                | inj₂ (nounify , refl) = inj₂ ( (λ {_} -> NothingForkRight σ s1 s2 t1 t2 ρ a nounify) , refl)
-- -- -- -- -- -- --     … | .(just (n1 , σ1 ++ (σ ++ ρ))) | inj₁ (n1 , σ1 , b , refl)
-- -- -- -- -- -- --         = inj₁ (n1 , σ1 ++ σ , MaxFork s1 s2 t1 t2 ρ σ a σ1 b , cong (λ σ -> just (n1 , σ)) (++-assoc σ1 σ ρ))
-- -- -- -- -- -- --     amgu-c {suc l} {i x} {i y} (var-var) | .(just (flexFlex x y))
-- -- -- -- -- -- --      with thick? x y | Thick.fact1 x y (thick? x y) refl
-- -- -- -- -- -- --     …  | .(just y') | inj₂ (y' , thinxy'≡y , refl )
-- -- -- -- -- -- --       = inj₁ (l , anil asnoc i y' / x , var-elim-i-≡ x (i y) (sym (cong i thinxy'≡y)) , refl )
-- -- -- -- -- -- --     …  | .nothing | inj₁ ( x≡y , refl ) rewrite sym x≡y
-- -- -- -- -- -- --       = inj₁ (suc l , anil , trivial-problem {_} {_} {i x} {sub anil} , refl)
-- -- -- -- -- -- --     amgu-c {suc l} {i x} {t} (var-t ix≢t) | .(flexRigid x t)
-- -- -- -- -- -- --      with check x t | check-prop x t
-- -- -- -- -- -- --     … | .nothing  | inj₂ ( ps , r , refl) = inj₂ ( (λ {_} -> NothingStep x t ix≢t ps r )  , refl)
-- -- -- -- -- -- --     … | .(just t') | inj₁ (t' , r , refl) = inj₁ ( l , anil asnoc t' / x , var-elim-i-≡ x t r , refl )
-- -- -- -- -- -- --     amgu-c {suc m} {s} {t} {l} {ρ asnoc r / z} s-t
-- -- -- -- -- -- --       | .((λ x' → x' ∃asnoc r / z) <$>
-- -- -- -- -- -- --           (amgu ((r for z) ◃ s) ((r for z) ◃ t) (l , ρ)))
-- -- -- -- -- -- --      with amgu-c (view ((r for z) ◃ s) ((r for z) ◃ t) (l , ρ))
-- -- -- -- -- -- --     … | inj₂ (nounify , ra) = inj₂ ( (λ {_} -> NothingFor→NothingComposition s t ρ r z nounify) , cong (_<$>_ (λ x' → x' ∃asnoc r / z)) ra )
-- -- -- -- -- -- --     … | inj₁ (n , σ , a , ra)  = inj₁ (n , σ , MaxFor→MaxComposition s t ρ r z σ a , cong (_<$>_ (λ x' → x' ∃asnoc r / z)) ra)
-- -- -- -- -- -- --     amgu-c {m} {s} {t} {l} {ρ} (Flip amguts≡amgust amguts) | ._ = amgu-Ccomm⋆ t s (l , ρ) amguts≡amgust (amgu-c amguts)
-- -- -- -- -- -- --     amgu-c {zero} {i ()} _ | _

-- -- -- -- -- -- --   mgu-c : ∀ {m} (s t : Term m) ->
-- -- -- -- -- -- --              (∃ λ n → ∃ λ σ → (Max⋆ (Unifies⋆ s t)) (sub σ) × mgu s t ≡ just (n , σ))
-- -- -- -- -- -- --            ⊎ (Nothing⋆ (Unifies⋆ s t)                       × mgu s t ≡ nothing)
-- -- -- -- -- -- --   mgu-c {m} s t = amgu-c (view s t (m , anil))

-- -- -- -- -- -- --   unify : ∀ {m} (s t : Term m) ->
-- -- -- -- -- -- --              (∃ λ n → ∃ λ (σ : AList m n) → Max⋆ (Unifies⋆ s t) $ sub σ)
-- -- -- -- -- -- --              ⊎ Nothing⋆ (Unifies⋆ s t)
-- -- -- -- -- -- --   unify {m} s t with amgu-c (view s t (m , anil))
-- -- -- -- -- -- --   unify {m} s₁ t | inj₁ (proj₃ , proj₄ , proj₅ , proj₆) = inj₁ (proj₃ , proj₄ , proj₅)
-- -- -- -- -- -- --   unify {m} s t | inj₂ (proj₃ , _) = inj₂ proj₃

-- -- -- -- -- -- --   unifyV : ∀ {m N} (s t : Vec (Term m) N) ->
-- -- -- -- -- -- --              (∃ λ n → ∃ λ (σ : AList m n) → Max⋆ (Unifies⋆V s t) $ sub σ)
-- -- -- -- -- -- --              ⊎ Nothing⋆ (Unifies⋆V s t)
-- -- -- -- -- -- --   unifyV {m} {N} s t with amguV-c (viewV s t (m , anil))
-- -- -- -- -- -- --   … | inj₁ (proj₃ , proj₄ , proj₅ , proj₆) = inj₁ (proj₃ , proj₄ , proj₅)
-- -- -- -- -- -- --   … | inj₂ (proj₃ , _) = inj₂ proj₃

-- -- -- -- -- -- --   open import Oscar.Data.Permutation

-- -- -- -- -- -- --   unifyWith : ∀ {m N} (p q : Term m) (X Y : Vec (Term m) N) →
-- -- -- -- -- -- --               (∃ λ X* → X* ≡ordering' X × ∃ λ n → ∃ λ (σ : AList m n) → Max⋆ (Unifies⋆V (p ∷ X*) (q ∷ Y)) $ sub σ)
-- -- -- -- -- -- --               ⊎
-- -- -- -- -- -- --               (∀ X* → X* ≡ordering' X → Nothing⋆ (Unifies⋆V (p ∷ X*) (q ∷ Y)))
-- -- -- -- -- -- --   unifyWith p q X Y = {!!}


{-# OPTIONS --type-in-type #-}
module functors where
open import prelude

record Category {O : Set} (𝒞[_,_] : O → O → Set) : Set where
  constructor 𝒾:_▸:_𝒾▸:_▸𝒾:
  infixl 8 _▸_
  field
    𝒾 : ∀ {x} → 𝒞[ x , x ]
    _▸_ : ∀ {x y z} → 𝒞[ x , y ] → 𝒞[ y , z ] → 𝒞[ x , z ]
    𝒾▸ : ∀ {x y} (f : 𝒞[ x , y ]) → (𝒾 ▸ f) ≡ f
    ▸𝒾 : ∀ {x y} (f : 𝒞[ x , y ]) → (f ▸ 𝒾) ≡ f
open Category ⦃...⦄ public

record Functor {A : Set} {𝒜[_,_] : A → A → Set}
               {B : Set} {ℬ[_,_] : B → B → Set}
               (f : A → B) : Set where
  constructor φ:_𝒾:_▸:
  field
    ⦃ cat₁ ⦄ : Category {A} 𝒜[_,_]
    ⦃ cat₂ ⦄ : Category {B} ℬ[_,_]
    φ : ∀ {a b} → 𝒜[ a , b ] → ℬ[ f a , f b ]
    functor-id : ∀ {a} → φ {a} 𝒾 ≡ 𝒾
    functor-comp : ∀ {A B C} → (f : 𝒜[ A , B ]) (g : 𝒜[ B , C ])
                 → φ (f ▸ g) ≡ φ f ▸ φ g
open Functor ⦃...⦄ public

record Nat {A : Set} {𝒜[_,_] : A → A → Set}
           {B : Set} {ℬ[_,_] : B → B → Set}
           {F : A → B} {G : A → B}
           (α : (x : A) → ℬ[ F x , G x ]) : Set where
  field
    overlap ⦃ fun₁ ⦄ : Functor {A} {𝒜[_,_]} {B} {ℬ[_,_]} F
    overlap ⦃ fun₂ ⦄ : Functor {A} {𝒜[_,_]} {B} {ℬ[_,_]} G
    nat : ∀ {x y : A} (f : 𝒜[ x , y ]) → let _▹_ = _▸_ ⦃ cat₂ ⦄
                                          in φ f ▹ α y ≡ α x ▹ φ f

module _ {A : Set} {𝒜[_,_] : A → A → Set}  where
    instance
        id-functor : ⦃ Category 𝒜[_,_] ⦄ → Functor id
        id-functor = φ: id
                     𝒾: refl
                     ▸: λ f g → refl
    record Monad (f : A → A) : Set where
      field
        ⦃ functor ⦄ : Functor {_} {𝒜[_,_]} {_} {𝒜[_,_]} f
        η : ∀ {a} → 𝒜[ a , f a ]
        μ : ∀ {a} → 𝒜[ f (f a) , f a ]
    open Monad ⦃...⦄ public

{-
    record Lift[_⇒_] (pre post : (Set → Set) → Set) (t : (Set → Set) → Set → Set) : Set where
      field
        ⦃ lifted ⦄ : ∀ {f} → post (t f)
        lift : {f : Set → Set} {a : Set} → ⦃ pre f ⦄ → f a → t f a
    open Lift[_⇒_] ⦃...⦄ public
-}

Cat[_,_] : Set → Set → Set
Cat[ a , b ] = a → b

instance
  Cat-cat : Category Cat[_,_]
  Cat-cat = record { 𝒾 = id ; _▸_ = λ f g → g ∘ f ; 𝒾▸ = λ _ → refl; ▸𝒾 = λ _ → refl}
instance
  ≡-cat : ∀ {A} → Category {A} (λ a b → a ≡ b)
  𝒾 {{≡-cat}} = refl
  _▸_ {{≡-cat}} = trans
  𝒾▸ {{≡-cat}} _ = refl
  ▸𝒾 {{≡-cat}} x≡y rewrite x≡y = refl
instance
    ×-cat : ∀ {A 𝒜[_,_]} ⦃ 𝒜 : Category {A} 𝒜[_,_] ⦄
              {B ℬ[_,_]} ⦃ ℬ : Category {B} ℬ[_,_] ⦄
          → Category {A × B} (λ (a , b) (a′ , b′) → 𝒜[ a , a′ ] × ℬ[ b , b′ ])
    𝒾 {{×-cat}} = 𝒾 , 𝒾
    _▸_ {{×-cat}} (f , f′ ) ( g , g′ ) = f ▸ g , f′ ▸ g′
    𝒾▸ {{×-cat}} (f , g) = 𝒾▸ f ×⁼ 𝒾▸ g
    ▸𝒾 {{×-cat}} (f , g) = ▸𝒾 f ×⁼ ▸𝒾 g

data _ᵒᵖ {A : Set} (𝒜 : A → A → Set) : A → A → Set where
  _ᵗ : ∀ {y x} → 𝒜(y )( x) → (𝒜 ᵒᵖ)(x )( y)

instance
    op-cat  : {A : Set} {𝒜[_,_] : A → A → Set} ⦃ 𝒜 : Category {A} 𝒜[_,_] ⦄
            → Category (𝒜[_,_] ᵒᵖ)
    𝒾 {{op-cat}}  = 𝒾 ᵗ
    _▸_ {{op-cat}} (f ᵗ) (g ᵗ) = (g ▸ f) ᵗ
    𝒾▸ {{op-cat}} (f ᵗ) = _ᵗ ⟨$⟩ ▸𝒾 f
    ▸𝒾 {{op-cat}} (f ᵗ) = _ᵗ ⟨$⟩ 𝒾▸ f


{-

Defines different notions of morphisms and properties of morphisms of
groups:

- GroupHom (homomorphisms)
- GroupEquiv (equivs which are homomorphisms)
- GroupIso (isos which are homomorphisms)
- Image
- Kernel
- Surjective
- Injective
- Mono
- BijectionIso (surjective + injective)

-}
{-# OPTIONS --safe #-}
module Cubical.Algebra.Group.Morphisms where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Structure

open import Cubical.Algebra.Group.Base
open import Cubical.Algebra.Group.DirProd
open import Cubical.Data.Sigma

open import Cubical.Reflection.RecordEquiv

private
  variable
    ℓ ℓ' ℓ'' ℓ''' : Level

record IsGroupHom {A : Type ℓ} {B : Type ℓ'}
  (M : GroupStr A) (f : A → B) (N : GroupStr B)
  : Type (ℓ-max ℓ ℓ')
  where

  -- Shorter qualified names
  private
    module M = GroupStr M
    module N = GroupStr N

  field
    pres· : (x y : A) → f (x M.· y) ≡ f x N.· f y
    pres1 : f M.1g ≡ N.1g
    presinv : (x : A) → f (M.inv x) ≡ N.inv (f x)

unquoteDecl IsGroupHomIsoΣ = declareRecordIsoΣ IsGroupHomIsoΣ (quote IsGroupHom)

GroupHom : (G : Group ℓ) (H : Group ℓ') → Type (ℓ-max ℓ ℓ')
GroupHom G H = Σ[ f ∈ (G .fst → H .fst) ] IsGroupHom (G .snd) f (H .snd)

GroupIso : (G : Group ℓ) (H : Group ℓ') → Type (ℓ-max ℓ ℓ')
GroupIso G H = Σ[ e ∈ Iso (G .fst) (H .fst) ] IsGroupHom (G .snd) (e .Iso.fun) (H .snd)

IsGroupEquiv : {A : Type ℓ} {B : Type ℓ'}
  (M : GroupStr A) (e : A ≃ B) (N : GroupStr B) → Type (ℓ-max ℓ ℓ')
IsGroupEquiv M e N = IsGroupHom M (e .fst) N

GroupEquiv : (G : Group ℓ) (H : Group ℓ') → Type (ℓ-max ℓ ℓ')
GroupEquiv G H = Σ[ e ∈ (G .fst ≃ H .fst) ] IsGroupEquiv (G .snd) e (H .snd)

groupEquivFun : {G : Group ℓ} {H : Group ℓ'} → GroupEquiv G H → G .fst → H .fst
groupEquivFun e = e .fst .fst

-- Image, kernel, surjective, injective, and bijections

open IsGroupHom
open GroupStr

private
  variable
    G H : Group ℓ

isInIm : GroupHom G H → ⟨ H ⟩ → Type _
isInIm {G = G} ϕ h = ∃[ g ∈ ⟨ G ⟩ ] ϕ .fst g ≡ h

isInKer : GroupHom G H → ⟨ G ⟩ → Type _
isInKer {H = H} ϕ g = ϕ .fst g ≡ 1g (snd H)

Ker : GroupHom G H → Type _
Ker {G = G} ϕ = Σ[ x ∈ ⟨ G ⟩ ] isInKer ϕ x

Im : GroupHom G H → Type _
Im {H = H} ϕ = Σ[ x ∈ ⟨ H ⟩ ] isInIm ϕ x

isSurjective : GroupHom G H → Type _
isSurjective {H = H} ϕ = (x : ⟨ H ⟩) → isInIm ϕ x

isInjective : GroupHom G H → Type _
isInjective {G = G} ϕ = (x : ⟨ G ⟩) → isInKer ϕ x → x ≡ 1g (snd G)

isMono : GroupHom G H → Type _
isMono {G = G} f = {x y : ⟨ G ⟩} → f .fst x ≡ f .fst y → x ≡ y

-- Group bijections
record BijectionIso (G : Group ℓ) (H : Group ℓ') : Type (ℓ-max ℓ ℓ') where

  constructor bijIso

  field
    fun : GroupHom G H
    inj : isInjective fun
    surj : isSurjective fun


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

module 18-circle where

import 17-groups
open 17-groups public

{- Section 11.1 The induction principle of the circle -}

free-loops :
  { l1 : Level} (X : UU l1) → UU l1
free-loops X = Σ X (λ x → Id x x)

base-free-loop :
  { l1 : Level} {X : UU l1} → free-loops X → X
base-free-loop = pr1

loop-free-loop :
  { l1 : Level} {X : UU l1} (l : free-loops X) →
  Id (base-free-loop l) (base-free-loop l)
loop-free-loop = pr2

-- Now we characterize the identity types of free loops

Eq-free-loops :
  { l1 : Level} {X : UU l1} (l l' : free-loops X) → UU l1
Eq-free-loops (pair x l) l' =
  Σ (Id x (pr1 l')) (λ p → Id (l ∙ p) (p ∙ (pr2 l')))

reflexive-Eq-free-loops :
  { l1 : Level} {X : UU l1} (l : free-loops X) → Eq-free-loops l l
reflexive-Eq-free-loops (pair x l) = pair refl right-unit

Eq-free-loops-eq :
  { l1 : Level} {X : UU l1} (l l' : free-loops X) →
  Id l l' → Eq-free-loops l l'
Eq-free-loops-eq l .l refl = reflexive-Eq-free-loops l

abstract
  is-contr-total-Eq-free-loops :
    { l1 : Level} {X : UU l1} (l : free-loops X) →
    is-contr (Σ (free-loops X) (Eq-free-loops l))
  is-contr-total-Eq-free-loops (pair x l) =
    is-contr-total-Eq-structure
      ( λ x l' p → Id (l ∙ p) (p ∙ l'))
      ( is-contr-total-path x)
      ( pair x refl)
      ( is-contr-is-equiv'
        ( Σ (Id x x) (λ l' → Id l l'))
        ( tot (λ l' α → right-unit ∙ α))
        ( is-equiv-tot-is-fiberwise-equiv
          ( λ l' → is-equiv-concat right-unit l'))
        ( is-contr-total-path l))

abstract
  is-equiv-Eq-free-loops-eq :
    { l1 : Level} {X : UU l1} (l l' : free-loops X) →
    is-equiv (Eq-free-loops-eq l l')
  is-equiv-Eq-free-loops-eq l =
    fundamental-theorem-id l
      ( reflexive-Eq-free-loops l)
      ( is-contr-total-Eq-free-loops l)
      ( Eq-free-loops-eq l)

{- We introduce dependent free loops, which are used in the induction principle
   of the circle. -}

dependent-free-loops :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2) → UU l2
dependent-free-loops l P =
  Σ ( P (base-free-loop l))
    ( λ p₀ → Id (tr P (loop-free-loop l) p₀) p₀)

Eq-dependent-free-loops :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2) →
  ( p p' : dependent-free-loops l P) → UU l2
Eq-dependent-free-loops (pair x l) P (pair y p) p' =
  Σ ( Id y (pr1 p'))
    ( λ q → Id (p ∙ q) ((ap (tr P l) q) ∙ (pr2 p')))

reflexive-Eq-dependent-free-loops :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2) →
  ( p : dependent-free-loops l P) → Eq-dependent-free-loops l P p p
reflexive-Eq-dependent-free-loops (pair x l) P (pair y p) =
  pair refl right-unit

Eq-dependent-free-loops-eq :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2) →
  ( p p' : dependent-free-loops l P) →
  Id p p' → Eq-dependent-free-loops l P p p'
Eq-dependent-free-loops-eq l P p .p refl =
  reflexive-Eq-dependent-free-loops l P p

abstract
  is-contr-total-Eq-dependent-free-loops :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2) →
    ( p : dependent-free-loops l P) →
    is-contr (Σ (dependent-free-loops l P) (Eq-dependent-free-loops l P p))
  is-contr-total-Eq-dependent-free-loops (pair x l) P (pair y p) =
    is-contr-total-Eq-structure
      ( λ y' p' q → Id (p ∙ q) ((ap (tr P l) q) ∙ p'))
      ( is-contr-total-path y)
      ( pair y refl)
      ( is-contr-is-equiv'
        ( Σ (Id (tr P l y) y) (λ p' → Id p p'))
        ( tot (λ p' α → right-unit ∙ α))
        ( is-equiv-tot-is-fiberwise-equiv
          ( λ p' → is-equiv-concat right-unit p'))
        ( is-contr-total-path p))

abstract
  is-equiv-Eq-dependent-free-loops-eq :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2)
    ( p p' : dependent-free-loops l P) →
    is-equiv (Eq-dependent-free-loops-eq l P p p')
  is-equiv-Eq-dependent-free-loops-eq l P p =
    fundamental-theorem-id p
      ( reflexive-Eq-dependent-free-loops l P p)
      ( is-contr-total-Eq-dependent-free-loops l P p)
      ( Eq-dependent-free-loops-eq l P p)

eq-Eq-dependent-free-loops :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2)
  ( p p' : dependent-free-loops l P) →
  Eq-dependent-free-loops l P p p' → Id p p'
eq-Eq-dependent-free-loops l P p p' =
  inv-is-equiv (is-equiv-Eq-dependent-free-loops-eq l P p p')

{- We now define the induction principle of the circle. -}

ev-free-loop' :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (P : X → UU l2) →
  ( (x : X) → P x) → dependent-free-loops l P
ev-free-loop' (pair x₀ p) P f = pair (f x₀) (apd f p)

induction-principle-circle :
  { l1 : Level} (l2 : Level) {X : UU l1} (l : free-loops X) →
  UU ((lsuc l2) ⊔ l1)
induction-principle-circle l2 {X} l =
  (P : X → UU l2) → sec (ev-free-loop' l P)

{- Section 11.2 The universal property of the circle -}

{- We first state the universal property of the circle -}

ev-free-loop :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (Y : UU l2) →
  ( X → Y) → free-loops Y
ev-free-loop l Y f = pair (f (pr1 l)) (ap f (pr2 l))

universal-property-circle :
  { l1 : Level} (l2 : Level) {X : UU l1} (l : free-loops X) → UU _
universal-property-circle l2 l =
  ( Y : UU l2) → is-equiv (ev-free-loop l Y)

{- A fairly straightforward proof of the universal property of the circle
   factors through the dependent universal property of the circle. -}

dependent-universal-property-circle :
  { l1 : Level} (l2 : Level) {X : UU l1} (l : free-loops X) →
  UU ((lsuc l2) ⊔ l1)
dependent-universal-property-circle l2 {X} l =
  ( P : X → UU l2) → is-equiv (ev-free-loop' l P)

{- We first prove that the dependent universal property of the circle follows
   from the induction principle of the circle. To show this, we have to show
   that the section of ev-free-loop' is also a retraction. This construction
   is also by the induction principle of the circle, but it requires (a minimal
   amount of) preparations. -}

Eq-subst :
  { l1 l2 : Level} {X : UU l1} {P : X → UU l2} (f g : (x : X) → P x) →
  X → UU _
Eq-subst f g x = Id (f x) (g x)

tr-Eq-subst :
  { l1 l2 : Level} {X : UU l1} {P : X → UU l2} (f g : (x : X) → P x)
  { x y : X} (p : Id x y) (q : Id (f x) (g x)) (r : Id (f y) (g y))→
  ( Id ((apd f p) ∙ r) ((ap (tr P p) q) ∙ (apd g p))) →
  ( Id (tr (Eq-subst f g) p q) r)
tr-Eq-subst f g refl q .((ap id q) ∙ refl) refl =
  inv (right-unit ∙ (ap-id q))

dependent-free-loops-htpy :
  {l1 l2 : Level} {X : UU l1} {l : free-loops X} {P : X → UU l2}
  {f g : (x : X) → P x} →
  ( Eq-dependent-free-loops l P (ev-free-loop' l P f) (ev-free-loop' l P g)) →
  ( dependent-free-loops l (λ x → Id (f x) (g x)))
dependent-free-loops-htpy {l = (pair x l)} (pair p q) =
  pair p (tr-Eq-subst _ _ l p p q)

isretr-ind-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
  ( ind-circle : induction-principle-circle l2 l) (P : X → UU l2) →
  ( (pr1 (ind-circle P)) ∘ (ev-free-loop' l P)) ~ id
isretr-ind-circle l ind-circle P f =
  eq-htpy
    ( pr1
      ( ind-circle
        ( λ t → Id (pr1 (ind-circle P) (ev-free-loop' l P f) t) (f t)))
      ( dependent-free-loops-htpy
        ( Eq-dependent-free-loops-eq l P _ _
          ( pr2 (ind-circle P) (ev-free-loop' l P f)))))

abstract
  dependent-universal-property-induction-principle-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    induction-principle-circle l2 l → dependent-universal-property-circle l2 l
  dependent-universal-property-induction-principle-circle l ind-circle P =
    is-equiv-has-inverse
      ( pr1 (ind-circle P))
      ( pr2 (ind-circle P))
      ( isretr-ind-circle l ind-circle P)

{- We use the dependent universal property to derive a uniqeness property of
   dependent functions on the circle. -}

dependent-uniqueness-circle :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
  dependent-universal-property-circle l2 l →
  { P : X → UU l2} (k : dependent-free-loops l P) →
  is-contr
    ( Σ ( (x : X) → P x)
        ( λ h → Eq-dependent-free-loops l P (ev-free-loop' l P h) k))
dependent-uniqueness-circle l dup-circle {P} k =
  is-contr-is-equiv'
    ( fib (ev-free-loop' l P) k)
    ( tot (λ h → Eq-dependent-free-loops-eq l P (ev-free-loop' l P h) k))
    ( is-equiv-tot-is-fiberwise-equiv
      (λ h → is-equiv-Eq-dependent-free-loops-eq l P (ev-free-loop' l P h) k))
    ( is-contr-map-is-equiv (dup-circle P) k)

{- Now that we have established the dependent universal property, we can
   reduce the (non-dependent) universal property to the dependent case. We do
   so by constructing a commuting triangle relating ev-free-loop to
   ev-free-loop' via a comparison equivalence. -}

tr-const :
  {i j : Level} {A : UU i} {B : UU j} {x y : A} (p : Id x y) (b : B) →
  Id (tr (λ (a : A) → B) p b) b
tr-const refl b = refl

apd-const :
  {i j : Level} {A : UU i} {B : UU j} (f : A → B) {x y : A}
  (p : Id x y) → Id (apd f p) ((tr-const p (f x)) ∙ (ap f p))
apd-const f refl = refl

comparison-free-loops :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (Y : UU l2) →
  free-loops Y → dependent-free-loops l (λ x → Y)
comparison-free-loops l Y =
  tot (λ y l' → (tr-const (pr2 l) y) ∙ l')

abstract
  is-equiv-comparison-free-loops :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) (Y : UU l2) →
    is-equiv (comparison-free-loops l Y)
  is-equiv-comparison-free-loops l Y =
    is-equiv-tot-is-fiberwise-equiv
      ( λ y → is-equiv-concat (tr-const (pr2 l) y) y)

triangle-comparison-free-loops :
  { l1 l2 : Level} {X : UU l1} (l : free-loops X) (Y : UU l2) →
  ( (comparison-free-loops l Y) ∘ (ev-free-loop l Y)) ~
  ( ev-free-loop' l (λ x → Y))
triangle-comparison-free-loops (pair x l) Y f =
  eq-Eq-dependent-free-loops
    ( pair x l)
    ( λ x → Y)
    ( comparison-free-loops (pair x l) Y (ev-free-loop (pair x l) Y f))
    ( ev-free-loop' (pair x l) (λ x → Y) f)
    ( pair refl (right-unit ∙ (inv (apd-const f l))))

abstract
  universal-property-dependent-universal-property-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    ( dependent-universal-property-circle l2 l) →
    ( universal-property-circle l2 l)
  universal-property-dependent-universal-property-circle l dup-circle Y =
    is-equiv-right-factor
      ( ev-free-loop' l (λ x → Y))
      ( comparison-free-loops l Y)
      ( ev-free-loop l Y)
      ( htpy-inv (triangle-comparison-free-loops l Y))
      ( is-equiv-comparison-free-loops l Y)
      ( dup-circle (λ x → Y))

{- Now we get the universal property of the circle from the induction principle
   of the circle by composing the earlier two proofs. -}

abstract
  universal-property-induction-principle-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    induction-principle-circle l2 l → universal-property-circle l2 l
  universal-property-induction-principle-circle l =
    ( universal-property-dependent-universal-property-circle l) ∘
    ( dependent-universal-property-induction-principle-circle l)

unique-mapping-property-circle :
  { l1 : Level} (l2 : Level) {X : UU l1} (l : free-loops X) →
  UU (l1 ⊔ (lsuc l2))
unique-mapping-property-circle l2 {X} l =
  ( Y : UU l2) (l' : free-loops Y) →
    is-contr (Σ (X → Y) (λ f → Eq-free-loops (ev-free-loop l Y f) l'))

abstract
  unique-mapping-property-universal-property-circle :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    universal-property-circle l2 l →
    unique-mapping-property-circle l2 l
  unique-mapping-property-universal-property-circle l up-circle Y l' =
    is-contr-is-equiv'
      ( fib (ev-free-loop l Y) l')
      ( tot (λ f → Eq-free-loops-eq (ev-free-loop l Y f) l'))
      ( is-equiv-tot-is-fiberwise-equiv
        ( λ f → is-equiv-Eq-free-loops-eq (ev-free-loop l Y f) l'))
      ( is-contr-map-is-equiv (up-circle Y) l')

{- We assume that we have a circle. -}

postulate 𝕊¹ : UU lzero

postulate base-𝕊¹ : 𝕊¹

postulate loop-𝕊¹ : Id base-𝕊¹ base-𝕊¹

free-loop-𝕊¹ : free-loops 𝕊¹
free-loop-𝕊¹ = pair base-𝕊¹ loop-𝕊¹

postulate ind-𝕊¹ : {l : Level} → induction-principle-circle l free-loop-𝕊¹

dependent-universal-property-𝕊¹ :
  {l : Level} → dependent-universal-property-circle l free-loop-𝕊¹
dependent-universal-property-𝕊¹ =
  dependent-universal-property-induction-principle-circle free-loop-𝕊¹ ind-𝕊¹

dependent-uniqueness-𝕊¹ :
  {l : Level} {P : 𝕊¹ → UU l} (k : dependent-free-loops free-loop-𝕊¹ P) →
  is-contr (Σ ((x : 𝕊¹) → P x) (λ h → Eq-dependent-free-loops free-loop-𝕊¹ P (ev-free-loop' free-loop-𝕊¹ P h) k))
dependent-uniqueness-𝕊¹ {l} {P} k =
  dependent-uniqueness-circle free-loop-𝕊¹ dependent-universal-property-𝕊¹ k

universal-property-𝕊¹ :
  {l : Level} → universal-property-circle l free-loop-𝕊¹
universal-property-𝕊¹ =
  universal-property-dependent-universal-property-circle
    free-loop-𝕊¹
    dependent-universal-property-𝕊¹

-- Section 14.3 Multiplication on the circle

{- Exercises -}

-- Exercise 11.1

{- The dependent universal property of the circle (and hence also the induction
   principle of the circle, implies that the circle is connected in the sense
   that for any family of propositions parametrized by the circle, if the
   proposition at the base holds, then it holds for any x : circle. -}

abstract
  is-connected-circle' :
    { l1 l2 : Level} {X : UU l1} (l : free-loops X) →
    ( dup-circle : dependent-universal-property-circle l2 l)
    ( P : X → UU l2) (is-prop-P : (x : X) → is-prop (P x)) →
    P (base-free-loop l) → (x : X) → P x
  is-connected-circle' l dup-circle P is-prop-P p =
    inv-is-equiv
      ( dup-circle P)
      ( pair p (center (is-prop-P _ (tr P (pr2 l) p) p)))


{-# OPTIONS --guardedness #-}

module Prelude where

open import Class.Equality public
open import Class.Functor public
open import Class.Monad public
open import Class.Monoid public
open import Class.Show public
open import Class.Traversable public

open import Data.Bool hiding (_≟_; _<_; _<?_; _≤_; _≤?_) public
open import Data.Bool.Instance public
open import Data.Char using (Char) public
open import Data.Char.Instance public
open import Data.Empty public
open import Data.Empty.Instance public
open import Data.Fin using (Fin) public
open import Data.List using (List; []; [_]; _∷_; drop; boolFilter; filter; head; reverse; _++_; zipWith; foldl; intersperse; map; null; span; break; allFin; length; mapMaybe; or; and) public
open import Data.List.Exts public
open import Data.List.Instance public
open import Data.Maybe using (Maybe; just; nothing; maybe; from-just; is-just; is-nothing; _<∣>_) public
open import Data.Maybe.Instance public
open import Data.Nat hiding (_+_; _≟_) public
open import Data.Nat.Instance public
open import Data.Product using (_×_; _,_; proj₁; proj₂; ∃-syntax; -,_; Σ; swap; Σ-syntax; map₁; map₂) public
open import Data.Product.Instance public
open import Data.String using (String; unwords; unlines; padRight; _<+>_) public
open import Data.String.Exts public
open import Data.String.Instance public
open import Data.Sum using (_⊎_; inj₁; inj₂; from-inj₁; from-inj₂) public
open import Data.Sum.Instance public
open import Data.Unit.Instance public
open import Data.Unit.Polymorphic using (⊤; tt) public
open import IO using (IO; putStr) public
open import IO.Finite using (getLine) public
open import IO.Exts public
open import IO.Instance public
open import System.Environment public
open import System.Exit public

open import Function public

open import Relation.Nullary using (Dec; yes; no) public
open import Relation.Nullary.Decidable using (⌊_⌋) public
open import Relation.Nullary.Negation public
open import Relation.Unary using (Decidable) public
open import Relation.Binary.PropositionalEquality using (_≡_; refl) public


{-# OPTIONS --cubical #-}
open import Agda.Builtin.Cubical.Path

data PushOut {A B C : Set} (f : C → A) (g : C → B) : Set where
  inl : A → PushOut f g
  inr : B → PushOut f g
  push : ∀ c → inl (f c) ≡ inr (g c)
  squash : ∀ a b → a ≡ b

data ∥_∥₀ (A : Set) : Set where
  ∣_∣    : A → ∥ A ∥₀
  squash : ∀ (x y : ∥ A ∥₀) → (p q : x ≡ y) → p ≡ q

data Segment : Set where
  start end : Segment
  line      : start ≡ end

-- prop truncation
data ∥_∥ (A : Set) : Set where
  ∣_∣ : A → ∥ A ∥
  squash : ∀ (x y : ∥ A ∥) → x ≡ y

elim : ∀ {A : Set} (P : Set) → ((x y : P) → x ≡ y) → (A → P) → ∥ A ∥ → P
elim P Pprop f ∣ x ∣          = f x
elim P Pprop f (squash x y i) = Pprop (elim P Pprop f x) (elim P Pprop f y) i