module Cats.Functor.Yoneda where

open import Data.Product using (_,_)
open import Relation.Binary using (Rel ; Setoid ; IsEquivalence)
open import Relation.Binary.PropositionalEquality using (_≡_ ; refl)

open import Cats.Bifunctor using (transposeBifunctor₂)
open import Cats.Category
open import Cats.Category.Cat.Facts.Exponential using (Eval)
open import Cats.Category.Cat.Facts.Product using (First ; Swap)
open import Cats.Category.Fun using (Fun ; Trans ; ≈-intro ; ≈-elim)
open import Cats.Category.Fun.Facts using (NatIso→≅)
open import Cats.Category.Op using (_ᵒᵖ)
open import Cats.Category.Product.Binary using (_×_)
open import Cats.Category.Setoids using (Setoids ; ≈-intro ; ≈-elim ; ≈-elim′)
open import Cats.Functor using
  ( Functor ; _∘_ ; IsFull ; IsFaithful ; IsEmbedding ; Embedding→Full
  ; Embedding→Faithful )
open import Cats.Functor.Op using (Op)
open import Cats.Functor.Representable using (Hom[_])
open import Cats.Util.SetoidMorphism.Iso using (IsIso-resp)

import Cats.Util.SetoidReasoning as SetoidReasoning
import Cats.Category.Constructions.Iso

open Functor
open Trans
open Cats.Category.Setoids._⇒_
open Setoid using (Carrier)

-- We force C to be at l/l/l. Can we generalise to lo/la/l≈?
module _ {l} {C : Category l l l} where

  private
    Sets : Category _ _ _
    Sets = Setoids l l

    Presheaves : Category _ _ _
    Presheaves = Fun (C ᵒᵖ) Sets

    Funs : Category _ _ _
    Funs = Fun ((C ᵒᵖ) × Presheaves) Sets

    module C = Category C
    module Sets = Category Sets
    module Pre = Category Presheaves
    module Funs = Category Funs

  y : Functor C Presheaves
  y = transposeBifunctor₂ Hom[ C ]

  module _ (c : C.Obj) (F : Functor (C ᵒᵖ) (Sets)) where

    private
      module ycc≈ = Setoid (fobj (fobj y c) c)
      module Fc≈ = Setoid (fobj F c)

    forth : Pre.Hom (fobj y c) F Sets.⇒ fobj F c
    forth = record
        { arr = λ f → arr (component f c) C.id
        ; resp = λ f≈g → ≈-elim′ (≈-elim f≈g)
        }

    back-θ-component : Carrier (fobj F c) → (c′ : C.Obj) → C.Hom c′ c Sets.⇒ fobj F c′
    back-θ-component a c′ = record
        { arr = λ h → arr (fmap F h) a
        ; resp = λ f≈g → ≈-elim′ (fmap-resp F f≈g)
        }

    back-θ : Carrier (fobj F c) → fobj y c Pre.⇒ F
    back-θ a = record
        { component = back-θ-component a
        ; natural = λ {c′} {d′} {f} → ≈-intro λ {g} {g′} g≈g′ →
            let open Setoid (fobj F d′) using (sym) in
            begin⟨ fobj F d′ ⟩
              arr (back-θ-component a d′ Sets.∘ fmap (fobj y c) f) g
            ≡⟨⟩
              arr (fmap F (C.id C.∘ g C.∘ f)) a
            ≈⟨ ≈-elim′ (fmap-resp F (C.≈.trans C.id-l (C.∘-resp-l g≈g′))) ⟩
              arr (fmap F (g′ C.∘ f)) a
            ≈⟨ sym (≈-elim′ (fmap-∘ F)) ⟩
              arr (fmap F f Sets.∘ fmap F g′) a
            ≡⟨⟩
              arr (fmap F f Sets.∘ back-θ-component a c′) g′
            ∎
        }
      where
        open SetoidReasoning

    back : fobj F c Sets.⇒ Pre.Hom (fobj y c) F
    back = record
        { arr = back-θ
        ; resp = λ f≈g → ≈-intro (≈-intro λ x≈y → ≈-elim (fmap-resp F x≈y) f≈g)
        }

    back-forth : back Sets.∘ forth Sets.≈ Sets.id
    back-forth = ≈-intro λ {θ} {θ′} θ≈θ′ → ≈-intro λ {c′} → ≈-intro λ {f} {g} f≈g →
        begin⟨ fobj F c′ ⟩
          arr (component (arr (back Sets.∘ forth) θ) c′) f
        ≡⟨⟩
          arr (fmap F f Sets.∘ component θ c) C.id
        ≈⟨ ≈-elim′ (Sets.≈.sym (natural θ)) ⟩
          arr (component θ c′ Sets.∘ fmap (fobj y c) f) C.id
        ≡⟨⟩
          arr (component θ c′) (C.id C.∘ C.id C.∘ f)
        ≈⟨ resp (component θ c′) (C.≈.trans C.id-l C.id-l) ⟩
          arr (component θ c′) f
        ≈⟨ ≈-elim (≈-elim θ≈θ′) f≈g ⟩
          arr (component θ′ c′) g
        ∎
      where
        open SetoidReasoning

    forth-back : forth Sets.∘ back Sets.≈ Sets.id
    forth-back = ≈-intro λ x≈y → ≈-elim (fmap-id F) x≈y

    iso : fobj Hom[ Presheaves ] (fobj y c , F) Sets.≅ fobj F c
    iso = record
        { forth = forth
        ; back = back
        ; back-forth = back-forth
        ; forth-back = forth-back
        }

  yoneda : (Hom[ Presheaves ] ∘ First (Op y)) Funs.≅ (Eval ∘ Swap)
  yoneda = NatIso→≅ record
      { iso = λ { {c , F} → iso c F }
      ; forth-natural = λ where
          {c , F} {c′ , F′} {f , θ} → ≈-intro λ {ι} {τ} ι≈τ →
            let module S = Setoid (fobj F′ c′) in
            triangle (fobj F′ c′) (arr (component (θ Pre.∘ ι) c′) f)
              ( begin⟨ fobj F′ c′ ⟩
                  arr (forth c′ F′ Sets.∘ fmap Hom[ Presheaves ]
                         (fmap (First {D = Presheaves ᵒᵖ} (Op y)) (f , θ)))
                      ι
                ≡⟨⟩
                  arr (component (Pre.id Pre.∘ θ Pre.∘ ι) c′) (f C.∘ C.id C.∘ C.id)
                ≈⟨ ≈-elim (≈-elim (Pre.id-l {f = θ Pre.∘ ι}))
                    (C.≈.trans (C.∘-resp-r C.id-r) C.id-r) ⟩
                  arr (component (θ Pre.∘ ι) c′) f
                ∎
              )

              ( begin⟨ fobj F′ c′ ⟩
                  arr (fmap F′ f Sets.∘ component θ c Sets.∘ forth c F) τ
                ≡⟨⟩
                  arr (fmap F′ f Sets.∘ component (θ Pre.∘ τ) c) C.id
                ≈⟨ S.sym (≈-elim′ (natural (θ Pre.∘ τ))) ⟩
                  arr (component (θ Pre.∘ τ) c′ Sets.∘ fmap (fobj y c) f) C.id
                ≡⟨⟩
                  arr (component (θ Pre.∘ τ) c′) (C.id C.∘ C.id C.∘ f)
                ≈⟨ ≈-elim (≈-elim (Pre.∘-resp-r {f = θ} (Pre.≈.sym {i = ι} {τ} ι≈τ)))
                    (C.≈.trans C.id-l C.id-l) ⟩
                  arr (component (θ Pre.∘ ι) c′) f
                ∎
              )
      }
    where
      open SetoidReasoning

  back≈sfmap : ∀ {a b} → back a (fobj y b) Sets.≈ sfmap y
  back≈sfmap {a} {b} = ≈-intro λ {f} {g} f≈g → ≈-intro (≈-intro λ {x} {y} x≈y →
      begin
        C.id C.∘ f C.∘ x
      ≈⟨ C.id-l ⟩
        f C.∘ x
      ≈⟨ C.∘-resp f≈g x≈y ⟩
        g C.∘ y
      ≈⟨ C.≈.sym C.id-r ⟩
        (g C.∘ y) C.∘ C.id
      ≈⟨ C.assoc ⟩
        g C.∘ y C.∘ C.id
      ∎)
    where
      open C.≈-Reasoning

  y-Embedding : IsEmbedding y
  y-Embedding {a} {b} = IsIso-resp back≈sfmap record
      { back = forth a (fobj y b)
      ; forth-back = back-forth a (fobj y b)
      ; back-forth = forth-back a (fobj y b)
      }

  y-Full : IsFull y
  y-Full = Embedding→Full y y-Embedding

  y-Faithful : IsFaithful y
  y-Faithful = Embedding→Faithful y y-Embedding


