------------------------------------------------------------------------
-- The Agda standard library
--
-- Solver for commutative ring or semiring equalities
------------------------------------------------------------------------

-- Uses ideas from the Coq ring tactic. See "Proving Equalities in a
-- Commutative Ring Done Right in Coq" by Grégoire and Mahboubi. The
-- code below is not optimised like theirs, though (in particular, our
-- Horner normal forms are not sparse).
--
-- At first the `WeaklyDecidable` type may at first glance look useless
-- as there is no guarantee that it doesn't always return `nothing`.
-- However the implementation of it affects the power of the solver. The
-- more equalities it returns, the more expressions the ring solver can
-- solve.

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

open import Algebra
open import Algebra.Solver.Ring.AlmostCommutativeRing
open import Relation.Binary.Core using (WeaklyDecidable)

module Algebra.Solver.Ring
  {r₁ r₂ r₃}
  (Coeff : RawRing r₁)               -- Coefficient "ring".
  (R : AlmostCommutativeRing r₂ r₃)  -- Main "ring".
  (morphism : Coeff -Raw-AlmostCommutative⟶ R)
  (_coeff≟_ : WeaklyDecidable (Induced-equivalence morphism))
  where

open import Algebra.Solver.Ring.Lemmas Coeff R morphism
private module C = RawRing Coeff
open AlmostCommutativeRing R
  renaming (zero to *-zero; zeroˡ to *-zeroˡ; zeroʳ to *-zeroʳ)
open import Algebra.FunctionProperties _≈_
open import Algebra.Morphism
open _-Raw-AlmostCommutative⟶_ morphism renaming (⟦_⟧ to ⟦_⟧′)
open import Algebra.Operations.Semiring semiring

open import Relation.Binary
open import Relation.Nullary using (yes; no)
open import Relation.Binary.Reasoning.Setoid setoid
import Relation.Binary.PropositionalEquality as PropEq
import Relation.Binary.Reflection as Reflection

open import Data.Nat.Base using (ℕ; suc; zero)
open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_; lookup)
open import Data.Maybe.Base using (just; nothing)
open import Function
open import Level using (_⊔_)

infix  9 :-_ -H_ -N_
infixr 9 _:×_ _:^_ _^N_
infix  8 _*x+_ _*x+HN_ _*x+H_
infixl 8 _:*_ _*N_ _*H_ _*NH_ _*HN_
infixl 7 _:+_ _:-_ _+H_ _+N_
infix  4 _≈H_ _≈N_

------------------------------------------------------------------------
-- Polynomials

data Op : Set where
  [+] : Op
  [*] : Op

-- The polynomials are indexed by the number of variables.

data Polynomial (m : ℕ) : Set r₁ where
  op   : (o : Op) (p₁ : Polynomial m) (p₂ : Polynomial m) → Polynomial m
  con  : (c : C.Carrier) → Polynomial m
  var  : (x : Fin m) → Polynomial m
  _:^_ : (p : Polynomial m) (n : ℕ) → Polynomial m
  :-_  : (p : Polynomial m) → Polynomial m

-- Short-hand notation.

_:+_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n
_:+_ = op [+]

_:*_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n
_:*_ = op [*]

_:-_ : ∀ {n} → Polynomial n → Polynomial n → Polynomial n
x :- y = x :+ :- y

_:×_ : ∀ {n} → ℕ → Polynomial n → Polynomial n
zero :× p = con C.0#
suc m :× p = p :+ m :× p

-- Semantics.

sem : Op → Op₂ Carrier
sem [+] = _+_
sem [*] = _*_

⟦_⟧ : ∀ {n} → Polynomial n → Vec Carrier n → Carrier
⟦ op o p₁ p₂ ⟧ ρ = ⟦ p₁ ⟧ ρ ⟨ sem o ⟩ ⟦ p₂ ⟧ ρ
⟦ con c      ⟧ ρ = ⟦ c ⟧′
⟦ var x      ⟧ ρ = lookup ρ x
⟦ p :^ n     ⟧ ρ = ⟦ p ⟧ ρ ^ n
⟦ :- p       ⟧ ρ = - ⟦ p ⟧ ρ

------------------------------------------------------------------------
-- Normal forms of polynomials

-- A univariate polynomial of degree d,
--
--     p = a_d x^d + a_{d-1}x^{d-1} + … + a_0,
--
-- is represented in Horner normal form by
--
--     p = ((a_d x + a_{d-1})x + …)x + a_0.
--
-- Note that Horner normal forms can be represented as lists, with the
-- empty list standing for the zero polynomial of degree "-1".
--
-- Given this representation of univariate polynomials over an
-- arbitrary ring, polynomials in any number of variables over the
-- ring C can be represented via the isomorphisms
--
--     C[] ≅ C
--
-- and
--
--     C[X_0,...X_{n+1}] ≅ C[X_0,...,X_n][X_{n+1}].

mutual

  -- The polynomial representations are indexed by the polynomial's
  -- degree.

  data HNF : ℕ → Set r₁ where
    ∅     : ∀ {n} → HNF (suc n)
    _*x+_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n)

  data Normal : ℕ → Set r₁ where
    con  : C.Carrier → Normal zero
    poly : ∀ {n} → HNF (suc n) → Normal (suc n)

  -- Note that the data types above do /not/ ensure uniqueness of
  -- normal forms: the zero polynomial of degree one can be
  -- represented using both ∅ and ∅ *x+ con C.0#.

mutual

  -- Semantics.

  ⟦_⟧H : ∀ {n} → HNF (suc n) → Vec Carrier (suc n) → Carrier
  ⟦ ∅       ⟧H _       = 0#
  ⟦ p *x+ c ⟧H (x ∷ ρ) = ⟦ p ⟧H (x ∷ ρ) * x + ⟦ c ⟧N ρ

  ⟦_⟧N : ∀ {n} → Normal n → Vec Carrier n → Carrier
  ⟦ con c  ⟧N _ = ⟦ c ⟧′
  ⟦ poly p ⟧N ρ = ⟦ p ⟧H ρ

------------------------------------------------------------------------
-- Equality and decidability

mutual

  -- Equality.

  data _≈H_ : ∀ {n} → HNF n → HNF n → Set (r₁ ⊔ r₃) where
    ∅     : ∀ {n} → _≈H_ {suc n} ∅ ∅
    _*x+_ : ∀ {n} {p₁ p₂ : HNF (suc n)} {c₁ c₂ : Normal n} →
            p₁ ≈H p₂ → c₁ ≈N c₂ → (p₁ *x+ c₁) ≈H (p₂ *x+ c₂)

  data _≈N_ : ∀ {n} → Normal n → Normal n → Set (r₁ ⊔ r₃) where
    con  : ∀ {c₁ c₂} → ⟦ c₁ ⟧′ ≈ ⟦ c₂ ⟧′ → con c₁ ≈N con c₂
    poly : ∀ {n} {p₁ p₂ : HNF (suc n)} → p₁ ≈H p₂ → poly p₁ ≈N poly p₂

mutual

  -- Equality is weakly decidable.

  _≟H_ : ∀ {n} → WeaklyDecidable (_≈H_ {n = n})
  ∅           ≟H ∅           = just ∅
  ∅           ≟H (_ *x+ _)   = nothing
  (_ *x+ _)   ≟H ∅           = nothing
  (p₁ *x+ c₁) ≟H (p₂ *x+ c₂) with p₁ ≟H p₂ | c₁ ≟N c₂
  ... | just p₁≈p₂ | just c₁≈c₂ = just (p₁≈p₂ *x+ c₁≈c₂)
  ... | _          | nothing    = nothing
  ... | nothing    | _          = nothing

  _≟N_ : ∀ {n} → WeaklyDecidable (_≈N_ {n = n})
  con c₁ ≟N con c₂ with c₁ coeff≟ c₂
  ... | just c₁≈c₂ = just (con c₁≈c₂)
  ... | nothing    = nothing
  poly p₁ ≟N poly p₂ with p₁ ≟H p₂
  ... | just p₁≈p₂ = just (poly p₁≈p₂)
  ... | nothing    = nothing

mutual

  -- The semantics respect the equality relations defined above.

  ⟦_⟧H-cong : ∀ {n} {p₁ p₂ : HNF (suc n)} →
              p₁ ≈H p₂ → ∀ ρ → ⟦ p₁ ⟧H ρ ≈ ⟦ p₂ ⟧H ρ
  ⟦ ∅               ⟧H-cong _       = refl
  ⟦ p₁≈p₂ *x+ c₁≈c₂ ⟧H-cong (x ∷ ρ) =
    (⟦ p₁≈p₂ ⟧H-cong (x ∷ ρ) ⟨ *-cong ⟩ refl)
      ⟨ +-cong ⟩
    ⟦ c₁≈c₂ ⟧N-cong ρ

  ⟦_⟧N-cong :
    ∀ {n} {p₁ p₂ : Normal n} →
    p₁ ≈N p₂ → ∀ ρ → ⟦ p₁ ⟧N ρ ≈ ⟦ p₂ ⟧N ρ
  ⟦ con c₁≈c₂  ⟧N-cong _ = c₁≈c₂
  ⟦ poly p₁≈p₂ ⟧N-cong ρ = ⟦ p₁≈p₂ ⟧H-cong ρ

------------------------------------------------------------------------
-- Ring operations on Horner normal forms

-- Zero.

0H : ∀ {n} → HNF (suc n)
0H = ∅

0N : ∀ {n} → Normal n
0N {zero}  = con C.0#
0N {suc n} = poly 0H

mutual

  -- One.

  1H : ∀ {n} → HNF (suc n)
  1H {n} = ∅ *x+ 1N {n}

  1N : ∀ {n} → Normal n
  1N {zero}  = con C.1#
  1N {suc n} = poly 1H

-- A simplifying variant of _*x+_.

_*x+HN_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n)
(p *x+ c′) *x+HN c = (p *x+ c′) *x+ c
∅          *x+HN c with c ≟N 0N
... | just c≈0 = ∅
... | nothing  = ∅ *x+ c

mutual

  -- Addition.

  _+H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n)
  ∅           +H p           = p
  p           +H ∅           = p
  (p₁ *x+ c₁) +H (p₂ *x+ c₂) = (p₁ +H p₂) *x+HN (c₁ +N c₂)

  _+N_ : ∀ {n} → Normal n → Normal n → Normal n
  con c₁  +N con c₂  = con (c₁ C.+ c₂)
  poly p₁ +N poly p₂ = poly (p₁ +H p₂)

-- Multiplication.

_*x+H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n)
p₁         *x+H (p₂ *x+ c) = (p₁ +H p₂) *x+HN c
∅          *x+H ∅          = ∅
(p₁ *x+ c) *x+H ∅          = (p₁ *x+ c) *x+ 0N

mutual

  _*NH_ : ∀ {n} → Normal n → HNF (suc n) → HNF (suc n)
  c *NH ∅          = ∅
  c *NH (p *x+ c′) with c ≟N 0N
  ... | just c≈0 = ∅
  ... | nothing  = (c *NH p) *x+ (c *N c′)

  _*HN_ : ∀ {n} → HNF (suc n) → Normal n → HNF (suc n)
  ∅          *HN c = ∅
  (p *x+ c′) *HN c with c ≟N 0N
  ... | just c≈0 = ∅
  ... | nothing  = (p *HN c) *x+ (c′ *N c)

  _*H_ : ∀ {n} → HNF (suc n) → HNF (suc n) → HNF (suc n)
  ∅           *H _           = ∅
  (_ *x+ _)   *H ∅           = ∅
  (p₁ *x+ c₁) *H (p₂ *x+ c₂) =
    ((p₁ *H p₂) *x+H (p₁ *HN c₂ +H c₁ *NH p₂)) *x+HN (c₁ *N c₂)

  _*N_ : ∀ {n} → Normal n → Normal n → Normal n
  con c₁  *N con c₂  = con (c₁ C.* c₂)
  poly p₁ *N poly p₂ = poly (p₁ *H p₂)

-- Exponentiation.

_^N_ : ∀ {n} → Normal n → ℕ → Normal n
p ^N zero  = 1N
p ^N suc n = p *N (p ^N n)

mutual

  -- Negation.

  -H_ : ∀ {n} → HNF (suc n) → HNF (suc n)
  -H p = (-N 1N) *NH p

  -N_ : ∀ {n} → Normal n → Normal n
  -N con c  = con (C.- c)
  -N poly p = poly (-H p)

------------------------------------------------------------------------
-- Normalisation

normalise-con : ∀ {n} → C.Carrier → Normal n
normalise-con {zero}  c = con c
normalise-con {suc n} c = poly (∅ *x+HN normalise-con c)

normalise-var : ∀ {n} → Fin n → Normal n
normalise-var zero    = poly ((∅ *x+ 1N) *x+ 0N)
normalise-var (suc i) = poly (∅ *x+HN normalise-var i)

normalise : ∀ {n} → Polynomial n → Normal n
normalise (op [+] t₁ t₂) = normalise t₁ +N normalise t₂
normalise (op [*] t₁ t₂) = normalise t₁ *N normalise t₂
normalise (con c)        = normalise-con c
normalise (var i)        = normalise-var i
normalise (t :^ k)       = normalise t ^N k
normalise (:- t)         = -N normalise t

-- Evaluation after normalisation.

⟦_⟧↓ : ∀ {n} → Polynomial n → Vec Carrier n → Carrier
⟦ p ⟧↓ ρ = ⟦ normalise p ⟧N ρ

------------------------------------------------------------------------
-- Homomorphism lemmas

0N-homo : ∀ {n} ρ → ⟦ 0N {n} ⟧N ρ ≈ 0#
0N-homo []      = 0-homo
0N-homo (x ∷ ρ) = refl

-- If c is equal to 0N, then c is semantically equal to 0#.

0≈⟦0⟧ : ∀ {n} {c : Normal n} → c ≈N 0N → ∀ ρ → 0# ≈ ⟦ c ⟧N ρ
0≈⟦0⟧ {c = c} c≈0 ρ = sym (begin
  ⟦ c  ⟧N ρ  ≈⟨ ⟦ c≈0 ⟧N-cong ρ ⟩
  ⟦ 0N ⟧N ρ  ≈⟨ 0N-homo ρ ⟩
  0#         ∎)

1N-homo : ∀ {n} ρ → ⟦ 1N {n} ⟧N ρ ≈ 1#
1N-homo []      = 1-homo
1N-homo (x ∷ ρ) = begin
  0# * x + ⟦ 1N ⟧N ρ  ≈⟨ refl ⟨ +-cong ⟩ 1N-homo ρ ⟩
  0# * x + 1#         ≈⟨ lemma₆ _ _ ⟩
  1#                  ∎

-- _*x+HN_ is equal to _*x+_.

*x+HN≈*x+ : ∀ {n} (p : HNF (suc n)) (c : Normal n) →
            ∀ ρ → ⟦ p *x+HN c ⟧H ρ ≈ ⟦ p *x+ c ⟧H ρ
*x+HN≈*x+ (p *x+ c′) c ρ       = refl
*x+HN≈*x+ ∅          c (x ∷ ρ) with c ≟N 0N
... | just c≈0 = begin
  0#                 ≈⟨ 0≈⟦0⟧ c≈0 ρ ⟩
  ⟦ c ⟧N ρ           ≈⟨ sym $ lemma₆ _ _ ⟩
  0# * x + ⟦ c ⟧N ρ  ∎
... | nothing = refl

∅*x+HN-homo : ∀ {n} (c : Normal n) x ρ →
              ⟦ ∅ *x+HN c ⟧H (x ∷ ρ) ≈ ⟦ c ⟧N ρ
∅*x+HN-homo c x ρ with c ≟N 0N
... | just c≈0 = 0≈⟦0⟧ c≈0 ρ
... | nothing = lemma₆ _ _

mutual

  +H-homo : ∀ {n} (p₁ p₂ : HNF (suc n)) →
            ∀ ρ → ⟦ p₁ +H p₂ ⟧H ρ ≈ ⟦ p₁ ⟧H ρ + ⟦ p₂ ⟧H ρ
  +H-homo ∅           p₂          ρ       = sym (+-identityˡ _)
  +H-homo (p₁ *x+ x₁) ∅           ρ       = sym (+-identityʳ _)
  +H-homo (p₁ *x+ c₁) (p₂ *x+ c₂) (x ∷ ρ) = begin
    ⟦ (p₁ +H p₂) *x+HN (c₁ +N c₂) ⟧H (x ∷ ρ)                           ≈⟨ *x+HN≈*x+ (p₁ +H p₂) (c₁ +N c₂) (x ∷ ρ) ⟩

    ⟦ p₁ +H p₂ ⟧H (x ∷ ρ) * x + ⟦ c₁ +N c₂ ⟧N ρ                        ≈⟨ (+H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ +N-homo c₁ c₂ ρ ⟩

    (⟦ p₁ ⟧H (x ∷ ρ) + ⟦ p₂ ⟧H (x ∷ ρ)) * x + (⟦ c₁ ⟧N ρ + ⟦ c₂ ⟧N ρ)  ≈⟨ lemma₁ _ _ _ _ _ ⟩

    (⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ c₁ ⟧N ρ) +
    (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ)                                  ∎

  +N-homo : ∀ {n} (p₁ p₂ : Normal n) →
            ∀ ρ → ⟦ p₁ +N p₂ ⟧N ρ ≈ ⟦ p₁ ⟧N ρ + ⟦ p₂ ⟧N ρ
  +N-homo (con c₁)  (con c₂)  _ = +-homo _ _
  +N-homo (poly p₁) (poly p₂) ρ = +H-homo p₁ p₂ ρ

*x+H-homo :
  ∀ {n} (p₁ p₂ : HNF (suc n)) x ρ →
  ⟦ p₁ *x+H p₂ ⟧H (x ∷ ρ) ≈
  ⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ p₂ ⟧H (x ∷ ρ)
*x+H-homo ∅         ∅ _ _ = sym $ lemma₆ _ _
*x+H-homo (p *x+ c) ∅ x ρ = begin
  ⟦ p *x+ c ⟧H (x ∷ ρ) * x + ⟦ 0N ⟧N ρ  ≈⟨ refl ⟨ +-cong ⟩ 0N-homo ρ ⟩
  ⟦ p *x+ c ⟧H (x ∷ ρ) * x + 0#         ∎
*x+H-homo p₁         (p₂ *x+ c₂) x ρ = begin
  ⟦ (p₁ +H p₂) *x+HN c₂ ⟧H (x ∷ ρ)                         ≈⟨ *x+HN≈*x+ (p₁ +H p₂) c₂ (x ∷ ρ) ⟩
  ⟦ p₁ +H p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ                    ≈⟨ (+H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ refl ⟩
  (⟦ p₁ ⟧H (x ∷ ρ) + ⟦ p₂ ⟧H (x ∷ ρ)) * x + ⟦ c₂ ⟧N ρ      ≈⟨ lemma₀ _ _ _ _ ⟩
  ⟦ p₁ ⟧H (x ∷ ρ) * x + (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ)  ∎

mutual

  *NH-homo :
    ∀ {n} (c : Normal n) (p : HNF (suc n)) x ρ →
    ⟦ c *NH p ⟧H (x ∷ ρ) ≈ ⟦ c ⟧N ρ * ⟦ p ⟧H (x ∷ ρ)
  *NH-homo c ∅          x ρ = sym (*-zeroʳ _)
  *NH-homo c (p *x+ c′) x ρ with c ≟N 0N
  ... | just c≈0 = begin
    0#                                            ≈⟨ sym (*-zeroˡ _) ⟩
    0# * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ)         ≈⟨ 0≈⟦0⟧ c≈0 ρ ⟨ *-cong ⟩ refl ⟩
    ⟦ c ⟧N ρ  * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ)  ∎
  ... | nothing = begin
    ⟦ c *NH p ⟧H (x ∷ ρ) * x + ⟦ c *N c′ ⟧N ρ                 ≈⟨ (*NH-homo c p x ρ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ *N-homo c c′ ρ ⟩
    (⟦ c ⟧N ρ * ⟦ p ⟧H (x ∷ ρ)) * x + (⟦ c ⟧N ρ * ⟦ c′ ⟧N ρ)  ≈⟨ lemma₃ _ _ _ _ ⟩
    ⟦ c ⟧N ρ * (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ)               ∎

  *HN-homo :
    ∀ {n} (p : HNF (suc n)) (c : Normal n) x ρ →
    ⟦ p *HN c ⟧H (x ∷ ρ) ≈ ⟦ p ⟧H (x ∷ ρ) * ⟦ c ⟧N ρ
  *HN-homo ∅          c x ρ = sym (*-zeroˡ _)
  *HN-homo (p *x+ c′) c x ρ with c ≟N 0N
  ... | just c≈0 = begin
    0#                                           ≈⟨ sym (*-zeroʳ _) ⟩
    (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * 0#        ≈⟨ refl ⟨ *-cong ⟩ 0≈⟦0⟧ c≈0 ρ ⟩
    (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * ⟦ c ⟧N ρ  ∎
  ... | nothing = begin
    ⟦ p *HN c ⟧H (x ∷ ρ) * x + ⟦ c′ *N c ⟧N ρ                 ≈⟨ (*HN-homo p c x ρ ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ *N-homo c′ c ρ ⟩
    (⟦ p ⟧H (x ∷ ρ) * ⟦ c ⟧N ρ) * x + (⟦ c′ ⟧N ρ * ⟦ c ⟧N ρ)  ≈⟨ lemma₂ _ _ _ _ ⟩
    (⟦ p ⟧H (x ∷ ρ) * x + ⟦ c′ ⟧N ρ) * ⟦ c ⟧N ρ               ∎

  *H-homo : ∀ {n} (p₁ p₂ : HNF (suc n)) →
            ∀ ρ → ⟦ p₁ *H p₂ ⟧H ρ ≈ ⟦ p₁ ⟧H ρ * ⟦ p₂ ⟧H ρ
  *H-homo ∅           p₂          ρ       = sym $ *-zeroˡ _
  *H-homo (p₁ *x+ c₁) ∅           ρ       = sym $ *-zeroʳ _
  *H-homo (p₁ *x+ c₁) (p₂ *x+ c₂) (x ∷ ρ) = begin
    ⟦ ((p₁ *H p₂) *x+H ((p₁ *HN c₂) +H (c₁ *NH p₂))) *x+HN
      (c₁ *N c₂) ⟧H (x ∷ ρ)                                              ≈⟨ *x+HN≈*x+ ((p₁ *H p₂) *x+H ((p₁ *HN c₂) +H (c₁ *NH p₂)))
                                                                                (c₁ *N c₂) (x ∷ ρ) ⟩
    ⟦ (p₁ *H p₂) *x+H
      ((p₁ *HN c₂) +H (c₁ *NH p₂)) ⟧H (x ∷ ρ) * x +
    ⟦ c₁ *N c₂ ⟧N ρ                                                      ≈⟨ (*x+H-homo (p₁ *H p₂) ((p₁ *HN c₂) +H (c₁ *NH p₂)) x ρ
                                                                               ⟨ *-cong ⟩
                                                                             refl)
                                                                              ⟨ +-cong ⟩
                                                                            *N-homo c₁ c₂ ρ ⟩
    (⟦ p₁ *H p₂ ⟧H (x ∷ ρ) * x +
     ⟦ (p₁ *HN c₂) +H (c₁ *NH p₂) ⟧H (x ∷ ρ)) * x +
    ⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ                                                ≈⟨ (((*H-homo p₁ p₂ (x ∷ ρ) ⟨ *-cong ⟩ refl)
                                                                                ⟨ +-cong ⟩
                                                                              (+H-homo (p₁ *HN c₂) (c₁ *NH p₂) (x ∷ ρ)))
                                                                               ⟨ *-cong ⟩
                                                                             refl)
                                                                              ⟨ +-cong ⟩
                                                                            refl ⟩
    (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ p₂ ⟧H (x ∷ ρ) * x +
     (⟦ p₁ *HN c₂ ⟧H (x ∷ ρ) + ⟦ c₁ *NH p₂ ⟧H (x ∷ ρ))) * x +
    ⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ                                                ≈⟨ ((refl ⟨ +-cong ⟩ (*HN-homo p₁ c₂ x ρ ⟨ +-cong ⟩ *NH-homo c₁ p₂ x ρ))
                                                                               ⟨ *-cong ⟩
                                                                             refl)
                                                                              ⟨ +-cong ⟩
                                                                            refl ⟩
    (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ p₂ ⟧H (x ∷ ρ) * x +
     (⟦ p₁ ⟧H (x ∷ ρ) * ⟦ c₂ ⟧N ρ + ⟦ c₁ ⟧N ρ * ⟦ p₂ ⟧H (x ∷ ρ))) * x +
    (⟦ c₁ ⟧N ρ * ⟦ c₂ ⟧N ρ)                                              ≈⟨ lemma₄ _ _ _ _ _ ⟩

    (⟦ p₁ ⟧H (x ∷ ρ) * x + ⟦ c₁ ⟧N ρ) *
    (⟦ p₂ ⟧H (x ∷ ρ) * x + ⟦ c₂ ⟧N ρ)                                    ∎

  *N-homo : ∀ {n} (p₁ p₂ : Normal n) →
            ∀ ρ → ⟦ p₁ *N p₂ ⟧N ρ ≈ ⟦ p₁ ⟧N ρ * ⟦ p₂ ⟧N ρ
  *N-homo (con c₁)  (con c₂)  _ = *-homo _ _
  *N-homo (poly p₁) (poly p₂) ρ = *H-homo p₁ p₂ ρ

^N-homo : ∀ {n} (p : Normal n) (k : ℕ) →
          ∀ ρ → ⟦ p ^N k ⟧N ρ ≈ ⟦ p ⟧N ρ ^ k
^N-homo p zero    ρ = 1N-homo ρ
^N-homo p (suc k) ρ = begin
  ⟦ p *N (p ^N k) ⟧N ρ       ≈⟨ *N-homo p (p ^N k) ρ ⟩
  ⟦ p ⟧N ρ * ⟦ p ^N k ⟧N ρ   ≈⟨ refl ⟨ *-cong ⟩ ^N-homo p k ρ ⟩
  ⟦ p ⟧N ρ * (⟦ p ⟧N ρ ^ k)  ∎

mutual

  -H‿-homo : ∀ {n} (p : HNF (suc n)) →
             ∀ ρ → ⟦ -H p ⟧H ρ ≈ - ⟦ p ⟧H ρ
  -H‿-homo p (x ∷ ρ) = begin
    ⟦ (-N 1N) *NH p ⟧H (x ∷ ρ)     ≈⟨ *NH-homo (-N 1N) p x ρ ⟩
    ⟦ -N 1N ⟧N ρ * ⟦ p ⟧H (x ∷ ρ)  ≈⟨ trans (-N‿-homo 1N ρ) (-‿cong (1N-homo ρ)) ⟨ *-cong ⟩ refl ⟩
    - 1# * ⟦ p ⟧H (x ∷ ρ)          ≈⟨ lemma₇ _ ⟩
    - ⟦ p ⟧H (x ∷ ρ)               ∎

  -N‿-homo : ∀ {n} (p : Normal n) →
             ∀ ρ → ⟦ -N p ⟧N ρ ≈ - ⟦ p ⟧N ρ
  -N‿-homo (con c)  _ = -‿homo _
  -N‿-homo (poly p) ρ = -H‿-homo p ρ

------------------------------------------------------------------------
-- Correctness

correct-con : ∀ {n} (c : C.Carrier) (ρ : Vec Carrier n) →
              ⟦ normalise-con c ⟧N ρ ≈ ⟦ c ⟧′
correct-con c []      = refl
correct-con c (x ∷ ρ) = begin
  ⟦ ∅ *x+HN normalise-con c ⟧H (x ∷ ρ)  ≈⟨ ∅*x+HN-homo (normalise-con c) x ρ ⟩
  ⟦ normalise-con c ⟧N ρ            ≈⟨ correct-con c ρ ⟩
  ⟦ c ⟧′                                   ∎

correct-var : ∀ {n} (i : Fin n) →
              ∀ ρ → ⟦ normalise-var i ⟧N ρ ≈ lookup ρ i
correct-var ()      []
correct-var (suc i) (x ∷ ρ) = begin
  ⟦ ∅ *x+HN normalise-var i ⟧H (x ∷ ρ)  ≈⟨ ∅*x+HN-homo (normalise-var i) x ρ ⟩
  ⟦ normalise-var i ⟧N ρ                ≈⟨ correct-var i ρ ⟩
  lookup ρ i                            ∎
correct-var zero (x ∷ ρ) = begin
  (0# * x + ⟦ 1N ⟧N ρ) * x + ⟦ 0N ⟧N ρ  ≈⟨ ((refl ⟨ +-cong ⟩ 1N-homo ρ) ⟨ *-cong ⟩ refl) ⟨ +-cong ⟩ 0N-homo ρ ⟩
  (0# * x + 1#) * x + 0#                ≈⟨ lemma₅ _ ⟩
  x                                     ∎

correct : ∀ {n} (p : Polynomial n) → ∀ ρ → ⟦ p ⟧↓ ρ ≈ ⟦ p ⟧ ρ
correct (op [+] p₁ p₂) ρ = begin
  ⟦ normalise p₁ +N normalise p₂ ⟧N ρ  ≈⟨ +N-homo (normalise p₁) (normalise p₂) ρ ⟩
  ⟦ p₁ ⟧↓ ρ + ⟦ p₂ ⟧↓ ρ                ≈⟨ correct p₁ ρ ⟨ +-cong ⟩ correct p₂ ρ ⟩
  ⟦ p₁ ⟧ ρ + ⟦ p₂ ⟧ ρ                  ∎
correct (op [*] p₁ p₂) ρ = begin
  ⟦ normalise p₁ *N normalise p₂ ⟧N ρ  ≈⟨ *N-homo (normalise p₁) (normalise p₂) ρ ⟩
  ⟦ p₁ ⟧↓ ρ * ⟦ p₂ ⟧↓ ρ                ≈⟨ correct p₁ ρ ⟨ *-cong ⟩ correct p₂ ρ ⟩
  ⟦ p₁ ⟧ ρ * ⟦ p₂ ⟧ ρ                  ∎
correct (con c)  ρ = correct-con c ρ
correct (var i)  ρ = correct-var i ρ
correct (p :^ k) ρ = begin
  ⟦ normalise p ^N k ⟧N ρ  ≈⟨ ^N-homo (normalise p) k ρ ⟩
  ⟦ p ⟧↓ ρ ^ k             ≈⟨ correct p ρ ⟨ ^-cong ⟩ PropEq.refl {x = k} ⟩
  ⟦ p ⟧ ρ ^ k              ∎
correct (:- p) ρ = begin
  ⟦ -N normalise p ⟧N ρ  ≈⟨ -N‿-homo (normalise p) ρ ⟩
  - ⟦ p ⟧↓ ρ             ≈⟨ -‿cong (correct p ρ) ⟩
  - ⟦ p ⟧ ρ              ∎

------------------------------------------------------------------------
-- "Tactics"

open Reflection setoid var ⟦_⟧ ⟦_⟧↓ correct public
  using (prove; solve) renaming (_⊜_ to _:=_)

-- For examples of how solve and _:=_ can be used to
-- semi-automatically prove ring equalities, see, for instance,
-- Data.Digit or Data.Nat.DivMod.


postulate
  Nat : Set
  Fin : Nat → Set
  Foo : (n : Nat) → Fin n → Set

private
 module M where

  variable
    n : Nat
    m : Fin _

  postulate
    Bar : Foo n m → Set

open M public using (Bar)

variable
  n : Nat
  m : Fin _
  l : Foo n m

before : Bar l
before {n} {m} {l} = {!C-c C-e!}

after : Bar l
after {n} {m} {l} = {!C-c C-e!}


{-# OPTIONS --type-in-type   #-} -- NOT SOUND!

open import Data.Empty      using (⊥)
open import Data.Nat        renaming (ℕ to Nat)
open import Data.Nat.DivMod
open import Data.Product    hiding (map)
open import Data.Unit       using (⊤)

module x where

{-
https://webspace.science.uu.nl/~swier004/publications/2019-icfp-submission-a.pdf

A predicate transformer semantics for effects

WOUTER SWIERSTRA and TIM BAANEN, Universiteit Utrecht

abstract

reasoning about effectful code harder than pure code

predicate transformer (PT) semantics gives a refinement relation that can be used to
- relate a program to its specification, or
- calculate effectful programs that are correct by construction

INTRODUCTION

key techniques
- syntax of effectful computations represented as free monads
  - assigning meaning to these monads gives meaning to the syntactic ops each effect provides
- paper shows how to assign PT semantics to computations arising
  from Kleisli arrows on free monads
  - enables computing the weakest precondition associated with a given postcondition
- using weakest precondition semantics
  - define refinement on computations
  - show how to
    - use this refinement relation to show a program satisfies its specification, or
    - calculate a program from its specification.
- show how programs and specifications may be mixed,
  enabling verified programs to be calculated from their specification one step at a time

2 BACKGROUND

Free monads
-}

-- C          : type of commands
-- Free C R   : returns an 'a' or issues command c : C
-- For each c : C, there is a set of responses R c
-- 2nd arg of Step is continuation : how to proceed after receiving response R c
data Free (C : Set) (R : C → Set) (a : Set) : Set where
  Pure :                           a  → Free C R a
  Step : (c : C) → (R c → Free C R a) → Free C R a

-- show that 'Free' is a monad:

map : ∀ {a b C : Set} {R : C → Set} → (a → b) → Free C R a → Free C R b
map f (Pure x)   = Pure (f x)
map f (Step c k) = Step c (λ r → map f (k r))

return : ∀ {a C : Set} {R : C → Set} → a → Free C R a
return = Pure

_>>=_ : ∀ {a b C : Set} {R : C → Set} → Free C R a → (a → Free C R b) → Free C R b
Pure   x >>= f = f x
Step c x >>= f = Step c (λ r → x r >>= f)

{-
different effects choose C and R differently, depending on their ops

Weakest precondition semantics

idea of associating weakest precondition semantics with imperative programs
dates to Dijkstra’s Guarded Command Language [1975]

ways to specify behaviour of function f : a → b
- reference implementation
- define a relation R : a → b → Set
- write contracts and test cases
- PT semantics

call values of type a → Set : predicate on type a

PTs are functions between predicates
e.g., weakest precondition:
-}

-- "maps"
-- function f : a → b and
-- desired postcondition on the function’s output, b → Set
-- to weakest precondition a → Set on function’s input that ensures postcondition satisfied
--
-- note: definition is just reverse function composition
-- wp0 : ∀ {a b : Set} → (f : a → b) → (b → Set) → (a → Set)
wp0 : ∀ {a : Set} {b :     Set} (f :       a → b)   →           (b   → Set) → (a → Set)
wp0 f P = λ x → P   (f x)
{-
above wp semantics is sometimes too restrictive
- no way to specify that output is related to input
- fix via making f dependent:
-}
wp  : ∀ {a : Set} {b : a → Set} (f : (x : a) → b x) → ((x : a) → b x → Set) → (a → Set)
wp  f P = λ x → P x (f x)

-- shorthand for working with predicates and predicates transformers
_⊆_ : ∀ {a : Set} → (a → Set) → (a → Set) → Set
P ⊆ Q = ∀ x → P x → Q x

-- refinement relation defined between PTs
_⊑_ : ∀ {a : Set} {b : a → Set} → (pt1 pt2 : ((x : a) → b x → Set) → (a → Set)) → Set₁
pt1 ⊑ pt2 = ∀ P → pt1 P ⊆ pt2 P

{-
use refinement relation
- to relate PT semantics between programs and specifications
- to show a program satisfies its specification; or
- to show that one program is somehow ‘better’ than another,
  where ‘better’ is defined by choice of PT semantics

in pure setting, this refinement relation is not interesting:
the refinement relation corresponds to extensional equality between functions:

lemma follows from the ‘Leibniz rule’ for equality in intensional type theory:
refinement : ∀ (f g : a → b) → (wp f ⊑ wp g) ↔ (∀ x → f x ≡ g x)

this paper defines PT semantics for Kleisli arrows of form

    a → Free C R b

could use 'wp' to assign semantics to these computations directly,
but typically not interested in syntactic equality between free monads

rather want to study semantics of effectful programs they represent

to define a PT semantics for effects
define a function with form:

  -- how to lift a predicate on 'a' over effectful computation returning 'a'
  pt : (a → Set) → Free C R a → Set

'pt' def depends on semantics desired for a particulr free monad

Crucially,
choice of pt and weakest precondition semantics, wp, together
give a way to assign weakest precondition semantics to Kleisli arrows
representing effectful computations

3 PARTIALITY

Partial computations : i.e., 'Maybe'

make choices for commands C and responses R
-}

data C : Set where
  Abort : C -- no continuation

R : C → Set
R Abort = ⊥ -- since C has no continuation, valid responses is empty

Partial : Set → Set
Partial = Free C R

-- smart constructor for failure:
abort : ∀ {a : Set} → Partial a
abort = Step Abort (λ ())

{-
computation of type Partial a will either
- return a value of type a or
- fail, issuing abort command

Note that responses to Abort command are empty;
abort smart constructor abort uses this to discharge the continuation
in the second argument of the Step constructor

Example: division

expression language, closed under division and natural numbers:
-}

data Expr : Set where
  Val : Nat  → Expr
  Div : Expr → Expr → Expr

-- semantics specified using inductively defined RELATION:
-- def rules out erroneous results by requiring the divisor evaluates to non-zero
data _⇓_ : Expr → Nat → Set where
  Base : ∀ {x : Nat}
       → Val x ⇓ x
  Step : ∀ {l r : Expr} {v1 v2 : Nat}
       →       l ⇓  v1
       →       r ⇓         (suc v2)
       → Div l r ⇓ (v1 div (suc v2))

-- Alternatively
-- evaluate Expr via monadic INTERPRETER, using Partial to handle division-by-zero

-- op used by ⟦_⟧ interpreter
_÷_ : Nat → Nat → Partial Nat
n ÷ zero    = abort
n ÷ (suc k) = return (n div (suc k))

⟦_⟧ : Expr → Partial Nat
⟦ Val x ⟧     = return x
⟦ Div e1 e2 ⟧ = ⟦ e1 ⟧ >>= λ v1 → ⟦ e2 ⟧ >>= λ v2 → v1 ÷ v2

{-
std lib 'div' requires implicit proof that divisor is non-zero

when divisor is zero, interpreter fail explicitly with abort

How to relate these two definitions?

Assign a weakest precondition semantics to Kleisli arrows of the form

    a → Partial b
-}

wpPartial : ∀ {a : Set} {b : a → Set}
          → (f : (x : a) → Partial (b x))
          → (P : (x : a) →          b x → Set)
          → (a → Set)
wpPartial f P = wp f (mustPT P)
 where
  mustPT : ∀ {a : Set} {b : a → Set}
         → (P : (x : a) → b x → Set)
         →      (x : a)
         → Partial       (b x) → Set
  mustPT P _ (Pure y)       = P _ y
  mustPT P _ (Step Abort _) = ⊥
{-
To call 'wp', must show how to transform
-      predicate                  P :         b → Set
- to a predicate on partial results : Partial b → Set
Done via proposition 'mustPT P c'
- holds when computation c of type Partial b successfully returns a 'b' that satisfies P

particular PT semantics of partial computations determined by def mustPT
here: rule out failure entirely
- so case Abort returns empty type

Given this PT semantics for Kleisli arrows in general,
can now study semantics of above monadic interpreter
via passing
- interpreter: ⟦_⟧
- desired postcondition : _⇓_
as arguments to wpPartial:

  wpPartial ⟦_⟧ _⇓_ : Expr → Set

resulting in a predicate on expressions

for all expressions satisfying this predicate,
the monadic interpreter and the relational specification, _⇓_,
must agree on the result of evaluation

What does this say about correctness of interpreter?
To understand the predicate better, consider defining this predicate on expressions:
-}

SafeDiv : Expr → Set
SafeDiv (Val x)     = ⊤
SafeDiv (Div e1 e2) = (e2 ⇓ zero → ⊥) {-∧-} × SafeDiv e1 {-∧-} × SafeDiv e2

{-
Expect : any expr e for which SafeDiv e holds
can be evaluated without division-by-zero

can prove SafeDiv is sufficient condition for two notions of evaluation to coincide:

-- lemma relates the two semantics
-- expressed as a relation and an evaluator
-- for those expressions that satisfy the SafeDiv property
correct : SafeDiv ⊆ wpPartial ⟦_⟧ _⇓_

Instead of manually defining SafeDiv, define more general predicate
characterising the domain of a partial function:
-}

dom : ∀ {a : Set} {b : a → Set}
    → ((x : a)
    → Partial (b x))
    → (a → Set)
dom f = wpPartial f (λ _ _ → ⊤)

{-
can show that the two semantics agree precisely on the domain of the interpreter:

sound    : dom       ⟦_⟧ ⊆ wpPartial ⟦_⟧ _⇓_
complete : wpPartial ⟦_⟧ _⇓_ ⊆ dom ⟦_⟧

both proofs proceed by induction on the argument expression

Refinement

weakest precondition semantics on partial computations give rise
to a refinement relation on Kleisli arrows of the form a → Partial b

can characterise this relation by proving:

refinement : (f g : a → Maybe b)
           → (wpPartial f ⊑ wpPartial g) ↔ (∀ x → (f x ≡ g x) ∨ (f x ≡ Nothing))

use refinement to relate Kleisli morphisms,
and to relate a program to a specification given by a pre- and postcondition

Example: Add (interpreter for stack machine)

add top two elements; can fail fail if stack has too few elements

below shows how to prove the definition meets its specification

Define specification in terms of a pre/post condition.
The specification of a function of type (x : a) → b x consists of
-}
record Spec (a : Set) (b : a → Set) : Set where
  constructor [_,_]
  field
    pre  : a → Set             -- a precondition on a, and
    post : (x : a) → b x → Set -- a postcondition relating inputs that satisfy this precondition
                               -- and the corresponding outputs


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

open import Algebra
open import Bundles
open import Structures

module Properties.RingWithoutOne {r₁ r₂} (R : RingWithoutOne r₁ r₂) where

open RingWithoutOne R

import Algebra.Properties.AbelianGroup as AbelianGroupProperties
open import Function.Base using (_$_)
open import Relation.Binary.Reasoning.Setoid setoid


open import Data.Product using ( _×_ ; _,_ )
open import Relation.Unary using ( _∈_ )
open import Web.Semantic.DL.FOL using  ( Formula ; _∈₂_ ; _∈₂_⇒_ )
open import Web.Semantic.DL.FOL.Model using ( _⊨f_ )
open import Web.Semantic.DL.Role using ( Role ; ⟨_⟩ ; ⟨_⟩⁻¹ )
open import Web.Semantic.DL.Role.Model using ( _⟦_⟧₂ ; ⟦⟧₂-resp-≈ )
open import Web.Semantic.DL.Signature using ( Signature )
open import Web.Semantic.DL.TBox.Interp using ( Interp ; ≈-sym )

module Web.Semantic.DL.Role.Skolemization {Σ : Signature} where

rskolem : ∀ {Δ} → Role Σ → Δ → Δ → Formula Σ Δ
rskolem ⟨ r ⟩   x y = (x , y) ∈₂ r
rskolem ⟨ r ⟩⁻¹ x y = (y , x) ∈₂ r

rskolem⇒ : ∀ {Δ} → Role Σ → Δ → Δ → Formula Σ Δ → Formula Σ Δ
rskolem⇒ ⟨ r ⟩   x y F = (x , y) ∈₂ r ⇒ F
rskolem⇒ ⟨ r ⟩⁻¹ x y F = (y , x) ∈₂ r ⇒ F

rskolem-sound : ∀ I R x y → (I ⊨f rskolem R x y) → ((x , y) ∈ I ⟦ R ⟧₂)
rskolem-sound I ⟨ r ⟩   x y xy∈⟦r⟧ = xy∈⟦r⟧
rskolem-sound I ⟨ r ⟩⁻¹ x y yx∈⟦r⟧ = yx∈⟦r⟧

rskolem⇒-sound : ∀ I R x y F → (I ⊨f rskolem⇒ R x y F) → ((x , y) ∈ I ⟦ R ⟧₂) → (I ⊨f F)
rskolem⇒-sound I ⟨ r ⟩   x y F xy∈r⇒F xy∈⟦r⟧ = xy∈r⇒F xy∈⟦r⟧
rskolem⇒-sound I ⟨ r ⟩⁻¹ x y F yx∈r⇒F yx∈⟦r⟧ = yx∈r⇒F yx∈⟦r⟧


{-# OPTIONS --safe --without-K #-}
module Source.Size.Substitution.Theory where

open import Source.Size
open import Source.Size.Substitution.Canonical as SC using (Sub⊢)
open import Source.Size.Substitution.Universe as SU using (⟨_⟩ ; Sub⊢ᵤ)
open import Util.Prelude

record SubTheory (A : Ctx → Set) : Set where
  infixl 5 _[_] _[_]ᵤ
  field
    _[_] : A Ω → SC.Sub Δ Ω → A Δ
    [Id] : ∀ {Δ} (a : A Δ) → a [ SC.Id ] ≡ a
    [>>] : ∀ {Δ Δ′ Δ″} (σ : SC.Sub Δ Δ′) (τ : SC.Sub Δ′ Δ″) a
      → a [ σ SC.>> τ ] ≡ a [ τ ] [ σ ]

  abstract
    [Id]′ : ∀ {Δ} {σ : SC.Sub Δ Δ} a
      → σ ≡ SC.Id
      → a [ σ ] ≡ a
    [Id]′ a refl = [Id] a

    [>>]′ : ∀ {Δ Δ′ Δ″} (ι : SC.Sub Δ Δ″) (σ : SC.Sub Δ Δ′) (τ : SC.Sub Δ′ Δ″) a
      → ι ≡ σ SC.>> τ
      → a [ ι ] ≡ a [ τ ] [ σ ]
    [>>]′ ι σ τ a refl = [>>] σ τ a

    [>>]″ :  ∀ {Δ Δ′ Δ″} (σ : SC.Sub Δ Δ′) (τ : SC.Sub Δ′ Δ″)
      → ∀ (σ′ : SC.Sub Δ Ω) (τ′ : SC.Sub Ω Δ″) a
      → σ SC.>> τ ≡ σ′ SC.>> τ′
      → a [ τ ] [ σ ] ≡ a [ τ′ ] [ σ′ ]
    [>>]″ σ τ σ′ τ′ a eq
      = trans (sym ([>>] σ τ a)) (trans (cong (λ σ → a [ σ ]) eq) ([>>] σ′ τ′ a))

  _[_]ᵤ : A Ω → SU.Sub Δ Ω → A Δ
  a [ σ ]ᵤ = a [ ⟨ σ ⟩ ]

  abstract
    []ᵤ-resp-≈ : ∀ {Δ Ω} {σ τ : SU.Sub Δ Ω}
      → σ SU.≈ τ
      → ∀ a
      → a [ σ ]ᵤ ≡ a [ τ ]ᵤ
    []ᵤ-resp-≈ (SU.≈⁺ p) a = cong (λ σ → a [ σ ]) p

    [Id]ᵤ : ∀ {Δ} (a : A Δ) → a [ SU.Id ]ᵤ ≡ a
    [Id]ᵤ a = [Id] a

    [Id]ᵤ′ : ∀ {Δ} {σ : SU.Sub Δ Δ} (a : A Δ)
      → σ SU.≈ SU.Id
      → a [ σ ]ᵤ ≡ a
    [Id]ᵤ′ a (SU.≈⁺ p) = [Id]′ a p

    [>>]ᵤ : ∀ {Δ Δ′ Δ″} (σ : SU.Sub Δ Δ′) (τ : SU.Sub Δ′ Δ″) (a : A Δ″)
      → a [ σ SU.>> τ ]ᵤ ≡ a [ τ ]ᵤ [ σ ]ᵤ
    [>>]ᵤ σ τ a = [>>] _ _ _

    [>>]ᵤ′ : ∀ {Δ Δ′ Δ″} (ι : SU.Sub Δ Δ″) (σ : SU.Sub Δ Δ′) (τ : SU.Sub Δ′ Δ″) a
      → ι SU.≈ σ SU.>> τ
      → a [ ι ]ᵤ ≡ a [ τ ]ᵤ [ σ ]ᵤ
    [>>]ᵤ′ ι σ τ a (SU.≈⁺ p) = [>>]′ ⟨ ι ⟩ ⟨ σ ⟩ ⟨ τ ⟩ a p

    [>>]ᵤ″ :  ∀ {Δ Δ′ Δ″} (σ : SU.Sub Δ Δ′) (τ : SU.Sub Δ′ Δ″)
      → ∀ (σ′ : SU.Sub Δ Ω) (τ′ : SU.Sub Ω Δ″) a
      → σ SU.>> τ SU.≈ σ′ SU.>> τ′
      → a [ τ ]ᵤ [ σ ]ᵤ ≡ a [ τ′ ]ᵤ [ σ′ ]ᵤ
    [>>]ᵤ″ σ τ σ′ τ′ a (SU.≈⁺ p) = [>>]″ ⟨ σ ⟩ ⟨ τ ⟩ ⟨ σ′ ⟩ ⟨ τ′ ⟩ a p

open SubTheory {{...}} public

instance
  SubTheory-Size : SubTheory Size
  SubTheory-Size = record
    { _[_] = λ n σ → SC.sub σ n
    ; [Id] = λ n → SC.sub-Id n refl
    ; [>>] = λ σ τ n → SC.sub->> n refl
    }


module Example where

open import Bool
open import Nat hiding (_==_; _+_)
open import AC

open Provable

infix 40 _+_
infix 30 _==_

postulate
  X : Set
  _==_ : X -> X -> Set
  |0|  : X
  _+_  : X -> X -> X
  refl  : forall {x}     -> x == x
  sym   : forall {x y}   -> x == y -> y == x
  trans : forall {x y z} -> x == y -> y == z -> x == z
  idL   : forall {x}     -> |0| + x == x
  idR   : forall {x}     -> x + |0| == x
  comm  : forall {x y}   -> x + y == y + x
  assoc : forall {x y z} -> x + (y + z) == (x + y) + z
  congL : forall {x y z} -> y == z -> x + y == x + z
  congR : forall {x y z} -> x == y -> x + z == y + z

open Semantics
      _==_ _+_ |0| refl sym trans idL idR
      comm assoc congL congR

thm = theorem 11 \a b c d e f g h i j k ->
      j ○ (k ○ (((((h ○ (e ○ ((e ○ (a ○ (a ○ (b ○ ((c ○ (((c ○ (d ○ d)) ○ (((d
      ○ (d ○ ((d ○ ((e ○ k) ○ ((((a ○ b) ○ (((h ○ (k ○ f)) ○ (((d ○ ((j ○ (h ○
      (a ○ (((g ○ (k ○ g)) ○ ((b ○ (i ○ (i ○ ((i ○ ((k ○ (d ○ (b ○ ((b ○ ((h ○
      k) ○ e)) ○ a)))) ○ j)) ○ a)))) ○ i)) ○ h)))) ○ (g ○ h))) ○ f) ○ h)) ○ b))
      ○ f) ○ f))) ○ (e ○ d)))) ○ d) ○ c)) ○ c)) ○ b))))) ○ (((a ○ a) ○ k) ○
      e)))) ○ c) ○ h) ○ (d ○ a)) ○ (c ○ a)))
      ≡
      (j ○ (k ○ (((h ○ (h ○ e)) ○ ((((e ○ (((a ○ (b ○ ((b ○ c) ○ (((d ○ d) ○
      ((d ○ d) ○ ((((e ○ (e ○ (f ○ f))) ○ (((a ○ ((b ○ (h ○ (k ○ (h ○ ((f ○ ((h
      ○ ((h ○ (a ○ ((k ○ (g ○ (b ○ (k ○ ((((a ○ (((e ○ h) ○ k) ○ b)) ○ b) ○ d)
      ○ j))))) ○ ((((a ○ i) ○ i) ○ i) ○ i)))) ○ ((g ○ h) ○ g))) ○ (j ○ d))) ○
      f))))) ○ b)) ○ k) ○ d)) ○ d) ○ d))) ○ ((c ○ c) ○ c))))) ○ (a ○ a)) ○ a))
      ○ (k ○ e)) ○ c) ○ d)) ○ a))) ○ (c ○ a)

test = prove thm


{-# OPTIONS --copatterns #-}

module examplesPaperJFP.IOGraphicsLib where

open import Data.Bool.Base
open import Data.Char.Base
open import Data.Nat.Base hiding (_⊓_; _+_; _*_)
open import Data.List.Base hiding (_++_)
open import Data.Integer.Base hiding (suc)
open import Data.String.Base
open import Data.Maybe.Base

open import Function

open import Size

open import SizedIO.Base
open import SizedIO.IOGraphicsLib hiding (GraphicsCommands; GraphicsResponses; GraphicsInterface; IOGraphics) renaming (Size to WindowSize)

open import NativeInt --PrimTypeHelpers
open import NativeIO

data GraphicsCommands  :  Set where
  getWindowEvent  :  Window  →  GraphicsCommands
  openWindow      :  String  →  Maybe Point  →  ℕ  → ℕ
                             →  RedrawMode   →  Maybe Word32
                             →  GraphicsCommands
  closeWindow     :  Window  →  GraphicsCommands
  drawInWindow    :  Window  →  Graphic → GraphicsCommands

GraphicsResponses  :                       GraphicsCommands → Set
GraphicsResponses  (getWindowEvent _)        =  Event
GraphicsResponses  (openWindow _ _ _ _ _ _)  =  Window
GraphicsResponses  (closeWindow _)           =  Unit
GraphicsResponses  (drawInWindow _ _)        =  Unit

GraphicsInterface            :  IOInterface
Command   GraphicsInterface  =  GraphicsCommands
Response  GraphicsInterface  =  GraphicsResponses

IOGraphics : Size → Set → Set
IOGraphics i = IO GraphicsInterface i

translateNative : (c : GraphicsCommands) → NativeIO (GraphicsResponses c)

translateNative  (getWindowEvent w)               =  nativeGetWindowEvent w
translateNative  (openWindow str point n1 n2 m w)  =  nativeOpenWindowExNat str point n1 n2 m w
translateNative  (closeWindow w)                  =  nativeCloseWindow w
translateNative  (drawInWindow w g)               =  nativeDrawInWindow w g


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

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels

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

S²ToSetRec : ∀ {ℓ} {A : S² → Type ℓ}
           → ((x : S²) → isSet (A x))
           → A base
           → (x : S²) → A x
S²ToSetRec set b base = b
S²ToSetRec set b (surf i j) =
  isOfHLevel→isOfHLevelDep 2 set b b {a0 = refl} {a1 = refl} refl refl surf i j


{-# OPTIONS --cubical --no-import-sorts #-}

module Module where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Structures.Ring
open import Cubical.Structures.Group
open import Cubical.Structures.AbGroup

open import NumberBundles2

record IsLeftRModule {ℓ ℓᴿ : Level}
  {R : Type ℓᴿ} (   1ᴿ : R) (_+ᴿ_ _·ᴿ_ : R → R → R)
  {X  : Type ℓ} (0ᴹ    : X) (_+ᴹ_      : X → X → X) (_·ᴹ_ : R → X → X) (-ᴹ_ : X → X)
  : Type (ℓ-max ℓ ℓᴿ) where
  field
    isAbGroupᴹ  : IsAbGroup 0ᴹ    _+ᴹ_      -ᴹ_
    ·ᴹ-dist-+ᴹ  : ∀ r x y → r ·ᴹ (x +ᴹ y) ≡ (r ·ᴹ x) +ᴹ (r ·ᴹ y)
    ·ᴹ-dist-+ᴿ  : ∀ r s x → (r +ᴿ s) ·ᴹ x ≡ (r ·ᴹ x) +ᴹ (s ·ᴹ x)
    ·ᴹ-assoc-·ᴿ : ∀ r s x → (r ·ᴿ s) ·ᴹ x ≡ r ·ᴹ (s ·ᴹ x)
    ·ᴹ-identity : ∀ x → 1ᴿ ·ᴹ x ≡ x
  open IsAbGroup isAbGroupᴹ renaming
    ( _-_ to _-ᴹ_
    ; assoc       to +ᴹ-assoc
    ; identity    to +ᴹ-identity
    ; lid         to +ᴹ-lid
    ; rid         to +ᴹ-rid
    ; inverse     to +ᴹ-inv
    ; invl        to +ᴹ-linv
    ; invr        to +ᴹ-rinv
    ; comm        to +ᴹ-comm
    ; isSemigroup to +ᴹ-isSemigroup
    ; isMonoid    to +ᴹ-isMonoid
    ; isGroup     to +ᴹ-isGroup
    ) public

ApartnessRingWithAbs = Ring -- TODO define `ApartnessRingWithAbs`

record LeftRModule {ℓ ℓᴿ : Level} (ring : ApartnessRingWithAbs {ℓᴿ}) : Type (ℓ-suc (ℓ-max ℓ ℓᴿ)) where
  open Ring ring renaming
    ( Carrier       to Carrierᴿ
    ; 0r            to 0ᴿ
    ; 1r            to 1ᴿ
    ; _+_           to _+ᴿ_
    ; _·_           to _·ᴿ_
    ; -_            to -ᴿ_
    ; is-set        to is-setᴿ
    ; +-assoc       to +ᴿ-assoc
    ; +-identity    to +ᴿ-identity
    ; +-lid         to +ᴿ-lid
    ; +-rid         to +ᴿ-rid
    ; +-inv         to +ᴿ-inv
    ; +-linv        to +ᴿ-linv
    ; +-rinv        to +ᴿ-rinv
    ; +-comm        to +ᴿ-comm
    ; +-isSemigroup to +ᴿ-isSemigroup
    ; +-isMonoid    to +ᴿ-isMonoid
    ; +-isGroup     to +ᴿ-isGroup
    ; ·-assoc       to ·ᴿ-assoc
    ; ·-identity    to ·ᴿ-identity
    ; ·-lid         to ·ᴿ-lid
    ; ·-rid         to ·ᴿ-rid
    ; ·-isSemigroup to ·ᴿ-isSemigroup
    ; ·-rdist-+     to ·ᴿ-rdist-+ᴿ
    ; ·-ldist-+     to ·ᴿ-ldist-+ᴿ
    ) public

  field
    Carrier  : Type ℓ
    0ᴹ       : Carrier
    _+ᴹ_     : Carrier → Carrier → Carrier
    _·ᴹ_     : Carrierᴿ → Carrier → Carrier
    -ᴹ_      : Carrier → Carrier
    isLeftRModule : IsLeftRModule 1ᴿ _+ᴿ_ _·ᴿ_ 0ᴹ _+ᴹ_ _·ᴹ_ -ᴹ_

  open IsLeftRModule isLeftRModule public

  infix  8 -ᴹ_
  infixl 7 _·ᴹ_
  infixl 6 _+ᴹ_

record LeftKModule {ℓ ℓᴷ : Level} (ffield : CompleteApartnessFieldWithAbs {ℓᴷ}) : Type (ℓ-suc (ℓ-max ℓ ℓᴷ)) where
   open CompleteApartnessFieldWithAbs ffield renaming
     ( Carrier       to Carrierᴷ
     ; 0f            to 0ᴷ
     ; 1f            to 1ᴷ
     ; _+_           to _+ᴷ_
     ; _·_           to _·ᴷ_
     ; -_            to -ᴷ_
     ) public
   field
     Carrier  : Type ℓ
     0ᴹ       : Carrier
     _+ᴹ_     : Carrier → Carrier → Carrier
     _·ᴹ_     : Carrierᴷ → Carrier → Carrier
     -ᴹ_      : Carrier → Carrier
     isLeftRModule : IsLeftRModule 1ᴷ _+ᴷ_ _·ᴷ_ 0ᴹ _+ᴹ_ _·ᴹ_ -ᴹ_


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of the pointwise lifting of a predicate to a binary tree
------------------------------------------------------------------------

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

module Data.Tree.Binary.Relation.Unary.All.Properties where

open import Level
open import Data.Tree.Binary as Tree using (Tree; leaf; node)
open import Data.Tree.Binary.Relation.Unary.All
open import Relation.Unary

private
  variable
    a b p q : Level
    A : Set a
    B : Set b

module _ {P : B → Set p} where

  map⁺ : (f : A → B) → ∀[ All (f ⊢ P) ⇒ Tree.map f ⊢ All P ]
  map⁺ f leaf         = leaf
  map⁺ f (node l m r) = node (map⁺ f l) m (map⁺ f r)


------------------------------------------------------------------------
-- Syntax of pure type systems (PTS)
------------------------------------------------------------------------

module Pts.Syntax where

open import Data.Fin using (Fin)
open import Data.Fin.Substitution
open import Data.Fin.Substitution.Lemmas
open import Data.Fin.Substitution.ExtraLemmas
open import Data.Fin.Substitution.Typed
open import Data.Star using (Star; ε; _◅_)
open import Data.Nat using (ℕ; suc; _+_)
open import Data.Vec using (lookup)
open import Relation.Binary.PropositionalEquality as PropEq
open PropEq.≡-Reasoning

-- All submodules are parametrized by a given set of sorts.
module _ (Sort : Set) where

  ----------------------------------------------------------------------
  -- Abstract syntax of terms

  module Syntax where

    infixl 9 _·_

    -- Untyped terms with up to n free variables.
    data Term (n : ℕ) : Set where
      var  : (x : Fin n)                     → Term n  -- variable
      sort : (s : Sort)                      → Term n  -- sort
      Π    : (a : Term n) (b : Term (1 + n)) → Term n  -- dependent product
      ƛ    : (a : Term n) (b : Term (1 + n)) → Term n  -- abstraction
      _·_  : (a b : Term n)                  → Term n  -- application

  open Syntax

  ----------------------------------------------------------------------
  -- Substitutions in terms

  -- Application of generic substitutions to terms
  module SubstApp {T} (l : Lift T Term) where
    open Lift l

    infixl 8 _/_

    -- Apply a substitution to a term.
    _/_ : ∀ {m n} → Term m → Sub T m n → Term n
    var x  / σ = lift (lookup x σ)
    sort s / σ = sort s
    Π a b  / σ = Π (a / σ) (b / σ ↑)
    ƛ a b  / σ = ƛ (a / σ) (b / σ ↑)
    a · b  / σ = (a / σ) · (b / σ)

    -- Some helper lemmas about applying sequences of substitutions.
    -- To be used in PathSubstLemmas.

    open Application (record { _/_ = _/_ }) hiding (_/_)

    -- Sorts are invariant under substitution.
    sort-/✶-↑✶ : ∀ k {m n s} (σs : Subs T m n) → sort s /✶ σs ↑✶ k ≡ sort s
    sort-/✶-↑✶ k ε        = refl
    sort-/✶-↑✶ k (σ ◅ σs) = cong₂ _/_ (sort-/✶-↑✶ k σs) refl

    -- Substitutions in dependent product types are compositional.
    Π-/✶-↑✶ : ∀ k {m n a b} (σs : Subs T m n) →
                  (Π a b) /✶ σs ↑✶ k ≡  Π (a /✶ σs ↑✶ k) (b /✶ σs ↑✶ suc k)
    Π-/✶-↑✶ k ε        = refl
    Π-/✶-↑✶ k (σ ◅ σs) = cong₂ _/_ (Π-/✶-↑✶ k σs) refl

    -- Substitutions in abstractions are compositional.
    ƛ-/✶-↑✶ : ∀ k {m n a b} (σs : Subs T m n) →
                  (ƛ a b) /✶ σs ↑✶ k ≡  ƛ (a /✶ σs ↑✶ k) (b /✶ σs ↑✶ suc k)
    ƛ-/✶-↑✶ k ε        = refl
    ƛ-/✶-↑✶ k (σ ◅ σs) = cong₂ _/_ (ƛ-/✶-↑✶ k σs) refl

    -- Substitutions in applications are compositional.
    ·-/✶-↑✶ : ∀ k {m n a b} (σs : Subs T m n) →
                  (a · b) /✶ σs ↑✶ k ≡ (a /✶ σs ↑✶ k) · (b /✶ σs ↑✶ k)
    ·-/✶-↑✶ k ε        = refl
    ·-/✶-↑✶ k (σ ◅ σs) = cong₂ _/_ (·-/✶-↑✶ k σs) refl

  -- Substitutions in terms and associated lemmas.
  module Substitution where

    -- Term substitutions.
    termSubst : TermSubst Term
    termSubst = record { var = var; app = SubstApp._/_ }

    -- Lemmas relating application of sequences of generic substitutions
    -- lifted to any number of additional variables.
    --
    -- Using these generic lemmas, we can instantiate the record
    -- Data.Fin.Substitution.Lemmas.TermLemmas below, which gives access
    -- to a number of useful (derived) lemmas about path substitutions.
    module Lemmas {T₁ T₂} {lift₁ : Lift T₁ Term} {lift₂ : Lift T₂ Term} where
      open SubstApp
      open Lift lift₁ using () renaming (_↑✶_ to _↑✶₁_)
      open Lift lift₂ using () renaming (_↑✶_ to _↑✶₂_)
      open Application (record { _/_ = SubstApp._/_ lift₁ }) using ()
        renaming (_/✶_ to _/✶₁_)
      open Application (record { _/_ = SubstApp._/_ lift₂ }) using ()
        renaming (_/✶_ to _/✶₂_)

      -- Sequences of (lifted) T₁ and T₂-substitutions are equivalent
      -- when applied to terms if they are equivalent when applied to
      -- variables.
      /✶-↑✶ : ∀ {m n} (σs₁ : Subs T₁ m n) (σs₂ : Subs T₂ m n) →
                (∀ k x → var x /✶₁ σs₁ ↑✶₁ k ≡ var x /✶₂ σs₂ ↑✶₂ k) →
                 ∀ k t → t     /✶₁ σs₁ ↑✶₁ k ≡ t     /✶₂ σs₂ ↑✶₂ k
      /✶-↑✶ σs₁ σs₂ hyp k (var x)  = hyp k x
      /✶-↑✶ σs₁ σs₂ hyp k (sort s) = begin
        sort s /✶₁ σs₁ ↑✶₁ k   ≡⟨ sort-/✶-↑✶ _ k σs₁ ⟩
        sort s                 ≡⟨ sym (sort-/✶-↑✶ _ k σs₂) ⟩
        sort s /✶₂ σs₂ ↑✶₂ k   ∎
      /✶-↑✶ σs₁ σs₂ hyp k (Π a b) = begin
          (Π a b) /✶₁ σs₁ ↑✶₁ k
        ≡⟨ Π-/✶-↑✶ _ k σs₁ ⟩
          Π (a /✶₁ σs₁ ↑✶₁ k) (b /✶₁ σs₁ ↑✶₁ suc k)
        ≡⟨ cong₂ Π (/✶-↑✶ σs₁ σs₂ hyp k a) (/✶-↑✶ σs₁ σs₂ hyp (suc k) b) ⟩
          Π (a /✶₂ σs₂ ↑✶₂ k) (b /✶₂ σs₂ ↑✶₂ suc k)
        ≡⟨ sym (Π-/✶-↑✶ _ k σs₂) ⟩
          (Π a b) /✶₂ σs₂ ↑✶₂ k
        ∎
      /✶-↑✶ σs₁ σs₂ hyp k (ƛ a b) = begin
          (ƛ a b) /✶₁ σs₁ ↑✶₁ k
        ≡⟨ ƛ-/✶-↑✶ _ k σs₁ ⟩
          ƛ (a /✶₁ σs₁ ↑✶₁ k) (b /✶₁ σs₁ ↑✶₁ suc k)
        ≡⟨ cong₂ ƛ (/✶-↑✶ σs₁ σs₂ hyp k a) (/✶-↑✶ σs₁ σs₂ hyp (suc k) b) ⟩
          ƛ (a /✶₂ σs₂ ↑✶₂ k) (b /✶₂ σs₂ ↑✶₂ suc k)
        ≡⟨ sym (ƛ-/✶-↑✶ _ k σs₂) ⟩
          (ƛ a b) /✶₂ σs₂ ↑✶₂ k
        ∎
      /✶-↑✶ σs₁ σs₂ hyp k (a · b) = begin
          (a · b) /✶₁ σs₁ ↑✶₁ k
        ≡⟨ ·-/✶-↑✶ _ k σs₁ ⟩
          (a /✶₁ σs₁ ↑✶₁ k) · (b /✶₁ σs₁ ↑✶₁ k)
        ≡⟨ cong₂ _·_ (/✶-↑✶ σs₁ σs₂ hyp k a) (/✶-↑✶ σs₁ σs₂ hyp k b) ⟩
          (a /✶₂ σs₂ ↑✶₂ k) · (b /✶₂ σs₂ ↑✶₂ k)
        ≡⟨ sym (·-/✶-↑✶ _ k σs₂) ⟩
          (a · b) /✶₂ σs₂ ↑✶₂ k
        ∎

    -- By instantiating TermLemmas, we get access to a number of useful
    -- (derived) lemmas about path substitutions.
    termLemmas : TermLemmas Term
    termLemmas = record
      { termSubst = termSubst
      ; app-var   = refl
      ; /✶-↑✶     = Lemmas./✶-↑✶
      }

    open TermLemmas termLemmas public hiding (var; termSubst)

    -- By instantiating TermLikeLemmas, we get access to a number of
    -- useful (derived) lemmas about variable substitutions (renamings).
    private
      termLikeLemmas : TermLikeLemmas Term Term
      termLikeLemmas = record
        { app        = SubstApp._/_
        ; termLemmas = termLemmas
        ; /✶-↑✶₁     = Lemmas./✶-↑✶
        ; /✶-↑✶₂     = Lemmas./✶-↑✶
        }

    open TermLikeLemmas termLikeLemmas public
      using (varLiftAppLemmas; varLiftSubLemmas; _/Var_)

    infix 10 _[_]

    -- Shorthand for single-variable term substitutions.
    _[_] : ∀ {n} → Term (1 + n) → Term n → Term n
    a [ b ] = a / sub b

  ----------------------------------------------------------------------
  -- Concrete typing contexts over terms.

  module Ctx where
    open Substitution using (weaken)
    open Context      Term public hiding (module Ctx)

    weakenOps : WeakenOps
    weakenOps = record { weaken = weaken }

    open WeakenOps weakenOps public hiding (weaken)


------------------------------------------------------------------------
-- Indexed applicative functors
------------------------------------------------------------------------

-- Note that currently the applicative functor laws are not included
-- here.

module Category.Applicative.Indexed where

open import Data.Function
open import Data.Product
open import Category.Functor

IFun : Set → Set₁
IFun I = I → I → Set → Set

record RawIApplicative {I : Set} (F : IFun I) : Set₁ where
  infixl 4 _⊛_ _<⊛_ _⊛>_
  infix  4 _⊗_

  field
    pure : ∀ {i A} → A → F i i A
    _⊛_  : ∀ {i j k A B} → F i j (A → B) → F j k A → F i k B

  rawFunctor : ∀ {i j} → RawFunctor (F i j)
  rawFunctor = record
    { _<$>_ = λ g x → pure g ⊛ x
    }

  private
    open module RF {i j : I} =
           RawFunctor (rawFunctor {i = i} {j = j})
           public

  _<⊛_ : ∀ {i j k A B} → F i j A → F j k B → F i k A
  x <⊛ y = const <$> x ⊛ y

  _⊛>_ : ∀ {i j k A B} → F i j A → F j k B → F i k B
  x ⊛> y = flip const <$> x ⊛ y

  _⊗_ : ∀ {i j k A B} → F i j A → F j k B → F i k (A × B)
  x ⊗ y = (_,_) <$> x ⊛ y


module Logic.Structure.Applicative where

data Applicative (f : Set -> Set) : Set1 where
  applicative :
      (pure  : {a : Set} -> a -> f a)
      (_<*>_ : {a b : Set} -> f (a -> b) -> f a -> f b) ->
      Applicative f

module Applicative {f : Set -> Set}(App : Applicative f) where

  private
    pure' : Applicative f -> {a : Set} -> a -> f a
    pure' (applicative p _) = p

    app' : Applicative f -> {a b : Set} -> f (a -> b) -> f a -> f b
    app' (applicative _ a) = a

  pure : {a : Set} -> a -> f a
  pure = pure' App

  _<*>_ : {a b : Set} -> f (a -> b) -> f a -> f b
  _<*>_ = app' App


{-# OPTIONS --warning=error --safe --without-K #-}

open import LogicalFormulae
open import Semirings.Definition

module Semirings.Solver {a : _} {A : Set a} {Zero One : A} {_+_ : A → A → A} {_*_ : A → A → A} (S : Semiring Zero One _+_ _*_) (comm : (a b : A) → a * b ≡ b * a) where

open Semiring S

-- You can see how to use the solver in LectureNotes/NumbersAndSets/Lecture1.agda.

data Expr : Set a where
  const : A → Expr
  zero : Expr
  succ : Expr → Expr
  plus : Expr → Expr → Expr
  times : Expr → Expr → Expr

-- TODO: do this in distinct phases. (Work out what those phases are.)
-- Expose those phases to the user so that they can choose which tactics to use.
-- Phases:
--  * In any expression which is all sums, extract all consts out to the front
--  * In any expression which is all sums, extract all the succs to the front

eval : Expr → A
eval (const k) = k
eval zero = Zero
eval (succ e) = One + (eval e)
eval (plus x y) = (eval x) + (eval y)
eval (times x y) = (eval x) * (eval y)

simplePlus : Expr → Expr → Expr
simplePlus (const x) (const y) = plus (const x) (const y)
simplePlus (const x) zero = const x
simplePlus (const x) (succ b) = succ (plus (const x) b)
simplePlus (const x) (plus a b) = plus (const x) (plus a b)
simplePlus (const x) (times a b) = plus (const x) (times a b)
simplePlus zero b = b
simplePlus (succ a) (const x) = succ (plus (const x) a)
simplePlus (succ a) zero = succ a
simplePlus (succ a) (succ b) = succ (succ (plus a b))
simplePlus (succ a) (plus b c) = succ (plus a (plus b c))
simplePlus (succ a) (times b c) = succ (plus a (times b c))
simplePlus (plus a b) (const x) = plus (const x) (plus a b)
simplePlus (plus a b) zero = plus a b
simplePlus (plus a b) (succ c) = succ (plus a (plus b c))
simplePlus (plus a b) (plus c d) = plus a (plus b (plus c d))
simplePlus (plus a b) (times c d) = plus a (plus b (times c d))
simplePlus (times a b) (const x) = plus (const x) (times a b)
simplePlus (times a b) zero = times a b
simplePlus (times a b) (succ c) = succ (plus (times a b) c)
simplePlus (times a b) (plus c d) = plus (times a b) (plus c d)
simplePlus (times a b) (times c d) = plus (times a b) (times c d)

private
  lemma : (a b c : A) → a + (b + c) ≡ b + (a + c)
  lemma a b c rewrite commutative a (b + c) | equalityCommutative (+Associative b c a) = applyEquality (b +_) (commutative _ _)

simplePlusIsPlus : (a b : Expr) → eval (simplePlus a b) ≡ eval (plus a b)
simplePlusIsPlus (const x) (const x₁) = refl
simplePlusIsPlus (const x) zero rewrite Semiring.sumZeroRight S x = refl
simplePlusIsPlus (const x) (succ b) = lemma One x (eval b)
simplePlusIsPlus (const x) (plus b c) = refl
simplePlusIsPlus (const x) (times b c) = refl
simplePlusIsPlus zero b = equalityCommutative (sumZeroLeft (eval b))
simplePlusIsPlus (succ a) (const x) rewrite lemma One x (eval a) = commutative x _
simplePlusIsPlus (succ a) zero = equalityCommutative (sumZeroRight _)
simplePlusIsPlus (succ a) (succ b) rewrite lemma (One + eval a) One (eval b) = applyEquality (One +_) (+Associative One _ _)
simplePlusIsPlus (succ a) (plus b c) = +Associative _ _ _
simplePlusIsPlus (succ a) (times b c) = +Associative _ _ _
simplePlusIsPlus (plus a b) (const x) = commutative x _
simplePlusIsPlus (plus a b) zero = equalityCommutative (sumZeroRight _)
simplePlusIsPlus (plus a b) (succ c) rewrite lemma (eval a + eval b) One (eval c) = applyEquality (One +_) (+Associative _ _ _)
simplePlusIsPlus (plus a b) (plus c d) = +Associative (eval a) _ _
simplePlusIsPlus (plus a b) (times c d) = +Associative _ _ _
simplePlusIsPlus (times a b) (const x) = commutative x _
simplePlusIsPlus (times a b) zero = equalityCommutative (sumZeroRight _)
simplePlusIsPlus (times a b) (succ c) rewrite lemma One (eval a * eval b) (eval c) = refl
simplePlusIsPlus (times a b) (plus c d) = refl
simplePlusIsPlus (times a b) (times c d) = refl

simplify : Expr → Expr
simplify (const k) = const k
simplify zero = zero
simplify (succ e) = succ (simplify e)
simplify (plus (const k) (const x)) = simplePlus (const k) (const x)
simplify (plus (const k) zero) = simplify (const k)
simplify (plus (const k) (succ expr)) = succ (simplify (plus (const k) expr))
simplify (plus (const k) (plus x y)) = simplePlus (const k) (simplify (plus x y))
simplify (plus (const k) (times x y)) = simplePlus (const k) (simplify (times x y))
simplify (plus zero expr2) = simplify expr2
simplify (plus (succ expr1) expr2) = succ (simplify (plus expr1 expr2))
simplify (plus (plus expr1 expr3) zero) = simplify (plus expr1 expr3)
simplify (plus (plus expr1 expr3) (const k)) = simplePlus (const k) (simplify (plus expr1 expr3))
simplify (plus (plus expr1 expr3) (succ expr2)) = succ (simplePlus (simplify (plus expr1 expr3)) (simplify expr2))
simplify (plus (plus expr1 expr3) (plus expr2 expr4)) = simplePlus (simplify (plus expr1 expr3)) (simplify (plus expr2 expr4))
simplify (plus (plus expr1 expr3) (times expr2 expr4)) = simplePlus (simplify (plus expr1 expr3)) (simplify (times expr2 expr4))
simplify (plus (times expr1 expr3) (const k)) = simplePlus (const k) (simplify (times expr1 expr3))
simplify (plus (times expr1 expr3) zero) = times (simplify expr1) (simplify expr3)
simplify (plus (times expr1 expr3) (succ expr2)) = succ (simplePlus (simplify (times expr1 expr3)) (simplify expr2))
simplify (plus (times expr1 expr3) (plus expr2 expr4)) = simplePlus (simplify (times expr1 expr3)) (simplify (plus expr2 expr4))
simplify (plus (times expr1 expr3) (times expr2 expr4)) = simplePlus (simplify (times expr1 expr3)) (simplify (times expr2 expr4))
simplify (times (const k) (const x)) = times (const k) (const x)
simplify (times (const k) zero) = zero
simplify (times (const k) (succ zero)) = const k
simplify (times (const k) (succ (const y))) = simplePlus (const k) (times (const k) (const y))
simplify (times (const k) (succ (plus a b))) = simplePlus (const k) (simplify (times (const k) (plus a b)))
simplify (times (const k) (succ (times a b))) = simplePlus (const k) (simplify (times (const k) (times a b)))
simplify (times (const k) (succ (succ x))) = simplePlus (const k) (simplify (times (const k) (succ x)))
simplify (times (const k) (plus expr2 expr3)) = simplePlus (simplify (times (const k) (expr2))) (simplify (times (const k) expr3))
simplify (times (const k) (times expr2 expr3)) = times (const k) (simplify (times expr2 expr3))
simplify (times zero expr2) = zero
simplify (times (succ zero) expr2) = simplify expr2
simplify (times (succ (succ expr1)) expr2) = simplePlus (simplify expr2) (simplify (times (succ expr1) expr2))
simplify (times (succ (plus expr1 expr3)) (const k)) = times (const k) (simplify (succ (plus expr1 expr3)))
simplify (times (succ (plus expr1 expr3)) zero) = zero
simplify (times (succ (plus expr1 expr3)) (succ expr2)) = succ (simplePlus (simplify (times expr1 expr2)) (simplePlus (simplify (times expr3 expr2)) (simplePlus expr2 (simplify (plus expr1 expr3)))))
simplify (times (succ (plus expr1 expr3)) (plus expr2 expr4)) = times (simplify (succ (plus expr1 expr3))) (simplify (plus expr2 expr4))
simplify (times (succ (plus expr1 expr3)) (times expr2 expr4)) = times (simplify (succ (plus expr1 expr3))) (simplify (times expr2 expr4))
simplify (times (succ (const k)) (const x)) = simplePlus (const x) (times (const k) (const x))
simplify (times (succ (const k)) zero) = zero
simplify (times (succ (const k)) (succ (const x))) = succ (simplePlus (const k) (simplePlus (const x) (simplify (times (const k) (const x)))))
simplify (times (succ (const k)) (succ zero)) = succ (const k)
simplify (times (succ (const k)) (succ (succ expr2))) = succ (simplePlus (const k) (simplePlus (simplify (succ expr2)) (simplify (times (const k) (succ (expr2))))))
simplify (times (succ (const k)) (succ (plus expr2 expr3))) = succ (simplePlus (const k) (simplePlus (simplify (plus expr2 expr3)) (simplify (times (const k) (plus expr2 expr3)))))
simplify (times (succ (const k)) (succ (times expr2 expr3))) = succ (simplePlus (const k) (simplePlus (simplify (times expr2 expr3)) (simplify (times (const k) (times expr2 expr3)))))
simplify (times (succ (const k)) (plus expr2 expr3)) = simplePlus (simplify (plus expr2 expr3)) (simplify (times (const k) (plus expr2 expr3)))
simplify (times (succ (const k)) (times expr2 expr3)) = simplePlus (simplify (times expr2 expr3)) (simplify (times (const k) (times expr2 expr3)))
simplify (times (succ (times expr1 expr3)) (const x)) = times (const x) (simplify (succ (times expr1 expr3)))
simplify (times (succ (times expr1 expr3)) zero) = zero
simplify (times (succ (times expr1 expr3)) (succ expr2)) = succ (simplePlus (simplify expr2) (plus (simplify (times expr1 expr3)) (simplify (times (times expr1 expr3) expr2))))
simplify (times (succ (times expr1 expr3)) (plus expr2 expr4)) = simplePlus (simplify (plus expr2 expr4)) (simplify (times (times expr1 expr3) (plus expr2 expr4)))
simplify (times (succ (times expr1 expr3)) (times expr2 expr4)) = simplePlus (simplify (times expr2 expr4)) (simplify (times (times expr1 expr3) (times expr2 expr4)))
simplify (times (plus expr1 expr3) zero) = zero
simplify (times (plus expr1 expr3) (succ expr2)) = simplePlus (simplify (plus expr1 expr3)) (simplify (times (plus expr1 expr3) expr2))
simplify (times (plus expr1 expr3) (const x)) = times (const x) (simplify (plus expr1 expr3))
simplify (times (plus expr1 expr3) (plus expr2 expr4)) = simplePlus (simplify (times expr1 expr2)) (simplePlus (simplify (times expr3 expr2)) (simplePlus (simplify (times expr1 expr4)) (simplify (times expr3 expr4))))
simplify (times (plus expr1 expr3) (times expr2 expr4)) = simplePlus (simplify (times expr1 (times expr2 expr4))) (simplify (times expr3 (times expr2 expr4)))
simplify (times (times expr1 expr3) zero) = zero
simplify (times (times expr1 expr3) (succ expr2)) = simplePlus (simplify (times expr1 expr3)) (simplify (times (times expr1 expr3) expr2))
simplify (times (times expr1 expr3) (plus expr2 expr4)) = simplePlus (simplify (times (times expr1 expr3) expr2)) (simplify (times (times expr1 expr3) expr4))
simplify (times (times expr1 expr3) (times expr2 expr4)) = times (simplify expr1) (simplify (times expr3 (times expr2 expr4)))
simplify (times (times expr1 expr3) (const x)) = times (simplify (times expr1 expr3)) (const x)

equalPlus : {a b c d : A} → (a ≡ c) → (b ≡ d) → (a + b) ≡ (c + d)
equalPlus refl refl = refl

equalTimes : {a b c d : A} → (a ≡ c) → (b ≡ d) → (a * b) ≡ (c * d)
equalTimes refl refl = refl

otherDist : {a b c : A} → (a * b) + (c * b) ≡ (a + c) * b
otherDist = transitivity (equalPlus (comm _ _) (comm _ _)) (transitivity (equalityCommutative (+DistributesOver* _ _ _)) (comm _ _))

simplifyPreserves : (a : Expr) → eval (simplify a) ≡ eval a
simplifyPreserves (const x) = refl
simplifyPreserves zero = refl
simplifyPreserves (succ a) = applyEquality (One +_) (simplifyPreserves a)
simplifyPreserves (plus (const x) (const y)) = refl
simplifyPreserves (plus (const x) zero) = equalityCommutative (sumZeroRight x)
simplifyPreserves (plus (const x) (succ b)) = transitivity (transitivity (applyEquality (One +_) (transitivity (simplifyPreserves (plus (const x) b)) (commutative x (eval b)))) (+Associative One (eval b) x)) (commutative (One + eval b) x)
simplifyPreserves (plus (const x) (plus b c)) = transitivity (simplePlusIsPlus (const x) (simplify (plus b c))) (applyEquality (x +_) (simplifyPreserves (plus b c)))
simplifyPreserves (plus (const x) (times b c)) = transitivity (simplePlusIsPlus (const x) (simplify (times b c))) (applyEquality (x +_) (simplifyPreserves (times b c)))
simplifyPreserves (plus zero a) = transitivity (simplifyPreserves a) (equalityCommutative (sumZeroLeft (eval a)))
simplifyPreserves (plus (succ a) b) = transitivity (applyEquality (One +_) (simplifyPreserves (plus a b))) (+Associative One (eval a) (eval b))
simplifyPreserves (plus (plus a b) (const x)) = transitivity (simplePlusIsPlus (const x) (simplify (plus a b))) (transitivity (commutative x (eval (simplify (plus a b)))) (applyEquality (_+ x) (simplifyPreserves (plus a b))))
simplifyPreserves (plus (plus a b) zero) = transitivity (simplifyPreserves (plus a b)) (equalityCommutative (sumZeroRight _))
simplifyPreserves (plus (plus a b) (succ c)) = transitivity (applyEquality (One +_) (simplePlusIsPlus (simplify (plus a b)) (simplify c))) (transitivity (+Associative One _ _) (transitivity (applyEquality (_+ eval (simplify c)) (commutative One _)) (transitivity (equalityCommutative (+Associative _ _ _)) (transitivity (applyEquality (_+ (One + eval (simplify c))) (simplifyPreserves (plus a b))) (applyEquality (λ i → (eval a + eval b) + (One + i)) (simplifyPreserves c))))))
simplifyPreserves (plus (plus a b) (plus c d)) = transitivity (simplePlusIsPlus (simplify (plus a b)) (simplify (plus c d))) (transitivity (applyEquality (_+ eval (simplify (plus c d))) (simplifyPreserves (plus a b))) (applyEquality ((eval a + eval b) +_) (simplifyPreserves (plus c d))))
simplifyPreserves (plus (plus a b) (times c d)) = transitivity (simplePlusIsPlus (simplify (plus a b)) (simplify (times c d))) (transitivity (applyEquality (_+ eval (simplify (times c d))) (simplifyPreserves (plus a b))) (applyEquality ((eval a + eval b) +_) (simplifyPreserves (times c d))))
simplifyPreserves (plus (times a b) (const x)) = transitivity (simplePlusIsPlus (const x) (simplify (times a b))) (transitivity (commutative x _) (applyEquality (_+ x) (simplifyPreserves (times a b))))
simplifyPreserves (plus (times a b) zero) = transitivity (transitivity (applyEquality (_* eval (simplify b)) (simplifyPreserves a)) (applyEquality ((eval a) *_) (simplifyPreserves b))) (equalityCommutative (sumZeroRight _))
simplifyPreserves (plus (times a b) (succ c)) = transitivity (transitivity (applyEquality (One +_) (transitivity (simplePlusIsPlus (simplify (times a b)) (simplify c)) (transitivity (transitivity (applyEquality (eval (simplify (times a b)) +_) (simplifyPreserves c)) (applyEquality (_+ eval c) (simplifyPreserves (times a b)))) (commutative _ (eval c))))) (+Associative One (eval c) _)) (commutative _ (eval a * eval b))
simplifyPreserves (plus (times a b) (plus c d)) = transitivity (simplePlusIsPlus (simplify (times a b)) (simplify (plus c d))) (transitivity (applyEquality (_+ eval (simplify (plus c d))) (simplifyPreserves (times a b))) (applyEquality ((eval a * eval b) +_) (simplifyPreserves (plus c d))))
simplifyPreserves (plus (times a b) (times c d)) = transitivity (simplePlusIsPlus (simplify (times a b)) (simplify (times c d))) (transitivity (applyEquality (_+ eval (simplify (times c d))) (simplifyPreserves (times a b))) (applyEquality ((eval a * eval b) +_) (simplifyPreserves (times c d))))
simplifyPreserves (times (const x) (const y)) = refl
simplifyPreserves (times (const x) zero) = equalityCommutative (productZeroRight x)
simplifyPreserves (times (const x) (succ (const y))) = transitivity (applyEquality (_+ (x * y)) (equalityCommutative (productOneRight _))) (equalityCommutative (+DistributesOver* x One y))
simplifyPreserves (times (const x) (succ zero)) = equalityCommutative (transitivity (applyEquality (x *_) (sumZeroRight One)) (productOneRight x))
simplifyPreserves (times (const x) (succ (succ b))) = transitivity (simplePlusIsPlus (const x) (simplify (times (const x) (succ b)))) (transitivity (equalPlus (equalityCommutative (productOneRight _)) (simplifyPreserves (times (const x) (succ b)))) (equalityCommutative (+DistributesOver* x One _)))
simplifyPreserves (times (const x) (succ (plus b c))) = transitivity (simplePlusIsPlus (const x) (simplePlus (simplify (times (const x) b)) (simplify (times (const x) c)))) (transitivity (equalPlus (equalityCommutative (productOneRight _)) (transitivity (simplePlusIsPlus (simplify (times (const x) b)) (simplify (times (const x) c))) (transitivity (equalPlus (simplifyPreserves (times (const x) b)) (simplifyPreserves (times (const x) c))) (equalityCommutative (+DistributesOver* x (eval b) (eval c)))))) (equalityCommutative (+DistributesOver* x One _)))
simplifyPreserves (times (const x) (succ (times b c))) = transitivity (equalPlus (equalityCommutative (productOneRight x)) (applyEquality (x *_) (simplifyPreserves (times b c)))) (equalityCommutative (+DistributesOver* x One _))
simplifyPreserves (times (const x) (plus b c)) = transitivity (simplePlusIsPlus (simplify (times (const x) b)) (simplify (times (const x) c))) (transitivity (transitivity (applyEquality (eval (simplify (times (const x) b)) +_) (simplifyPreserves (times (const x) c))) (applyEquality (_+ (x * eval c)) (simplifyPreserves (times (const x) b)))) (equalityCommutative (+DistributesOver* x (eval b) (eval c))))
simplifyPreserves (times (const x) (times b c)) = applyEquality (x *_) (simplifyPreserves (times b c))
simplifyPreserves (times zero b) = equalityCommutative (productZeroLeft (eval b))
simplifyPreserves (times (succ (const x)) (const y)) = transitivity (transitivity (equalPlus (equalityCommutative (productOneRight y)) (comm x y)) (equalityCommutative (+DistributesOver* y One x))) (comm y _)
simplifyPreserves (times (succ (const x)) zero) = equalityCommutative (productZeroRight _)
simplifyPreserves (times (succ (const x)) (succ (const y))) = transitivity (transitivity (transitivity (+Associative One x _) (applyEquality ((One + x) +_) (transitivity (equalPlus (equalityCommutative (productOneRight y)) (comm x y)) (equalityCommutative (+DistributesOver* y One x))))) (equalPlus (equalityCommutative (productOneRight (One + x))) (comm _ _))) (equalityCommutative (+DistributesOver* _ _ _))
simplifyPreserves (times (succ (const x)) (succ zero)) = equalityCommutative (transitivity (applyEquality ((One + x) *_) (sumZeroRight One)) (productOneRight _))
simplifyPreserves (times (succ (const x)) (succ (succ b))) = transitivity (applyEquality (One +_) (simplePlusIsPlus (const x) (simplePlus (succ (simplify b)) (simplify (times (const x) (succ b)))))) (transitivity (applyEquality (λ i → One + (x + i)) (simplePlusIsPlus (succ (simplify b)) (simplify (times (const x) (succ b))))) (transitivity (applyEquality (λ i → One + (x + ((One + i) + eval (simplify (times (const x) (succ b)))))) (simplifyPreserves b)) (transitivity (applyEquality (λ i → One + (x + ((One + eval b) + i))) (simplifyPreserves (times (const x) (succ b)))) (transitivity (transitivity (+Associative One x _) (equalPlus (equalityCommutative (productOneRight _)) (transitivity (transitivity (transitivity (applyEquality ((One + eval b) +_) (+DistributesOver* x One (eval b))) (transitivity (transitivity (equalityCommutative (+Associative One (eval b) _)) (transitivity (applyEquality (One +_) (transitivity (+Associative (eval b) _ _) (transitivity (equalPlus (transitivity (commutative _ _) (equalPlus (productOneRight x) (equalityCommutative (productOneRight _)))) (comm x _)) (equalityCommutative (+Associative x _ _))))) (+Associative One x _))) (applyEquality ((One + x) +_) (equalityCommutative (+DistributesOver* (eval b) One x))))) (equalPlus (equalityCommutative (productOneRight _)) (comm (eval b) _))) (equalityCommutative (+DistributesOver* (One + x) One _))))) (equalityCommutative (+DistributesOver* (One + x) One _))))))
simplifyPreserves (times (succ (const x)) (succ (plus b c))) = transitivity (transitivity (transitivity (applyEquality (One +_) (simplePlusIsPlus (const x) (simplePlus (simplify (plus b c)) (simplePlus (simplify (times (const x) b)) (simplify (times (const x) c)))))) (transitivity (+Associative One x _) (applyEquality ((One + x) +_) (transitivity (simplePlusIsPlus (simplify (plus b c)) (simplePlus (simplify (times (const x) b)) (simplify (times (const x) c)))) (transitivity (equalPlus (simplifyPreserves (plus b c)) (simplePlusIsPlus (simplify (times (const x) b)) (simplify (times (const x) c)))) (transitivity (transitivity (transitivity (transitivity (equalityCommutative (+Associative _ _ _ )) (transitivity (applyEquality (eval b +_) (transitivity (applyEquality (eval c +_) (equalPlus (simplifyPreserves (times (const x) b)) (simplifyPreserves (times (const x) c)))) (transitivity (+Associative (eval c) _ _) (transitivity (applyEquality (_+ (x * eval c)) (commutative _ _)) (equalityCommutative (+Associative _ _ _)))))) (+Associative _ _ _))) (equalPlus (equalPlus (equalityCommutative (productOneRight (eval b))) (comm _ _)) (equalPlus (equalityCommutative (productOneRight (eval c))) (comm x _)))) (equalPlus (equalityCommutative (+DistributesOver* (eval b) One x)) (equalityCommutative (+DistributesOver* (eval c) One x)))) (equalPlus (comm _ _) (comm _ _)))))))) (equalPlus (equalityCommutative (productOneRight _)) (equalityCommutative (+DistributesOver* (One + x) _ _)))) (equalityCommutative (+DistributesOver* (One + x) _ _))
simplifyPreserves (times (succ (const x)) (succ (times b c))) = transitivity (transitivity (applyEquality (One +_) (simplePlusIsPlus (const x) (simplePlus (simplify (times b c)) (times (const x) (simplify (times b c)))))) (transitivity (+Associative One x _) (equalPlus (equalityCommutative (productOneRight _)) (transitivity (simplePlusIsPlus (simplify (times b c)) (times (const x) (simplify (times b c)))) (transitivity (transitivity (equalPlus (transitivity (simplifyPreserves (times b c)) (equalityCommutative (productOneRight _))) (transitivity (comm _ _) (applyEquality (_* x) (simplifyPreserves (times b c))))) (equalityCommutative (+DistributesOver* _ One x))) (comm _ _)))))) (equalityCommutative (+DistributesOver* _ _ _))
simplifyPreserves (times (succ (const x)) (plus b c)) = transitivity (simplePlusIsPlus (simplify (plus b c)) (simplePlus (simplify (times (const x) b)) (simplify (times (const x) c)))) (transitivity (transitivity (equalPlus (transitivity (simplifyPreserves (plus b c)) (equalityCommutative (productOneRight _))) (transitivity (simplePlusIsPlus (simplify (times (const x) b)) (simplify (times (const x) c))) (transitivity (transitivity (equalPlus (simplifyPreserves (times (const x) b)) (simplifyPreserves (times (const x) c))) (equalityCommutative (+DistributesOver* x _ _))) (comm x _)))) (equalityCommutative (+DistributesOver* _ One x))) (comm _ _))
simplifyPreserves (times (succ (const x)) (times b c)) = transitivity (simplePlusIsPlus (simplify (times b c)) (times (const x) (simplify (times b c)))) (transitivity (transitivity (equalPlus (transitivity (simplifyPreserves (times b c)) (equalityCommutative (productOneRight _))) (transitivity (comm x _) (applyEquality (_* x) (simplifyPreserves (times b c))))) (equalityCommutative (+DistributesOver* _ One x))) (comm _ _))
simplifyPreserves (times (succ zero) b) = transitivity (simplifyPreserves b) (transitivity (equalityCommutative (productOneLeft (eval b))) (applyEquality (_* eval b) (equalityCommutative (sumZeroRight One))))
simplifyPreserves (times (succ (succ a)) b) = transitivity (simplePlusIsPlus (simplify b) (simplify (times (succ a) b))) (transitivity (equalPlus (simplifyPreserves b) (simplifyPreserves (times (succ a) b))) (transitivity (transitivity (equalPlus (equalityCommutative (productOneRight _)) (comm _ _)) (equalityCommutative (+DistributesOver* (eval b) One _))) (comm (eval b) _)))
simplifyPreserves (times (succ (plus a b)) (const x)) = transitivity (comm x _) (applyEquality (λ i → (One + i) * x) (simplifyPreserves (plus a b)))
simplifyPreserves (times (succ (plus a b)) zero) = equalityCommutative (productZeroRight _)
simplifyPreserves (times (succ (plus a b)) (succ c)) = transitivity (transitivity (transitivity (applyEquality (One +_) (transitivity (simplePlusIsPlus (simplify (times a c)) (simplePlus (simplify (times b c)) (simplePlus c (simplify (plus a b))))) (transitivity (transitivity (equalPlus (simplifyPreserves (times a c)) (simplePlusIsPlus (simplify (times b c)) (simplePlus c (simplify (plus a b))))) (transitivity (+Associative _ _ _) (transitivity (transitivity (equalPlus (transitivity (equalPlus (comm _ _) (transitivity (simplifyPreserves (times b c)) (comm _ _))) (equalityCommutative (+DistributesOver* _ _ _))) (transitivity (simplePlusIsPlus c (simplify (plus a b))) (transitivity (commutative _ _) (equalPlus (simplifyPreserves (plus a b)) (equalityCommutative (productOneRight _)))))) (commutative _ _)) (equalityCommutative (+Associative _ _ _))))) (applyEquality ((eval a + eval b) +_) (equalityCommutative (+DistributesOver* _ One _)))))) (+Associative One _ _)) (equalPlus (equalityCommutative (productOneRight _)) (comm _ _))) (equalityCommutative (+DistributesOver* _ _ _))
simplifyPreserves (times (succ (plus a b)) (plus c d)) = equalTimes (applyEquality (One +_) (simplifyPreserves (plus a b))) (simplifyPreserves (plus c d))
simplifyPreserves (times (succ (plus a b)) (times c d)) = equalTimes (applyEquality (One +_) (simplifyPreserves (plus a b))) (simplifyPreserves (times c d))
simplifyPreserves (times (succ (times a b)) (const x)) = transitivity (comm x _) (applyEquality (λ i → (One + i) * x) (simplifyPreserves (times a b)))
simplifyPreserves (times (succ (times a b)) zero) = equalityCommutative (productZeroRight _)
simplifyPreserves (times (succ (times a b)) (succ c)) = transitivity (transitivity (transitivity (applyEquality (One +_) (transitivity (simplePlusIsPlus (simplify c) (plus (simplify (times a b)) (simplify (times (times a b) c)))) (transitivity (transitivity (transitivity (equalPlus (transitivity (simplifyPreserves c) (equalityCommutative (productOneRight _))) (transitivity (commutative _ _) (equalPlus (transitivity (simplifyPreserves (times (times a b) c)) (comm _ _)) (simplifyPreserves (times a b))))) (+Associative _ _ _)) (applyEquality (_+ (eval a * eval b)) (equalityCommutative (+DistributesOver* _ One _)))) (commutative _ _)))) (+Associative One _ _)) (equalPlus (equalityCommutative (productOneRight _)) (comm _ _))) (equalityCommutative (+DistributesOver* _ One _))
simplifyPreserves (times (succ (times a b)) (plus c d)) = transitivity (simplePlusIsPlus (simplify (plus c d)) (simplePlus (simplify (times (times a b) c)) (simplify (times (times a b) d)))) (transitivity (equalPlus (simplifyPreserves (plus c d)) (simplePlusIsPlus (simplify (times (times a b) c)) (simplify (times (times a b) d)))) (transitivity (transitivity (equalPlus (equalityCommutative (productOneRight _)) (transitivity (transitivity (equalPlus (simplifyPreserves (times (times a b) c)) (simplifyPreserves (times (times a b) d))) (equalityCommutative (+DistributesOver* _ _ _))) (comm _ _))) (equalityCommutative (+DistributesOver* _ One _))) (comm _ _)))
simplifyPreserves (times (succ (times a b)) (times c d)) = transitivity (simplePlusIsPlus (simplify (times c d)) (times (simplify a) (simplify (times b (times c d))))) (transitivity (equalPlus (simplifyPreserves (times c d)) (equalTimes (simplifyPreserves a) (simplifyPreserves (times b (times c d))))) (transitivity (transitivity (equalPlus (equalityCommutative (productOneRight _)) (transitivity (*Associative (eval a) _ _) (comm _ _))) (equalityCommutative (+DistributesOver* _ One _))) (comm _ _)))
simplifyPreserves (times (plus a b) (const x)) = transitivity (comm x _) (applyEquality (_* x) (simplifyPreserves (plus a b)))
simplifyPreserves (times (plus a b) zero) = equalityCommutative (productZeroRight _)
simplifyPreserves (times (plus a b) (succ c)) = transitivity (simplePlusIsPlus (simplify (plus a b)) (simplify (times (plus a b) c))) (transitivity (applyEquality ((eval (simplify (plus a b))) +_) (simplifyPreserves (times (plus a b) c))) (transitivity (applyEquality (_+ ((eval a + eval b) * eval c)) (simplifyPreserves (plus a b))) (transitivity (equalPlus (equalityCommutative (productOneRight _)) refl) (equalityCommutative (+DistributesOver* _ One (eval c))))))
simplifyPreserves (times (plus a b) (plus c d)) = transitivity (simplePlusIsPlus (simplify (times a c)) (simplePlus (simplify (times b c)) (simplePlus (simplify (times a d)) (simplify (times b d))))) (transitivity (transitivity (transitivity (transitivity (equalPlus (transitivity (simplifyPreserves (times a c)) (comm _ _)) (transitivity (simplePlusIsPlus (simplify (times b c)) (simplePlus (simplify (times a d)) (simplify (times b d)))) (equalPlus (transitivity (simplifyPreserves (times b c)) (comm _ _)) (transitivity (simplePlusIsPlus (simplify (times a d)) (simplify (times b d))) (equalPlus (transitivity (simplifyPreserves (times a d)) (comm _ _)) (transitivity (simplifyPreserves (times b d)) (comm _ _))))))) (+Associative _ _ _)) (equalPlus (equalityCommutative (+DistributesOver* (eval c) (eval a) _)) (equalityCommutative (+DistributesOver* (eval d) (eval a) _)))) (equalPlus (comm (eval c) _) (comm (eval d) _))) (equalityCommutative (+DistributesOver* _ (eval c) (eval d))))
simplifyPreserves (times (plus a b) (times c d)) = transitivity (simplePlusIsPlus (simplify (times a (times c d))) (simplify (times b (times c d)))) (transitivity (equalPlus (simplifyPreserves (times a (times c d))) (simplifyPreserves (times b (times c d)))) (transitivity (equalPlus (comm (eval a) _) (comm (eval b) _)) (transitivity (equalityCommutative (+DistributesOver* _ (eval a) (eval b))) (comm _ _))))
simplifyPreserves (times (times a b) (const x)) = applyEquality (_* x) (simplifyPreserves (times a b))
simplifyPreserves (times (times a b) zero) = equalityCommutative (productZeroRight _)
simplifyPreserves (times (times a b) (succ c)) = transitivity (simplePlusIsPlus (simplify (times a b)) (simplify (times (times a b) c))) (transitivity (equalPlus (simplifyPreserves (times a b)) (simplifyPreserves (times (times a b) c))) (transitivity (applyEquality (_+ ((eval a * eval b) * eval c)) (equalityCommutative (productOneRight _))) (equalityCommutative (+DistributesOver* _ One (eval c)))))
simplifyPreserves (times (times a b) (plus c d)) = transitivity (simplePlusIsPlus (simplify (times (times a b) c)) (simplify (times (times a b) d))) (transitivity (equalPlus (simplifyPreserves (times (times a b) c)) (simplifyPreserves (times (times a b) d))) (equalityCommutative (+DistributesOver* _ _ _)))
simplifyPreserves (times (times a b) (times c d)) = transitivity (equalTimes (simplifyPreserves a) (simplifyPreserves (times b (times c d)))) (*Associative (eval a) (eval b) _)

from_to_by_ : (x y : Expr) (pr : eval (simplify x) ≡ eval (simplify y)) → eval x ≡ eval y
from a to b by pr = transitivity (equalityCommutative (simplifyPreserves a)) (transitivity pr (simplifyPreserves b))


module FRP.LTL.ISet where

open import FRP.LTL.ISet.Core public using ( ISet ; ⟨_⟩ ; ⟦_⟧ )

-- Propositional logic

open import FRP.LTL.ISet.Unit public using ( T )
open import FRP.LTL.ISet.Empty public using ( F )
open import FRP.LTL.ISet.Product public using ( _∧_ ; fst ; snd ; _&&&_ )
open import FRP.LTL.ISet.Sum public using ( _∨_ )
open import FRP.LTL.ISet.Stateless public using ( _⇒_ )

-- LTL

open import FRP.LTL.ISet.Next public using ( ○ )
open import FRP.LTL.ISet.Future public using ( ◇ )
open import FRP.LTL.ISet.Globally public using ( □ ; [_] )
open import FRP.LTL.ISet.Until public using ( _U_ )
open import FRP.LTL.ISet.Causal public using ( _⊵_ ; arr ; identity ; _⋙_ )
open import FRP.LTL.ISet.Decoupled public using ( _▹_ )


-- Now you don't need a mutual keyword anymore!
module Issue162 where

data Odd : Set
data Even : Set where
  zero : Even
  suc  : Odd → Even

data Odd where
  suc : Even → Odd

-- This means you can have all kinds of things in
-- mutual blocks.

-- Like postulates
_o+e_ : Odd → Even → Odd

_e+e_ : Even → Even → Even
zero e+e m = m
suc n e+e m = suc (n o+e m)

postulate todo : Even

suc n o+e m = suc todo

-- Or modules
_e+o_ : Even → Odd → Odd
_o+o_ : Odd → Odd → Even
suc n o+o m = suc (n e+o m)

module Helper where
  f : Even → Odd → Odd
  f zero    m = m
  f (suc n) m = suc (n o+o m)

n e+o m = Helper.f n m

-- Multiplication just for the sake of it
_o*o_ : Odd → Odd → Odd
_e*o_ : Even → Odd → Even
zero  e*o m = zero
suc n e*o m = m o+o (n o*o m)

suc n o*o m = m o+e (n e*o m)


------------------------------------------------------------------------------
-- The Booleans
------------------------------------------------------------------------------

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

module FOTC.Data.Bool where

open import FOTC.Base
open import FOTC.Data.Bool.Type public

infixr 6 _&&_

------------------------------------------------------------------------------
-- Basic functions

-- The conjunction.
_&&_  : D → D → D
a && b = if a then b else false
{-# ATP definition _&&_ #-}

-- The negation.
not : D → D
not b = if b then false else true
{-# ATP definition not #-}


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

module FunExt where

open import Base

module _ {i j} {A : Type i} {B : A → Type j} where

  happly : (f g : (x : A) → B x) → (f == g) → ((x : A) → f x == g x)
  happly f g = ind== D d where
    D : (f g : (x : A) → B x) → f == g → Type _
    D f g _ = (x : A) → f x == g x

    d : (f : (x : A) → B x) → D f f idp
    d f = λ x → idp

  postulate
    fun-ext : (f g : (x : A) → B x) → is-equiv (happly f g)


module Everything where

-- basic utilities
open import Library
open import Isomorphism

-- basic category theory
open import Categories
open import Categories.Sets
open import Categories.Families
open import Categories.Initial
open import Categories.Terminal
open import Categories.CoProducts
open import Categories.PushOuts
open import Categories.Setoids -- should be replaced by standard libary def

open import Functors
open import Functors.Fin
open import Functors.FullyFaithful

open import Naturals

-- basic examples
open import Monoids
open import FunctorCat

-- ordinary monads
open import Monads
open import Monads.MonadMorphs
open import Adjunctions
open import Adjunctions.Adj2Mon
open import Monads.Kleisli
open import Monads.Kleisli.Functors
open import Monads.Kleisli.Adjunction
open import Monads.EM
open import Monads.EM.Functors
open import Monads.EM.Adjunction
open import Monads.CatofAdj
open import Monads.CatofAdj.InitAdj
open import Monads.CatofAdj.TermAdjObj
open import Monads.CatofAdj.TermAdjHom
open import Monads.CatofAdj.TermAdjUniq
open import Monads.CatofAdj.TermAdj

-- relative monads
open import RMonads
open import RMonads.RMonadMorphs
open import RAdjunctions
open import RAdjunctions.RAdj2RMon
open import RMonads.REM
open import RMonads.REM.Functors
open import RMonads.REM.Adjunction
open import RMonads.RKleisli
open import RMonads.RKleisli.Functors
open import RMonads.RKleisli.Adjunction
open import RMonads.Restriction
open import RMonads.SpecialCase
open import RMonads.CatofRAdj
open import RMonads.CatofRAdj.InitRAdj
open import RMonads.CatofRAdj.TermRAdjObj
open import RMonads.CatofRAdj.TermRAdjHom
open import RMonads.CatofRAdj.TermRAdj
open import RMonads.Modules

-- rmonad examples
open import WellScopedTerms
open import WellScopedTermsModel
open import WellTypedTerms
open import WellTypedTermsModel

open import Lawvere


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

open import lib.Basics
open import lib.NType2
open import lib.PathGroupoid

open import lib.types.Bool
open import lib.types.IteratedSuspension
open import lib.types.Lift
open import lib.types.LoopSpace
open import lib.types.Nat
open import lib.types.Paths
open import lib.types.Pi
open import lib.types.Pointed
open import lib.types.Sigma
open import lib.types.Suspension
open import lib.types.TLevel
open import lib.types.Unit

open SuspensionRec public using () renaming (f to Susp-rec)

open import nicolai.pseudotruncations.Preliminary-definitions
open import nicolai.pseudotruncations.Liblemmas

module nicolai.pseudotruncations.pointed-O-Sphere where

{- helper file for some technical things -}

module _ {i} where

  bool = fst (⊙Sphere {i} O)
  tt₀ : bool
  tt₀ = snd (⊙Sphere {i} O)
  ff₀ : bool
  ff₀ = lift false

module bool-neutral
           {i j}
           (P : bool {i} → Type j)
           (p₀ : P tt₀) where

  bool-pair : (P tt₀ × P ff₀) ≃ ((b : bool) → P b)
  bool-pair = equiv (λ tf → (λ { (lift true) → fst tf ; (lift false) → snd tf }))
                    (λ f → (f tt₀ , f ff₀))
                    (λ f → λ= (λ { (lift true) → idp ; (lift false) → idp }))
                    (λ tf → idp)

  pair-red : Σ (P tt₀ × P ff₀) (λ tf → fst tf == p₀) → P ff₀
  pair-red ((pt , pf) , q) = pf

  sing-exp : P ff₀ → Σ (P tt₀ × P ff₀) (λ tf → fst tf == p₀)
  sing-exp pf = ((p₀ , pf) , idp)

  red-exp : (pf : P ff₀) → pair-red (sing-exp pf) == pf
  red-exp _ = idp

  exp-red : (x : Σ (P tt₀ × P ff₀) (λ tf → fst tf == p₀)) → sing-exp (pair-red x) == x
  exp-red ((.p₀ , pf) , idp) = idp
  {- I tried to do it with pattern matching, but this does not introduce
     a dot [.] before [p₀]. Thus, is fails. Is this a bug? -}

  pair-one-determined : Σ (P tt₀ × P ff₀) (λ tf → fst tf == p₀) ≃ P ff₀
  pair-one-determined = equiv pair-red sing-exp red-exp exp-red

  {- This reduction result is (on paper) trivial, but for our formalization
     quite powerful! -}
  reduction : (Σ ((b : bool) → P b) λ g → g tt₀ == p₀)   ≃   P ff₀
  reduction = (Σ ((b : bool) → P b) λ g → g tt₀ == p₀)
                 ≃⟨ equiv-Σ-fst {A = P tt₀ × P ff₀}
                                {B = (b : bool) → P b}
                                (λ g → g tt₀ == p₀)
                                {h = fst bool-pair}
                                (snd bool-pair) ⁻¹ ⟩
               Σ (P tt₀ × P ff₀) ((λ g → g tt₀ == p₀) ∘ fst bool-pair)
                 ≃⟨ ide _ ⟩
               Σ (P tt₀ × P ff₀) (λ tf → fst tf == p₀)
                 ≃⟨ pair-one-determined ⟩
               P ff₀
                 ≃∎


-- Andreas, 2012-09-24 Ensure that size successor is monotone

-- Andreas, 2015-03-16 SizeUniv is still imperfect, so we need type-in-type
-- here to work around the conflation of sLub and the PTS rule.
{-# OPTIONS --type-in-type #-}

module SizeSucMonotone where

open import Common.Size

data Bool : Set where
  true false : Bool

-- T should be monotone in its second arg
T : Bool → Size → Set
T true  i = (Size< i     → Bool) → Bool
T false i = (Size< (↑ i) → Bool) → Bool

test : {x : Bool}{i : Size}{j : Size< i} → T x j → T x i
test h = h


{-# OPTIONS --cubical --no-import-sorts --safe #-}

open import Cubical.Core.Everything
open import Cubical.Foundations.HLevels

module Cubical.Algebra.Magma.Construct.Left {ℓ} (Aˢ : hSet ℓ) where

open import Cubical.Foundations.Prelude
open import Cubical.Algebra.Magma

private
  A = ⟨ Aˢ ⟩
  isSetA = Aˢ .snd

_◂_ : Op₂ A
x ◂ y = x

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

◂-zeroˡ : ∀ x → LeftZero x _◂_
◂-zeroˡ _ _ = refl

◂-identityʳ : ∀ x → RightIdentity x _◂_
◂-identityʳ _ _ = refl

------------------------------------------------------------------------
-- Magma definition

Left-isMagma : IsMagma A _◂_
Left-isMagma = record { is-set = isSetA }

LeftMagma : Magma ℓ
LeftMagma = record { isMagma = Left-isMagma }


------------------------------------------------------------------------
-- The Agda standard library
--
-- A solver for proving that one list is a sublist of the other for types
-- which enjoy decidable equalities.
------------------------------------------------------------------------

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

open import Relation.Binary using (Decidable)
open import Agda.Builtin.Equality using (_≡_)

module Data.List.Relation.Binary.Sublist.DecPropositional.Solver
       {a} {A : Set a} (_≟_ : Decidable {A = A} _≡_)
       where

import Relation.Binary.PropositionalEquality as P

open import Data.List.Relation.Binary.Sublist.DecSetoid.Solver (P.decSetoid _≟_) public


module Punctaffy.Hypersnippet.Dim where

open import Level using (Level; suc; _⊔_)
open import Algebra.Bundles using (IdempotentCommutativeMonoid)
open import Algebra.Morphism using (IsIdempotentCommutativeMonoidMorphism)

-- For all the purposes we have for it so far, a `DimSys` is a bounded
-- semilattice. The `agda-stdlib` library calls this an idempotent commutative
-- monoid.
record DimSys {n l : Level} : Set (suc (n ⊔ l)) where
  field
    dimIdempotentCommutativeMonoid : IdempotentCommutativeMonoid n l
  open IdempotentCommutativeMonoid dimIdempotentCommutativeMonoid public

record DimSysMorphism {n₀ n₁ l₀ l₁ : Level} : Set (suc (n₀ ⊔ n₁ ⊔ l₀ ⊔ l₁)) where
  field
    From : DimSys {n₀} {l₀}
    To : DimSys {n₁} {l₁}

  private
    module F = DimSys From
    module T = DimSys To

  field
    morphDim : F.Carrier → T.Carrier
    isIdempotentCommutativeMonoidMorphism :
      IsIdempotentCommutativeMonoidMorphism F.dimIdempotentCommutativeMonoid T.dimIdempotentCommutativeMonoid morphDim

dimLte : {n l : Level} → {ds : DimSys {n} {l}} → DimSys.Carrier ds → DimSys.Carrier ds → Set l
dimLte {n} {l} {ds} a b = DimSys._≈_ ds (DimSys._∙_ ds a b) b


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

open import Categories.Category using () renaming (Category to Setoid-Category)
open import Categories.Category.Monoidal

module Categories.Category.Construction.EnrichedFunctors
  {o ℓ e} {V : Setoid-Category o ℓ e} (M : Monoidal V) where

-- The (enriched) functor category for a given pair of V-enriched categories

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

open import Categories.Enriched.Category M
open import Categories.Enriched.Functor M renaming (id to idF)
open import Categories.Enriched.NaturalTransformation M renaming (id to idNT)
open import Categories.Functor.Bifunctor using (Bifunctor)

open NaturalTransformation using (_[_])

EnrichedFunctors : ∀ {c d} (C : Category c) (D : Category d) →
                   Setoid-Category (ℓ ⊔ e ⊔ c ⊔ d) (ℓ ⊔ e ⊔ c) (e ⊔ c)
EnrichedFunctors C D = record
  { Obj = Functor C D
  ; _⇒_ = NaturalTransformation
  ; _≈_ = λ α β → ∀ {X} → α [ X ] ≈ β [ X ]
  ; id  = idNT
  ; _∘_ = _∘ᵥ_
  ; assoc     = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv     = record
    { refl  = Equiv.refl
    ; sym   = λ α≈β → Equiv.sym α≈β
    ; trans = λ α≈β β≈γ → Equiv.trans α≈β β≈γ
    }
  ; ∘-resp-≈ = λ α₁≈β₁ α₂≈β₂ → ∘-resp-≈ α₁≈β₁ α₂≈β₂
  }
  where open Underlying D

-- Horizontal composition of natural transformations (aka the Godement
-- product) induces a composition functor over functor categories.
--
-- Note that all the equational reasoning happens in the underlying
-- (ordinary) categories!

⊚ : ∀ {c d e} {C : Category c} {D : Category d} {E : Category e} →
    Bifunctor (EnrichedFunctors D E) (EnrichedFunctors C D) (EnrichedFunctors C E)
⊚ {_} {_} {_} {_} {D} {E} = record
  { F₀ = uncurry′ _∘F_
  ; F₁ = uncurry′ _∘ₕ_
  ; identity = λ{ {F , G} {X} →
    begin
      (F $₁ D.id) ∘ E.id   ≈⟨ identityʳ ⟩
      F $₁ D.id            ≈⟨ identity F ⟩
      E.id                 ∎ }
  ; homomorphism = λ{ {_ , F₂} {G₁ , G₂} {H₁ , _} {α₁ , α₂} {β₁ , β₂} {X} →
    begin
      H₁ $₁ (β₂ [ X ] D.∘ α₂ [ X ]) ∘ β₁ [ F₂ $₀ X ] ∘ α₁ [ F₂ $₀ X ]
    ≈⟨ homomorphism H₁ ⟩∘⟨refl ⟩
      (H₁ $₁ β₂ [ X ] ∘ H₁ $₁ α₂ [ X ]) ∘ β₁ [ F₂ $₀ X ] ∘ α₁ [ F₂ $₀ X ]
    ≈⟨ ⟺ assoc ○ ∘-resp-≈ˡ assoc ⟩
      (H₁ $₁ β₂ [ X ] ∘ (H₁ $₁ α₂ [ X ] ∘ β₁ [ F₂ $₀ X ])) ∘ α₁ [ F₂ $₀ X ]
    ≈˘⟨ (refl⟩∘⟨ commute β₁ (α₂ [ X ])) ⟩∘⟨refl ⟩
      (H₁ $₁ β₂ [ X ] ∘ (β₁ [ G₂ $₀ X ] ∘ G₁ $₁ α₂ [ X ])) ∘ α₁ [ F₂ $₀ X ]
    ≈˘⟨ ⟺ assoc ○ ∘-resp-≈ˡ assoc ⟩
      (H₁ $₁ β₂ [ X ] ∘ β₁ [ G₂ $₀ X ]) ∘ G₁ $₁ α₂ [ X ] ∘ α₁ [ F₂ $₀ X ]
    ∎ }
  ; F-resp-≈ = λ{ {_} {F , _} (eq₁ , eq₂) → ∘-resp-≈ (F-resp-≈ F eq₂) eq₁ }
  }
  where
    module D = Underlying D
    module E = Underlying E
    open E hiding (id)
    open HomReasoning
    open UnderlyingFunctor hiding (F₀; F₁)
    open UnderlyingNT

    -- Aliases used to shorten some proof expressions

    infixr 14 _$₀_ _$₁_
    _$₀_ = UnderlyingFunctor.F₀
    _$₁_ = UnderlyingFunctor.F₁