{-# OPTIONS --cubical #-}

module Type.Cubical.Univalence where

open import Function.Axioms
open import Functional
open import Logic.Predicate
open import Logic.Propositional
import      Lvl
open import Structure.Function.Domain using (intro ; Inverseₗ ; Inverseᵣ)
open import Structure.Relator.Properties
open import Structure.Type.Identity
open import Type.Cubical.Path.Equality
open import Type.Cubical.Equiv
open import Type.Cubical
open import Type.Properties.MereProposition
open import Type

private variable ℓ ℓ₁ ℓ₂ : Lvl.Level
private variable T A B P Q : Type{ℓ}

-- TODO: Move
primitive primGlue : (A : Type{ℓ₁}) → ∀{i : Interval} → (T : Interval.Partial i (Type{ℓ₂})) → (e : Interval.PartialP i (\o → T(o) ≍ A)) → Type{ℓ₂}

type-extensionalityₗ : (A ≡ B) ← (A ≍ B)
type-extensionalityₗ {A = A}{B = B} ab i = primGlue(B)
  (\{(i = Interval.𝟎) → A  ; (i = Interval.𝟏) → B})
  (\{(i = Interval.𝟎) → ab ; (i = Interval.𝟏) → reflexivity(_≍_)})

module _ ⦃ prop-P : MereProposition{ℓ}(P) ⦄ ⦃ prop-Q : MereProposition{ℓ}(Q) ⦄ where
  propositional-extensionalityₗ : (P ≡ Q) ← (P ↔ Q)
  propositional-extensionalityₗ pq = type-extensionalityₗ([∃]-intro pq ⦃ intro ⦄) where
    instance
      l : Inverseₗ([↔]-to-[←] pq)([↔]-to-[→] pq)
      Inverseᵣ.proof l = uniqueness(Q)

    instance
      r : Inverseᵣ([↔]-to-[←] pq)([↔]-to-[→] pq)
      Inverseᵣ.proof r = uniqueness(P)

module _ {P Q : T → Type} ⦃ prop-P : ∀{x} → MereProposition{ℓ}(P(x)) ⦄ ⦃ prop-Q : ∀{x} → MereProposition{ℓ}(Q(x)) ⦄ where
  prop-set-extensionalityₗ : (P ≡ Q) ← (∀{x} → P(x) ↔ Q(x))
  prop-set-extensionalityₗ pq = functionExtensionalityOn P Q (propositional-extensionalityₗ pq)

-- module _ ⦃ uip-P : UniqueIdentityProofs{ℓ}(P) ⦄ ⦃ uip-Q : UniqueIdentityProofs{ℓ}(Q) ⦄ where

-- TODO: Actual proof of univalence


-- Duplicate of #1984

postulate
  Path : {A : Set} → A → Set
  admit : {Z : Set} → Z
  X : Set
  Y : X → Set
  Y' : X → Set

record Square : Set₁ where
  field
    A : Set
    B : Set
    b : B
    coh : Path b

-- Spurious mutual block to trigger the problem
mut : Set

record Cocone : Set where
  field
    x : X

-- x : Cocone → X
-- x (mkCocone x) = x

postulate
  m n : Cocone
  fung : (c : Cocone) → Y' (Cocone.x c) → Path c

record CoconeDep (P : X → Set) : Set where
  inductive
  field
    x' : P (Cocone.x m)

s : Square
s .Square.A = CoconeDep Y
s .Square.B = Cocone
s .Square.b = n
s .Square.coh = fung _ (admit {Y' (Cocone.x (s .Square.b))})

mut = X


module Numeral.CoordinateVector.Proofs where

import      Lvl
open import Data.Boolean
open import Data.Boolean.Stmt
open import Data.Boolean.Stmt.Proofs
import      Data.Either as Either
import      Functional as Fn
open import Function.Equals
open import Function.Names
open import Function.PointwiseStructure
open import Logic.Classical
open import Logic.Predicate
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Numeral.CoordinateVector
open import Numeral.Finite
open import Numeral.Finite.Oper.Comparisons
open import Numeral.Finite.Proofs
open import Numeral.Natural
import      Relator.Equals as Eq
open import Relator.Equals.Proofs.Equivalence
open import Structure.Setoid
open import Structure.Function.Multi
import      Structure.Function.Names as Names
open import Structure.Function
open import Structure.Operator.Field
open import Structure.Operator.Group
open import Structure.Operator.Monoid
open import Structure.Operator.Properties
open import Structure.Operator.Vector
open import Structure.Operator
open import Structure.Relator.Properties
open import Type
open import Syntax.Function
open import Syntax.Transitivity

-- Note: The structure stuff here is actually a specialization of Function.PointwiseStructure
module _ {ℓ ℓₑ} {T : Type{ℓ}} ⦃ _ : Equiv{ℓₑ}(T) ⦄ where
  private variable _▫_ _▫₁_ _▫₂_ _+_ _⋅_ : T → T → T
  private variable f inv : T → T
  private variable id 𝟎ₛ 𝟏ₛ x init : T
  private variable d n : ℕ
  private variable i j k : 𝕟(n)
  private variable v : Vector(n)(T)

  instance
    -- A component-wise operator have a left identity of repeated elements when its underlying operator have a left identity.
    map₂-fill-identityₗ : ⦃ ident : Identityₗ(_▫_)(id) ⦄ → Identityₗ(map₂{d = n}(_▫_))(fill{d = n}(id))
    map₂-fill-identityₗ = pointwiseFunction-identityₗ

  instance
    -- A component-wise operator have a right identity of repeated elements when its underlying operator have a right identity.
    map₂-fill-identityᵣ : ⦃ ident : Identityᵣ(_▫_)(id) ⦄ → Identityᵣ(map₂{d = n}(_▫_))(fill{d = n}(id))
    map₂-fill-identityᵣ = pointwiseFunction-identityᵣ

  instance
    -- A component-wise operator have an identity of repeated elements when its underlying operator have an identity.
    map₂-fill-identity : ⦃ ident : Identity(_▫_)(id) ⦄ → Identity(map₂{d = n}(_▫_))(fill{d = n}(id))
    map₂-fill-identity = pointwiseFunction-identity

  instance
    map₂-map-inverseₗ : ⦃ ident : Identityₗ(_▫_)(id) ⦄ ⦃ inver : InverseFunctionₗ(_▫_) ⦃ [∃]-intro _ ⦄ (inv) ⦄ → InverseFunctionₗ(map₂{d = n}(_▫_)) ⦃ [∃]-intro _ ⦄ (map(inv))
    map₂-map-inverseₗ = pointwiseFunction-inverseFunctionₗ

  instance
    map₂-map-inverseᵣ : ⦃ ident : Identityᵣ(_▫_)(id) ⦄ ⦃ inver : InverseFunctionᵣ(_▫_) ⦃ [∃]-intro _ ⦄ (inv) ⦄ → InverseFunctionᵣ(map₂{d = n}(_▫_)) ⦃ [∃]-intro _ ⦄ (map(inv))
    map₂-map-inverseᵣ = pointwiseFunction-inverseFunctionᵣ

  instance
    map₂-map-inverse : ⦃ ident : Identity(_▫_)(id) ⦄ ⦃ inver : InverseFunction(_▫_) ⦃ [∃]-intro _ ⦄ (inv) ⦄ → InverseFunction(map₂{d = n}(_▫_)) ⦃ [∃]-intro _ ⦄ (map(inv))
    map₂-map-inverse = pointwiseFunction-inverseFunction

  instance
    -- A component-wise operator is commutative when its underlying operator is commutative.
    map₂-commutativity : ⦃ comm : Commutativity(_▫_) ⦄ → Commutativity(map₂{d = n}(_▫_))
    map₂-commutativity = pointwiseFunction-commutativity

  instance
    -- A component-wise operator is associative when its underlying operator is associative.
    map₂-associativity : ⦃ assoc : Associativity(_▫_) ⦄ → Associativity(map₂{d = n}(_▫_))
    map₂-associativity = pointwiseFunction-associativity

  instance
    -- A component-wise operator is left distributive over another component-wise operator when their underlying operators distribute.
    map₂-distributivityₗ : ⦃ distₗ : Distributivityₗ(_▫₁_)(_▫₂_) ⦄ → Distributivityₗ(map₂{d = n}(_▫₁_))(map₂{d = n}(_▫₂_))
    map₂-distributivityₗ = pointwiseFunction-distributivityₗ

  instance
    -- A component-wise operator is right distributive over another component-wise operator when their underlying operators distribute.
    map₂-distributivityᵣ : ⦃ distᵣ : Distributivityᵣ(_▫₁_)(_▫₂_) ⦄ → Distributivityᵣ(map₂{d = n}(_▫₁_))(map₂{d = n}(_▫₂_))
    map₂-distributivityᵣ = pointwiseFunction-distributivityᵣ

  instance
    map₂-preserves : Preserving₂(fill) (_▫_) (map₂{d = n}(_▫_))
    map₂-preserves = pointwiseFunction-const-preserves

  instance
    -- A component-wise function is a function when its underlying function is a function.
    map-function : ⦃ func : Function(f) ⦄ → Function(map{d = n}(f))
    map-function = pointwiseFunction-function

  instance
    -- A component-wise binary operator is a binary operator when its underlying binary operator is a binary operator.
    map₂-binaryOperator : ⦃ oper : BinaryOperator(_▫_) ⦄ → BinaryOperator(map₂{d = n}(_▫_))
    map₂-binaryOperator = pointwiseFunction-binaryOperator

  instance
    -- A component-wise operator is a monoid when its underlying operator is a monoid.
    map₂-monoid : ⦃ monoid : Monoid(_▫_) ⦄ → Monoid(map₂{d = n}(_▫_))
    map₂-monoid = pointwiseFunction-monoid

  instance
    -- A component-wise operator is a group when its underlying operator is a group.
    map₂-group : ⦃ group : Group(_▫_) ⦄ → Group(map₂{d = n}(_▫_))
    map₂-group = pointwiseFunction-group

  instance
    -- A component-wise operator is a commutative group when its underlying operator is a commutative group.
    map₂-commutativeGroup : ⦃ commutativeGroup : CommutativeGroup(_▫_) ⦄ → CommutativeGroup(map₂{d = n}(_▫_))
    map₂-commutativeGroup = pointwiseFunction-commutativeGroup

  {- TODO: Is this even possible?
  instance
    -- Note: The reason for `d = 𝐒(n)` is so that one cannot shrink a field to the "trivial field" in this way (which is not a field).
    map₂-field : ⦃ field-structure : Field(_+_)(_⋅_) ⦄ → Field(map₂{d = 𝐒(n)}(_+_))(map₂{d = 𝐒(n)}(_⋅_))
    Field.[+]-commutative-group map₂-field = map₂-commutativeGroup
    Field.[⋅]-monoid map₂-field = map₂-monoid
    Field.⅟ (map₂-field ⦃ f ⦄) v ⦃ Field.intro nonzero ⦄ = {!!} -- map (x ↦ Field.⅟ f x ⦃ Field.intro (p ↦ nonzero (intro {!!})) ⦄) v
    Field.[⋅]-inverseₗ map₂-field = {!!}
    Field.[⋅]-inverseᵣ map₂-field = {!!}
    Field.distinct-identities (map₂-field ⦃ f ⦄) p = Field.distinct-identities f (_⊜_.proof p {𝟎})
  -}

  instance
    -- Component-wise operators constructs a vector space from a field when using the fields as scalars and coordinate vectors as vectors.
    CoordinateVector-vectorSpace : ⦃ field-structure : Field(_+_)(_⋅_) ⦄ → VectorSpace(map₂{d = n}(_+_)) (s ↦ map{d = n}(s ⋅_)) (_+_) (_⋅_)
    CoordinateVector-vectorSpace ⦃ field-structure ⦄ = pointwiseFunction-vectorSpace field-structure

  indexProject-values : ∀{true false : T} → (proj(indexProject i true false) j ≡ true) ∨ (proj(indexProject i true false) j ≡ false)
  indexProject-values {𝐒 n}{i = i}{j = j} with (i ≡? j)
  ... | 𝑇 = [∨]-introₗ (reflexivity(_≡_))
  ... | 𝐹 = [∨]-introᵣ (reflexivity(_≡_))

  indexProject-true  : ∀{true false : T} → (i Eq.≡ j) ∨ (false ≡ true) ↔ (proj(indexProject i true false) j ≡ true)
  indexProject-true {n}{i = i}{j = j} {true = true}{false = false} =
    [∨]-mapₗ-[↔] [≡][≡?]-equivalence ⦗ [↔]-transitivity ⦘ᵣ
    [↔]-intro
      (l{n}{i}{j})
      ([↔]-to-[←] [→ₗ][∨][∧]-preserving ([∧]-intro (r₁{n}{i}{j}) (r₂{n}{i}{j})))
    where
      l : ∀{n}{i j : 𝕟(n)} → IsTrue(i ≡? j) ∨ (false ≡ true) ← (proj(indexProject i true false) j ≡ true)
      l {𝐒 n} {i = i} {j = j} p with (i ≡? j)
      ... | 𝑇 = [∨]-introₗ [⊤]-intro
      ... | 𝐹 = [∨]-introᵣ p

      r₁ : ∀{n}{i j : 𝕟(n)} → IsTrue(i ≡? j) → (proj(indexProject i true false) j ≡ true)
      r₁ {𝐒 n} {i = i}{j = j} p with 𝑇 ← (i ≡? j) = reflexivity(_≡_)

      r₂ : ∀{n}{i j : 𝕟(n)} → (false ≡ true) → (proj(indexProject i true false) j ≡ true)
      r₂ {𝐒 n} {i = i}{j = j} p with (i ≡? j)
      ... | 𝑇 = reflexivity(_≡_)
      ... | 𝐹 = p

  indexProject-false : ∀{true false : T} → ((i Eq.≢ j) ∨ (false ≡ true)) ↔ (proj(indexProject i true false) j ≡ false)
  indexProject-false {n}{i = i}{j = j} {true = true}{false = false} =
    [∨]-mapₗ-[↔] ([↔]-transitivity ([¬]-unaryOperator [≡][≡?]-equivalence) ([↔]-symmetry false-true-opposites)) ⦗ [↔]-transitivity ⦘ᵣ
    [↔]-intro
      (l{n}{i}{j})
      ([↔]-to-[←] [→ₗ][∨][∧]-preserving ([∧]-intro (r₁{n}{i}{j}) (r₂{n}{i}{j})))
    where
      l : ∀{n}{i j : 𝕟(n)} → (IsFalse(i ≡? j) ∨ (false ≡ true)) ← (proj(indexProject i true false) j ≡ false)
      l {n} {i} {j} p with (i ≡? j)
      ... | 𝑇 = [∨]-introᵣ (symmetry(_≡_) p)
      ... | 𝐹 = [∨]-introₗ [⊤]-intro

      r₁ : ∀{n}{i j : 𝕟(n)} → IsFalse(i ≡? j) → (proj(indexProject i true false) j ≡ false)
      r₁ {𝐒 n} {i = i}{j = j} p with (i ≡? j)
      ... | 𝑇 = [⊥]-elim p
      ... | 𝐹 = reflexivity(_≡_)

      r₂ : ∀{n}{i j : 𝕟(n)} → (false ≡ true) → (proj(indexProject i true false) j ≡ false)
      r₂ {𝐒 n} {i = i}{j = j} p with (i ≡? j)
      ... | 𝑇 = symmetry(_≡_) p
      ... | 𝐹 = reflexivity(_≡_)

  module _
    ⦃ ident : Identityₗ(_⋅_)(𝟏ₛ) ⦄
    ⦃ absor : Absorberₗ(_⋅_)(𝟎ₛ) ⦄
    where
    map₂-indexProject-identityₗ : map₂(_⋅_) (indexProject i 𝟏ₛ 𝟎ₛ) v ≡ indexProject i (v(i)) 𝟎ₛ
    _⊜_.proof (map₂-indexProject-identityₗ {i = i}{v = v}) {x} with (i ≡? x) | [↔]-to-[←] ([≡][≡?]-equivalence {i = i}{j = x})
    ... | 𝑇 | p = identityₗ(_⋅_)(𝟏ₛ) 🝖 congruence₁ ⦃ [≡]-equiv ⦄ (v) ⦃ [≡]-to-function ⦄ (symmetry(Eq._≡_) (p([⊤]-intro)))
    ... | 𝐹 | _ = absorberₗ(_⋅_)(𝟎ₛ)

  module _
    ⦃ ident : Identityᵣ(_⋅_)(𝟏ₛ) ⦄
    ⦃ absor : Absorberᵣ(_⋅_)(𝟎ₛ) ⦄
    where
    map₂-indexProject-identityᵣ : map₂(_⋅_) v (indexProject i 𝟏ₛ 𝟎ₛ) ≡ indexProject i (v(i)) 𝟎ₛ
    _⊜_.proof (map₂-indexProject-identityᵣ {v = v}{i = i}) {x} with (i ≡? x) | [↔]-to-[←] ([≡][≡?]-equivalence {i = i}{j = x})
    ... | 𝑇 | p = identityᵣ(_⋅_)(𝟏ₛ) 🝖 congruence₁ ⦃ [≡]-equiv ⦄ (v) ⦃ [≡]-to-function ⦄ (symmetry(Eq._≡_) (p([⊤]-intro)))
    ... | 𝐹 | _ = absorberᵣ(_⋅_)(𝟎ₛ)

  tail-function : Function(tail{d = 𝐒(d)}{T = T})
  Function.congruence(tail-function{d = d}) (intro xy) = intro xy

  instance
    foldᵣ-function : ∀{ℓᵣ ℓₑᵣ}{R : Type{ℓᵣ}} ⦃ equiv-R : Equiv{ℓₑᵣ}(R)⦄ {f : T → R → R}{init} → ⦃ oper : BinaryOperator(f) ⦄ → Function(foldᵣ{d = d} f init)
    foldᵣ-function {d} {f = f}{init = init} = intro(p{d = d}) where
      p : ∀{d} → Names.Congruence₁(foldᵣ{d = d} f init)
      p {𝟎}       _  = reflexivity(_≡_)
      p {𝐒(𝟎)}    xy = congruence₂ₗ(f)(_) (_⊜_.proof xy)
      p {𝐒(𝐒(d))} xy = congruence₂(f) (_⊜_.proof xy) (p {𝐒(d)} (congruence₁(tail) ⦃ tail-function ⦄ xy))

  -- TODO: Generalize Numeral.Natural.Oper.Summation for these kinds of proofs
  {-
  module _
    ⦃ oper : BinaryOperator(_▫_) ⦄
    ⦃ ident : Identityᵣ(_▫_)(id) ⦄
    ( neq : (id ≢ x) )
    where
    foldᵣ-indexProject-identityᵣ : foldᵣ(_▫_) init (indexProject i x id) ≡ x ▫ init
    foldᵣ-indexProject-identityᵣ {init}{𝐒(𝟎)}    {i = 𝟎}   = reflexivity(_≡_)
    foldᵣ-indexProject-identityᵣ {init}{𝐒(𝐒(n))} {i = 𝟎}   =
      foldᵣ{d = 𝐒(𝐒(n))}(_▫_) init (indexProject 𝟎 x id)                                                🝖[ _≡_ ]-[]
      proj(indexProject{d = 𝐒(𝐒(n))} 𝟎 x id)(𝟎) ▫ foldᵣ{d = 𝐒(n)}(_▫_) init (tail(indexProject 𝟎 x id)) 🝖[ _≡_ ]-[]
      x ▫ foldᵣ{d = 𝐒(n)}(_▫_) init (tail(indexProject 𝟎 x id))                                         🝖[ _≡_ ]-[ {!!} ]
      x ▫ init                                                                                🝖-end
      {-foldᵣ(_▫_) id (indexProject 𝟎 x id)                                        🝖[ _≡_ ]-[ {!!} ]
      proj(indexProject 𝟎 x id)(𝟎) ▫ (foldᵣ(_▫_) id (tail(indexProject 𝟎 x id))) 🝖[ _≡_ ]-[ {!!} ]
      id ▫ (foldᵣ(_▫_) id (tail(indexProject 𝟎 x id)))                           🝖[ _≡_ ]-[ {!!} ]
      foldᵣ(_▫_) id (tail(indexProject 𝟎 x id))                                  🝖[ _≡_ ]-[ {!!} ]
      x                                                                          🝖-end-}
    foldᵣ-indexProject-identityᵣ {init}{𝐒(𝐒(n))} {i = 𝐒 i} = {!!}
  -}


{-# OPTIONS --safe #-}
module Cubical.Algebra.NatSolver.Solver where

open import Cubical.Foundations.Prelude

open import Cubical.Data.FinData
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order using (zero-≤)
open import Cubical.Data.Vec.Base
open import Cubical.Algebra.NatSolver.NatExpression
open import Cubical.Algebra.NatSolver.HornerForms
open import Cubical.Algebra.NatSolver.EvalHom

private
  variable
    ℓ : Level

module EqualityToNormalform where
  open Eval
  open IteratedHornerOperations
  open HomomorphismProperties

  normalize : {n : ℕ} → Expr n → IteratedHornerForms n
  normalize {n = n} (K r) = Constant n r
  normalize {n = n} (∣ k) = Variable n k
  normalize (x +' y) =
    (normalize x) +ₕ (normalize y)
  normalize (x ·' y) =
    (normalize x) ·ₕ (normalize y)

  isEqualToNormalform :
            {n : ℕ}
            (e : Expr n) (xs : Vec ℕ n)
          → eval (normalize e) xs ≡ ⟦ e ⟧ xs
  isEqualToNormalform (K r) [] = refl
  isEqualToNormalform {n = ℕ.suc n} (K r) (x ∷ xs) =
     eval (Constant (ℕ.suc n) r) (x ∷ xs)           ≡⟨ refl ⟩
     eval (0ₕ ·X+ Constant n r) (x ∷ xs)             ≡⟨ refl ⟩
     eval 0ₕ (x ∷ xs) · x + eval (Constant n r) xs
    ≡⟨ cong (λ u → u · x + eval (Constant n r) xs) (eval0H (x ∷ xs)) ⟩
     0 · x + eval (Constant n r) xs
    ≡⟨ refl ⟩
     eval (Constant n r) xs
    ≡⟨ isEqualToNormalform (K r) xs ⟩
     r ∎

  isEqualToNormalform (∣ zero) (x ∷ xs) =
    eval (1ₕ ·X+ 0ₕ) (x ∷ xs)           ≡⟨ refl ⟩
    eval 1ₕ (x ∷ xs) · x + eval 0ₕ xs   ≡⟨ cong (λ u → u · x + eval 0ₕ xs)
                                               (eval1ₕ (x ∷ xs)) ⟩
    1 · x + eval 0ₕ xs                  ≡⟨ cong (λ u → 1 · x + u ) (eval0H xs) ⟩
    1 · x + 0                          ≡⟨ +-zero _ ⟩
    1 · x                               ≡⟨ ·-identityˡ _ ⟩
    x ∎
  isEqualToNormalform {n = ℕ.suc n} (∣ (suc k)) (x ∷ xs) =
      eval (0ₕ ·X+ Variable n k) (x ∷ xs)             ≡⟨ refl ⟩
      eval 0ₕ (x ∷ xs) · x + eval (Variable n k) xs
    ≡⟨ cong (λ u → u · x + eval (Variable n k) xs) (eval0H (x ∷ xs)) ⟩
      0 · x + eval (Variable n k) xs
    ≡⟨ refl ⟩
      eval (Variable n k) xs
    ≡⟨ isEqualToNormalform (∣ k) xs ⟩
      ⟦ ∣ (suc k) ⟧ (x ∷ xs) ∎

  isEqualToNormalform (e +' e₁) [] =
        eval (normalize e +ₕ normalize e₁) []
      ≡⟨ +Homeval (normalize e) _ [] ⟩
        eval (normalize e) []
        + eval (normalize e₁) []
      ≡⟨ cong (λ u → u + eval (normalize e₁) [])
              (isEqualToNormalform e []) ⟩
        ⟦ e ⟧ []
        + eval (normalize e₁) []
      ≡⟨ cong (λ u → ⟦ e ⟧ [] + u) (isEqualToNormalform e₁ []) ⟩
        ⟦ e ⟧ [] + ⟦ e₁ ⟧ [] ∎
  isEqualToNormalform (e +' e₁) (x ∷ xs) =
        eval (normalize e
              +ₕ normalize e₁) (x ∷ xs)
      ≡⟨ +Homeval (normalize e) _ (x ∷ xs) ⟩
        eval (normalize e) (x ∷ xs)
        + eval (normalize e₁) (x ∷ xs)
      ≡⟨ cong (λ u → u + eval (normalize e₁) (x ∷ xs))
              (isEqualToNormalform e (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs)
        + eval (normalize e₁) (x ∷ xs)
      ≡⟨ cong (λ u → ⟦ e ⟧ (x ∷ xs) + u)
              (isEqualToNormalform e₁ (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs) + ⟦ e₁ ⟧ (x ∷ xs) ∎

  isEqualToNormalform (e ·' e₁) [] =
        eval (normalize e ·ₕ normalize e₁) []
      ≡⟨ ·Homeval (normalize e) _ [] ⟩
        eval (normalize e) []
        · eval (normalize e₁) []
      ≡⟨ cong (λ u → u · eval (normalize e₁) [])
              (isEqualToNormalform e []) ⟩
        ⟦ e ⟧ []
        · eval (normalize e₁) []
      ≡⟨ cong (λ u → ⟦ e ⟧ [] · u) (isEqualToNormalform e₁ []) ⟩
        ⟦ e ⟧ [] · ⟦ e₁ ⟧ [] ∎

  isEqualToNormalform (e ·' e₁) (x ∷ xs) =
        eval (normalize e ·ₕ normalize e₁) (x ∷ xs)
      ≡⟨ ·Homeval (normalize e) _ (x ∷ xs) ⟩
        eval (normalize e) (x ∷ xs)
        · eval (normalize e₁) (x ∷ xs)
      ≡⟨ cong (λ u → u · eval (normalize e₁) (x ∷ xs))
              (isEqualToNormalform e (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs)
        · eval (normalize e₁) (x ∷ xs)
      ≡⟨ cong (λ u → ⟦ e ⟧ (x ∷ xs) · u)
              (isEqualToNormalform e₁ (x ∷ xs)) ⟩
        ⟦ e ⟧ (x ∷ xs) · ⟦ e₁ ⟧ (x ∷ xs) ∎

  solve :
    {n : ℕ} (e₁ e₂ : Expr n) (xs : Vec ℕ n)
    (p : eval (normalize e₁) xs ≡ eval (normalize e₂) xs)
    → ⟦ e₁ ⟧ xs ≡ ⟦ e₂ ⟧ xs
  solve e₁ e₂ xs p =
    ⟦ e₁ ⟧ xs                ≡⟨ sym (isEqualToNormalform e₁ xs) ⟩
    eval (normalize e₁) xs ≡⟨ p ⟩
    eval (normalize e₂) xs ≡⟨ isEqualToNormalform e₂ xs ⟩
    ⟦ e₂ ⟧ xs ∎


{- https://lists.chalmers.se/pipermail/agda/2013/006033.html http://code.haskell.org/~Saizan/unification/ 18-Nov-2013 Andrea Vezzosi -}
module Unify-monolithic-EnhancedTerm where

-- some equivalences needed to adapt Tactic.Nat to the standard library
module EquivalenceOf≤ where
  open import Agda.Builtin.Equality
  open import Agda.Builtin.Nat

  open import Data.Nat using (less-than-or-equal) renaming (_≤_ to _≤s_)
  open import Data.Nat.Properties using (≤⇒≤″; ≤″⇒≤)
  open import Prelude using (diff; id) renaming (_≤_ to _≤p_)

  open import Tactic.Nat.Generic (quote _≤p_) (quote id) (quote id) using (by)

  ≤p→≤s : ∀ {a b} → a ≤p b → a ≤s b
  ≤p→≤s (diff k b₊₁≡k₊₁+a) = ≤″⇒≤ (less-than-or-equal {k = k} (by b₊₁≡k₊₁+a))

  ≤s→≤p : ∀ {a b} → a ≤s b → a ≤p b
  ≤s→≤p a≤sb with ≤⇒≤″ a≤sb
  ≤s→≤p _ | less-than-or-equal {k = k} a+k≡b = diff k (by a+k≡b)

module _ where
  open EquivalenceOf≤
  open import Data.Nat
  open import Tactic.Nat.Generic (quote _≤_) (quote ≤s→≤p) (quote ≤p→≤s) public

open import Data.Fin using (Fin; suc; zero)
open import Data.Nat hiding (_≤_)
--open import Relation.Binary.PropositionalEquality
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function
open import Relation.Nullary
--open import Data.Product
open import Data.Product renaming (map to _***_)
open import Data.Empty
open import Data.List renaming (_++_ to _++L_)

{- -- not enhanced
data Term (n : ℕ) : Set where
  i : (x : Fin n) -> Term n
  leaf : Term n
  _fork_ : (s t : Term n) -> Term n
-}

data Term (n : _) : Set where
  i : (x : Fin n) -> Term n
  function : ℕ → List (Term n) → Term n

term-function-inj₁ : ∀ {x₁ x₂} {n} {ts₁ : List (Term n)} {ts₂} → Term.function x₁ ts₁ ≡ function x₂ ts₂ → x₁ ≡ x₂
term-function-inj₁ refl = refl

term-function-inj₂ : ∀ {x₁ x₂} {n} {ts₁ : List (Term n)} {ts₂} → Term.function x₁ ts₁ ≡ function x₂ ts₂ → ts₁ ≡ ts₂
term-function-inj₂ refl = refl

--data Term (n : ℕ) (I : Size) : Set where
--  i : (x : Fin n) -> Term n I
--  function : ℕ → (J : Size< I) → SizedList J (Term n J) → Term n I
{-
data Term : ℕ -> Set where
  i : ∀ ..{n} -> (x : Fin n) -> Term n
  leaf : ∀ ..{n} -> Term n
  _fork_ : ∀ ..{n} -> (s t : Term n) -> Term n
-}
_~>_ : (m n : ℕ) -> Set
(m ~> n) = Fin m -> Term n

▹ : ∀ {m n} -> (r : Fin m -> Fin n) -> Fin m -> Term n
▹ r = i ∘ r

mutual

  infixr 20 _◃s_
  _◃s_ : ∀ {m n} -> (f : m ~> n) -> List (Term m) -> List (Term n)
  _◃s_ f [] = []
  _◃s_ f (x ∷ xs) = (f ◃ x) ∷ f ◃s xs

  _◃_ : ∀ {m n} -> (f : m ~> n) -> Term m -> Term n
  f ◃ (i x) = f x
  f ◃ (function n ts) = function n (f ◃s ts)

{-
_◃_ : ∀ {m n} -> (f : m ~> n) -> Term m -> Term n
_◃_ = _◃
-}

_≐_ : {m n : ℕ} -> (Fin m -> Term n) -> (Fin m -> Term n) -> Set
f ≐ g = ∀ x -> f x ≡ g x

mutual

  ◃ext : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ t -> f ◃ t ≡ g ◃ t
  ◃ext p (i x) = p x
  ◃ext p (function x ts) = cong (function x) (◃exts p ts)

  ◃exts : ∀ {m n} {f g : Fin m -> Term n} -> f ≐ g -> ∀ ts -> f ◃s ts ≡ g ◃s ts
  ◃exts p [] = refl
  ◃exts p (t ∷ ts) = cong₂ _∷_ (◃ext p t) (◃exts p ts)

_◇_ : ∀ {l m n : ℕ } -> (f : Fin m -> Term n) (g : Fin l -> Term m) -> Fin l -> Term n
f ◇ g = (f ◃_) ∘ g

≐-cong : ∀ {m n o} {f : m ~> n} {g} (h : _ ~> o) -> f ≐ g -> (h ◇ f) ≐ (h ◇ g)
≐-cong h f≐g t = cong (h ◃_) (f≐g t)

≐-sym : ∀ {m n} {f : m ~> n} {g} -> f ≐ g -> g ≐ f
≐-sym f≐g = sym ∘ f≐g

module Sub where
  mutual

    fact1 : ∀ {n} -> (t : Term n) -> i ◃ t ≡ t
    fact1 (i x) = refl
    fact1 (function x ts) = cong (function x) (fact1s ts)

    fact1s : ∀ {n} -> (ts : List (Term n)) -> i ◃s ts ≡ ts
    fact1s [] = refl
    fact1s (t ∷ ts) = cong₂ _∷_ (fact1 t) (fact1s ts)

  mutual

    fact2 : ∀ {l m n} -> (f : Fin m -> Term n) (g : _) (t : Term l)
      -> (f ◇ g) ◃ t ≡ f ◃ (g ◃ t)
    fact2 f g (i x) = refl
    fact2 f g (function x ts) = cong (function x) (fact2s f g ts)

    fact2s : ∀ {l m n} -> (f : Fin m -> Term n) (g : _) (ts : List (Term l))
      -> (f ◇ g) ◃s ts ≡ f ◃s g ◃s ts
    fact2s f g [] = refl
    fact2s f g (t ∷ ts) = cong₂ _∷_ (fact2 f g t) (fact2s f g ts)

  fact3 : ∀ {l m n} (f : Fin m -> Term n) (r : Fin l -> Fin m) -> (f ◇ (▹ r)) ≡ (f ∘ r)
  fact3 f r = refl -- ext (λ _ -> refl)

◃ext' : ∀ {m n o} {f : Fin m -> Term n}{g : Fin m -> Term o}{h} -> f ≐ (h ◇ g) -> ∀ t -> f ◃ t ≡ h ◃ (g ◃ t)
◃ext' p t = trans (◃ext p t) (Sub.fact2 _ _ t)
s : ℕ -> ℕ
s = suc

thin : ∀ {n} -> (x : Fin (s n)) (y : Fin n) -> Fin (s n)
thin zero y = suc y
thin (suc x) zero = zero
thin (suc x) (suc y) = suc (thin x y)

p : ∀ {n} -> Fin (suc (suc n)) -> Fin (suc n)
p (suc x) = x
p zero = zero

module Thin where
  fact1 : ∀ {n} x y z -> thin {n} x y ≡ thin x z -> y ≡ z
  fact1 zero y .y refl = refl
  fact1 (suc x) zero zero r = refl
  fact1 (suc x) zero (suc z) ()
  fact1 (suc x) (suc y) zero ()
  fact1 (suc x) (suc y) (suc z) r = cong suc (fact1 x y z (cong p r))

  fact2 : ∀ {n} x y -> ¬ thin {n} x y ≡ x
  fact2 zero y ()
  fact2 (suc x) zero ()
  fact2 (suc x) (suc y) r = fact2 x y (cong p r)

  fact3 : ∀{n} x y -> ¬ x ≡ y -> ∃ λ y' -> thin {n} x y' ≡ y
  fact3 zero zero ne = ⊥-elim (ne refl)
  fact3 zero (suc y) _ = y , refl
  fact3 {zero} (suc ()) _ _
  fact3 {suc n} (suc x) zero ne = zero , refl
  fact3 {suc n} (suc x) (suc y) ne with y | fact3 x y (ne ∘ cong suc)
  ... | .(thin x y') | y' , refl = suc y' , refl

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

thick : ∀ {n} -> (x y : Fin (suc n)) -> Maybe (Fin n)
thick zero zero = nothing
thick zero (suc y) = just y
thick {zero} (suc ()) _
thick {suc _} (suc x) zero = just zero
thick {suc _} (suc x) (suc y) = suc <$> (thick x y)

open import Data.Sum

_≡Fin_ : ∀ {n} -> (x y : Fin n) -> Dec (x ≡ y)
zero ≡Fin zero = yes refl
zero ≡Fin suc y = no λ ()
suc x ≡Fin zero = no λ ()
suc {suc _} x ≡Fin suc y with x ≡Fin y
...              | yes r = yes (cong suc r)
...              | no r = no λ e -> r (cong p e)
suc {zero} () ≡Fin _

module Thick where
  half1 : ∀ {n} (x : Fin (suc n)) -> thick x x ≡ nothing
  half1 zero = refl
  half1 {suc _} (suc x) = cong (_<$>_ suc) (half1 x)
  half1 {zero} (suc ())

  half2 : ∀ {n} (x : Fin (suc n)) y -> ∀ y' -> thin x y' ≡ y -> thick x y ≡ just y'
  half2 zero zero y' ()
  half2 zero (suc y) .y refl = refl
  half2 {suc n} (suc x) zero zero refl = refl
  half2 {suc _} (suc _) zero (suc _) ()
  half2 {suc n} (suc x) (suc y) zero ()
  half2 {suc n} (suc x) (suc .(thin x y')) (suc y') refl with thick x (thin x y') | half2 x (thin x y') y' refl
  ...                                                       | .(just y')          | refl = refl
  half2 {zero} (suc ()) _ _ _

  fact1 : ∀ {n} (x : Fin (suc n)) y r
    -> thick x y ≡ r
    -> x ≡ y × r ≡ nothing ⊎ ∃ λ y' -> thin x y' ≡ y × r ≡ just y'
  fact1 x y .(thick x y) refl with x ≡Fin y
  fact1 x .x ._ refl | yes refl = inj₁ (refl , half1 x)
  ... | no el with Thin.fact3 x y el
  ...            | y' , thinxy'=y = inj₂ (y' , ( thinxy'=y , half2 x y y' thinxy'=y ))

mutual

  check : ∀{n} (x : Fin (suc n)) (t : Term (suc n)) -> Maybe (Term n)
  check x (i y) = i <$> thick x y
  check x (function v ts) = (function v) <$> checks x ts

  checks : ∀{n} (x : Fin (suc n)) (t : List (Term (suc n))) -> Maybe (List (Term n))
  checks x [] = just []
  checks x (t ∷ ts) = _∷_ <$> check x t ⊛ checks x ts

_for_ : ∀ {n} (t' : Term n) (x : Fin (suc n)) -> Fin (suc n) -> Term n
(t' for x) y = maybe′ i t' (thick x y)

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

sub : ∀ {m n} (σ : AList m n) -> Fin m -> Term n
sub anil = i
sub (σ asnoc t' / x) = sub σ ◇ (t' for x)

_++_ : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> AList l n
ρ ++ anil = ρ
ρ ++ (σ asnoc t' / x) = (ρ ++ σ) asnoc t' / x

++-assoc : ∀ {l m n o} (ρ : AList l m) (σ : AList n _) (τ : AList o _) -> ρ ++ (σ ++ τ) ≡ (ρ ++ σ) ++ τ
++-assoc ρ σ anil = refl
++-assoc ρ σ (τ asnoc t / x) = cong (λ s -> s asnoc t / x) (++-assoc ρ σ τ)

module SubList where
  anil-id-l : ∀ {m n} (σ : AList m n) -> anil ++ σ ≡ σ
  anil-id-l anil = refl
  anil-id-l (σ asnoc t' / x) = cong (λ σ -> σ asnoc t' / x) (anil-id-l σ)

  fact1 : ∀ {l m n} (ρ : AList m n) (σ : AList l m) -> sub (ρ ++ σ) ≐ (sub ρ ◇ sub σ)
  fact1 ρ anil v = refl
  fact1 {suc l} {m} {n} r (s asnoc t' / x) v = trans hyp-on-terms ◃-assoc
    where
      t = (t' for x) v
      hyp-on-terms = ◃ext (fact1 r s) t
      ◃-assoc = Sub.fact2 (sub r) (sub s) t

_∃asnoc_/_ : ∀ {m} (a : ∃ (AList m)) (t' : Term m) (x : Fin (suc m))
  -> ∃ (AList (suc m))
(n , σ) ∃asnoc t' / x = n , σ asnoc t' / x

flexFlex : ∀ {m} (x y : Fin m) -> ∃ (AList m)
flexFlex {suc m} x y with thick x y
...              | just y' = m , anil asnoc i y' / x
...              | nothing = suc m , anil
flexFlex {zero} () _

flexRigid : ∀ {m} (x : Fin m) (t : Term m) -> Maybe (∃(AList m))
flexRigid {suc m} x t with check x t
...                   | just t' = just (m , anil asnoc t' / x)
...                   | nothing = nothing
flexRigid {zero} () _

mutual

  amgu : ∀ {m} (s t : Term m) (acc : ∃ (AList m)) -> Maybe (∃ (AList m))
  amgu (function x ts) (function x' ts') acc with x ≟ x'
  … | yes refl = amgus ts ts' acc
  … | no neq = nothing
  amgu (i x) (i y) (m , anil) = just (flexFlex x y)
  amgu (i x) t     (m , anil) = flexRigid x t
  amgu t     (i x) (m , anil) = flexRigid x t
  amgu s     t  (n , σ asnoc r / z) =
           (λ σ -> σ ∃asnoc r / z) <$>
             amgu ((r for z) ◃ s) ((r for z) ◃ t) (n , σ)

  amgus : ∀ {m} (ss ts : List (Term m)) (acc : ∃ (AList m)) -> Maybe (∃ (AList m))
  amgus [] [] acc = just acc
  amgus [] (_ ∷ _) acc = nothing
  amgus (_ ∷ _) [] acc = nothing
  amgus (s ∷ ss) (t ∷ ts) acc = amgus ss ts =<< amgu s t acc

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

{-
open import Data.Fin using (Fin; suc; zero)
open import Data.Nat hiding (_≤_)
open import Relation.Binary.PropositionalEquality hiding ([_])
open import Function
open import Relation.Nullary
open import Data.Product renaming (map to _***_)
open import Data.Empty
-}
open import Data.Maybe using (maybe; maybe′; nothing; just; monad; Maybe)
open import Data.Sum
--open import Unify
--open import Data.List renaming (_++_ to _++L_)
open ≡-Reasoning
open import Category.Functor
open import Category.Monad
import Level as L
--open RawMonad (Data.Maybe.monad {L.zero})

record Σ₁ (A : Set1) (F : A -> Set) : Set1 where
  field
    π₁ : A
    π₂ : F π₁

_,,_ : ∀ {A F} (x : A) -> F x -> Σ₁ A F
x ,, b = record{ π₁ = x; π₂ = b }

open Σ₁

Property⋆ : (m : ℕ) -> Set1
Property⋆ m = ∀ {n} -> (Fin m -> Term n) -> Set

Extensional : {m : ℕ} -> Property⋆ m -> Set
Extensional P = ∀ {m f g} -> f ≐ g -> P {m} f -> P g

Property : (m : ℕ) -> Set1
Property m = Σ₁ (Property⋆ m) Extensional

prop-id : ∀ {m n} {f : _ ~> n} {P : Property m} -> π₁ P f -> π₁ P (i ◇ f)
prop-id {_} {_} {f} {P'} Pf = π₂ P' (λ x → sym (Sub.fact1 (f x))) Pf

Unifies⋆ : ∀ {m} (s t : Term m) -> Property⋆ m
Unifies⋆ s t f = f ◃ s ≡ f ◃ t

Unifies : ∀ {m} (s t : Term m) -> Property m
Unifies s t = (λ {_} -> Unifies⋆ s t) ,, λ {_} {f} {g} f≐g f◃s=f◃t ->
  begin
    g ◃ s
  ≡⟨ sym (◃ext f≐g s) ⟩
    f ◃ s
  ≡⟨ f◃s=f◃t ⟩
    f ◃ t
  ≡⟨ ◃ext f≐g t ⟩
    g ◃ t
  ∎

_∧⋆_ : ∀{m} -> (P Q : Property⋆ m) -> Property⋆ m
P ∧⋆ Q = (λ f -> P f × Q f)

_∧_ : ∀{m} -> (P Q : Property m) -> Property m
P ∧ Q = (λ {_} f -> π₁ P f × π₁ Q f) ,, λ {_} {_} {_} f≐g Pf×Qf -> π₂ P f≐g (proj₁ Pf×Qf) , π₂ Q f≐g (proj₂ Pf×Qf)

_⇔⋆_ : ∀{m} -> (P Q : Property⋆ m) -> Set
P ⇔⋆ Q = ∀ {n} f -> (P {n} f -> Q f) × (Q f -> P f)

_⇔_ : ∀{m} -> (P Q : Property m) -> Set
P ⇔ Q = ∀ {n} f -> (π₁ P {n} f -> π₁ Q f) × (π₁ Q f -> π₁ P f)

switch⋆ : ∀ {m} (P Q : Property⋆ m) -> P ⇔⋆ Q -> Q ⇔⋆ P
switch⋆ _ _ P⇔Q f = proj₂ (P⇔Q f) , proj₁ (P⇔Q f)

switch : ∀ {m} (P Q : Property m) -> P ⇔ Q -> Q ⇔ P
switch _ _ P⇔Q f = proj₂ (P⇔Q f) , proj₁ (P⇔Q f)

Nothing⋆ : ∀{m} -> (P : Property⋆ m) -> Set
Nothing⋆ P = ∀{n} f -> P {n} f -> ⊥

Nothing : ∀{m} -> (P : Property m) -> Set
Nothing P = ∀{n} f -> π₁ P {n} f -> ⊥

_[-◇⋆_] : ∀{m n} (P : Property⋆ m) (f : Fin m -> Term n) -> Property⋆ n
(P [-◇⋆ f ]) g = P (g ◇ f)

_[-◇_] : ∀{m n} (P : Property m) (f : Fin m -> Term n) -> Property n
P [-◇ f ] = (λ {_} g -> π₁ P (g ◇ f)) ,, λ {_} {f'} {g'} f'≐g' Pf'◇f -> π₂ P (◃ext f'≐g' ∘ f)  Pf'◇f

module Properties where
  fact1 : ∀ {m} {s t : Term m} -> (Unifies s t) ⇔ (Unifies t s)
  fact1 _ = sym , sym

{-
  fact1'⋆ : ∀ {m} {x1 x2} {s1 t1 : Term m} {s2 t2 : List (Term m)}
         -> Unifies⋆ (function x1 (s1 ∷ s2)) (function x2 (t1 ∷ t2)) ⇔⋆ (Unifies⋆ s1 t1 ∧⋆ Unifies⋆ (function x1 s2) (function x2 t2))
  fact1'⋆ f = (λ x → {!deconstr!}) , {!!} -- deconstr _ _ _ _ _ _ _ , {!uncurry (cong₂ function)!}
    where deconstr : ∀ {m} x1 x2 (s1 t1 : Term m) (s2 t2 : List (Term m))
                   -> function x1 (s1 ∷ s2) ≡ function x2 (t1 ∷ t2)
                   -> (x1 ≡ x2) × (s1 ≡ t1) × (s2 ≡ t2)
          deconstr x1 .x1 s1 .s1 s2 .s2 refl = refl , refl , refl
-}
{-
  fact1' : ∀ {m} {s1 s2 t1 t2 : Term m}
         -> Unifies (s1 fork s2) (t1 fork t2) ⇔ (Unifies s1 t1 ∧ Unifies s2 t2)
  fact1' f = deconstr _ _ _ _ , uncurry (cong₂ _fork_)
    where deconstr : ∀ {m} (s1 s2 t1 t2 : Term m)
                   -> (s1 fork s2) ≡ (t1 fork t2)
                   -> (s1 ≡ t1) × (s2 ≡ t2)
          deconstr s1 s2 .s1 .s2 refl = refl , refl
-}

  fact2⋆ : ∀ {m} (P Q : Property⋆ m) -> P ⇔⋆ Q -> Nothing⋆ P -> Nothing⋆ Q
  fact2⋆ P Q iff notp f q with iff f
  ...                        | (p2q , q2p) = notp f (q2p q)

  fact2 : ∀ {m} (P Q : Property m) -> P ⇔ Q -> Nothing P -> Nothing Q
  fact2 P Q iff notp f q with iff f
  ...                       | (p2q , q2p) = notp f (q2p q)

  fact3 : ∀ {m} {P : Property m} -> P ⇔ (P [-◇ i ])
  fact3 f = id , id

  fact4 : ∀{m n} {P : Property m} (f : _ -> Term n)
          -> Nothing P -> Nothing (P [-◇ f ])
  fact4 f nop g = nop (g ◇ f)

  fact5⋆ : ∀{m n} (P Q : Property⋆ _) (f : m ~> n) -> P ⇔⋆ Q -> (P [-◇⋆ f ]) ⇔⋆ (Q [-◇⋆ f ])
  fact5⋆ _ _ f P⇔Q f' = P⇔Q (f' ◇ f)

  fact5 : ∀{m n} (P Q : Property _) (f : m ~> n) -> P ⇔ Q -> (P [-◇ f ]) ⇔ (Q [-◇ f ])
  fact5 _ _ f P⇔Q f' = P⇔Q (f' ◇ f)

  fact6 : ∀{m n} P {f g : m ~> n} -> f ≐ g -> (P [-◇ f ]) ⇔ (P [-◇ g ])
  fact6 P f≐g h = π₂ P (≐-cong h f≐g) , π₂ P (≐-sym (≐-cong h f≐g))
{-
  fact5 : ∀ {l m n} {f : Fin n -> Term l} {g : Fin m -> Term n}
            {P : Property _ }
        -> (P [-◇ g ]) [-◇ f ] ⇔ P [-◇ (f ◇ g) ]
  fact5 h = {!!} , {!!}
-}

_≤_ : ∀ {m n n'} (f : Fin m -> Term n) (g : Fin m -> Term n') -> Set
f ≤ g = ∃ λ f' -> f ≐ (f' ◇ g)

module Order where

  reflex : ∀ {m n} {f : Fin m -> Term n} -> f ≤ f
  reflex = i  , λ _ -> sym (Sub.fact1 _)

  transitivity : ∀ {l m n o} {f : Fin l -> Term m}{g : _ -> Term n}
                             {h : _ -> Term o}
                   -> f ≤ g -> g ≤ h -> f ≤ h
  transitivity {l} {_} {_} {_} {f} {g} {h} (fg , pfg) (gh , pgh) =
                   fg ◇ gh , proof
    where
      proof : (x : Fin l) → f x ≡ (λ x' → fg ◃ (gh x')) ◃ (h x)
      proof x = trans z (sym (Sub.fact2 fg gh (h x)))
        where z = trans (pfg x) (cong (fg ◃_) (pgh x))

  i-max : ∀ {m n} (f : Fin m -> Term n) -> f ≤ i
  i-max f = f , λ _ -> refl

  dist : ∀{l m n o}{f : Fin l -> Term m}{g : _ -> Term n}(h : Fin o -> _) -> f ≤ g -> (f ◇ h) ≤ (g ◇ h)
  dist h (fg , pfg) = fg  , λ x -> trans (◃ext pfg (h x)) (Sub.fact2 _ _ (h x))

Max⋆ : ∀ {m} (P : Property⋆ m) -> Property⋆ m
Max⋆ P f = P f × (∀ {n} f' -> P {n} f' -> f' ≤ f)

Max : ∀ {m} (P : Property m) -> Property m
Max P' = (λ {_} → Max⋆ P) ,, λ {_} {_} {_} -> lemma1
  where
    open Σ₁ P' renaming (π₁ to P; π₂ to Peq)
    lemma1 : {m : ℕ} {f : Fin _ → Term m} {g : Fin _ → Term m} →
             f ≐ g →
             P f × ({n : ℕ} (f' : Fin _ → Term n) → P f' → f' ≤ f) →
             P g × ({n : ℕ} (f' : Fin _ → Term n) → P f' → f' ≤ g)
    lemma1 {_} {f} {g} f≐g (Pf , MaxPf) = Peq f≐g Pf , λ {_} -> lemma2
      where
        lemma2 : ∀ {n} f' → P {n} f' → ∃ λ f0 → f' ≐ (f0 ◇ g)
        lemma2 f' Pf' = f0 , λ x -> trans (f'≐f0◇f x) (cong (f0 ◃_) (f≐g x))
              where
                f0 = proj₁ (MaxPf f' Pf')
                f'≐f0◇f = proj₂ (MaxPf f' Pf')

module Max where
  fact : ∀{m}(P Q : Property m) -> P ⇔ Q -> Max P ⇔ Max Q
  fact {m} P Q a f =
   (λ maxp → pq (proj₁ maxp) , λ f' → proj₂ maxp f' ∘ qp)
    , λ maxq → qp (proj₁ maxq) , λ f'  → proj₂ maxq f' ∘ pq
    where
      pq : {n : ℕ} {f0 : Fin m → Term n} → (π₁ P f0 → π₁ Q f0)
      pq {_} {f} =  proj₁ (a f)
      qp : {n : ℕ} {f0 : Fin m → Term n} → (π₁ Q f0 → π₁ P f0)
      qp {_} {f} = proj₂ (a f)

DClosed : ∀{m} (P : Property m) -> Set
DClosed P = ∀ {n} f {o} g -> f ≤ g -> π₁ P {o} g -> π₁ P {n} f

module DClosed where

  fact1 : ∀ {m} s t -> DClosed {m} (Unifies s t)
  fact1 s t f g (f≤g , p) gs=gt =
         begin
         f ◃ s
         ≡⟨ ◃ext' p s ⟩
         f≤g ◃ (g ◃ s)
         ≡⟨ cong (f≤g ◃_) gs=gt ⟩
         f≤g ◃ (g ◃ t)
         ≡⟨ sym (◃ext' p t) ⟩
         f ◃ t
         ∎

optimist : ∀ {l m n o} (a : Fin _ -> Term n) (p : Fin _ -> Term o)
                 (q : Fin _ -> Term l) (P Q : Property m)
           -> DClosed P -> π₁ (Max (P [-◇ a ])) p
           -> π₁ (Max (Q [-◇ (p ◇ a) ])) q
           -> π₁ (Max ((P ∧ Q) [-◇ a ])) (q ◇ p)
optimist a p q P' Q' DCP (Ppa , pMax) (Qqpa , qMax) =
     (Peq (sym ∘ (Sub.fact2 _ _) ∘ a) (DCP (q ◇ (p ◇ a)) (p ◇ a) (q , λ _ -> refl) Ppa)
      , Qeq (sym ∘ (Sub.fact2 _ _) ∘ a) Qqpa )
     , λ {_} -> aux
  where
    open Σ₁ P' renaming (π₁ to P; π₂ to Peq)
    open Σ₁ Q' renaming (π₁ to Q; π₂ to Qeq)
    aux : ∀ {n} (f : _ -> Term n) -> P (f ◇ a) × Q (f ◇ a) -> f ≤ (q ◇ p)
    aux f (Pfa , Qfa) = h ,
                        λ x -> trans (f≐g◇p x) (◃ext' g≐h◇q (p x))
      where
        one = pMax f Pfa
        g = proj₁ one
        f≐g◇p = proj₂ one
        Qgpa : Q (g ◇ (p ◇ a))
        Qgpa = Qeq (λ x -> ◃ext' f≐g◇p (a x)) Qfa
        g≤q = qMax g Qgpa
        h = proj₁ g≤q
        g≐h◇q = proj₂ g≤q

module failure-propagation where

  first⋆ : ∀ {m n} (a : _ ~> n) (P Q : Property⋆ m) ->
         Nothing⋆ (P [-◇⋆ a ]) -> Nothing⋆ ((P ∧⋆ Q) [-◇⋆ a ])
  first⋆ a P' Q' noP-a f (Pfa , Qfa) = noP-a f Pfa

  first : ∀ {m n} (a : _ ~> n) (P Q : Property m) ->
         Nothing (P [-◇ a ]) -> Nothing ((P ∧ Q) [-◇ a ])
  first a P' Q' noP-a f (Pfa , Qfa) = noP-a f Pfa
{-
  second⋆ : ∀ {m n o} (a : _ ~> n) (p : _ ~> o)(P Q : Property⋆ m) ->
             (Max⋆ (P [-◇⋆ a ])) p -> Nothing⋆ (Q [-◇⋆ (p ◇ a)])
             -> Nothing⋆ ((P ∧⋆ Q) [-◇⋆ a ])
  second⋆ a p P' Q' (Ppa , pMax) noQ-p◇a f (Pfa , Qfa) = noQ-p◇a g Qgpa
       where
         f≤p = pMax f Pfa
         g = proj₁ f≤p
         f≐g◇p = proj₂ f≤p
         Qgpa : Q' (g ◇ (p ◇ a))
         Qgpa = {!!}
  {-
                                                      noQ-p◇a g Qgpa
       where
         f≤p = pMax f Pfa
         g = proj₁ f≤p
         f≐g◇p = proj₂ f≤p
         Qgpa : π₁ Q' (g ◇ (p ◇ a))
         Qgpa = π₂ Q' (◃ext' f≐g◇p ∘ a)  Qfa
  -}
-}
  second⋆ : ∀ {m n o} (a : _ ~> n) (p : _ ~> o)(P : Property⋆ m)(Q : Property m) ->
             (Max⋆ (P [-◇⋆ a ])) p -> Nothing⋆ (π₁ Q [-◇⋆ (p ◇ a)])
             -> Nothing⋆ ((P ∧⋆ π₁ Q) [-◇⋆ a ])
  second⋆ a p P' Q' (Ppa , pMax) noQ-p◇a f (Pfa , Qfa) = noQ-p◇a g Qgpa
       where
         f≤p = pMax f Pfa
         g = proj₁ f≤p
         f≐g◇p = proj₂ f≤p
         Qgpa : π₁ Q' (g ◇ (p ◇ a))
         Qgpa = π₂ Q' (◃ext' f≐g◇p ∘ a)  Qfa

  second : ∀ {m n o} (a : _ ~> n) (p : _ ~> o)(P Q : Property m) ->
             π₁ (Max (P [-◇ a ])) p -> Nothing (Q [-◇ (p ◇ a)])
             -> Nothing ((P ∧ Q) [-◇ a ])
  second a p P' Q' (Ppa , pMax) noQ-p◇a f (Pfa , Qfa) =
                                                      noQ-p◇a g Qgpa
       where
         f≤p = pMax f Pfa
         g = proj₁ f≤p
         f≐g◇p = proj₂ f≤p
         Qgpa : π₁ Q' (g ◇ (p ◇ a))
         Qgpa = π₂ Q' (◃ext' f≐g◇p ∘ a)  Qfa

trivial-problem : ∀ {m n t} {f : m ~> n} -> π₁ (Max ((Unifies t t) [-◇ f ])) i
trivial-problem = refl , λ f' _ → f' , λ _ → refl

var-elim : ∀ {m} (x : Fin (suc m)) (t' : Term _)
              -> π₁ (Max ((Unifies (i x) ((▹ (thin x) ◃_) t')))) (t' for x)
var-elim x t' = first , \{_} -> second
  where
    lemma : ∀{m}(x : Fin (suc m)) t → i ≐ ((t for x) ◇ (▹ (thin x)))
    lemma x t x' = sym (cong (maybe i t) (Thick.half2 x _ x' refl))
    first = begin
             (t' for x) ◃ (i x) ≡⟨ cong (maybe i t') (Thick.half1 x) ⟩
             t'                 ≡⟨ sym (Sub.fact1 t') ⟩
             i ◃ t'             ≡⟨ ◃ext' (lemma x t') t' ⟩
             (t' for x) ◃ ((▹ (thin x) ◃_) t') ∎

    second : ∀ {n} (f : _ ~> n) → f x ≡ f ◃ ((▹ (thin x) ◃_) t') → f ≤ (t' for x)
    second f Unifiesf = (f ∘ thin x) , third
        where
          third : ((x' : Fin _) →  f x' ≡ (f ∘ thin x) ◃ (maybe′ i t' (thick x x')))
          third x' with thick x x' | Thick.fact1 x x' (thick x x') refl
          third .x | .nothing | inj₁ (refl , refl)  =
                                       sym (begin
                                           (f ∘ thin x) ◃ t'  ≡⟨ cong (λ g -> (g ◃_) t') (sym (Sub.fact3 f (thin x))) ⟩
                                           (f ◇ (▹ (thin x))) ◃ t' ≡⟨ Sub.fact2 f (▹ (thin x)) t' ⟩
                                           f ◃ ((▹ (thin x) ◃_) t') ≡⟨ sym Unifiesf ⟩
                                           f x ∎)
          third x' | .(just y) | inj₂ (y , ( thinxy≡x' , refl))  = sym (cong f thinxy≡x')

var-elim-i : ∀ {m} (x : Fin (suc m)) (t' : Term _)
              -> π₁ (Max ((Unifies (i x) ((▹ (thin x) ◃_) t')))) (i ◇ (t' for x))
var-elim-i {m} x t = prop-id {_} {_} {t for x} {Max (Unifies (i x) ((▹ (thin x) ◃_) t))} (var-elim {m} x t)

var-elim-i-≡ : ∀ {m} {t'} (x : Fin (suc m)) t1  -> t1 ≡ (i ∘ thin x) ◃ t' -> π₁ (Max (Unifies (i x) t1)) (i ◇ (t' for x))
var-elim-i-≡ {_} {t'} x .((i ∘ thin x) ◃ t') refl = var-elim-i x t'

data Step (n : ℕ) : Set where
  step : ℕ → List (Term n) → List (Term n) → Step n

open Data.List using () renaming (map to mapL)

fmapS : ∀ {n m} (f : Term n -> Term m) (s : Step n) -> Step m
fmapS f (step x ls rs) = step x (mapL f ls) (mapL f rs)

infixl 10 _⊹_
_⊹_ : ∀ {n} (ps : List (Step n)) (t : Term n) -> Term n
([] ⊹ t)                  = t
((step x ls rs ∷ ps) ⊹ t) = function x (ls ++L (ps ⊹ t ∷ rs))

_◃S_ : ∀ {n m} (f : n ~> m) -> List (Step n) -> List (Step m)
_◃S_ f = mapL (fmapS (f ◃_))

map-[] : ∀ {n m} (f : n ~> m) ps -> f ◃S ps ≡ [] -> ps ≡ []
map-[] f [] _ = refl
map-[] f (x ∷ xs) ()

module StepM where

  lemma1 : ∀ {n} (x : Step n) xs t -> [ x ] ⊹ ( xs ⊹ t ) ≡ (x ∷ xs) ⊹ t
  lemma1 (step x ls rs) xs t = refl

  lemma2 : ∀ {n} {r} {t} {xs} (x : Step n) -> xs ⊹ t ≡ r -> ((x ∷ xs) ⊹ t ) ≡ [ x ] ⊹ r
  lemma2 (step x ls rs) eq = cong (λ t → function x (ls ++L t ∷ rs)) eq -- cong (λ t -> t fork y) eq

  fact1 : ∀ {n} ps qs (t : Term n) -> (ps ++L qs) ⊹ t ≡ ps ⊹ (qs ⊹ t)
  fact1 [] qs t = refl
  fact1 (p ∷ ps) qs t = begin (p ∷ (ps ++L qs)) ⊹ t ≡⟨ lemma2 p (fact1 ps qs t) ⟩
                              [ p ] ⊹ (ps ⊹ (qs ⊹ t)) ≡⟨ lemma1 p ps (qs ⊹ t)  ⟩
                              (p ∷ ps) ⊹ (qs ⊹ t) ∎

  lemma3 : ∀ {m n} (f : m ~> n) ls rs → f ◃s (ls ++L rs) ≡ mapL (f ◃_) ls ++L mapL (f ◃_) rs
  lemma3 f [] (r ∷ rs) = cong (f ◃ r ∷_) (lemma3 f [] rs)
  lemma3 f (l ∷ ls) rs = cong (f ◃ l ∷_) (lemma3 f ls rs)
  lemma3 f [] [] = refl

  fact2 : ∀ {m n} (f : m ~> n) t ps ->
               f ◃ (ps ⊹ t) ≡ f ◃S ps ⊹ f ◃ t
  fact2 f t [] = refl
  fact2 f t (step x [] [] ∷ xs) = cong (function x) (cong (λ section → section ∷ []) (fact2 f t xs))
  fact2 f t (step x [] (r ∷ rs) ∷ xs) rewrite lemma3 f [] rs = cong (function x) (cong₂ _∷_ (fact2 f t xs) refl)
  fact2 f t (step x (l ∷ ls) rs ∷ xs) rewrite sym $ fact2 f t xs | lemma3 f ls (xs ⊹ t ∷ rs) = cong (function x) (cong (f ◃ l ∷_) refl)

mutual

  check-prop : ∀ {m} (x : Fin (suc m)) t ->
             (∃ λ t' -> t ≡ ▹ (thin x) ◃ t' × check x t ≡ just t')
             ⊎ (∃ λ ps -> t ≡ (ps ⊹ i x) × check x t ≡ nothing)
  check-prop x (i x') with Thick.fact1 x x' (thick x x') refl
  check-prop x (i .x) | inj₁ (refl , e) = inj₂ ([] , refl , cong (_<$>_ i) e)
  ... | inj₂ (y , thinxy≡x' , thickxx'≡justy')
      = inj₁ (i y
             , cong i (sym (thinxy≡x'))
             , cong (_<$>_ i) thickxx'≡justy' )
  check-prop x (function xx ts) with checks-prop x ts
  … | inj₁ (asdf , df , er) rewrite df | er = inj₁ (function xx asdf , refl , refl)
  … | inj₂ (ls , ps , rs , ts= , checks=) rewrite ts= | checks= = inj₂ (step xx ls rs ∷ ps , refl , refl)

  checks-prop : ∀ {m} (x : Fin (suc m)) ts ->
              (∃ λ ts' -> ts ≡ (▹ (thin x) ◃s_) ts' × checks x ts ≡ just ts')
              ⊎ ∃ λ ls → ∃ λ ps → ∃ λ rs -> ts ≡ ls ++L (ps ⊹ i x) ∷ rs × checks x ts ≡ nothing -- (∃ λ pss -> ts ≡ (pss ⊹s i x) × checks x ts ≡ nothing)
  checks-prop x [] = inj₁ ([] , refl , refl)
  checks-prop x (t ∷ ts) with check-prop x t | checks-prop x ts
  … | inj₁ (t' , t= , check=) | inj₁ (ts' , ts= , checks=)
    rewrite t= | check= | ts= | checks=
    = inj₁ (t' ∷ ts' , refl , refl)
  … | inj₂ (ps , t= , check=) | _
    rewrite t= | check=
    = inj₂ ([] , ps , ts , refl , refl)
  … | _ | inj₂ (ls , ps , rs , ts= , checks=)
    rewrite ts= | checks=
    = inj₂ (t ∷ ls , ps , rs , refl , lemma (_ <$> check _ t))
    where
      lemma : ∀ {a b : Set} {y : b} (x : Maybe a) -> maybe (λ _ → y) y x ≡ y
      lemma (just x') = refl
      lemma nothing = refl

function++ : ∀ {m} {x} {t : Term m} {ls rs : List (Term m)} ps ->
                   (ps ⊹ (function x (ls ++L t ∷ rs)) ≡ (ps ++L [ step x ls rs ]) ⊹ t)
function++ [] = refl
function++ (step x ls rs ∷ ps) = cong (function x) (cong (λ t → ls ++L t ∷ rs)
  (sym $ StepM.fact1 ps (step _ _ _ ∷ []) _))

open import Data.List.Properties using (∷-injective; ∷ʳ-injective)

list-craz : ∀ {a} {A : Set a} {x : A} {xs} → x ∷ xs ≡ [] → ⊥
list-craz ()

listʳ-craz : ∀ {a} {A : Set a} {x : A} {xs} → xs ∷ʳ x ≡ [] → ⊥
listʳ-craz {x = x} {[]} ()
listʳ-craz {x = x} {x₁ ∷ xs} ()

mutual

  termSize : ∀ {m} → Term m → ℕ
  termSize (i x₁) = 1
  termSize (function x₁ x₂) = suc (termsSize x₂)

  termsSize : ∀ {m} → List (Term m) → ℕ
  termsSize [] = 0
  termsSize (x₁ ∷ x₂) = termSize x₁ + termsSize x₂

sizeFact1 : ∀ {m} (ls rs : List (Term m)) → termsSize (ls ++L rs) ≡ termsSize ls + termsSize rs
sizeFact1 [] rs = refl
sizeFact1 (x ∷ ls) rs rewrite sizeFact1 ls rs = auto

sizeFact2a : ∀ {m} (p : Step m) (ps : List (Step m)) (t : Term m)
  → termSize (ps ⊹ t) Data.Nat.≤ termSize ((p ∷ ps) ⊹ t)
sizeFact2a (step x x₁ x₂) ps t rewrite sizeFact1 x₁ (ps ⊹ t ∷ x₂) = auto

≤-trans : ∀ {x y z} → x Data.Nat.≤ y → y Data.Nat.≤ z → x Data.Nat.≤ z
≤-trans z≤n z≤n = auto
≤-trans z≤n (s≤s x₂) = auto
≤-trans (s≤s x₁) (s≤s x₂) = by (≤-trans x₁ x₂)

sizeFact2 : ∀ {m} (ps : List (Step m)) x (t : Term m) (ts : List (Term m))
  → suc (termSize t + termsSize ts) Data.Nat.≤ termSize (ps ⊹ function x (t ∷ ts))
sizeFact2 [] x t ts = auto
sizeFact2 (p ∷ ps) x t ts
  with sizeFact2 ps x t ts | sizeFact2a p ps (function x (t ∷ ts))
… | siz1 | siz2 = ≤-trans siz1 siz2 where
  open import Data.Nat.Properties

No-Cycle : ∀{m} (t : Term m) ps -> t ≡ ps ⊹ t -> ps ≡ []
No-Cycle _ [] ref = refl
No-Cycle (i x) (step x₁ x₂ x₃ ∷ ps) ()
No-Cycle (function x []) (step x' [] rs ∷ ps) ()
No-Cycle (function x []) (step x' (x₁ ∷ ls) rs ∷ ps) ()
No-Cycle (function x (t ∷ ts)) (step x' [] rs ∷ ps) r
  with No-Cycle t (ps ++L step x [] ts ∷ []) $ trans (proj₁ ∘ ∷-injective $ term-function-inj₂ r) (function++ {x = x} {t = t} {ls = []} {rs = ts} ps)
… | dfsd = ⊥-elim (listʳ-craz {x = step x [] ts} {xs = ps} dfsd)
No-Cycle (function x (t ∷ ts)) (step x' ls@(l ∷ ls') rs ∷ ps) r
  with (proj₂ ∘ ∷-injective $ term-function-inj₂ r)
… | ts=ls+ps+rs with cong termsSize ts=ls+ps+rs
… | sizs with sizeFact1 ls' (ps ⊹ function x (t ∷ ts) ∷ rs)
… | siz1 rewrite siz1 | sizs with sizeFact2 ps x t ts
… | siz2 with termsSize ts | termSize t | termsSize rs | termsSize ls' | termSize (ps ⊹ function x (t ∷ ts))
… | a | b | c | d | e rewrite sizs = refute siz2 where

module Step2 where
  fact : ∀{m} (x : Fin m) p ps -> Nothing (Unifies (i x) ((p ∷ ps) ⊹ i x))
  fact x p ps f r with No-Cycle (f x) (f ◃S (p ∷ ps)) (trans r (StepM.fact2 f (i x) (p ∷ ps)))
  ... | ()

◇-assoc : ∀ {l m n o} (f : l ~> m) (g : n ~> _) (h : o ~> _) ->
               (f ◇ (g ◇ h)) ≐ ((f ◇ g) ◇ h)
◇-assoc f g h x = sym (Sub.fact2 f g (h x))

bind-assoc : ∀ {l m n o} (f : l ~> m) (g : n ~> _) (h : o ~> _) t -> (f ◇ g) ◃ (h ◃ t) ≡ (f ◇ (g ◇ h)) ◃ t
bind-assoc f g h t = sym (begin
           (f ◇ (g ◇ h)) ◃ t  ≡⟨ ◃ext (◇-assoc f g h) t ⟩
           ((f ◇ g) ◇ h) ◃ t  ≡⟨ Sub.fact2 (f ◇ g) h t ⟩
           (f ◇ g) ◃ (h  ◃ t)
                              ∎)

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 ∎

-- We use a view so that we need to handle fewer cases in the main proof
data Amgu : {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 ->
    Amgu {m} t s acc (amgu t s acc) ->   Amgu           s                       t                      acc        (amgu s t acc)
  fn-neq     : ∀ {m x y ss ts acc} -> x ≢ y →  Amgu {m} (function x ss)         (function y ts)        acc        nothing
  leaf-leaf  : ∀ {m x acc} ->            Amgu {m}       (function x [])         (function x [])        acc        (just acc)
  leaf-fork  : ∀ {m x t ts acc} ->       Amgu {m}       (function x [])         (function x (t ∷ ts))  acc        nothing
  fork-leaf  : ∀ {m x s ss acc} ->       Amgu {m}       (function x (s ∷ ss))   (function x [])        acc        nothing
  fork-fork  : ∀ {m x s ss t ts acc} →   Amgu {m}       (function x (s ∷ ss))   (function x (t ∷ ts))  acc        (amgus ss ts =<< amgu s t acc)
  var-var   : ∀ {m x y} ->               Amgu           (i x)                   (i y)                  (m , anil) (just (flexFlex x y))
  var-t : ∀ {m x t} -> i x ≢ t ->        Amgu           (i x)                   t                      (m , anil) (flexRigid x t)
  s-t : ∀{m s t n σ r z} ->              Amgu {suc m}   s                       t                      (n , σ asnoc r / z) ((λ σ -> σ ∃asnoc r / z) <$>
                                                                                amgu ((r for z) ◃ s) ((r for z) ◃ t) (n , σ))

view : ∀ {m : ℕ} -> (s t : Term m) -> (acc : ∃ (AList m)) -> Amgu s t acc (amgu s t acc)
view (function x ss) (function y ts) acc with x ≟ y
view (function x []) (function .x []) acc | yes refl = leaf-leaf
view (function x []) (function .x (x₁ ∷ ts)) acc | yes refl = leaf-fork
view (function x (x₁ ∷ ss)) (function .x []) acc | yes refl = fork-leaf
view (function x (s ∷ ss)) (function .x (t ∷ ts)) acc | yes refl = fork-fork
… | no neq = fn-neq neq
view (i x) (i x₁) (proj₃ , anil) = var-var
view (i x) (i x₁) (proj₃ , (proj₄ asnoc t' / x₂)) = s-t
view (i x) (function x₁ x₂) (proj₃ , anil) = var-t (λ ())
view (i x) (function x₁ x₂) (proj₃ , (proj₄ asnoc t' / x₃)) = s-t
view (function x x₁) (i x₂) (proj₃ , anil) = Flip refl (var-t (λ ()))
view (function x x₁) (i x₂) (proj₃ , (proj₄ asnoc t' / x₃)) = s-t

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} 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} 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-c⋆ : ∀ {m s t l ρ} -> Amgu s t (l , ρ) (amgu s t (l , ρ)) ->
           (∃ λ n → ∃ λ σ → (Max⋆ ((Unifies⋆ s t) [-◇⋆ sub ρ ])) (sub σ) × amgu {m} s t (l , ρ) ≡ just (n , σ ++ ρ ))
         ⊎ (Nothing⋆ ((Unifies⋆ s t) [-◇⋆ sub ρ ])                       × amgu {m} s t (l , ρ) ≡ nothing)
amgu-c⋆ {m} {s} {t} {l} {ρ} amg with amgu s t (l , ρ)
amgu-c⋆ {m} {l = l} {ρ} leaf-leaf | _ = inj₁ (l , anil , (refl , λ f' x → f' , λ x₁ → refl) , cong (just ∘ _,_ l) (sym $ SubList.anil-id-l ρ))
amgu-c⋆ {m} {s} {t} {l} {ρ} (Flip amguts≡amgust amguts) | _ = amgu-Ccomm⋆ t s (l , ρ) amguts≡amgust (amgu-c⋆ amguts)
amgu-c⋆ {m} {l = l} {ρ} (fn-neq x₁) | _ = inj₂ ((λ f x → x₁ (term-function-inj₁ x)) , refl)
amgu-c⋆ {m} {l = l} {ρ} leaf-fork | _ = inj₂ ((λ f x → case term-function-inj₂ x of λ ()) , refl)
amgu-c⋆ {m} {l = l} {ρ} fork-leaf | _ = inj₂ (((λ f x → case term-function-inj₂ x of λ ()) , refl))
amgu-c⋆ {m} {function x1 (s1 ∷ s1s)} {function .x1 (t1 ∷ t1s)} {l = l} {ρ} fork-fork | _
  with amgu s1 t1 (l , ρ)  | amgu-c⋆ $ view s1 t1 (l , ρ)
… | nothing | inj₂ (nounify , refl) = inj₂ ((λ {n} f x → {!!}) , refl)
{-
  where
    P = Unifies⋆ (function x1 (s1 ∷ s1s)) (function x1 (t1 ∷ t1s))
    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
-}
… | just x | (inj₁ x₁) = {!!}
… | nothing | inj₁ (_ , _ , _ , ())
… | just x | (inj₂ (_ , ()))
amgu-c⋆ {m} var-var | _ = {!!}
amgu-c⋆ {m} {t = t} (var-t x₁) | _ = {!!}
amgu-c⋆ {s = s} {t} {l} s-t | _ = {!!}
-- 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⋆ leaf-fork | .nothing = 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₂ ((λ {_} -> No[Q◇ρ]→No[P◇ρ] No[Q◇ρ]) , refl)
--   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

-- ... | .(just (n , σ ++ ρ)) | inj₁ (n , σ , a , refl)
--  with amgu s2 t2 (n , σ ++ ρ) | amgu-c⋆ (view s2 t2 (n , (σ ++ ρ)))
-- ... | .nothing                | inj₂ (nounify , refl) = inj₂ ( (λ {_} -> No[Q◇ρ]→No[P◇ρ]⋆ No[Q◇ρ]⋆) , refl)
--     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 σ ρ))
-- {-
--     No[Q◇ρ]⋆ = failure-propagation.second (sub ρ) (sub σ) (Unifies s1 t1) (Unifies s2 t2) a
-- --       (λ f Unifs2t2-f◇σ◇ρ → nounify f ((π₂ (Unifies s2 t2) (λ t → cong (f ◃) (sym (SubList.fact1 σ ρ t))) Unifs2t2-f◇σ◇ρ)))
-- --       (λ f → nounify f ∘ π₂ (Unifies s2 t2) (λ t → cong (f ◃) (sym (SubList.fact1 σ ρ t))))
--        (λ f → nounify f ∘ π₂ (Unifies s2 t2) (cong (f ◃) ∘ sym ∘ SubList.fact1 σ ρ))
-- -}
--     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 Unifs2t2-f◇σ◇ρ → nounify f (π₂ (Unifies s2 t2) (λ t → cong (f ◃) (sym (SubList.fact1 σ ρ t))) Unifs2t2-f◇σ◇ρ))

-- ... | .(just (n1 , σ1 ++ (σ ++ ρ))) | inj₁ (n1 , σ1 , b , refl)
--     = inj₁ (n1 , σ1 ++ σ , Max[P∧Q◇ρ][σ1++σ] , cong (λ σ -> just (n1 , σ)) (++-assoc σ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)))

-- 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₂ ( (λ {_} -> No-Unifier )  , refl)
--   where
--     No-Unifier : {n : ℕ} (f : Fin (suc l) → Term n) → f x ≡ f ◃ t → ⊥
--     No-Unifier f fx≡f◃t = ix≢t (sym (trans r (cong (λ ps -> ps ⊹ i x) ps≡[])))
--           where
--             ps≡[] : ps ≡ []
--             ps≡[] = map-[] f ps (No-Cycle (f x) ((f ◃S) ps)
--                   (begin f x             ≡⟨ fx≡f◃t ⟩
--                          f ◃ t           ≡⟨ cong (f ◃) r ⟩
--                          f ◃ (ps ⊹ i x)  ≡⟨ StepM.fact2 f (i x) ps ⟩
--                          (f ◃S) ps ⊹ f x ∎))

-- ... | .(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₂ ( (λ {_} -> NoQ→NoP nounify) , cong (_<$>_ (λ x' → x' ∃asnoc r / z)) ra )
--       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))
-- ... | inj₁ (n , σ , a , ra)  = inj₁ (n , σ , proj₂ (MaxP⇔MaxQ (sub σ)) a , cong (_<$>_ (λ x' → x' ∃asnoc r / z)) ra)
--       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)
-- 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))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.Rationals.SigmaQ.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism

open import Cubical.HITs.Ints.QuoInt
import Cubical.HITs.SetQuotients as SetQuotient

open import Cubical.Data.Nat as ℕ hiding (_·_)
open import Cubical.Data.NatPlusOne
open import Cubical.Data.Sigma

open import Cubical.Data.Nat.GCD
open import Cubical.Data.Nat.Coprime

open import Cubical.HITs.Rationals.QuoQ as Quo using (ℕ₊₁→ℤ)
import Cubical.HITs.Rationals.SigmaQ.Base as Sigma

reduce : Quo.ℚ → Sigma.ℚ
reduce = SetQuotient.rec Sigma.isSetℚ Sigma.[_]
  (λ { (a , b) (c , d) p →   sym (Sigma.[]-cancelʳ (a , b) d)
                           ∙ (λ i → Sigma.[ p i , ·₊₁-comm b d i ])
                           ∙ Sigma.[]-cancelʳ (c , d) b })

private
  toCoprime-eq₁ : ∀ s ((a , b) : ℕ × ℕ₊₁)
                  → signed s (toCoprime (a , b) .fst) · ℕ₊₁→ℤ b
                  ≡ signed s a · ℕ₊₁→ℤ (toCoprime (a , b) .snd)
  toCoprime-eq₁ s (a , b) =
    signed s c₁ · ℕ₊₁→ℤ b              ≡⟨ ·-signed-pos c₁ (ℕ₊₁→ℕ b) ⟩
    signed s (c₁ ℕ.· ℕ₊₁→ℕ b)          ≡[ i ]⟨ signed s (c₁ ℕ.· p₂ (~ i)) ⟩
    signed s (c₁ ℕ.· (ℕ₊₁→ℕ c₂ ℕ.· d)) ≡[ i ]⟨ signed s (c₁ ℕ.· ℕ.·-comm (ℕ₊₁→ℕ c₂) d i) ⟩
    signed s (c₁ ℕ.· (d ℕ.· ℕ₊₁→ℕ c₂)) ≡[ i ]⟨ signed s (ℕ.·-assoc c₁ d (ℕ₊₁→ℕ c₂) i) ⟩
    signed s ((c₁ ℕ.· d) ℕ.· ℕ₊₁→ℕ c₂) ≡[ i ]⟨ signed s (p₁ i ℕ.· ℕ₊₁→ℕ c₂) ⟩
    signed s (a ℕ.· ℕ₊₁→ℕ c₂)          ≡⟨ sym (·-signed-pos a (ℕ₊₁→ℕ c₂)) ⟩
    signed s a · ℕ₊₁→ℤ c₂ ∎
    where open ToCoprime (a , b)

[]-reduce : ∀ x → Quo.[ reduce x .fst ] ≡ x
[]-reduce = SetQuotient.elimProp (λ _ → Quo.isSetℚ _ _)
  (λ { (signed s a , b) → Quo.eq/ _ _ (toCoprime-eq₁ s (a , b))
     ; (posneg i , b) j → isSet→isSet' Quo.isSetℚ
         (Quo.eq/ (fst (reduce Quo.[ pos 0 , b ])) (pos 0 , b) (toCoprime-eq₁ spos (0 , b)))
         (Quo.eq/ (fst (reduce Quo.[ neg 0 , b ])) (neg 0 , b) (toCoprime-eq₁ sneg (0 , b)))
         (λ i → Quo.[ reduce (Quo.[ posneg i , b ]) .fst ]) (λ i → Quo.[ posneg i , b ]) i j })

private
  toCoprime-eq₂ : ∀ s ((a , b) : ℕ × ℕ₊₁) (cp : areCoprime (a , ℕ₊₁→ℕ b))
                  → Sigma.signedPair s (toCoprime (a , b)) ≡ Sigma.signedPair s (a , b)
  toCoprime-eq₂ s (a , b) cp i = Sigma.signedPair s (toCoprime-idem (a , b) cp i)

reduce-[] : ∀ x → reduce Quo.[ x .fst ] ≡ x
     -- equivalent to: Sigma.[ s .fst ] ≡ x
reduce-[] ((signed s a , b) , cp) =
  Σ≡Prop (λ _ → isPropIsGCD) (toCoprime-eq₂ s (a , b) cp)
reduce-[] ((posneg i , b) , cp) j =
  isSet→isSet' Sigma.isSetℚ
    (Σ≡Prop (λ _ → isPropIsGCD) (toCoprime-eq₂ spos (0 , b) cp))
    (Σ≡Prop (λ _ → isPropIsGCD) (toCoprime-eq₂ sneg (0 , b) cp))
    (λ i → Sigma.[ posneg i , b ]) (λ i → (posneg i , b) , cp) i j

Quoℚ-iso-Sigmaℚ : Iso Quo.ℚ Sigma.ℚ
Iso.fun Quoℚ-iso-Sigmaℚ = reduce
Iso.inv Quoℚ-iso-Sigmaℚ = Quo.[_] ∘ fst
Iso.rightInv Quoℚ-iso-Sigmaℚ = reduce-[]
Iso.leftInv  Quoℚ-iso-Sigmaℚ = []-reduce

Quoℚ≃Sigmaℚ : Quo.ℚ ≃ Sigma.ℚ
Quoℚ≃Sigmaℚ = isoToEquiv Quoℚ-iso-Sigmaℚ

Quoℚ≡Sigmaℚ : Quo.ℚ ≡ Sigma.ℚ
Quoℚ≡Sigmaℚ = isoToPath Quoℚ-iso-Sigmaℚ


{-# OPTIONS --cubical #-}
module Cubical.README where

------------------------------------------------------------------------
-- An experimental library for Cubical Agda
-----------------------------------------------------------------------

-- The library comes with a .agda-lib file, for use with the library
-- management system.

------------------------------------------------------------------------
-- Module hierarchy
------------------------------------------------------------------------

-- The core library for Cubical Agda.
-- It contains basic primitives, equivalences, glue types.
import Cubical.Core.Everything

-- The foundations for Cubical Agda.
-- The Prelude module is self-explanatory.
import Cubical.Foundations.Prelude
import Cubical.Foundations.Everything

-- Data types and properties
import Cubical.Data.Everything

-- Properties and proofs about relations
import Cubical.Relation.Everything

-- Higher-inductive types
import Cubical.HITs.Everything

-- Coinductive data types and properties
import Cubical.Codata.Everything

-- Various experiments using Cubical Agda
import Cubical.Experiments.Everything


------------------------------------------------------------------------
-- The Agda standard library
--
-- This module is DEPRECATED. Please use the
-- Relation.Binary.Reasoning.PartialOrder module directly.
------------------------------------------------------------------------

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

open import Relation.Binary

module Relation.Binary.PartialOrderReasoning
         {p₁ p₂ p₃} (P : Poset p₁ p₂ p₃) where

open import Relation.Binary.Reasoning.PartialOrder P public


{-# OPTIONS --without-K #-}
module function.extensionality.strong where

open import level
open import sum
open import function.core
open import equality.core
open import function.isomorphism
open import function.extensionality.core
open import function.extensionality.proof
open import hott.level.core
open import hott.level.closure.core
open import hott.equivalence.core

private
  module Dummy {i j}{X : Set i}{Y : X → Set j} where
    _~_ : (f g : (x : X) → Y x) → Set (i ⊔ j)
    f ~ g = ∀ x → f x ≡ g x
    infix 5 _~_

    R : (f : (x : X) → Y x) → f ~ f
    R f x = refl

    iso₁ : {f g : (x : X) → Y x} (p : f ≡ g)
         → funext (funext-inv p) ≡ p
    iso₁ {f} refl = funext-id f

    iso₂ : (f g : (x : X) → Y x) (h : f ~ g)
         → funext-inv (funext h) ≡ h
    iso₂ f g h = subst (λ {(g , h) → funext-inv (funext h) ≡ h})
                       (e-contr' (g , h))
                       strong-id
      where
        E : Set (i ⊔ j)
        E = Σ ((x : X) → Y x) λ g → f ~ g

        e-contr : contr E
        e-contr = retract-level
          (λ u → proj₁ ∘' u , proj₂ ∘' u)
          (λ {(g , h) x → g x , h x})
          (λ {(g , h) → refl})
          (Π-contr (λ x → singl-contr (f x)))

        e-contr' : (u : E) → (f , R f) ≡ u
        e-contr' u = contr⇒prop e-contr (f , R f) u

        strong-id : funext-inv (funext (R f)) ≡ R f
        strong-id = ap funext-inv (funext-id f)

    strong-funext-iso : {f g : (x : X) → Y x}
                   → (f ~ g) ≅ (f ≡ g)
    strong-funext-iso {f}{g} = iso funext funext-inv (iso₂ f g) iso₁

    strong-funext : {f g : (x : X) → Y x} → (f ~ g) ≡ (f ≡ g)
    strong-funext = ≅⇒≡ strong-funext-iso

open Dummy public using (strong-funext; strong-funext-iso)


module HasNegation where

record HasNegation (A : Set) : Set
 where
  field
    ~ : A → A

open HasNegation ⦃ … ⦄ public

{-# DISPLAY HasNegation.~ _ = ~ #-}


{-# OPTIONS --erased-cubical --safe --no-sized-types --no-guardedness
            --no-subtyping #-}

module Agda.Builtin.Cubical.HCompU where

open import Agda.Primitive
open import Agda.Builtin.Sigma
open import Agda.Primitive.Cubical renaming (primINeg to ~_; primIMax to _∨_; primIMin to _∧_;
                                             primHComp to hcomp; primTransp to transp; primComp to comp;
                                             itIsOne to 1=1)
open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Cubical.Sub renaming (Sub to _[_↦_]; primSubOut to outS; inc to inS)

module Helpers where
    -- Homogeneous filling
    hfill : ∀ {ℓ} {A : Set ℓ} {φ : I}
              (u : ∀ i → Partial φ A)
              (u0 : A [ φ ↦ u i0 ]) (i : I) → A
    hfill {φ = φ} u u0 i =
      hcomp (λ j → \ { (φ = i1) → u (i ∧ j) 1=1
                     ; (i = i0) → outS u0 })
            (outS u0)

    -- Heterogeneous filling defined using comp
    fill : ∀ {ℓ : I → Level} (A : ∀ i → Set (ℓ i)) {φ : I}
             (u : ∀ i → Partial φ (A i))
             (u0 : A i0 [ φ ↦ u i0 ]) →
             ∀ i →  A i
    fill A {φ = φ} u u0 i =
      comp (λ j → A (i ∧ j))
           (λ j → \ { (φ = i1) → u (i ∧ j) 1=1
                    ; (i = i0) → outS u0 })
           (outS {φ = φ} u0)

    module _ {ℓ} {A : Set ℓ} where
      refl : {x : A} → x ≡ x
      refl {x = x} = λ _ → x

      sym : {x y : A} → x ≡ y → y ≡ x
      sym p = λ i → p (~ i)

      cong : ∀ {ℓ'} {B : A → Set ℓ'} {x y : A}
             (f : (a : A) → B a) (p : x ≡ y)
           → PathP (λ i → B (p i)) (f x) (f y)
      cong f p = λ i → f (p i)

    isContr : ∀ {ℓ} → Set ℓ → Set ℓ
    isContr A = Σ A \ x → (∀ y → x ≡ y)

    fiber : ∀ {ℓ ℓ'} {A : Set ℓ} {B : Set ℓ'} (f : A → B) (y : B) → Set (ℓ ⊔ ℓ')
    fiber {A = A} f y = Σ A \ x → f x ≡ y

open Helpers

primitive
  prim^glueU : {la : Level} {φ : I} {T : I → Partial φ (Set la)}
                 {A : Set la [ φ ↦ T i0 ]} →
                 PartialP φ (T i1) → outS A → hcomp T (outS A)
  prim^unglueU : {la : Level} {φ : I} {T : I → Partial φ (Set la)}
                   {A : Set la [ φ ↦ T i0 ]} →
                   hcomp T (outS A) → outS A
  -- Needed for transp.
  primFaceForall : (I → I) → I

transpProof : ∀ {l} → (e : I → Set l) → (φ : I) → (a : Partial φ (e i0)) → (b : e i1 [ φ ↦ (\ o → transp (\ i → e i) i0 (a o)) ] ) → fiber (transp (\ i → e i) i0) (outS b)
transpProof e φ a b = f , \ j → comp (\ i → e i) (\ i →
                                               \ { (φ = i1) → transp (\ j → e (j ∧ i)) (~ i) (a 1=1)
                                                 ; (j = i0) → transp (\ j → e (j ∧ i)) (~ i) f
                                                 ; (j = i1) → g (~ i) })
                                        f
    where
      b' = outS {u = (\ o → transp (\ i → e i) i0 (a o))} b
      g : (k : I) → e (~ k)
      g k = fill (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1)
                                          ; (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) b' }) (inS b') k
      f = comp (\ i → e (~ i)) (\ i → \ { (φ = i1) → transp (\ j → e (j ∧ ~ i)) i (a 1=1); (φ = i0) → transp (\ j → e (~ j ∨ ~ i)) (~ i) b' }) b'

{-# BUILTIN TRANSPPROOF transpProof #-}


-- 2012-03-15, example by Nisse
module Issue585-11 where

data D₁ : Set where
  d₁ : D₁

f₁ : D₁ → D₁ → D₁
f₁ x d₁ = x

data D₂ : Set where
  d₂ : D₂ → D₂

postulate
  P  : D₁ → Set
  f₂ : ∀ {n₁ n₂} → P n₁ → P n₂ → P (f₁ n₁ n₂)

mutual

  f₃ : D₁ → D₂ → D₁
  f₃ _ (d₂ _) = _

  f₄ : ∀ {n} → P n → (i : D₂) → P (f₃ n i)
  f₄ p (d₂ i) = f₂ p (f₄ p i)

-- This worked until Agda 2.3.0
-- Now, recursive solutions  [here: f₃ n (d₂ i) = f₁ n (f₃ n i)]
-- are no longer found, since termination is not be guaranteed by the occurs check.


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

open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; refl; cong)
open import Function using (_∘_)

import Data.Empty as Empty
import Data.Product as Product
import Data.Product.Properties as Productₚ
import Data.Unit as Unit
import Data.Nat as Nat
import Data.Vec as Vec
import Data.Vec.Properties as Vecₚ
import Data.Bool as Bool
import Data.Fin as Fin
import Data.Vec.Relation.Unary.All as All

open Empty using (⊥-elim)
open Nat using (ℕ; zero; suc)
open Vec using (Vec; []; _∷_)
open All using (All; []; _∷_)
open Fin using (Fin ; zero ; suc)
open Product using (_,_; proj₁; proj₂)

import PiCalculus.Syntax
open PiCalculus.Syntax.Scoped
open import PiCalculus.Semantics
open import PiCalculus.LinearTypeSystem.Algebras

module PiCalculus.LinearTypeSystem.Strengthening (Ω : Algebras) where
open Algebras Ω
open import PiCalculus.LinearTypeSystem Ω
open import PiCalculus.LinearTypeSystem.ContextLemmas Ω

private
  variable
    n : ℕ
    idxs : Idxs n
    idx idx' : Idx
    t t' : Type
    i j : Fin n
    P Q : Scoped n

∋-strengthen : {γ : PreCtx (suc n)} {idxs : Idxs (suc n)} {Γ Θ : Ctx idxs} {m' : Usage idx' ²}
             → (i : Fin (suc n))
             → (i≢j : i ≢ j)
             → γ              ； Γ              ∋[ j ] t' ； m' ▹ Θ
             → Vec.remove γ i ； ctx-remove Γ i ∋[ Fin.punchOut i≢j ] t' ； m' ▹ ctx-remove Θ i
∋-strengthen zero i≢x (zero , zero _) = ⊥-elim (i≢x refl)
∋-strengthen zero i≢x (suc t , suc x) = t , x
∋-strengthen {γ = _ -, _ -, _} {_ -, _ -, _} {_ -, _ -, _} (suc i) i≢x (zero , zero xyz) = zero , zero xyz
∋-strengthen {γ = _ -, _ -, _} {_ -, _ -, _} {_ -, _ -, _} {_ -, _ -, _} (suc i) i≢x (suc t , suc x) = there (∋-strengthen i (i≢x ∘ cong suc) (t , x))

⊢-strengthen : {P : Scoped (suc n)} {γ : PreCtx (suc n)} {idxs : Idxs (suc n)} {Γ Θ : Ctx idxs}
             → (i : Fin (suc n))
             → (uP : Unused i P)
             → γ ； Γ ⊢ P ▹ Θ
             → Vec.remove γ i ； ctx-remove Γ i ⊢ lower i P uP ▹ ctx-remove Θ i
⊢-strengthen i uP 𝟘 = 𝟘
⊢-strengthen {γ = _ -, _} {Γ = _ -, _} {Θ = _ -, _} i uP (ν t m μ ⊢P)
  = ν t m μ (⊢-strengthen (suc i) uP ⊢P)
⊢-strengthen {γ = _ -, _} {Γ = _ -, _} {Θ = _ -, _} i (i≢x , uP) (_⦅⦆_ {Ξ = _ -, _} x ⊢P)
  = ∋-strengthen i i≢x x ⦅⦆ ⊢-strengthen (suc i) uP ⊢P
⊢-strengthen {γ = _ -, _} i (i≢x , i≢y , uP) (x ⟨ y ⟩ ⊢P)
  = ∋-strengthen i i≢x x ⟨ ∋-strengthen i i≢y y ⟩ ⊢-strengthen i uP ⊢P
⊢-strengthen {γ = _ -, _} i (uP , uQ) (⊢P ∥ ⊢Q)
  = ⊢-strengthen i uP ⊢P ∥ ⊢-strengthen i uQ ⊢Q


{-# OPTIONS --cubical --safe --postfix-projections #-}

module Relation.Nullary.Decidable.Base where

open import Level
open import Data.Bool
open import Data.Empty

data Reflects {a} (A : Type a) : Bool → Type a where
  ofʸ  : (p   :    A) → Reflects A true
  ofⁿ  : (¬p  : ¬  A) → Reflects A false

record Dec {a} (A : Type a) : Type a where
  constructor _because_
  field
    does  : Bool
    why   : Reflects A does
open Dec public

pattern yes p  = true   because ofʸ p
pattern no ¬p  = false  because ofⁿ ¬p

map-reflects : ∀ {d} → (A → B) → (¬ A → ¬ B) → Reflects A d → Reflects B d
map-reflects to fro (ofʸ p) = ofʸ (to p)
map-reflects to fro (ofⁿ ¬p) = ofⁿ (fro ¬p)

map-dec : (A → B) → (¬ A → ¬ B) → Dec A → Dec B
map-dec to fro dec .does = dec .does
map-dec to fro dec .why = map-reflects to fro (dec .why)

⟦yes_,no_⟧ : (A → B) → (B → A) → Dec A → Dec B
⟦yes to ,no fro ⟧ = map-dec to λ ¬A ¬B → ¬A (fro ¬B)

∣_∣yes⇒_∣no⇒_ : Dec A → (A → B) → (¬ A → ¬ B) → Dec B
∣ d ∣yes⇒ y ∣no⇒ n = map-dec y n d


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

module Data.Sigma where

open import Data.Sigma.Base public


------------------------------------------------------------------------
-- Various utility functions
------------------------------------------------------------------------

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

module Utilities where

open import Data.Bool
open import Data.Bool.Properties using (T-∧)
open import Data.Char
import Data.Char.Properties as Char
open import Data.List
open import Data.List.NonEmpty as List⁺
open import Data.Nat
import Data.Nat.Properties as NP
open import Data.Product
open import Data.String as String using (String)
open import Function
open import Function.Equality using (_⟨$⟩_)
open import Function.Equivalence
  using () renaming (module Equivalence to Eq)
open import Relation.Binary
import Relation.Binary.Properties.StrictTotalOrder as STO
open import Relation.Nullary.Decidable

------------------------------------------------------------------------
-- Some comparison operators

-- Is one number strictly smaller than another?

_<?ℕ_ : ℕ → ℕ → Bool
n₁ <?ℕ n₂ = ⌊ n₁ NP.<? n₂ ⌋

-- Is one character smaller than or equal to another?

_≤?C_ : Char → Char → Bool
c₁ ≤?C c₂ = ⌊ DecTotalOrder._≤?_
                (STO.decTotalOrder Char.<-strictTotalOrder)
                c₁ c₂ ⌋

------------------------------------------------------------------------
-- Conversion of strings satisfying given predicates to annotated
-- lists

private
  mutual

    str′ : {p : Char → Bool}
           (s : List Char) → T (all p s) → List (∃ (T ∘ p))
    str′ []       _  = []
    str′ (t ∷ ts) ok = List⁺.toList (str⁺′ (t ∷ ts) ok)

    str⁺′ : {p : Char → Bool}
            (s : List⁺ Char) → T (all p (List⁺.toList s)) →
            List⁺ (∃ (T ∘ p))
    str⁺′ (t ∷ ts) ok =
      let (ok₁ , ok₂) = Eq.to T-∧ ⟨$⟩ ok in
      (t , ok₁) ∷ str′ ts ok₂

str : {p : Char → Bool}
      (s : String)
      {ok : T (all p $ String.toList s)} →
      List (∃ (T ∘ p))
str s {ok} = str′ (String.toList s) ok

str⁺ : {p : Char → Bool}
       (s : String)
       {ok₁ : T (all p $ String.toList s)}
       {ok₂ : T (not $ null $ String.toList s)} →
       List⁺ (∃ (T ∘ p))
str⁺ s {ok₂ = _} with String.toList s
str⁺ s {ok₂ = ()} | []
str⁺ s {ok₁ = ok} | c ∷ cs = str⁺′ (c ∷ cs) ok


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

module Reasoning where

open import PiFrac

------------------------------------------------------------------------------
-- Useful for examples

infixr 2  _⟷⟨_⟩_
infix  3  _□

_⟷⟨_⟩_ : (t₁ : 𝕌) {t₂ : 𝕌} {t₃ : 𝕌} →
          (t₁ ⟷ t₂) → (t₂ ⟷ t₃) → (t₁ ⟷ t₃)
_ ⟷⟨ α ⟩ β = α ⊚ β

_□ : (t : 𝕌) → {t : 𝕌} → (t ⟷ t)
_□ t = id⟷

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


open import MLib.Finite

module MLib.Finite.Properties {c ℓ} (finiteSet : FiniteSet c ℓ) where

open import MLib.Prelude
import Data.Fin.Permutation as Perm

import Relation.Binary as B

open FE using (cong)
open LeftInverse using () renaming (_∘_ to _ⁱ∘_)

open Algebra using (IdempotentCommutativeMonoid)
open Table hiding (setoid)

open FiniteSet finiteSet renaming (Carrier to A)

private
  enumₜAt : ∀ {N} → OntoFin N → Table A N
  enumₜAt = tabulate ∘ _⟨$⟩_ ∘ LeftInverse.from

module _ {c ℓ} (icMonoid : IdempotentCommutativeMonoid c ℓ) where
  module S = IdempotentCommutativeMonoid icMonoid
  open S using (_∙_; ∙-cong) renaming (Carrier to S; _≈_ to _≈′_)
  open import Algebra.Operations.CommutativeMonoid S.commutativeMonoid
  open import Algebra.Properties.CommutativeMonoid S.commutativeMonoid

  foldMap : (A → S) → S
  foldMap f = sumₜ (Table.map f enumₜ)

  foldMap-cong : ∀ {f g} → (∀ x → f x ≈′ g x) → foldMap f ≈′ foldMap g
  foldMap-cong p = sumₜ-cong-≈ (p ∘ lookup enumₜ)

  private
    inhabited : ∀ {N} (i : Fin N) → ∃ λ n → N ≡ Nat.suc n
    inhabited Fin.zero = _ , ≡.refl
    inhabited (Fin.suc i) = _ , ≡.refl

  -- Folding with a constant function produces the constant.

  foldMap-const : ∀ {x} → x ∙ foldMap (λ _ → x) ≈′ x
  foldMap-const {x} =
    begin
      x ∙ foldMap (λ _ → x)                  ≡⟨⟩
      x ∙ sumₜ (Table.map (λ _ → x) enumₜ)   ≡⟨⟩
      x ∙ sumₜ (Table.replicate {N} x)       ≡⟨⟩
      sumₜ (Table.replicate {Nat.suc N} x)   ≈⟨ sumₜ-idem-replicate N (S.idem x) ⟩
      x                                      ∎
    where open EqReasoning S.setoid

  private
    module _ {n : ℕ} (ontoFin′ : OntoFin (Nat.suc n)) where
      from = LeftInverse.from ontoFin′ ⟨$⟩_
      to = LeftInverse.to ontoFin′ ⟨$⟩_
      from-to = LeftInverse.left-inverse-of ontoFin′

      enumₜ′ : Table A (Nat.suc n)
      enumₜ′ = enumₜAt ontoFin′

      ap : setoid ⟶ S.setoid → A → S
      ap = _⟨$⟩_

      enumₜ-complete′ : ∀ (func : setoid ⟶ S.setoid) x → (func ⟨$⟩ x) ∙ sumₜ (map (ap func) enumₜ′) ≈′ sumₜ (map (ap func) enumₜ′)
      enumₜ-complete′ func x =
        begin
          f x ∙ sumₜ (map f enumₜ′)                                        ≈⟨ ∙-cong S.refl (sumₜ-permute (map f enumₜ′) (Perm.transpose Fin.zero i)) ⟩
          f x ∙ sumₜ (permute (Perm.transpose Fin.zero i) (map f enumₜ′))  ≡⟨⟩
          f x ∙ (f (from (to x)) ∙ _)                                      ≈⟨ ∙-cong S.refl (∙-cong (cong func (from-to _)) S.refl) ⟩
          f x ∙ (f x ∙ _)                                                  ≈⟨ S.sym (S.assoc _ _ _) ⟩
          (f x ∙ f x) ∙ _                                                  ≈⟨ ∙-cong (S.idem _) S.refl ⟩
          f x ∙ _                                                          ≈⟨ ∙-cong (cong func (sym (from-to _))) S.refl ⟩
          f (from (to x)) ∙ _                                              ≡⟨⟩
          sumₜ (permute (Perm.transpose Fin.zero i) (map f enumₜ′))        ≈⟨ S.sym (sumₜ-permute (map f enumₜ′) (Perm.transpose Fin.zero i)) ⟩
          sumₜ (map f enumₜ′)                                              ∎
        where
          f = ap func
          i = to x

          open EqReasoning S.setoid

  private
    enumₜ-complete′′ :
      ∀ {N} (ontoFin′ : OntoFin N) (f : setoid ⟶ S.setoid) x
      → (f ⟨$⟩ x) ∙ sumₜ (Table.map (f ⟨$⟩_) (enumₜAt ontoFin′))
        ≈′ sumₜ (Table.map (f ⟨$⟩_) (enumₜAt ontoFin′))
    enumₜ-complete′′ ontoFin′ f x with inhabited (LeftInverse.to ontoFin′ ⟨$⟩ x)
    enumₜ-complete′′ ontoFin′ f x | n , ≡.refl = enumₜ-complete′ ontoFin′ f x

    sum/map-hom : ∀ {n} {a}{A : Set a} (f : A → S) (t : Table A n) → sumₗ (List.map f (toList t)) ≡ sumₜ (map f t)
    sum/map-hom f t =
      begin
        sumₗ (List.map f (toList t))   ≡⟨ ≡.cong sumₗ (Table.map-toList-hom t) ⟩
        sumₗ (toList (map f t))        ≡⟨ ≡.sym (sumₜ-toList (map f t)) ⟩
        sumₜ (map f t)                 ∎
      where
        open ≡.Reasoning

  -- Enumeration is complete: in any idempotent commutative monoid, adding one
  -- more element to the sum won't change it. In particular, this works in the
  -- powerset monoid, where 'f' is the singleton at its argument and addition
  -- is set union. This shows that every member of 'A' is present in the
  -- enumeration (even though the powerset monoid is quite difficult to
  -- implement in Agda so this proof is not present).

  enumₜ-complete : ∀ f x → (f ⟨$⟩ x) ∙ foldMap (f ⟨$⟩_) ≈′ foldMap (f ⟨$⟩_)
  enumₜ-complete = enumₜ-complete′′ ontoFin

  enumₗ-complete : ∀ (f : setoid ⟶ S.setoid) x → (f ⟨$⟩ x) ∙ sumₗ (List.map (f ⟨$⟩_) enumₗ) ≈′ sumₗ (List.map (f ⟨$⟩_) enumₗ)
  enumₗ-complete func x =
    begin
      f x ∙ sumₗ (List.map f enumₗ)           ≡⟨⟩
      f x ∙ sumₗ (List.map f (toList enumₜ))  ≡⟨ ≡.cong₂ _∙_ ≡.refl (sum/map-hom f enumₜ) ⟩
      f x ∙ sumₜ (map f enumₜ)                ≈⟨ enumₜ-complete func x ⟩
      sumₜ (map f enumₜ)                      ≡⟨ ≡.sym (sum/map-hom f enumₜ) ⟩
      sumₗ (List.map f enumₗ)                 ∎
    where
      f = func ⟨$⟩_
      open EqReasoning S.setoid

-- A finite set can be strictly totally ordered by its elements' indices

Ixorder : B.StrictTotalOrder _ _ _
Ixorder = record
  { _≈_ = _≈_
  ; _<_ = λ x y → toIx x Fin.< toIx y
  ; isStrictTotalOrder = record
    { isEquivalence = isEquivalence
    ; trans = Fin.<-trans
    ; compare = compare
    }
  }
  where
  compare : Trichotomous _≈_ (λ x y → toIx x Fin.< toIx y)
  compare x y with B.StrictTotalOrder.compare (Fin.<-strictTotalOrder N) (toIx x) (toIx y)
  compare x y | B.tri< a ¬b ¬c = B.tri< a (¬b ∘ cong (LeftInverse.to ontoFin)) ¬c
  compare x y | B.tri≈ ¬a b ¬c = B.tri≈ ¬a (LeftInverse.injective ontoFin b) ¬c
  compare x y | B.tri> ¬a ¬b c = B.tri> ¬a (¬b ∘ cong (LeftInverse.to ontoFin)) c

-- Equality between members of a finite set is decidable.

_≟_ : B.Decidable _≈_
_≟_ = B.StrictTotalOrder._≟_ Ixorder


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.GradedRing.Base where

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

open import Cubical.Algebra.Monoid
open import Cubical.Algebra.AbGroup
open import Cubical.Algebra.Ring

open import Cubical.Algebra.GradedRing.DirectSumHIT

private variable
  ℓ ℓ' : Level

open AbGroupStr
open GradedRing-⊕HIT-index
open GradedRing-⊕HIT-⋆

-----------------------------------------------------------------------------
-- Definition

record IsGradedRing (R    : Ring (ℓ-max ℓ ℓ'))
                    (IdM  : Monoid ℓ)
                    (G    : (k : (fst IdM)) → Type ℓ')
                    (Gstr : (k : fst IdM) → AbGroupStr (G k))
                    (1⋆   : G (MonoidStr.ε (snd IdM)))
                    (_⋆_  : {k l : fst IdM} → G k → G l → G (MonoidStr._·_ (snd IdM) k l))
                    : Type (ℓ-max ℓ ℓ')
                    where

  constructor isgradedring

  private
    Idx = fst IdM
    open MonoidStr (snd IdM)

  field
    0-⋆     : {k l : Idx} → (b : G l) → (0g (Gstr k)) ⋆ b ≡ 0g (Gstr (k · l))
    ⋆-0     : {k l : Idx} → (a : G k) → a ⋆ (0g (Gstr l)) ≡ 0g (Gstr (k · l))
    ⋆Assoc  : {k l m : Idx} → (a : G k) → (b : G l) → (c : G m) →
              ((k · (l · m)) , (a ⋆ (b ⋆ c))) ≡ (((k · l) · m) , ((a ⋆ b) ⋆ c))
    ⋆IdR    : {k : Idx} → (a : G k) → ( k · ε , a ⋆ 1⋆ ) ≡ (k , a)
    ⋆IdL    : {l : Idx} → (b : G l) → ( ε · l , 1⋆ ⋆ b ) ≡ (l , b)
    ⋆DistR+ : {k l : Idx} → (a : G k) → (b c : G l) →
              a ⋆ ((Gstr l) ._+_ b c) ≡ Gstr (k · l) ._+_ (a ⋆ b) (a ⋆ c)
    ⋆DistL+ : {k l : Idx} → (a b : G k) → (c : G l) →
              ((Gstr k) ._+_ a b) ⋆ c ≡ Gstr (k · l) ._+_ (a ⋆ c) (b ⋆ c)
    equivRing : RingEquiv R (⊕HITgradedRing-Ring IdM G Gstr 1⋆ _⋆_
                             0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+)

record GradedRingStr (R : Ring (ℓ-max ℓ ℓ')) : Type (ℓ-suc (ℓ-max ℓ ℓ')) where

  constructor gradedringstr

  field
    IdM  : Monoid ℓ
    G    : (k : (fst IdM)) → Type ℓ'
    Gstr : (k : fst IdM) → AbGroupStr (G k)
    1⋆   : G (MonoidStr.ε (snd IdM))
    _⋆_  : {k l : fst IdM} → G k → G l → G (MonoidStr._·_ (snd IdM) k l)
    isGradedRing : IsGradedRing R IdM G Gstr 1⋆ _⋆_

  open IsGradedRing isGradedRing public

GradedRing : ∀ ℓ ℓ' → Type (ℓ-suc (ℓ-max ℓ ℓ'))
GradedRing ℓ ℓ' = Σ[ R ∈ Ring (ℓ-max ℓ ℓ') ] GradedRingStr R

-----------------------------------------------------------------------------
-- make

open MonoidStr

makeIsGradedRing : {R : Ring (ℓ-max ℓ ℓ')} {IdM : Monoid ℓ}
                   {G       : (k : (fst IdM)) → Type ℓ'}
                   {Gstr    : (k : fst IdM) → AbGroupStr (G k)}
                   {1⋆      : G (ε (snd IdM))}
                   {_⋆_     : {k l : fst IdM} → G k → G l → G (_·_ (snd IdM) k l)}
                   (0-⋆     : {k l : fst IdM} (b : G l) → (0g (Gstr k) ⋆ b) ≡ 0g (Gstr ((snd IdM MonoidStr.· k) l)))
                   (⋆-0     : {k l : fst IdM} (a : G k) → (a ⋆ 0g (Gstr l)) ≡ 0g (Gstr ((snd IdM MonoidStr.· k) l)))
                   (⋆Assoc  : {k l m : fst IdM} (a : G k) (b : G l) (c : G m) →
                                 (((snd IdM ._·_ k) ((snd IdM ._·_ l) m) , (a ⋆ (b ⋆ c))))
                               ≡ ((snd IdM ._·_ ((snd IdM ._·_ k) l) m) , ((a ⋆ b) ⋆ c)))
                   (⋆IdR    : {k : fst IdM} → (a : G k) → ( snd IdM ._·_ k (snd IdM .ε) , a ⋆ 1⋆ ) ≡ (k , a))
                   (⋆IdL    : {l : fst IdM} → (b : G l) → ( snd IdM ._·_ (snd IdM .ε) l , 1⋆ ⋆ b ) ≡ (l , b))
                   (⋆DistR+ : {k l : fst IdM} → (a : G k) → (b c : G l) →
                              a ⋆ ((Gstr l) ._+_ b c) ≡ Gstr (snd IdM ._·_ k l) ._+_ (a ⋆ b) (a ⋆ c))
                   (⋆DistL+ : {k l : fst IdM} → (a b : G k) → (c : G l) →
                              ((Gstr k) ._+_ a b) ⋆ c ≡ Gstr (snd IdM ._·_ k l) ._+_ (a ⋆ c) (b ⋆ c))
                   (equivRing : RingEquiv R (⊕HITgradedRing-Ring IdM G Gstr 1⋆ _⋆_
                                             0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+))
           → IsGradedRing R IdM G Gstr 1⋆ _⋆_
makeIsGradedRing 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing =
  isgradedring 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing

makeGradedRing : (R : Ring (ℓ-max ℓ ℓ')) (IdM : Monoid ℓ)
                 (G      : (k : (fst IdM)) → Type ℓ')
                 (Gstr   : (k : fst IdM) → AbGroupStr (G k))
                 (1⋆     : G (ε (snd IdM)))
                 (_⋆_    : {k l : fst IdM} → G k → G l → G (_·_ (snd IdM) k l))
                 (0-⋆    : {k l : fst IdM} (b : G l) → (0g (Gstr k) ⋆ b) ≡ 0g (Gstr ((snd IdM MonoidStr.· k) l)))
                 (⋆-0    : {k l : fst IdM} (a : G k) → (a ⋆ 0g (Gstr l)) ≡ 0g (Gstr ((snd IdM MonoidStr.· k) l)))
                 (⋆Assoc : {k l m : fst IdM} (a : G k) (b : G l) (c : G m) →
                              (((snd IdM ._·_ k) ((snd IdM ._·_ l) m) , (a ⋆ (b ⋆ c))))
                            ≡ ((snd IdM ._·_ ((snd IdM ._·_ k) l) m) , ((a ⋆ b) ⋆ c)))
                 (⋆IdR    : {k : fst IdM} → (a : G k) → (snd IdM ._·_ k (snd IdM .ε) , a ⋆ 1⋆ ) ≡ (k , a))
                 (⋆IdL    : {l : fst IdM} → (b : G l) → (snd IdM ._·_ (snd IdM .ε) l , 1⋆ ⋆ b ) ≡ (l , b))
                 (⋆DistR+ : {k l : fst IdM} → (a : G k) → (b c : G l) →
                            a ⋆ ((Gstr l) ._+_ b c) ≡ Gstr (snd IdM ._·_ k l) ._+_ (a ⋆ b) (a ⋆ c))
                 (⋆DistL+ : {k l : fst IdM} → (a b : G k) → (c : G l) →
                            ((Gstr k) ._+_ a b) ⋆ c ≡ Gstr (snd IdM ._·_ k l) ._+_ (a ⋆ c) (b ⋆ c))
                 (equivRing : RingEquiv R (⊕HITgradedRing-Ring IdM G Gstr 1⋆ _⋆_
                                             0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+))
                  → GradedRing ℓ ℓ'
fst (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing) = R
GradedRingStr.IdM (snd (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing)) = IdM
GradedRingStr.G (snd (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing)) = G
GradedRingStr.Gstr (snd (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing)) = Gstr
GradedRingStr.1⋆ (snd (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing)) = 1⋆
GradedRingStr._⋆_ (snd (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing)) = _⋆_
GradedRingStr.isGradedRing (snd (makeGradedRing R IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing)) =
  makeIsGradedRing 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ equivRing

makeGradedRingSelf : (IdM : Monoid ℓ)
                     (G      : (k : (fst IdM)) → Type ℓ')
                     (Gstr   : (k : fst IdM) → AbGroupStr (G k))
                     (1⋆     : G (ε (snd IdM)))
                     (_⋆_    : {k l : fst IdM} → G k → G l → G (_·_ (snd IdM) k l))
                     (0-⋆    : {k l : fst IdM} (b : G l) → (0g (Gstr k) ⋆ b) ≡ 0g (Gstr ((snd IdM MonoidStr.· k) l)))
                     (⋆-0    : {k l : fst IdM} (a : G k) → (a ⋆ 0g (Gstr l)) ≡ 0g (Gstr ((snd IdM MonoidStr.· k) l)))
                     (⋆Assoc : {k l m : fst IdM} (a : G k) (b : G l) (c : G m) →
                                _≡_ {A = Σ[ k ∈ fst IdM ] G k} (((snd IdM ._·_ k) ((snd IdM ._·_ l) m) , (a ⋆ (b ⋆ c))))
                                                               ((snd IdM ._·_ ((snd IdM ._·_ k) l) m) , ((a ⋆ b) ⋆ c)))
                     (⋆IdR    : {k : fst IdM} → (a : G k) →
                                _≡_ {A = Σ[ k ∈ fst IdM ] G k} ( snd IdM ._·_ k (snd IdM .ε) , a ⋆ 1⋆ ) (k , a))
                     (⋆IdL    : {l : fst IdM} → (b : G l) →
                                _≡_ {A = Σ[ k ∈ fst IdM ] G k} ( snd IdM ._·_ (snd IdM .ε) l , 1⋆ ⋆ b ) (l , b))
                     (⋆DistR+ : {k l : fst IdM} → (a : G k) → (b c : G l) →
                                a ⋆ ((Gstr l) ._+_ b c) ≡ Gstr (snd IdM ._·_ k l) ._+_ (a ⋆ b) (a ⋆ c))
                     (⋆DistL+ : {k l : fst IdM} → (a b : G k) → (c : G l) →
                                ((Gstr k) ._+_ a b) ⋆ c ≡ Gstr (snd IdM ._·_ k l) ._+_ (a ⋆ c) (b ⋆ c))
                     → GradedRing ℓ ℓ'
makeGradedRingSelf IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+ =
  makeGradedRing (⊕HITgradedRing-Ring IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+)
                 IdM G Gstr 1⋆ _⋆_ 0-⋆ ⋆-0 ⋆Assoc ⋆IdR ⋆IdL ⋆DistR+ ⋆DistL+
                 ((idEquiv _) , (makeIsRingHom refl (λ _ _ → refl) (λ _ _ → refl)))