Algebra.Group.Homorphism: nicer notation with less explicit arguments

{-# OPTIONS --without-K #-}
module Algebra.Group.Homomorphism where

open import Type using (Type_)
open import Function.NP using (Op₂; _∘_; id)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Constructions
open import Level.NP
open import Data.Product.NP
open import Data.Nat.NP     using (1+_)
open import Data.Integer.NP using (ℤ; -[1+_]; +_; -_; module ℤ°)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

record GroupHomomorphism {a}{A : Type a}{b}{B : Type b}
                         (grpA0+ : Group A)(grpB1* : Group B)
                         (f : A → B) : Type (a ⊔ b) where
  constructor mk

  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  field
    hom : Homomorphic₂ f _+_ _*_

  pres-unit : f 0# ≡ 1#
  pres-unit = unique-1-left part
    where part = f 0# * f 0#  ≡⟨ ! hom ⟩
                 f (0# + 0#)  ≡⟨ ap f (fst +-identity) ⟩
                 f 0#         ∎

  mon-hom : MonoidHomomorphism +-mon *-mon f
  mon-hom = pres-unit , hom

  open MonoidHomomorphism mon-hom public

  pres-inv : ∀ {x} → f (0− x) ≡ (f x)⁻¹
  pres-inv {x} = unique-⁻¹ part
    where part = f (0− x) * f x  ≡⟨ ! hom ⟩
                 f (0− x + x)    ≡⟨ ap f (fst 0−-inverse) ⟩
                 f 0#            ≡⟨ pres-unit ⟩
                 1#              ∎

  0−-⁻¹ = pres-inv

  −-/ : ∀ {x y} → f (x − y) ≡ f x / f y
  −-/ {x} {y} = f (x − y)       ≡⟨ hom ⟩
                f x * f (0− y)  ≡⟨ ap (_*_ (f x)) pres-inv ⟩
                f x / f y       ∎

  hom-iterated⁻ : ∀ {x} n → f (x ⊗⁻ n) ≡ f x ^⁻ n
  hom-iterated⁻ {x} n =
    f (x ⊗⁻ n)      ≡⟨by-definition⟩
    f (0−(x ⊗⁺ n))  ≡⟨ pres-inv ⟩
    f(x ⊗⁺ n)⁻¹     ≡⟨ ap _⁻¹ (hom-iterated⁺ n) ⟩
    (f x ^⁺ n)⁻¹    ≡⟨by-definition⟩
    f x ^⁻ n        ∎

  hom-iterated : ∀ {x} i → f (x ⊗ i) ≡ f x ^ i
  hom-iterated -[1+ n ] = hom-iterated⁻ (1+ n)
  hom-iterated (+ n)    = hom-iterated⁺ n

ℤ+-grp-ops : Group-Ops ℤ
ℤ+-grp-ops = ℤ+-mon-ops , -_

ℤ+-grp-struct : Group-Struct ℤ+-grp-ops
ℤ+-grp-struct = ℤ+-mon-struct
              , (λ{x} → fst ℤ°.-‿inverse x)
              , (λ{x} → snd ℤ°.-‿inverse x)

ℤ+-grp : Group ℤ
ℤ+-grp = _ , ℤ+-grp-struct

module ℤ+ = Additive-Group ℤ+-grp

module _ {ℓ}{G : Type ℓ}(𝔾 : Group G) where
  open Groupᵒᵖ
  open Group 𝔾

  module ⁻¹-Hom where
    -- The proper type for ⁻¹-hom′
    ⁻¹-hom' : GroupHomomorphism 𝔾 (𝔾 ᵒᵖ) _⁻¹
    ⁻¹-hom' = mk ⁻¹-hom′
    open GroupHomomorphism ⁻¹-hom' public

  module ℤ+-^-Hom {b} where
    ^-+-hom : GroupHomomorphism ℤ+-grp 𝔾 (_^_ b)
    ^-+-hom = mk (λ {i} {j} → ^-+ i j)

    open GroupHomomorphism ^-+-hom public

module Stability-Minimal
  {a}{A  : Type a}
  {b}{B  : Type b}
  (φ     : A → B)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  {c}{C  : Type c}
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ*   : ∀ {k} → F φ ≡ F (_*_ k ∘ φ))
  where

  +-stable : ∀ {k} → F φ ≡ F (φ ∘ _+_ k)
  +-stable {k} =
    F φ                ≡⟨ Fφ* ⟩
    F (_*_ (φ k) ∘ φ)  ≡⟨ F= (λ x → ! φ-+-*) ⟩
    F (φ ∘ _+_ k)      ∎

module Stability
  {a}{A  : Type a}
  {b}{B  : Type b}
  (G+ : Group A)
  (G* : Group B)
  (φ : A → B)
  (φ-hom : GroupHomomorphism G+ G* φ)
  where
  open Additive-Group G+
  open Multiplicative-Group G*
  open GroupHomomorphism φ-hom

  open Stability-Minimal φ _+_ _*_ hom public

open GroupHomomorphism

module Identity
  {a}{A : Type a}
  (𝔸 : Group A)
  where

  id-hom : GroupHomomorphism 𝔸 𝔸 id
  id-hom = mk refl

module Compose
  {a}{A : Type a}
  {b}{B : Type b}
  {c}{C : Type c}
  (𝔸 : Group A)
  (𝔹 : Group B)
  (ℂ : Group C)
  (ψ : A → B)
  (ψ-hom : GroupHomomorphism 𝔸 𝔹 ψ)
  (φ : B → C)
  (φ-hom : GroupHomomorphism 𝔹 ℂ φ)
  where

  compose-hom : GroupHomomorphism 𝔸 ℂ (φ ∘ ψ)
  compose-hom = mk (ap φ (hom ψ-hom) ∙ hom φ-hom)

-- A nicer version of Compose.compose-hom: more implicit arguments
-- AND reverse order to fit with _∘_ order.
module _
  {a}{A : Type a}
  {b}{B : Type b}
  {c}{C : Type c}
  {𝔸 : Group A}
  {𝔹 : Group B}
  {ℂ : Group C}
  {φ : B → C}
  (φ-hom : GroupHomomorphism 𝔹 ℂ φ)
  {ψ : A → B}
  (ψ-hom : GroupHomomorphism 𝔸 𝔹 ψ)
  where

  _∘-hom_ : GroupHomomorphism 𝔸 ℂ (φ ∘ ψ)
  _∘-hom_ = Compose.compose-hom _ _ _ _ ψ-hom _ φ-hom

module Delta
  {a}{A : Type a}
  (𝔸 : Group A)
  where
  open Algebra.Group.Constructions.Product

  Δ-hom : GroupHomomorphism 𝔸 (×-grp 𝔸 𝔸) (λ x → x , x)
  Δ-hom = mk refl

module Zip
  {a₀}{A₀ : Type a₀}
  {a₁}{A₁ : Type a₁}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  (𝔸₀ : Group A₀)
  (𝔸₁ : Group A₁)
  (𝔹₀ : Group B₀)
  (𝔹₁ : Group B₁)
  (φ₀ : A₀ → B₀)
  (φ₀-hom : GroupHomomorphism 𝔸₀ 𝔹₀ φ₀)
  (φ₁ : A₁ → B₁)
  (φ₁-hom : GroupHomomorphism 𝔸₁ 𝔹₁ φ₁)
  where
  open Algebra.Group.Constructions.Product

  zip-hom : GroupHomomorphism (×-grp 𝔸₀ 𝔸₁) (×-grp 𝔹₀ 𝔹₁) (map φ₀ φ₁)
  zip-hom = mk (ap₂ _,_ (hom φ₀-hom) (hom φ₁-hom))

-- A nicer version of Zip.zip-hom: more implicit arguments
module _
  {a₀}{A₀ : Type a₀}
  {a₁}{A₁ : Type a₁}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  {𝔸₀ : Group A₀}
  {𝔸₁ : Group A₁}
  {𝔹₀ : Group B₀}
  {𝔹₁ : Group B₁}
  {φ₀ : A₀ → B₀}
  (φ₀-hom : GroupHomomorphism 𝔸₀ 𝔹₀ φ₀)
  {φ₁ : A₁ → B₁}
  (φ₁-hom : GroupHomomorphism 𝔸₁ 𝔹₁ φ₁)
  where
  <_×_>-hom = Zip.zip-hom _ _ _ _ _ φ₀-hom _ φ₁-hom

module Pair
  {a}{A   : Type a}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  (𝔸  : Group A)
  (𝔹₀ : Group B₀)
  (𝔹₁ : Group B₁)
  (φ₀ : A → B₀)
  (φ₀-hom : GroupHomomorphism 𝔸 𝔹₀ φ₀)
  (φ₁ : A → B₁)
  (φ₁-hom : GroupHomomorphism 𝔸 𝔹₁ φ₁)
  where

  -- pair = zip ∘ Δ
  pair-hom : GroupHomomorphism 𝔸 (Product.×-grp 𝔹₀ 𝔹₁) < φ₀ , φ₁ >
  pair-hom = < φ₀-hom × φ₁-hom >-hom ∘-hom Delta.Δ-hom _
  -- OR:
  -- pair-hom = mk (ap₂ _,_ (hom φ₀-hom) (hom φ₁-hom))

-- A nicer version of Pair.pair-hom: more implicit arguments
module _
  {a}{A   : Type a}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  {𝔸  : Group A}
  {𝔹₀ : Group B₀}
  {𝔹₁ : Group B₁}
  {φ₀ : A → B₀}
  (φ₀-hom : GroupHomomorphism 𝔸 𝔹₀ φ₀)
  {φ₁ : A → B₁}
  (φ₁-hom : GroupHomomorphism 𝔸 𝔹₁ φ₁)
  where
  <_,_>-hom = Pair.pair-hom _ _ _ _ φ₀-hom _ φ₁-hom
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
module Algebra.Group.Homomorphism where

open import Type using (Type_)
open import Function.NP using (Op₂; _∘_; id)
import Algebra.FunctionProperties.Eq
open Algebra.FunctionProperties.Eq.Implicits
open import Algebra.Monoid
open import Algebra.Monoid.Homomorphism
open import Algebra.Raw
open import Algebra.Group
open import Algebra.Group.Constructions
open import Level.NP
open import Data.Product.NP
open import Data.Nat.NP     using (1+_)
open import Data.Integer.NP using (ℤ; -[1+_]; +_; -_; module ℤ°)
open import Relation.Binary.PropositionalEquality.NP
open ≡-Reasoning

record GroupHomomorphism {a}{A : Type a}{b}{B : Type b}
                         (grpA0+ : Group A)(grpB1* : Group B)
                         (f : A → B) : Type (a ⊔ b) where
  constructor mk

  open Additive-Group grpA0+
  open Multiplicative-Group grpB1*

  field
    hom : Homomorphic₂ f _+_ _*_

  pres-unit : f 0# ≡ 1#
  pres-unit = unique-1-left part
    where part = f 0# * f 0#  ≡⟨ ! hom ⟩
                 f (0# + 0#)  ≡⟨ ap f (fst +-identity) ⟩
                 f 0#         ∎

  mon-hom : MonoidHomomorphism +-mon *-mon f
  mon-hom = pres-unit , hom

  open MonoidHomomorphism mon-hom public

  pres-inv : ∀ {x} → f (0− x) ≡ (f x)⁻¹
  pres-inv {x} = unique-⁻¹ part
    where part = f (0− x) * f x  ≡⟨ ! hom ⟩
                 f (0− x + x)    ≡⟨ ap f (fst 0−-inverse) ⟩
                 f 0#            ≡⟨ pres-unit ⟩
                 1#              ∎

  0−-⁻¹ = pres-inv

  −-/ : ∀ {x y} → f (x − y) ≡ f x / f y
  −-/ {x} {y} = f (x − y)       ≡⟨ hom ⟩
                f x * f (0− y)  ≡⟨ ap (_*_ (f x)) pres-inv ⟩
                f x / f y       ∎

  hom-iterated⁻ : ∀ {x} n → f (x ⊗⁻ n) ≡ f x ^⁻ n
  hom-iterated⁻ {x} n =
    f (x ⊗⁻ n)      ≡⟨by-definition⟩
    f (0−(x ⊗⁺ n))  ≡⟨ pres-inv ⟩
    f(x ⊗⁺ n)⁻¹     ≡⟨ ap _⁻¹ (hom-iterated⁺ n) ⟩
    (f x ^⁺ n)⁻¹    ≡⟨by-definition⟩
    f x ^⁻ n        ∎

  hom-iterated : ∀ {x} i → f (x ⊗ i) ≡ f x ^ i
  hom-iterated -[1+ n ] = hom-iterated⁻ (1+ n)
  hom-iterated (+ n)    = hom-iterated⁺ n

ℤ+-grp-ops : Group-Ops ℤ
ℤ+-grp-ops = ℤ+-mon-ops , -_

ℤ+-grp-struct : Group-Struct ℤ+-grp-ops
ℤ+-grp-struct = ℤ+-mon-struct
              , (λ{x} → fst ℤ°.-‿inverse x)
              , (λ{x} → snd ℤ°.-‿inverse x)

ℤ+-grp : Group ℤ
ℤ+-grp = _ , ℤ+-grp-struct

module ℤ+ = Additive-Group ℤ+-grp

module _ {ℓ}{G : Type ℓ}(𝔾 : Group G) where
  open Groupᵒᵖ
  open Group 𝔾

  module ⁻¹-Hom where
    -- The proper type for ⁻¹-hom′
    ⁻¹-hom' : GroupHomomorphism 𝔾 (𝔾 ᵒᵖ) _⁻¹
    ⁻¹-hom' = mk ⁻¹-hom′
    open GroupHomomorphism ⁻¹-hom' public

  module ℤ+-^-Hom {b} where
    ^-+-hom : GroupHomomorphism ℤ+-grp 𝔾 (_^_ b)
    ^-+-hom = mk (λ {i} {j} → ^-+ i j)

    open GroupHomomorphism ^-+-hom public

module Stability-Minimal
  {a}{A  : Type a}
  {b}{B  : Type b}
  (φ     : A → B)
  (_+_   : Op₂ A)
  (_*_   : Op₂ B)
  (φ-+-* : ∀ {x y} → φ (x + y) ≡ φ x * φ y)
  {c}{C  : Type c}
  (F     : (A → B) → C)
  (F=    : ∀ {f g : A → B} → f ≗ g → F f ≡ F g)
  (Fφ*   : ∀ {k} → F φ ≡ F (_*_ k ∘ φ))
  where

  +-stable : ∀ {k} → F φ ≡ F (φ ∘ _+_ k)
  +-stable {k} =
    F φ                ≡⟨ Fφ* ⟩
    F (_*_ (φ k) ∘ φ)  ≡⟨ F= (λ x → ! φ-+-*) ⟩
    F (φ ∘ _+_ k)      ∎

module Stability
  {a}{A  : Type a}
  {b}{B  : Type b}
  (G+ : Group A)
  (G* : Group B)
  (φ : A → B)
  (φ-hom : GroupHomomorphism G+ G* φ)
  where
  open Additive-Group G+
  open Multiplicative-Group G*
  open GroupHomomorphism φ-hom

  open Stability-Minimal φ _+_ _*_ hom public

open GroupHomomorphism

module Identity
  {a}{A : Type a}
  (𝔸 : Group A)
  where

  id-hom : GroupHomomorphism 𝔸 𝔸 id
  id-hom = mk refl

module Compose
  {a}{A : Type a}
  {b}{B : Type b}
  {c}{C : Type c}
  (𝔸 : Group A)
  (𝔹 : Group B)
  (ℂ : Group C)
  (ψ : A → B)
  (ψ-hom : GroupHomomorphism 𝔸 𝔹 ψ)
  (φ : B → C)
  (φ-hom : GroupHomomorphism 𝔹 ℂ φ)
  where

  ∘-hom : GroupHomomorphism 𝔸 ℂ (φ ∘ ψ)
  ∘-hom = mk (ap φ (hom ψ-hom) ∙ hom φ-hom)

module Delta
  {a}{A : Type a}
  (𝔸 : Group A)
  where
  open Algebra.Group.Constructions.Product

  Δ-hom : GroupHomomorphism 𝔸 (×-grp 𝔸 𝔸) (λ x → x , x)
  Δ-hom = mk refl

module Zip
  {a₀}{A₀ : Type a₀}
  {a₁}{A₁ : Type a₁}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  (𝔸₀ : Group A₀)
  (𝔸₁ : Group A₁)
  (𝔹₀ : Group B₀)
  (𝔹₁ : Group B₁)
  (φ₀ : A₀ → B₀)
  (φ₀-hom : GroupHomomorphism 𝔸₀ 𝔹₀ φ₀)
  (φ₁ : A₁ → B₁)
  (φ₁-hom : GroupHomomorphism 𝔸₁ 𝔹₁ φ₁)
  where
  open Algebra.Group.Constructions.Product

  zip-hom : GroupHomomorphism (×-grp 𝔸₀ 𝔸₁) (×-grp 𝔹₀ 𝔹₁) (map φ₀ φ₁)
  zip-hom = mk (ap₂ _,_ (hom φ₀-hom) (hom φ₁-hom))

module Pair
  {a}{A   : Type a}
  {b₀}{B₀ : Type b₀}
  {b₁}{B₁ : Type b₁}
  (𝔸  : Group A)
  (𝔹₀ : Group B₀)
  (𝔹₁ : Group B₁)
  (φ₀ : A → B₀)
  (φ₀-hom : GroupHomomorphism 𝔸 𝔹₀ φ₀)
  (φ₁ : A → B₁)
  (φ₁-hom : GroupHomomorphism 𝔸 𝔹₁ φ₁)
  where

  -- pair = zip ∘ Δ
  pair-hom : GroupHomomorphism 𝔸 (Product.×-grp 𝔹₀ 𝔹₁) < φ₀ , φ₁ >
  pair-hom = Compose.∘-hom _ _ _
               _ (Delta.Δ-hom 𝔸)
               _ (Zip.zip-hom _ _ _ _ _ φ₀-hom _ φ₁-hom)
  -- OR:
  -- pair-hom = mk (ap₂ _,_ (hom φ₀-hom) (hom φ₁-hom))
-- -}
-- -}
-- -}
-- -}


Renamed some stuff.

Renamed some stuff.

Ignore-this: e2f54884bcaca61788941d5e933768be

darcs-hash:20100604023904-3bd4e-d676bf2fd9d4f0894a26c11b8d10462bae861a86.gz

------------------------------------------------------------------------------
-- The division result is correct
------------------------------------------------------------------------------

module Examples.Division.IsCorrectER where

open import LTC.Minimal
open import LTC.MinimalER

open import Examples.Division
open import Examples.Division.EquationsER
open import Examples.Division.Specification

open import LTC.Data.N
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF-ER
open import LTC.Relation.Equalities.PropertiesER
open import LTC.Relation.InequalitiesPCF

import MyStdLib.Relation.Binary.EqReasoning
open module IsNER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

-- The division result is correct when the dividend is less than
-- the divisor.

div-x<y-aux : {i j : D} → N i → N j → LT i j → i ≡ j * (div i j) + i
div-x<y-aux {i} {j} Ni Nj i<j = sym
    ( begin
        j * (div i j) + i ≡⟨ prf₁ ⟩
        j * zero + i      ≡⟨ prf₂ ⟩
        zero + i          ≡⟨ +-leftIdentity Ni ⟩
        i
      ∎
    )
    where
      prf₁ : j * (div i j) + i ≡ j * zero + i
      prf₁ = subst (λ x → j * x + i ≡ j * zero + i )
                   (sym (div-x<y i<j ))
                   refl

      prf₂ : j * zero + i ≡ zero + i
      prf₂ = subst (λ x → x + i ≡ zero + i)
                   (sym (*-rightZero Nj))
                   refl

div-x<y-correct : {i j : D} → N i → N j → LT i j →
                  (∃D (λ r → N r ∧ LT r j ∧ i ≡ j * (div i j) + r))
div-x<y-correct {i} Ni Nj i<j =
  i , (Ni , (i<j , (div-x<y-aux Ni Nj i<j)))

-- The division result is correct when the dividend is greater or equal
-- than the divisor.
-- Using the inductive hypothesis 'ih' we know that
-- 'i - j = j * (div (i - j) j) + r'. From
-- that we get 'i = j * (succ (div (i - j) j)) + r', and
-- we know 'div i j = succ (div (i - j) j); therefore we
-- get 'i = j * div i j + r'.

postulate
  aux : {i j r : D} → N i → N j → N r →
        i - j ≡ j * (div (i - j) j) + r →
        i ≡ j * succ (div (i - j) j) + r

div-x≥y-aux : {i j r : D} → N i → N j → N r →
              GE i j →
              i - j ≡ j * (div (i - j) j) + r →
              i ≡ j * (div i j) + r
div-x≥y-aux {i} {j} {r} Ni Nj Nr i≥j auxH =
  begin
    i ≡⟨ aux Ni Nj Nr auxH ⟩
    j * succ (div (i - j) j) + r ≡⟨ prf ⟩
    j * (div i j) + r
  ∎

  where prf : j * succ (div (i - j) j) + r ≡ j * (div i j) + r
        prf = subst (λ x → j * x + r ≡ j * (div i j) + r )
                    (div-x≥y i≥j  )
                    refl

div-x≥y-correct : {i j : D} → N i → N j →
                  (ih : DIV (i - j) j (div (i - j) j)) →
                  GE i j →
                  ∃D (λ r → (N r) ∧ (LT r j) ∧ (i ≡ j * (div i j) + r))
div-x≥y-correct {i} {j} Ni Nj ih i≥j =
  r , (Nr , (r<j , (div-x≥y-aux Ni Nj Nr i≥j auxH)))

    where
      -- The parts of the inductive hipothesis 'ih-i-j'
      r : D
      r = ∃D-proj₁ (∧-proj₂ ih)

      r-correct : N r ∧ LT r j ∧ i - j ≡ j * (div (i - j) j) + r
      r-correct = ∃D-proj₂ (∧-proj₂ ih)

      Nr : N r
      Nr = ∧-proj₁ r-correct

      r<j : LT r j
      r<j = ∧-proj₁ (∧-proj₂ r-correct)

      auxH : i - j ≡ j * (div (i - j) j) + r
      auxH = ∧-proj₂ (∧-proj₂ r-correct)

------------------------------------------------------------------------------
-- The division result is correct
------------------------------------------------------------------------------

module Examples.Division.IsCorrectER where

open import LTC.Minimal
open import LTC.MinimalER

open import Examples.Division
open import Examples.Division.EquationsER
open import Examples.Division.Specification

open import LTC.Data.N
open import LTC.Function.ArithmeticPCF
open import LTC.Function.Arithmetic.PropertiesPCF-ER
open import LTC.Relation.Equalities.PropertiesER
open import LTC.Relation.InequalitiesPCF

import MyStdLib.Relation.Binary.EqReasoning
open module IsNER = MyStdLib.Relation.Binary.EqReasoning.StdLib _≡_ refl trans

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

-- The division result is correct when the dividend is less than
-- the divisor.

div-x<y-aux : {i j : D} → N i → N j → LT i j → i ≡ j * (div i j) + i
div-x<y-aux {i} {j} Ni Nj i<j = sym
    ( begin
        j * (div i j) + i ≡⟨ prf₁ ⟩
        j * zero + i      ≡⟨ prf₂ ⟩
        zero + i          ≡⟨ +-leftIdentity Ni ⟩
        i
      ∎
    )
    where
      prf₁ : j * (div i j) + i ≡ j * zero + i
      prf₁ = subst (λ x → j * x + i ≡ j * zero + i )
                   (sym (div-x<y i<j ))
                   refl

      prf₂ : j * zero + i ≡ zero + i
      prf₂ = subst (λ x → x + i ≡ zero + i)
                   (sym (*-rightZero Nj))
                   refl

div-x<y-correct : {i j : D} → N i → N j → LT i j →
                  (∃D (λ r → N r ∧ LT r j ∧ i ≡ j * (div i j) + r))
div-x<y-correct {i} Ni Nj i<j =
  i , (Ni , (i<j , (div-x<y-aux Ni Nj i<j)))

-- The division result is correct when the dividend is greater or equal
-- than the divisor.
-- Using the inductive hypothesis 'ih' we know that
-- 'i - j = j * (div (i - j) j) + r'. From
-- that we get 'i = j * (succ (div (i - j) j)) + r', and
-- we know 'div i j = succ (div (i - j) j); therefore we
-- get 'i = j * div i j + r'.

postulate
    ih-eq : {i j r : D} → N i → N j → N r →
            i - j ≡ j * (div (i - j) j) + r →
            i ≡ j * succ (div (i - j) j) + r

div-x≥y-aux : {i j r : D} → N i → N j → N r →
              GE i j →
              i - j ≡ j * (div (i - j) j) + r →
              i ≡ j * (div i j) + r
div-x≥y-aux {i} {j} {r} Ni Nj Nr i≥j DIV-eq =
  begin
    i ≡⟨ ih-eq Ni Nj Nr DIV-eq ⟩
    j * succ (div (i - j) j) + r ≡⟨ prf ⟩
    j * (div i j) + r
  ∎

  where prf : j * succ (div (i - j) j) + r ≡ j * (div i j) + r
        prf = subst (λ x → j * x + r ≡ j * (div i j) + r )
                    (div-x≥y i≥j  )
                    refl

div-x≥y-correct : {i j : D} → N i → N j →
                  (ih : DIV (i - j) j (div (i - j) j)) →
                  GE i j →
                  ∃D (λ r → (N r) ∧ (LT r j) ∧ (i ≡ j * (div i j) + r))
div-x≥y-correct {i} {j} Ni Nj ih i≥j =
  r , (Nr , (r<j , (div-x≥y-aux Ni Nj Nr i≥j DIV-eq)))

    where
      -- The parts of the inductive hipothesis 'ih-i-j'
      r : D
      r = ∃D-proj₁ (∧-proj₂ ih)

      r-correct : N r ∧ LT r j ∧ i - j ≡ j * (div (i - j) j) + r
      r-correct = ∃D-proj₂ (∧-proj₂ ih)

      Nr : N r
      Nr = ∧-proj₁ r-correct

      r<j : LT r j
      r<j = ∧-proj₁ (∧-proj₂ r-correct)

      DIV-eq : i - j ≡ j * (div (i - j) j) + r
      DIV-eq = ∧-proj₂ (∧-proj₂ r-correct)


Added missing definition.

Added missing definition.

Ignore-this: d856635bcd908756de7bd5fb0d97adef

darcs-hash:20100703041106-3bd4e-6a27085b48360f2388c10fe42bd1ac2d3a427103.gz

------------------------------------------------------------------------------
-- Inequalities on partial natural numbers
------------------------------------------------------------------------------

module LTC.Data.Nat.Inequalities where

open import LTC.Minimal

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

postulate
  lt : D → D → D

  lt-00 : lt zero zero                     ≡ false

  lt-0S : (d : D) → lt zero (succ d)       ≡ true

  lt-S0 : (d : D) → lt (succ d) zero       ≡ false

  lt-SS : (d e : D) → lt (succ d) (succ e) ≡ lt d e

{-# ATP axiom lt-00 #-}
{-# ATP axiom lt-0S #-}
{-# ATP axiom lt-S0 #-}
{-# ATP axiom lt-SS #-}

le : D → D → D
le d e = lt d (succ e)
{-# ATP definition le #-}

------------------------------------------------------------------------
-- The data types

-- infix 4 _≤_ _<_ _≥_ _>_

GT : D → D → Set
GT d e = lt e d ≡ true
{-# ATP definition GT #-}

LT : D → D  → Set
LT d e = lt d e ≡ true
{-# ATP definition LT #-}

LE : D → D → Set
LE d e = lt e d ≡ false
{-# ATP definition LE #-}

GE : D → D → Set
GE d e = lt d e ≡ false
{-# ATP definition GE #-}

------------------------------------------------------------------------------
-- The lexicographical order
LT₂ : D → D → D → D → Set
LT₂ x₁ y₁ x₂ y₂ = LT x₁ x₂ ∨ x₁ ≡ x₂ ∧ LT y₁ y₂
{-# ATP definition LT₂ #-}


Make-over of the Desc model, including natural numbers and doc.

{-# OPTIONS --type-in-type
            --no-termination-check
            --no-positivity-check #-}

module Desc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Sigma and friends
--****************

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A B : Set) -> Set
A * B = Sigma A \_ -> B

fst : {A : Set}{B : A -> Set} -> Sigma A B -> A
fst (a , _) = a

snd : {A : Set}{B : A -> Set} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero : Set where
record One : Set where

--****************
-- Sum and friends
--****************

data _+_ (A B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

--********************************************
-- Desc code
--********************************************

-- Inductive types are implemented as a Universe. Hence, in this
-- section, we implement their code.

-- We can read this code as follow (see Conor's "Ornamental
-- algebras"): a description in |Desc| is a program to read one node
-- of the described tree.

data Desc : Set where
  Arg : (X : Set) -> (X -> Desc) -> Desc
  -- Read a field in |X|; continue, given its value

  -- Often, |X| is an |EnumT|, hence allowing to choose a constructor
  -- among a finite set of constructors

  Ind : (H : Set) -> Desc -> Desc
  -- Read a field in H; read a recursive subnode given the field,
  -- continue regarless of the subnode

  -- Often, |H| is |1|, hence |Ind| simplifies to |Inf : Desc -> Desc|,
  -- meaning: read a recursive subnode and continue regardless

  Done : Desc
  -- Stop reading

--********************************************
-- Desc decoder
--********************************************

-- Provided the type of the recursive subnodes |R|, we decode a
-- description as a record describing the node.

[|_|]_ : Desc -> Set -> Set
[| Arg A D |] R = Sigma A (\ a -> [| D a |] R)
[| Ind H D |] R = (H -> R) * [| D |] R
[| Done |] R = One

--********************************************
-- Functions on codes
--********************************************

-- Saying that a "predicate" |p| holds everywhere in |v| amounts to
-- write something of the following type:

Everywhere : (d : Desc) (D : Set) (bp : D -> Set) (V : [| d |] D) -> Set
Everywhere (Arg A f) d p v =  Everywhere (f (fst v)) d p (snd v)
-- It must hold for this constructor

Everywhere (Ind H x) d p v =  ((y : H) -> p (fst v y)) * Everywhere x d p (snd v)
-- It must hold for the subtrees

Everywhere Done _ _ _ =  _
-- It trivially holds at endpoints

-- Then, we can build terms that inhabits this type. That is, a
-- function that takes a "predicate" |bp| and makes it hold everywhere
-- in the data-structure. It is the equivalent of a "map", but in a
-- dependently-typed setting.

everywhere : (d : Desc) (D : Set) (bp : D -> Set) ->
           ((y : D) -> bp y) -> (v : [| d |] D) ->
           Everywhere d D bp v
everywhere (Arg a f) d bp p v =  everywhere (f (fst v)) d bp p (snd v)
-- It holds everywhere on this constructor

everywhere (Ind H x) d bp p v = (\y -> p (fst v y)) ,  everywhere x d bp p (snd v)
-- It holds here, and down in the recursive subtrees

everywhere Done _ _ _ _ =  One
-- Nothing needs to be done on endpoints

-- Looking at the decoder, a natural thing to do is to define its
-- fixpoint |Mu D|, hence instantiating |R| with |Mu D| itself.

data Mu (D : Desc) : Set where
  Con : [| D |] (Mu D) -> Mu D

-- Using the "map" defined by |everywhere|, we can implement a "fold"
-- over the |Mu| fixpoint:

foldDesc : (D : Desc) (bp : Mu D -> Set) ->
         ((x : [| D |] (Mu D)) -> Everywhere D (Mu D) bp x -> bp (Con x)) ->
         (v : Mu D) ->
         bp v
foldDesc D bp p (Con v) =  p v (everywhere D (Mu D) bp (\x -> foldDesc D bp p x) v)

--********************************************
-- Nat
--********************************************

data NatConst : Set where
  ZE : NatConst
  SU : NatConst

natc : NatConst -> Desc
natc ZE = Done
natc SU = Ind One Done

natd : Desc
natd = Arg NatConst natc

nat : Set
nat = Mu natd

zero : nat
zero = Con ( ZE ,  _ )

suc : nat -> nat
suc n = Con ( SU , ( (\_ -> n) ,  _ ) )

two : nat
two = suc (suc zero)

four : nat
four = suc (suc (suc (suc zero)))

sum : nat ->
      ((x : Sigma NatConst (\ a -> [| natc a |] Mu (Arg NatConst natc))) ->
      Everywhere (natc (fst x)) (Mu (Arg NatConst natc)) (\ _ -> Mu (Arg NatConst natc)) (snd x) ->
      Mu (Arg NatConst natc))
sum n2 (ZE , _) p =  n2
sum n2 (SU , f) p =  suc ( fst p _)

plus : nat -> nat -> nat
plus n1 n2 = foldDesc natd (\_ -> nat) (sum n2) n1

x : nat
x = plus two two

{-# OPTIONS --type-in-type
            --no-termination-check
            --no-positivity-check #-}

module Desc where

import Data.Product
import Data.Unit
import Data.Empty

open import Data.Product
open import Data.Unit
open import Data.Empty

-- Then, we build Desc in Set
-- it's all Set in Set here

-- Desc code:
data Desc : Set where
  Done : Desc
  Arg : (X : Set) -> (X -> Desc) -> Desc
  Ind : (X : Set) -> Desc -> Desc

descOp : Desc -> Set -> Set
descOp Done _ = ⊤
descOp (Arg A f) D = Σ A (\ a -> descOp (f a) D)
descOp (Ind H x) D =  Σ (H -> D) (\ _ -> descOp x D)

-- Followed by Mu:

data Mu (X : Desc) : Set where
  Con : descOp X (Mu X) -> Mu X

-- All of this is fully-furnished with:
--   * boxOp
--   * mapBoxOp
--   * elimOp

boxOp : (d : Desc) -> (D : Set) -> (bp : D -> Set) -> (v : descOp d D) -> Set
boxOp Done _ _ _ =  ⊤
boxOp (Arg A f) d p v =  boxOp (f (proj₁ v)) d p (proj₂ v)
boxOp (Ind H x) d p v =  ((y : H) -> p (proj₁ v y))
                      × boxOp x d p (proj₂ v)

mapBoxOp : (d : Desc) -> (D : Set) -> (bp : D -> Set) ->
           ((y : D) -> bp y) -> (v : descOp d D) ->
           (boxOp d D bp v)
mapBoxOp Done _ _ _ _ =  tt
mapBoxOp (Arg a f) d bp p v =  mapBoxOp (f (proj₁ v)) d bp p (proj₂ v)
mapBoxOp (Ind H x) d bp p v = (\y -> p (proj₁ v y)) ,  mapBoxOp x d bp p (proj₂ v)

elimOp : (d : Desc) -> (bp : Mu d -> Set) ->
         ((x : descOp d (Mu d)) -> (boxOp d (Mu d) bp x) -> bp (Con x)) ->
         (v : Mu d) -> bp v
elimOp d bp p (Con v) =  p v (mapBoxOp d (Mu d) bp (\x -> elimOp d bp p x) v)


Parser: minor changes

Parser: minor changes

{-# OPTIONS --without-K #-}
open import Type using (★; ★_)
open import Data.Maybe.NP using (_→?_; module M?; just; maybe′; nothing; map?; is-nothing)
open import Data.Nat using (zero; suc)
open import Data.One using (𝟙)
open import Data.Char.NP renaming (_==_ to _==ᶜ_)
open import Data.List as L using (List; []; _∷_; null; filter)
open import Data.Vec using (Vec; []; _∷_)
open import Data.BoundedVec using (BoundedVec) renaming ([] to []ᵇᵛ; _∷_ to _∷ᵇᵛ_)
open import Data.Product.NP hiding (map)
open import Data.Bool using (Bool; if_then_else_; false)
open import Data.String using (String) renaming (toList to S▹L; fromList to L▹S)
open import Function.NP
open import Level.NP

module Text.Parser where

open M? ₀ using () renaming (_=<<_ to _=<<?_; _⊛_ to _⊛?_; join to join?)

Parser : ★ → ★
Parser A = List Char →? (A × List Char)

pure : ∀ {A} → A → Parser A
pure a s = just (a , s)

infixr 3 _⟨|⟩_
_⟨|⟩_ : ∀ {A} → (f g : Parser A) → Parser A
(f ⟨|⟩ g) s = maybe′ just (g s) (f s)

empty : ∀ {A} → Parser A
empty _ = nothing

sat : (Char → Bool) → Parser Char
sat pred (x ∷ xs) = (if pred x then pure x else empty) xs
sat _    []       = nothing

lookSat : (List Char → Bool) → Parser 𝟙
lookSat p xs = if p xs then just (_ , xs) else nothing

notFollowedBy : ∀ {A} → Parser A → Parser 𝟙
notFollowedBy m = lookSat (is-nothing ∘ m)

lookAhead : ∀ {A} → Parser A → Parser A
lookAhead p xs = map? (second (const xs)) (p xs)

eof : Parser 𝟙
eof = lookSat null

-- The remaning input is dropped, you may want to first
-- combine your parser `p' with `eof': `p <* eof'
runParser : ∀ {A} → Parser A → List Char →? A
runParser p s = map? fst (p s)

runParserˢ : ∀ {A} → Parser A → String →? A
runParserˢ p = runParser p ∘ S▹L

infixr 0 _>>=_
_>>=_ : ∀ {A B} → Parser A → (A → Parser B) → Parser B
_>>=_ pa f = maybe′ (uncurry f) nothing ∘ pa

infixl 0 _=<<_
_=<<_ : ∀ {A B} → (A → Parser B) → Parser A → Parser B
_=<<_ f pa = pa >>= f

join : ∀ {A} → Parser (Parser A) → Parser A
join = _=<<_ id

map : ∀ {A B} → (A → B) → Parser A → Parser B
map f pa = pa >>= pure ∘ f

infixl 4 _⊛_ _*>_ _<*_
_⊛_ : ∀ {A B} → Parser (A → B) → Parser A → Parser B
_⊛_ pf pa = pf >>= λ f → pa >>= λ a → pure (f a)

⟪_·_⟫ : ∀ {A B} → (A → B) → Parser A → Parser B
⟪ f · x ⟫ = map f x

⟪_·_·_⟫ : ∀ {A B C} →
            (A → B → C) → Parser A → Parser B → Parser C
⟪ f · x · y ⟫ = map f x ⊛ y

⟪_·_·_·_⟫ : ∀ {A B C D} → (A → B → C → D)
            → Parser A → Parser B → Parser C → Parser D
⟪ f · x · y · z ⟫ = map f x ⊛ y ⊛ z

_*>_ : ∀ {A B} → Parser A → Parser B → Parser B
p₁ *> p₂ = p₁ >>= const p₂

_<*_ : ∀ {A B} → Parser A → Parser B → Parser A
p₁ <* p₂ = p₁ >>= λ x → p₂ *> pure x

mapM : ∀ {a} {A : ★_ a} {B} → (A → Parser B) → List A → Parser (List B)
mapM f []       = pure []
mapM f (x ∷ xs) = ⟪ _∷_ · f x · mapM f xs ⟫

mapMvoid : ∀ {a} {A : ★_ a} {B} → (A → Parser B) → List A → Parser 𝟙
mapMvoid f []       = pure _
mapMvoid f (x ∷ xs) = f x *> mapMvoid f xs

choices : ∀ {A} → List (Parser A) → Parser A
choices = L.foldr _⟨|⟩_ empty

vec : ∀ {A} n → Parser A → Parser (Vec A n)
vec zero    p = pure []
vec (suc n) p = ⟪ _∷_ · p · vec n p ⟫

-- These are producing bounded vectors mainly for termination
-- reasons.
manyBV : ∀ {A} n → Parser A → Parser (BoundedVec A n)
someBV : ∀ {A} n → Parser A → Parser (BoundedVec A (suc n))

manyBV 0       _ = empty
manyBV (suc n) p = someBV n p ⟨|⟩ pure []ᵇᵛ

someBV n p = ⟪ _∷ᵇᵛ_ · p · manyBV n p ⟫

many : ∀ {A} n → Parser A → Parser (List A)
some : ∀ {A} n → Parser A → Parser (List A)

many 0       _ = empty
many (suc n) p = some n p ⟨|⟩ pure []

some n p = ⟪ _∷_ · p · many n p ⟫

manySat : (Char → Bool) → Parser (List Char)
manySat p []       = pure [] []
manySat p (x ∷ xs) = if p x then map? (first (_∷_ x)) (manySat p xs) else pure [] (x ∷ xs)

manySatˢ : (Char → Bool) → Parser String
manySatˢ = map L▹S ∘ manySat

someSat : (Char → Bool) → Parser (List Char)
someSat p = pure _∷_ ⊛ sat p ⊛ manySat p

someSatˢ : (Char → Bool) → Parser String
someSatˢ = map L▹S ∘ someSat

char : Char → Parser 𝟙
char c = sat (_==ᶜ_ c) *> pure _

string : String → Parser 𝟙
string = mapMvoid char ∘ S▹L

oneOf : List Char → Parser Char
oneOf cs = sat (λ c → c `elem` cs)

oneOfˢ : String → Parser Char
oneOfˢ = oneOf ∘ S▹L

noneOf : List Char → Parser Char
noneOf cs = sat (λ c → c `notElem` cs)

noneOfˢ : String → Parser Char
noneOfˢ = noneOf ∘ S▹L

someOneOf : List Char → Parser (List Char)
someOneOf cs = someSat (λ c → c `elem` cs)

someOneOfˢ : String → Parser String
someOneOfˢ = map L▹S ∘ someOneOf ∘ S▹L

someNoneOf : List Char → Parser (List Char)
someNoneOf cs = someSat (λ c → c `notElem` cs)

someNoneOfˢ : String → Parser String
someNoneOfˢ = map L▹S ∘ someNoneOf ∘ S▹L

manyOneOf : List Char → Parser (List Char)
manyOneOf cs = manySat (λ c → c `elem` cs)

manyOneOfˢ : String → Parser String
manyOneOfˢ = map L▹S ∘ manyOneOf ∘ S▹L

manyNoneOf : List Char → Parser (List Char)
manyNoneOf cs = manySat (λ c → c `notElem` cs)

manyNoneOfˢ : String → Parser String
manyNoneOfˢ = map L▹S ∘ manyNoneOf ∘ S▹L

lookSatHead : (Char → Bool) → Parser 𝟙
lookSatHead pᶜ = lookSat p
    where p : List Char → Bool
          p (x ∷ xs) = pᶜ x
          p []       = false

lookHeadNoneOf : List Char → Parser 𝟙
lookHeadNoneOf cs = lookSatHead (λ c → c `notElem` cs)

lookHeadNoneOfˢ : String → Parser 𝟙
lookHeadNoneOfˢ = lookHeadNoneOf ∘ S▹L

lookHeadSomeOf : List Char → Parser 𝟙
lookHeadSomeOf cs = lookSatHead (λ c → c `elem` cs)

lookHeadSomeOfˢ : String → Parser 𝟙
lookHeadSomeOfˢ = lookHeadSomeOf ∘ S▹L

module _ {A} where
    between : ∀ {_V} (begin end : Parser _V) → Endo (Parser A)
    between begin end p = begin *> p <* end

    betweenᶜ : (begin end : Char) → Endo (Parser A)
    betweenᶜ begin end = between (char begin) (char end)

    betweenˢ : (begin end : String) → Endo (Parser A)
    betweenˢ begin end = between (string begin) (string end)

    parens   = betweenᶜ '(' ')'
    braces   = betweenᶜ '{' '}'
    brackets = betweenᶜ '[' ']'
    angles   = betweenᶜ '<' '>'
    oxford   = betweenᶜ '⟦' '⟧'
-- -}

{-# OPTIONS --without-K #-}
open import Type using (★; ★_)
open import Data.Maybe.NP using (_→?_; module M?; just; maybe′; nothing; map?)
open import Data.Nat using (zero; suc)
open import Data.One using (𝟙)
open import Data.Char.NP renaming (_==_ to _==ᶜ_)
open import Data.List as L using (List; []; _∷_; null; filter)
open import Data.Vec using (Vec; []; _∷_)
open import Data.BoundedVec using (BoundedVec) renaming ([] to []ᵇᵛ; _∷_ to _∷ᵇᵛ_)
open import Data.Product.NP hiding (map)
open import Data.Bool using (Bool; if_then_else_; false)
open import Data.String using (String) renaming (toList to S▹L; fromList to L▹S)
open import Function.NP
open import Level.NP

module Text.Parser where

open M? ₀ using () renaming (_=<<_ to _=<<?_; _⊛_ to _⊛?_; join to join?)

Parser : ★ → ★
Parser A = List Char →? (A × List Char)

pure : ∀ {A} → A → Parser A
pure a s = just (a , s)

infixr 3 _⟨|⟩_
_⟨|⟩_ : ∀ {A} → (f g : Parser A) → Parser A
_⟨|⟩_ f g s = maybe′ just (g s) $ f s

empty : ∀ {A} → Parser A
empty _ = nothing

sat : (Char → Bool) → Parser Char
sat pred (x ∷ xs) = (if pred x then pure x else empty) xs
sat _    []       = nothing

eof : Parser 𝟙
eof s = if null s then pure _ [] else empty []

-- The remaning input is dropped, you may want to first
-- combine your parser `p' with `eof': `p <* eof'
runParser : ∀ {A} → Parser A → List Char →? A
runParser p s = map? fst (p s)

runParserˢ : ∀ {A} → Parser A → String →? A
runParserˢ p = runParser p ∘ S▹L

infixr 0 _>>=_
_>>=_ : ∀ {A B} → Parser A → (A → Parser B) → Parser B
_>>=_ pa f = maybe′ (uncurry f) nothing ∘ pa

infixl 0 _=<<_
_=<<_ : ∀ {A B} → (A → Parser B) → Parser A → Parser B
_=<<_ f pa = pa >>= f

join : ∀ {A} → Parser (Parser A) → Parser A
join = _=<<_ id

map : ∀ {A B} → (A → B) → Parser A → Parser B
map f pa = pa >>= pure ∘ f

infixl 4 _⊛_ _*>_ _<*_
_⊛_ : ∀ {A B} → Parser (A → B) → Parser A → Parser B
_⊛_ pf pa = pf >>= λ f → pa >>= λ a → pure (f a)

⟪_·_⟫ : ∀ {A B} → (A → B) → Parser A → Parser B
⟪ f · x ⟫ = map f x

⟪_·_·_⟫ : ∀ {A B C} →
            (A → B → C) → Parser A → Parser B → Parser C
⟪ f · x · y ⟫ = map f x ⊛ y

⟪_·_·_·_⟫ : ∀ {A B C D} → (A → B → C → D)
            → Parser A → Parser B → Parser C → Parser D
⟪ f · x · y · z ⟫ = map f x ⊛ y ⊛ z

_*>_ : ∀ {A B} → Parser A → Parser B → Parser B
p₁ *> p₂ = p₁ >>= const p₂

_<*_ : ∀ {A B} → Parser A → Parser B → Parser A
p₁ <* p₂ = p₁ >>= λ x → p₂ *> pure x

mapM : ∀ {a} {A : ★_ a} {B} → (A → Parser B) → List A → Parser (List B)
mapM f []       = pure []
mapM f (x ∷ xs) = ⟪ _∷_ · f x · mapM f xs ⟫

mapMvoid : ∀ {a} {A : ★_ a} {B} → (A → Parser B) → List A → Parser 𝟙
mapMvoid f []       = pure _
mapMvoid f (x ∷ xs) = f x *> mapMvoid f xs

choices : ∀ {A} → List (Parser A) → Parser A
choices = L.foldr _⟨|⟩_ empty

vec : ∀ {A} n → Parser A → Parser (Vec A n)
vec zero    p = pure []
vec (suc n) p = ⟪ _∷_ · p · vec n p ⟫

-- These are producing bounded vectors mainly for termination
-- reasons.
manyBV : ∀ {A} n → Parser A → Parser (BoundedVec A n)
someBV : ∀ {A} n → Parser A → Parser (BoundedVec A (suc n))

manyBV 0       _ = empty
manyBV (suc n) p = someBV n p ⟨|⟩ pure []ᵇᵛ

someBV n p = ⟪ _∷ᵇᵛ_ · p · manyBV n p ⟫

many : ∀ {A} n → Parser A → Parser (List A)
some : ∀ {A} n → Parser A → Parser (List A)

many 0       _ = empty
many (suc n) p = some n p ⟨|⟩ pure []

some n p = ⟪ _∷_ · p · many n p ⟫

manySat : (Char → Bool) → Parser (List Char)
manySat p []       = pure [] []
manySat p (x ∷ xs) = if p x then map? (first (_∷_ x)) (manySat p xs) else pure [] (x ∷ xs)

manySatˢ : (Char → Bool) → Parser String
manySatˢ = map L▹S ∘ manySat

someSat : (Char → Bool) → Parser (List Char)
someSat p = pure _∷_ ⊛ sat p ⊛ manySat p

someSatˢ : (Char → Bool) → Parser String
someSatˢ = map L▹S ∘ someSat

char : Char → Parser 𝟙
char c = sat (_==ᶜ_ c) *> pure _

string : String → Parser 𝟙
string = mapMvoid char ∘ S▹L

oneOf : List Char → Parser Char
oneOf cs = sat (λ c → c `elem` cs)

oneOfˢ : String → Parser Char
oneOfˢ = oneOf ∘ S▹L

noneOf : List Char → Parser Char
noneOf cs = sat (λ c → c `notElem` cs)

noneOfˢ : String → Parser Char
noneOfˢ = noneOf ∘ S▹L

someOneOf : List Char → Parser (List Char)
someOneOf cs = someSat (λ c → c `elem` cs)

someOneOfˢ : String → Parser String
someOneOfˢ = map L▹S ∘ someOneOf ∘ S▹L

someNoneOf : List Char → Parser (List Char)
someNoneOf cs = someSat (λ c → c `notElem` cs)

someNoneOfˢ : String → Parser String
someNoneOfˢ = map L▹S ∘ someNoneOf ∘ S▹L

manyOneOf : List Char → Parser (List Char)
manyOneOf cs = manySat (λ c → c `elem` cs)

manyOneOfˢ : String → Parser String
manyOneOfˢ = map L▹S ∘ manyOneOf ∘ S▹L

manyNoneOf : List Char → Parser (List Char)
manyNoneOf cs = manySat (λ c → c `notElem` cs)

manyNoneOfˢ : String → Parser String
manyNoneOfˢ = map L▹S ∘ manyNoneOf ∘ S▹L

lookSat : (List Char → Bool) → Parser 𝟙
lookSat p xs = if p xs then just (_ , xs) else nothing

lookSatHead : (Char → Bool) → Parser 𝟙
lookSatHead pᶜ = lookSat p
    where p : List Char → Bool
          p (x ∷ xs) = pᶜ x
          p []       = false

lookHeadNoneOf : List Char → Parser 𝟙
lookHeadNoneOf cs = lookSatHead (λ c → c `notElem` cs)

lookHeadNoneOfˢ : String → Parser 𝟙
lookHeadNoneOfˢ = lookHeadNoneOf ∘ S▹L

lookHeadSomeOf : List Char → Parser 𝟙
lookHeadSomeOf cs = lookSatHead (λ c → c `elem` cs)

lookHeadSomeOfˢ : String → Parser 𝟙
lookHeadSomeOfˢ = lookHeadSomeOf ∘ S▹L

module _ {A} where
    between : ∀ {_V} (begin end : Parser _V) → Endo (Parser A)
    between begin end p = begin *> p <* end

    betweenᶜ : (begin end : Char) → Endo (Parser A)
    betweenᶜ begin end = between (char begin) (char end)

    betweenˢ : (begin end : String) → Endo (Parser A)
    betweenˢ begin end = between (string begin) (string end)

    parens   = betweenᶜ '(' ')'
    braces   = betweenᶜ '{' '}'
    brackets = betweenᶜ '[' ']'
    angles   = betweenᶜ '<' '>'
    oxford   = betweenᶜ '⟦' '⟧'


FLABloM: completing the Square

FLABloM: completing the Square

-- Matrices indexed by shape
module SquareMatrix where

open import Shape
open import Matrix

-- Square matrices have the same shape in both dimensions
Sq : Set → Shape → Set
Sq a shape = M a shape shape

open import SemiNearRingRecord
open import Algebra.Structures
open import Relation.Binary
open import Data.Product hiding (swap)

open import Relation.Binary.PropositionalEquality hiding (trans; sym) renaming (refl to refl-≡)
import Relation.Binary.EqReasoning as EqReasoning

-- Lifting a SNR to a to a Square matrix of some shape
Square : SemiNearRing → Shape → SemiNearRing
Square snr shape = SNR
  where
  open SemiNearRing snr

  S = Sq s shape

  infixr 60 _∙S_
  infixr 50 _+S_

  _+S_ : ∀ {r c} → M s r c → M s r c → M s r c
  One x     +S One x₁    = One (x +ₛ x₁)
  Row m m₁  +S Row n n₁  = Row (m +S n) (m₁ +S n₁)
  Col m m₁  +S Col n n₁  = Col (m +S n) (m₁ +S n₁)
  Q m00 m01
    m10 m11 +S Q n00 n01
                n10 n11 = Q (m00 +S n00) (m01 +S n01)
                            (m10 +S n10) (m11 +S n11)

  _∙S_ : ∀ {r m c} → M s r m → M s m c → M s r c
  One x     ∙S One x₁    = One (x ∙ₛ x₁)
  One x     ∙S Row n n₁  = Row (One x ∙S n) (One x ∙S n₁)
  Row m m₁  ∙S Col n n₁  = m ∙S n +S m₁ ∙S n₁
  Row m m₁  ∙S Q n00 n01
                n10 n11 = Row (m ∙S n00 +S m₁ ∙S n10) (m ∙S n01 +S m₁ ∙S n11)
  Col m m₁  ∙S One x     = Col (m ∙S One x) (m₁ ∙S One x)
  Col m m₁  ∙S Row n n₁  = Q (m ∙S n)   (m ∙S n₁)
                            (m₁ ∙S n)  (m₁ ∙S n₁)
  Q m00 m01
    m10 m11 ∙S Col n n₁  = Col (m00 ∙S n +S m01 ∙S n₁) (m10 ∙S n +S m11 ∙S n₁)
  Q m00 m01
    m10 m11 ∙S Q n00 n01
                n10 n11 = Q (m00 ∙S n00 +S m01 ∙S n10) (m00 ∙S n01 +S m01 ∙S n11)
                            (m10 ∙S n00 +S m11 ∙S n10) (m10 ∙S n01 +S m11 ∙S n11)

  0S : (r c : Shape) → M s r c
  0S L L = One 0ₛ
  0S L (B s s₁) = Row (0S L s) (0S L s₁)
  0S (B r r₁) L = Col (0S r L) (0S r₁ L)
  0S (B r r₁) (B s s₁) =
      Q (0S r s) (0S r s₁)
        (0S r₁ s) (0S r₁ s₁)

  _≃S_ : {r c : Shape} →
        M s r c → M s r c → Set
  _≃S_ {L} {L} (One x) (One x₁) = x ≃ₛ x₁
  _≃S_ {L} {(B c₁ c₂)} (Row m m₁) (Row n n₁) =
    _≃S_ m n × _≃S_ m₁ n₁
  _≃S_ {(B r₁ r₂)} {L} (Col m m₁) (Col n n₁) =
    _≃S_ m n × _≃S_ m₁ n₁
  _≃S_ {(B r₁ r₂)} {(B c₁ c₂)} (Q m00 m01 m10 m11) (Q n00 n01 n10 n11) =
    _≃S_ m00 n00 ×
    _≃S_ m01 n01 ×
    _≃S_ m10 n10 ×
    _≃S_ m11 n11

  reflS : (r c : Shape) →
    {X : M s r c} → X ≃S X
  reflS L L {X = One x} = reflₛ {x}
  reflS L (B c₁ c₂) {X = Row X Y} = reflS L c₁ , reflS L c₂
  reflS (B r₁ r₂) L {X = Col X Y} = reflS r₁ L , reflS r₂ L
  reflS (B r₁ r₂) (B c₁ c₂) {X = Q X Y Z W} =
    reflS r₁ c₁ , reflS r₁ c₂ ,
    reflS r₂ c₁ , reflS r₂ c₂

  symS : (r c : Shape) →
    {i j : M s r c} → i ≃S j → j ≃S i
  symS L L {One x} {One x₁} p = symₛ p
  symS L (B c₁ c₂) {Row i₁ i₂} {Row j₁ j₂} (p , q) = symS L c₁ p , symS L c₂ q
  symS (B r₁ r₂) L {Col i₁ i} {Col j j₁} (p , q) = symS r₁ L p , symS r₂ L q
  symS (B r r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j j₁ j₂ j₃} (p , q , x , y) =
    symS r c₁ p , symS r c₂ q ,
    symS r₂ c₁ x , symS r₂ c₂ y

  transS : (r c : Shape) →
    {i j k : M s r c} → i ≃S j → j ≃S k → i ≃S k
  transS L L {One x} {One x₁} {One x₂} p q = trans p q
  transS L (B c₁ c₂) {Row i i₁} {Row j j₁} {Row k k₁} (p , q) (p' , q') =
    transS L c₁ p p' , transS L c₂ q q'
  transS (B r₁ r₂) L {Col i i₁} {Col j j₁} {Col k k₁} (p , q) (p' , q') =
    transS r₁ L p p' , transS r₂ L q q'
  transS (B r₁ r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j₂ j j₃ j₁} {Q k k₁ k₂ k₃}
    (p , q , x , y) (p' , q' , x' , y') =
    transS r₁ c₁ p p' , transS r₁ c₂ q q' ,
    transS r₂ c₁ x x' , transS r₂ c₂ y y'

  isEquivS =
    record
      { refl = reflS shape shape
      ; sym = symS shape shape
      ; trans = transS shape shape }

  assocS : (r c : Shape) (x y z : M s r c) → ((x +S y) +S z) ≃S (x +S (y +S z))
  assocS L L (One x) (One y) (One z) = assocₛ x y z
  assocS L (B c c₁) (Row x x₁) (Row y y₁) (Row z z₁) =
    assocS L c x y z  , assocS L c₁ x₁ y₁ z₁
  assocS (B r r₁) L (Col x x₁) (Col y y₁) (Col z z₁) =
    assocS r L x y z , assocS r₁ L x₁ y₁ z₁
  assocS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (assocS r c x y z) , (assocS r c₁ x₁ y₁ z₁) ,
    (assocS r₁ c x₂ y₂ z₂) , (assocS r₁ c₁ x₃ y₃ z₃)

  <+S> : (r c : Shape) {x y u v : M s r c} →
    x ≃S y → u ≃S v → (x +S u) ≃S (y +S v)
  <+S> L L {One x} {One x₁} {One x₂} {One x₃} p q = p <+> q
  <+S> L (B c c₁) {Row x x₁} {Row y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <+S> L c p q , <+S> L c₁ p₁ q₁
  <+S> (B r r₁) L {Col x x₁} {Col y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    <+S> r L p q , <+S> r₁ L p₁ q₁
  <+S> (B r r₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃}
    (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> r c p q , <+S> r c₁ p₁ q₁ ,
    <+S> r₁ c p₂ q₂ , <+S> r₁ c₁ p₃ q₃

  isSemgroupS =
    record
      { isEquivalence = isEquivS
      ; assoc = assocS shape shape
      ; ∙-cong = <+S> shape shape }

  identSˡ : (r c : Shape) (x : M s r c) →
     0S r c +S x ≃S x
  identSˡ L L (One x) = identityˡₛ x
  identSˡ L (B c c₁) (Row x x₁) = identSˡ L c x , identSˡ L c₁ x₁
  identSˡ (B r r₁) L (Col x x₁) = identSˡ r L x , identSˡ r₁ L x₁
  identSˡ (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    identSˡ r c x , identSˡ r c₁ x₁ ,
    identSˡ r₁ c x₂ , identSˡ r₁ c₁ x₃

  commS : (r c : Shape) → (x y : M s r c) →
    (x +S y) ≃S (y +S x)
  commS L L (One x) (One x₁) = commₛ x x₁
  commS L (B c c₁) (Row x x₁) (Row y y₁) = (commS L c x y) , (commS L c₁ x₁ y₁)
  commS (B r r₁) L (Col x x₁) (Col y y₁) = (commS r L x y) , (commS r₁ L x₁ y₁)
  commS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) =
    commS r c x y , commS r c₁ x₁ y₁ ,
    commS r₁ c x₂ y₂ , commS r₁ c₁ x₃ y₃

  isCommMonS =
    record
      { isSemigroup = isSemgroupS
      ; identityˡ = identSˡ shape shape
      ; comm = commS shape shape }

  setoidS : {r c : Shape} → Setoid _ _
  setoidS {r} {c} =
    record
      { Carrier = M s r c
      ; _≈_ = _≃S_ {r} {c}
      ; isEquivalence =
        record
          { refl = reflS r c ; sym = symS r c ; trans = transS r c } }

  zeroSˡ : (a b c : Shape) (x : M s b c) →
    (0S a b ∙S x) ≃S 0S a c
  zeroSˡ L L L (One x) = zeroˡ x
  zeroSˡ L L (B c c₁) (Row x x₁) = (zeroSˡ L L c x) , (zeroSˡ L L c₁ x₁)
  zeroSˡ L (B b b₁) L (Col x x₁) =
    let
      open EqReasoning setoidS
      ih = zeroSˡ L b L x
      ih₁ = zeroSˡ L b₁ L x₁
    in begin
      (Row (0S L b) (0S L b₁) ∙S (Col x x₁))
    ≡⟨ refl-≡ ⟩
      (0S L b) ∙S x +S (0S L b₁) ∙S x₁
    ≈⟨ <+S> L L {0S L b ∙S x} {0S L L} {0S L b₁ ∙S x₁} {0S L L} ih ih₁ ⟩
      0S L L +S 0S L L
    ≈⟨ identSˡ L L (0S L L) ⟩
      0S L L
    ∎
  zeroSˡ L (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSˡ L b c x
      ih₁ = zeroSˡ L b₁ c x₂
     in begin
       0S L b ∙S x +S 0S L b₁ ∙S x₂
     ≈⟨ <+S> L c ih ih₁ ⟩
       0S L c +S 0S L c
     ≈⟨ identSˡ L c (0S L c) ⟩
       0S L c
     ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ L b c₁ x₁
      ih₁ = zeroSˡ L b₁ c₁ x₃
    in begin
      0S L b ∙S x₁ +S 0S L b₁ ∙S x₃
    ≈⟨ <+S> L c₁ ih ih₁ ⟩
      0S L c₁ +S 0S L c₁
    ≈⟨ identSˡ L c₁ _ ⟩
      0S L c₁
    ∎)
  zeroSˡ (B a a₁) L L (One x) = zeroSˡ a L L (One x) , zeroSˡ a₁ L L (One x)
  zeroSˡ (B a a₁) L (B c c₁) (Row x x₁) =
    zeroSˡ a L c x , zeroSˡ a L c₁ x₁ ,
    zeroSˡ a₁ L c x , zeroSˡ a₁ L c₁ x₁
  zeroSˡ (B a a₁) (B b b₁) L (Col x x₁) =
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a b L x
      ih₁ = zeroSˡ a b₁ L x₁
    in begin
      0S a b ∙S x +S 0S a b₁ ∙S x₁
    ≈⟨ <+S> a L ih ih₁ ⟩
      0S a L +S 0S a L
    ≈⟨ identSˡ a L _ ⟩
      0S a L
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a₁ b L x
      ih₁ = zeroSˡ a₁ b₁ L x₁
    in begin
      0S a₁ b ∙S x +S 0S a₁ b₁ ∙S x₁
    ≈⟨ <+S> a₁ L ih ih₁ ⟩
      0S a₁ L +S 0S a₁ L
    ≈⟨ identSˡ a₁ L _ ⟩
      0S a₁ L
    ∎)
  zeroSˡ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a b c x
      ih₁ = zeroSˡ a b₁ c x₂
    in begin
      0S a b ∙S x +S 0S a b₁ ∙S x₂
    ≈⟨ <+S> a c ih ih₁ ⟩
      0S a c +S 0S a c
    ≈⟨ identSˡ a c _ ⟩
      0S a c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a b c₁ x₁
      ih₁ = zeroSˡ a b₁ c₁ x₃
    in begin
      0S a b ∙S x₁ +S 0S a b₁ ∙S x₃
    ≈⟨ <+S> a c₁ ih ih₁ ⟩
      0S a c₁ +S 0S a c₁
    ≈⟨ identSˡ a c₁ _ ⟩
      0S a c₁
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a₁ b c x
      ih₁ = zeroSˡ a₁ b₁ c x₂
    in begin
      0S a₁ b ∙S x +S 0S a₁ b₁ ∙S x₂
    ≈⟨ <+S> a₁ c ih ih₁ ⟩
      0S a₁ c +S 0S a₁ c
    ≈⟨ identSˡ a₁ c _ ⟩
      0S a₁ c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSˡ a₁ b c₁ x₁
      ih₁ = zeroSˡ a₁ b₁ c₁ x₃
    in begin
      0S a₁ b ∙S x₁ +S 0S a₁ b₁ ∙S x₃
    ≈⟨ <+S> a₁ c₁ ih ih₁ ⟩
      0S a₁ c₁ +S 0S a₁ c₁
    ≈⟨ identSˡ a₁ c₁ _ ⟩
      0S a₁ c₁
    ∎)

  zeroSʳ : (a b c : Shape) (x : M s a b) →
    (x ∙S 0S b c) ≃S 0S a c
  zeroSʳ L L L (One x) = zeroʳ x
  zeroSʳ L L (B c c₁) (One x) =
    (zeroSʳ L L c (One x)) , (zeroSʳ L L c₁ (One x))
  zeroSʳ L (B b b₁) L (Row x x₁) =
    let
      open EqReasoning setoidS
      ih = zeroSʳ L b L x
      ih₁ = zeroSʳ L b₁ L x₁
    in begin
      Row x x₁ ∙S Col (0S b L) (0S b₁ L)
    ≡⟨ refl-≡ ⟩
      (x ∙S 0S b L) +S (x₁ ∙S 0S b₁ L)
    ≈⟨ <+S> L L {x ∙S 0S b L} {0S L L} {x₁ ∙S 0S b₁ L} {0S L L} ih ih₁ ⟩
      0S L L +S 0S L L
    ≈⟨ identSˡ L L (0S L L) ⟩
      0S L L
    ∎
  zeroSʳ L (B b b₁) (B c c₁) (Row x x₁) =
    (let
      open EqReasoning setoidS
      ih = zeroSʳ L b c x
      ih₁ = zeroSʳ L b₁ c x₁
    in begin
      x ∙S 0S b c +S x₁ ∙S 0S b₁ c
    ≈⟨ <+S> L c ih ih₁ ⟩
      0S L c +S 0S L c
    ≈⟨ identSˡ L c (0S L c) ⟩
      0S L c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ L b c₁ x
      ih₁ = zeroSʳ L b₁ c₁ x₁
    in begin
      x ∙S 0S b c₁ +S x₁ ∙S 0S b₁ c₁
    ≈⟨ <+S> L c₁ ih ih₁ ⟩
      0S L c₁ +S 0S L c₁
    ≈⟨ identSˡ L c₁ (0S L c₁) ⟩
      0S L c₁
    ∎)
  zeroSʳ (B a a₁) L L (Col x x₁) = zeroSʳ a L L x , zeroSʳ a₁ L L x₁
  zeroSʳ (B a a₁) L (B c c₁) (Col x x₁) =
    zeroSʳ a L c x ,
    zeroSʳ a L c₁ x ,
    zeroSʳ a₁ L c x₁ ,
    zeroSʳ a₁ L c₁ x₁
  zeroSʳ (B a a₁) (B b b₁) L (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a b L x
      ih₁ = zeroSʳ a b₁ L x₁
    in begin
      x ∙S 0S b L +S x₁ ∙S 0S b₁ L
    ≈⟨ <+S> a L ih ih₁ ⟩
      0S a L +S 0S a L
    ≈⟨ identSˡ a L (0S _ _) ⟩
      0S a L
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a₁ b L x₂
      ih₁ = zeroSʳ a₁ b₁ L x₃
    in begin
      x₂ ∙S 0S b L +S x₃ ∙S 0S b₁ L
    ≈⟨ <+S> a₁ L ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ L (0S _ _) ⟩
      0S a₁ L
    ∎)
  zeroSʳ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a b c x
      ih₁ = zeroSʳ a b₁ c x₁
    in begin
      x ∙S 0S b c +S x₁ ∙S 0S b₁ c
    ≈⟨ <+S> a c ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a c (0S _ _) ⟩
      0S _ _
    ∎) ,
    (let
      ih = zeroSʳ a b c₁ x
      ih₁ = zeroSʳ a b₁ c₁ x₁
    in transS a c₁ (<+S> a c₁ ih ih₁) (identSˡ a c₁ (0S _ _))
    ) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a₁ b c x₂
      ih₁ = zeroSʳ a₁ b₁ c x₃
    in begin
      x₂ ∙S 0S b c +S x₃ ∙S 0S b₁ c
    ≈⟨ <+S> a₁ c ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ c (0S _ _) ⟩
      0S a₁ c
    ∎) ,
    (let
      open EqReasoning setoidS
      ih = zeroSʳ a₁ b c₁ x₂
      ih₁ = zeroSʳ a₁ b₁ c₁ x₃
    in begin
      x₂ ∙S 0S b c₁ +S x₃ ∙S 0S b₁ c₁
    ≈⟨ <+S> a₁ c₁ ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ c₁ (0S _ _) ⟩
      0S a₁ c₁
    ∎)

  <∙S> : (a b c : Shape) {x y : M s a b} {u v : M s b c} →
    x ≃S y → u ≃S v → (x ∙S u) ≃S (y ∙S v)
  <∙S> L L L {One x} {One x₁} {One x₂} {One x₃} p q = p <∙> q
  <∙S> L L (B c c₁) {One x} {One x₁} {Row u u₁} {Row v v₁} p (q , q₁) =
    (<∙S> L L c {One x} {One x₁} {u} {v} p q) ,
    <∙S> L L c₁ {One x} {One x₁} {u₁} {v₁} p q₁
  <∙S> L (B b b₁) L {Row x x₁} {Row y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    -- Row x x₁ ∙S Col u u₁ ≃S Row y y₁ ∙S Col v v₁
    let
      open EqReasoning setoidS
      ih = <∙S> _ _ _ {x} {y} {u} {v} p q
      ih₁ = <∙S> _ _ _ {x₁} {y₁} {u₁} {v₁} p₁ q₁
    in begin
      Row x x₁ ∙S Col u u₁
    ≡⟨ refl-≡ ⟩
      x ∙S u +S x₁ ∙S u₁
    ≈⟨ <+S> L L {x ∙S u} {y ∙S v} {x₁ ∙S u₁} {y₁ ∙S v₁} ih ih₁ ⟩
      y ∙S v +S y₁ ∙S v₁
    ∎
  <∙S> L (B b b₁) (B c c₁) {Row x x₁} {Row y y₁} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁) (q , q₁ , q₂ , q₃) =
    (let
      ih = <∙S> L b c p q
      ih₁ = <∙S> L b₁ c p₁ q₂
    in <+S> L c ih ih₁) ,
    <+S> L c₁ (<∙S> L b c₁ p q₁) (<∙S> L b₁ c₁ p₁ q₃)
  <∙S> (B a a₁) L L {Col x x₁} {Col y y₁} {One x₂} {One x₃} (p , p₁) q =
    <∙S> a L L p q ,
    <∙S> a₁ L L p₁ q
  <∙S> (B a a₁) L (B c c₁) {Col x x₁} {Col y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <∙S> a L c p q ,
    <∙S> a L c₁ p q₁  ,
    <∙S> a₁ L c p₁ q ,
    <∙S> a₁ L c₁ p₁ q₁
  <∙S> (B a a₁) (B b b₁) L {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Col u u₁} {Col v v₁} (p , p₁ , p₂ , p₃) (q , q₁) =
    <+S> a L (<∙S> a b L p q) (<∙S> a b₁ L p₁ q₁) ,
    <+S> a₁ L (<∙S> a₁ b L p₂ q) (<∙S> a₁ b₁ L p₃ q₁ )
  <∙S> (B a a₁) (B b b₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> a c (<∙S> a b c p q) (<∙S> a b₁ c p₁ q₂) ,
    <+S> a c₁ (<∙S> a b c₁ p q₁) (<∙S> a b₁ c₁ p₁ q₃) ,
    <+S> a₁ c (<∙S> a₁ b c p₂ q) (<∙S> a₁ b₁ c p₃ q₂) ,
    <+S> a₁ c₁ (<∙S> a₁ b c₁ p₂ q₁) (<∙S> a₁ b₁ c₁ p₃ q₃)

  idemS : (r c : Shape) (x : M s r c) → x +S x ≃S x
  idemS L L (One x) = idem x
  idemS L (B c c₁) (Row x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) L (Col x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (idemS _ _ x) , (idemS _ _ x₁ , (idemS _ _ x₂  , idemS _ _ x₃))

  swapMid : {r c : Shape} (x y z w : M s r c) →
    (x +S y) +S (z +S w) ≃S (x +S z) +S (y +S w)
  swapMid {r} {c} x y z w =
    let open EqReasoning setoidS
    in begin
      (x +S y) +S (z +S w)
    ≈⟨ assocS _ _ x y (z +S w) ⟩
      x +S y +S z +S w
    ≈⟨ <+S> r c (reflS r c) (symS r c (assocS r c y z w)) ⟩
      x +S (y +S z) +S w
    ≈⟨ <+S> r c (reflS r c) (<+S> r c (commS r c y z) (reflS r c)) ⟩
      x +S (z +S y) +S w
    ≈⟨ <+S> r c (reflS r c) (assocS r c z y w) ⟩
      x +S z +S y +S w
    ≈⟨ symS r c (assocS r c x z (y +S w)) ⟩
      (x +S z) +S (y +S w)
    ∎

  distlHelp : ∀ {a b b₁ c₁}
              (x : M s a b)
              (y z : M s b c₁)
              (x₁ : M s a b₁)
              (y₁ z₁ : M s b₁ c₁) →
            (x ∙S (y +S z)) ≃S (x ∙S y +S x ∙S z) →
            (x₁ ∙S (y₁ +S z₁)) ≃S (x₁ ∙S y₁ +S x₁ ∙S z₁) →
            (x ∙S (y +S z) +S x₁ ∙S (y₁ +S z₁))
            ≃S ((x ∙S y +S x₁ ∙S y₁) +S x ∙S z +S x₁ ∙S z₁)
  distlHelp x y z x₁ y₁ z₁ p q =
    let open EqReasoning setoidS
    in begin
      x ∙S (y +S z) +S x₁ ∙S (y₁ +S z₁)
    ≈⟨ <+S> _ _ {x ∙S (y +S z)} {x ∙S y +S x ∙S z}
                {x₁ ∙S (y₁ +S z₁)} {x₁ ∙S y₁ +S x₁ ∙S z₁} p q ⟩
      (x ∙S y +S x ∙S z) +S x₁ ∙S y₁ +S x₁ ∙S z₁
    ≈⟨ swapMid (x ∙S y) (x ∙S z) (x₁ ∙S y₁) (x₁ ∙S z₁) ⟩
      (x ∙S y +S x₁ ∙S y₁) +S x ∙S z +S x₁ ∙S z₁
    ∎

  distlS : {a b c : Shape} (x : M s a b) (y z : M s b c) →
    (x ∙S (y +S z)) ≃S ((x ∙S y) +S (x ∙S z))
  distlS {L} {L} {L} (One x) (One y) (One z) = distl x y z
  distlS {L} {L} {B c c₁} (One x) (Row y y₁) (Row z z₁) =
    distlS (One x) y z ,
    distlS (One x) y₁ z₁
  distlS {L} {(B b b₁)} {L} (Row x x₁) (Col y y₁) (Col z z₁) =
    distlHelp x y z x₁ y₁ z₁ (distlS x y z) (distlS x₁ y₁ z₁)
  distlS {L} {(B b b₁)} {(B c c₁)} (Row x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distlHelp x y z x₁ y₂ z₂ (distlS x y z) (distlS x₁ y₂ z₂) ,
    distlHelp x y₁ z₁ x₁ y₃ z₃  (distlS x y₁ z₁) (distlS x₁ y₃ z₃)
  distlS {(B a a₁)} {L} {L} (Col x x₁) (One x₂) (One x₃) =
    distlS x (One x₂) (One x₃) ,
    distlS x₁ (One x₂) (One x₃)
  distlS {(B a a₁)} {L} {(B c c₁)} (Col x x₁) (Row y y₁) (Row z z₁) =
    distlS x y z ,
    distlS x y₁ z₁ ,
    distlS x₁ y z ,
    distlS x₁ y₁ z₁
  distlS {(B a a₁)} {(B b b₁)} {L} (Q x x₁ x₂ x₃) (Col y y₁) (Col z z₁) =
    distlHelp x y z x₁ y₁ z₁ (distlS x y z) (distlS x₁ y₁ z₁) ,
    distlHelp x₂ y z x₃ y₁ z₁ (distlS x₂ y z) (distlS x₃ y₁ z₁)
  distlS {(B a a₁)} {(B b b₁)} {(B c c₁)} (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distlHelp x y z x₁ y₂ z₂ (distlS x y z) (distlS x₁ y₂ z₂) ,
    distlHelp x y₁ z₁ x₁ y₃ z₃ (distlS x y₁ z₁) (distlS x₁ y₃ z₃) ,
    distlHelp x₂ y z x₃ y₂ z₂ (distlS x₂ y z) (distlS x₃ y₂ z₂)  ,
    distlHelp x₂ y₁ z₁ x₃ y₃ z₃ (distlS x₂ y₁ z₁) (distlS x₃ y₃ z₃)

  distrHelp : ∀ {r m m₁ c : Shape}
              (x : M s m c)
              (y z : M s r m)
              (x₁ : M s m₁ c)
              (y₁ z₁ : M s r m₁) →
            ((y +S z) ∙S x) ≃S (y ∙S x +S z ∙S x) →
            ((y₁ +S z₁) ∙S x₁) ≃S (y₁ ∙S x₁ +S z₁ ∙S x₁) →
            ((y +S z) ∙S x +S (y₁ +S z₁) ∙S x₁)
            ≃S ((y ∙S x +S y₁ ∙S x₁) +S z ∙S x +S z₁ ∙S x₁)
  distrHelp x y z x₁ y₁ z₁ p q =
    let open EqReasoning setoidS
    in begin
      (y +S z) ∙S x +S (y₁ +S z₁) ∙S x₁
    ≈⟨ <+S> _ _ {(y +S z) ∙S x} {y ∙S x +S z ∙S x}
                {(y₁ +S z₁) ∙S x₁} {y₁ ∙S x₁ +S z₁ ∙S x₁} p q ⟩
      (y ∙S x +S z ∙S x) +S y₁ ∙S x₁ +S z₁ ∙S x₁
    ≈⟨ swapMid (y ∙S x) (z ∙S x) (y₁ ∙S x₁) (z₁ ∙S x₁) ⟩
      (y ∙S x +S y₁ ∙S x₁) +S z ∙S x +S z₁ ∙S x₁
    ∎

  distrS : {r m c : Shape} (x : M s m c) (y z : M s r m) →
    ((y +S z) ∙S x) ≃S ((y ∙S x) +S (z ∙S x))
  distrS {L} {L} {L} (One x) (One y) (One z) =
    distr x y z
  distrS {L} {L} {B c c₁} (Row x x₁) (One x₂) (One x₃) =
    (distrS x (One x₂) (One x₃)) ,
    (distrS x₁ (One x₂) (One x₃))
  distrS {L} {B m m₁} {L} (Col x x₁) (Row y y₁) (Row z z₁) =
    distrHelp x y z x₁ y₁ z₁ (distrS x y z) (distrS x₁ y₁ z₁)
  distrS {L} {B m m₁} {B c c₁} (Q x x₁ x₂ x₃) (Row y y₁) (Row z z₁) =
    (distrHelp x y z x₂ y₁ z₁ (distrS x y z) (distrS x₂ y₁ z₁)) ,
    (distrHelp x₁ y z x₃ y₁ z₁ (distrS x₁ y z) (distrS x₃ y₁ z₁))
  distrS {B r r₁} {L} {L} (One x) (Col y y₁) (Col z z₁) =
    distrS (One x) y z ,
    distrS (One x) y₁ z₁
  distrS {B r r₁} {L} {B c c₁} (Row x x₁) (Col y y₁) (Col z z₁) =
    (distrS x y z) ,
    (distrS x₁ y z) ,
    (distrS x y₁ z₁) ,
    (distrS x₁ y₁ z₁)
  distrS {B r r₁} {B m m₁} {L} (Col x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (distrHelp x y z x₁ y₁ z₁ (distrS x y z) (distrS x₁ y₁ z₁)) ,
    (distrHelp x y₂ z₂ x₁ y₃ z₃ (distrS x y₂ z₂) (distrS x₁ y₃ z₃))
  distrS {B r r₁} {B m m₁} {B c c₁} (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    distrHelp x y z x₂ y₁ z₁ (distrS x y z) (distrS x₂ y₁ z₁) ,
    distrHelp x₁ y z x₃ y₁ z₁ (distrS x₁ y z) (distrS x₃ y₁ z₁) ,
    distrHelp x y₂ z₂ x₂ y₃ z₃ (distrS x y₂ z₂) (distrS x₂ y₃ z₃) ,
    distrHelp x₁ y₂ z₂ x₃ y₃ z₃ (distrS x₁ y₂ z₂) (distrS x₃ y₃ z₃)

  SNR : SemiNearRing
  SNR =
    record
      { s = S
      ; _≃ₛ_ = _≃S_ {shape} {shape}
      ; 0ₛ = 0S shape shape
      ; _+ₛ_ = _+S_
      ; _∙ₛ_ = _∙S_
      ; isCommMon = isCommMonS
      ; zeroˡ = zeroSˡ shape shape shape
      ; zeroʳ = zeroSʳ shape shape shape
      ; _<∙>_ = <∙S> shape shape shape
      ; idem = idemS shape shape
      ; distl = distlS {shape} {shape}
      ; distr = distrS {shape} {shape}
      }

-- Matrices indexed by shape
module SquareMatrix where

open import Shape
open import Matrix

-- Square matrices have the same shape in both dimensions
Sq : Set → Shape → Set
Sq a shape = M a shape shape

open import SemiNearRingRecord
open import Algebra.Structures
open import Relation.Binary
open import Data.Product

open import Relation.Binary.PropositionalEquality hiding (trans; sym) renaming (refl to refl-≡)
import Relation.Binary.EqReasoning as EqReasoning

-- Lifting a SNR to a to a Square matrix of some shape
Square : SemiNearRing → Shape → SemiNearRing
Square snr shape = SNR
  where
  open SemiNearRing snr

  S = Sq s shape

  open Operations s _∙ₛ_ _+ₛ_
    renaming (_+_ to _+S_; _*_ to _∙S_)

  0S : (r c : Shape) → M s r c
  0S L L = One 0ₛ
  0S L (B s s₁) = Row (0S L s) (0S L s₁)
  0S (B r r₁) L = Col (0S r L) (0S r₁ L)
  0S (B r r₁) (B s s₁) =
      Q (0S r s) (0S r s₁)
        (0S r₁ s) (0S r₁ s₁)

  ≃S : (r c : Shape) →
        M s r c → M s r c → Set
  ≃S L L (One x) (One x₁) = x ≃ₛ x₁
  ≃S L (B c₁ c₂) (Row m m₁) (Row n n₁) = ≃S L c₁ m n × ≃S L c₂ m₁ n₁
  ≃S (B r₁ r₂) L (Col m m₁) (Col n n₁) = ≃S r₁ L m n × ≃S r₂ L m₁ n₁
  ≃S (B r₁ r₂) (B c₁ c₂) (Q m00 m01 m10 m11) (Q n00 n01 n10 n11) =
    ≃S r₁ c₁ m00 n00 × ≃S r₁ c₂ m01 n01 ×
    ≃S r₂ c₁ m10 n10 × ≃S r₂ c₂ m11 n11

  _≃S'_ : {r c : Shape} → M s r c → M s r c → Set
  _≃S'_ {r} {c} m n = ≃S r c m n

  reflS : (r c : Shape) →
    {X : M s r c} → X ≃S' X
  reflS L L {X = One x} = reflₛ {x}
  reflS L (B c₁ c₂) {X = Row X Y} = reflS L c₁ , reflS L c₂
  reflS (B r₁ r₂) L {X = Col X Y} = reflS r₁ L , reflS r₂ L
  reflS (B r₁ r₂) (B c₁ c₂) {X = Q X Y Z W} =
    reflS r₁ c₁ , reflS r₁ c₂ ,
    reflS r₂ c₁ , reflS r₂ c₂

  symS : (r c : Shape) →
    {i j : M s r c} → i ≃S' j → j ≃S' i
  symS L L {One x} {One x₁} p = symₛ p
  symS L (B c₁ c₂) {Row i₁ i₂} {Row j₁ j₂} (p , q) = symS L c₁ p , symS L c₂ q
  symS (B r₁ r₂) L {Col i₁ i} {Col j j₁} (p , q) = symS r₁ L p , symS r₂ L q
  symS (B r r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j j₁ j₂ j₃} (p , q , x , y) =
    symS r c₁ p , symS r c₂ q ,
    symS r₂ c₁ x , symS r₂ c₂ y

  transS : (r c : Shape) →
    {i j k : M s r c} → i ≃S' j → j ≃S' k → i ≃S' k
  transS L L {One x} {One x₁} {One x₂} p q = trans p q
  transS L (B c₁ c₂) {Row i i₁} {Row j j₁} {Row k k₁} (p , q) (p' , q') =
    transS L c₁ p p' , transS L c₂ q q'
  transS (B r₁ r₂) L {Col i i₁} {Col j j₁} {Col k k₁} (p , q) (p' , q') =
    transS r₁ L p p' , transS r₂ L q q'
  transS (B r₁ r₂) (B c₁ c₂) {Q i₂ i i₃ i₁} {Q j₂ j j₃ j₁} {Q k k₁ k₂ k₃}
    (p , q , x , y) (p' , q' , x' , y') =
    transS r₁ c₁ p p' , transS r₁ c₂ q q' ,
    transS r₂ c₁ x x' , transS r₂ c₂ y y'

  isEquivS =
    record
      { refl = reflS shape shape
      ; sym = symS shape shape
      ; trans = transS shape shape }

  liftAssoc : (r c : Shape) (x y z : M s r c) → ((x +S y) +S z) ≃S' (x +S (y +S z))
  liftAssoc L L (One x) (One y) (One z) = assocₛ x y z
  liftAssoc L (B c c₁) (Row x x₁) (Row y y₁) (Row z z₁) =
    liftAssoc L c x y z  , liftAssoc L c₁ x₁ y₁ z₁
  liftAssoc (B r r₁) L (Col x x₁) (Col y y₁) (Col z z₁) =
    liftAssoc r L x y z , liftAssoc r₁ L x₁ y₁ z₁
  liftAssoc (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    (liftAssoc r c x y z) , (liftAssoc r c₁ x₁ y₁ z₁) ,
    (liftAssoc r₁ c x₂ y₂ z₂) , (liftAssoc r₁ c₁ x₃ y₃ z₃)

  <+S> : (r c : Shape) {x y u v : M s r c} →
    x ≃S' y → u ≃S' v → (x +S u) ≃S' (y +S v)
  <+S> L L {One x} {One x₁} {One x₂} {One x₃} p q = p <+> q
  <+S> L (B c c₁) {Row x x₁} {Row y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <+S> L c p q , <+S> L c₁ p₁ q₁
  <+S> (B r r₁) L {Col x x₁} {Col y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    <+S> r L p q , <+S> r₁ L p₁ q₁
  <+S> (B r r₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃}
    (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> r c p q , <+S> r c₁ p₁ q₁ ,
    <+S> r₁ c p₂ q₂ , <+S> r₁ c₁ p₃ q₃

  isSemgroupS =
    record
      { isEquivalence = isEquivS
      ; assoc = liftAssoc shape shape
      ; ∙-cong = <+S> shape shape }

  identSˡ : (r c : Shape) (x : M s r c) →
     0S r c +S x ≃S' x
  identSˡ L L (One x) = identityˡₛ x
  identSˡ L (B c c₁) (Row x x₁) = identSˡ L c x , identSˡ L c₁ x₁
  identSˡ (B r r₁) L (Col x x₁) = identSˡ r L x , identSˡ r₁ L x₁
  identSˡ (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    identSˡ r c x , identSˡ r c₁ x₁ ,
    identSˡ r₁ c x₂ , identSˡ r₁ c₁ x₃

  liftComm : (r c : Shape) → (x y : M s r c) →
    (x +S y) ≃S' (y +S x)
  liftComm L L (One x) (One x₁) = commₛ x x₁
  liftComm L (B c c₁) (Row x x₁) (Row y y₁) = (liftComm L c x y) , (liftComm L c₁ x₁ y₁)
  liftComm (B r r₁) L (Col x x₁) (Col y y₁) = (liftComm r L x y) , (liftComm r₁ L x₁ y₁)
  liftComm (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) =
    liftComm r c x y , liftComm r c₁ x₁ y₁ ,
    liftComm r₁ c x₂ y₂ , liftComm r₁ c₁ x₃ y₃

  isCommMonS =
    record
      { isSemigroup = isSemgroupS
      ; identityˡ = identSˡ shape shape
      ; comm = liftComm shape shape }

  setoidS : (r c : Shape) → Setoid _ _
  setoidS r c =
    record
      { Carrier = M s r c
      ; _≈_ = ≃S r c
      ; isEquivalence =
        record
          { refl = reflS r c ; sym = symS r c ; trans = transS r c } }

  zeroSˡ : (a b c : Shape) (x : M s b c) →
    (0S a b ∙S x) ≃S' 0S a c
  zeroSˡ L L L (One x) = zeroˡ x
  zeroSˡ L L (B c c₁) (Row x x₁) = (zeroSˡ L L c x) , (zeroSˡ L L c₁ x₁)
  zeroSˡ L (B b b₁) L (Col x x₁) =
    let
      open EqReasoning (setoidS L L)
      ih = zeroSˡ L b L x
      ih₁ = zeroSˡ L b₁ L x₁
    in begin
      (Row (0S L b) (0S L b₁) ∙S (Col x x₁))
    ≡⟨ refl-≡ ⟩
      (0S L b) ∙S x +S (0S L b₁) ∙S x₁
    ≈⟨ <+S> L L {0S L b ∙S x} {0S L L} {0S L b₁ ∙S x₁} {0S L L} ih ih₁ ⟩
      0S L L +S 0S L L
    ≈⟨ identSˡ L L (0S L L) ⟩
      0S L L
    ∎
  zeroSˡ L (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning (setoidS L c)
      ih = zeroSˡ L b c x
      ih₁ = zeroSˡ L b₁ c x₂
     in begin
       0S L b ∙S x +S 0S L b₁ ∙S x₂
     ≈⟨ <+S> L c ih ih₁ ⟩
       0S L c +S 0S L c
     ≈⟨ identSˡ L c (0S L c) ⟩
       0S L c
     ∎) ,
    (let
      open EqReasoning (setoidS L c₁)
      ih = zeroSˡ L b c₁ x₁
      ih₁ = zeroSˡ L b₁ c₁ x₃
    in begin
      0S L b ∙S x₁ +S 0S L b₁ ∙S x₃
    ≈⟨ <+S> L c₁ ih ih₁ ⟩
      0S L c₁ +S 0S L c₁
    ≈⟨ identSˡ L c₁ _ ⟩
      0S L c₁
    ∎)
  zeroSˡ (B a a₁) L L (One x) = zeroSˡ a L L (One x) , zeroSˡ a₁ L L (One x)
  zeroSˡ (B a a₁) L (B c c₁) (Row x x₁) =
    zeroSˡ a L c x , zeroSˡ a L c₁ x₁ ,
    zeroSˡ a₁ L c x , zeroSˡ a₁ L c₁ x₁
  zeroSˡ (B a a₁) (B b b₁) L (Col x x₁) =
    (let
      open EqReasoning (setoidS a L)
      ih = zeroSˡ a b L x
      ih₁ = zeroSˡ a b₁ L x₁
    in begin
      0S a b ∙S x +S 0S a b₁ ∙S x₁
    ≈⟨ <+S> a L ih ih₁ ⟩
      0S a L +S 0S a L
    ≈⟨ identSˡ a L _ ⟩
      0S a L
    ∎) ,
    (let
      open EqReasoning (setoidS a₁ L)
      ih = zeroSˡ a₁ b L x
      ih₁ = zeroSˡ a₁ b₁ L x₁
    in begin
      0S a₁ b ∙S x +S 0S a₁ b₁ ∙S x₁
    ≈⟨ <+S> a₁ L ih ih₁ ⟩
      0S a₁ L +S 0S a₁ L
    ≈⟨ identSˡ a₁ L _ ⟩
      0S a₁ L
    ∎)
  zeroSˡ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning (setoidS a c)
      ih = zeroSˡ a b c x
      ih₁ = zeroSˡ a b₁ c x₂
    in begin
      0S a b ∙S x +S 0S a b₁ ∙S x₂
    ≈⟨ <+S> a c ih ih₁ ⟩
      0S a c +S 0S a c
    ≈⟨ identSˡ a c _ ⟩
      0S a c
    ∎) ,
    (let
      open EqReasoning (setoidS a c₁)
      ih = zeroSˡ a b c₁ x₁
      ih₁ = zeroSˡ a b₁ c₁ x₃
    in begin
      0S a b ∙S x₁ +S 0S a b₁ ∙S x₃
    ≈⟨ <+S> a c₁ ih ih₁ ⟩
      0S a c₁ +S 0S a c₁
    ≈⟨ identSˡ a c₁ _ ⟩
      0S a c₁
    ∎) ,
    (let
      open EqReasoning (setoidS a₁ c)
      ih = zeroSˡ a₁ b c x
      ih₁ = zeroSˡ a₁ b₁ c x₂
    in begin
      0S a₁ b ∙S x +S 0S a₁ b₁ ∙S x₂
    ≈⟨ <+S> a₁ c ih ih₁ ⟩
      0S a₁ c +S 0S a₁ c
    ≈⟨ identSˡ a₁ c _ ⟩
      0S a₁ c
    ∎) ,
    (let
      open EqReasoning (setoidS a₁ c₁)
      ih = zeroSˡ a₁ b c₁ x₁
      ih₁ = zeroSˡ a₁ b₁ c₁ x₃
    in begin
      0S a₁ b ∙S x₁ +S 0S a₁ b₁ ∙S x₃
    ≈⟨ <+S> a₁ c₁ ih ih₁ ⟩
      0S a₁ c₁ +S 0S a₁ c₁
    ≈⟨ identSˡ a₁ c₁ _ ⟩
      0S a₁ c₁
    ∎)

  zeroSʳ : (a b c : Shape) (x : M s a b) →
    (x ∙S 0S b c) ≃S' 0S a c
  zeroSʳ L L L (One x) = zeroʳ x
  zeroSʳ L L (B c c₁) (One x) =
    (zeroSʳ L L c (One x)) , (zeroSʳ L L c₁ (One x))
  zeroSʳ L (B b b₁) L (Row x x₁) =
    let
      open EqReasoning (setoidS L L)
      ih = zeroSʳ L b L x
      ih₁ = zeroSʳ L b₁ L x₁
    in begin
      Row x x₁ ∙S Col (0S b L) (0S b₁ L)
    ≡⟨ refl-≡ ⟩
      (x ∙S 0S b L) +S (x₁ ∙S 0S b₁ L)
    ≈⟨ <+S> L L {x ∙S 0S b L} {0S L L} {x₁ ∙S 0S b₁ L} {0S L L} ih ih₁ ⟩
      0S L L +S 0S L L
    ≈⟨ identSˡ L L (0S L L) ⟩
      0S L L
    ∎
  zeroSʳ L (B b b₁) (B c c₁) (Row x x₁) =
    (let
      open EqReasoning (setoidS L c)
      ih = zeroSʳ L b c x
      ih₁ = zeroSʳ L b₁ c x₁
    in begin
      x ∙S 0S b c +S x₁ ∙S 0S b₁ c
    ≈⟨ <+S> L c ih ih₁ ⟩
      0S L c +S 0S L c
    ≈⟨ identSˡ L c (0S L c) ⟩
      0S L c
    ∎) ,
    (let
      open EqReasoning (setoidS L c₁)
      ih = zeroSʳ L b c₁ x
      ih₁ = zeroSʳ L b₁ c₁ x₁
    in begin
      x ∙S 0S b c₁ +S x₁ ∙S 0S b₁ c₁
    ≈⟨ <+S> L c₁ ih ih₁ ⟩
      0S L c₁ +S 0S L c₁
    ≈⟨ identSˡ L c₁ (0S L c₁) ⟩
      0S L c₁
    ∎)
  zeroSʳ (B a a₁) L L (Col x x₁) = zeroSʳ a L L x , zeroSʳ a₁ L L x₁
  zeroSʳ (B a a₁) L (B c c₁) (Col x x₁) =
    zeroSʳ a L c x ,
    zeroSʳ a L c₁ x ,
    zeroSʳ a₁ L c x₁ ,
    zeroSʳ a₁ L c₁ x₁
  zeroSʳ (B a a₁) (B b b₁) L (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning (setoidS _ _)
      ih = zeroSʳ a b L x
      ih₁ = zeroSʳ a b₁ L x₁
    in begin
      x ∙S 0S b L +S x₁ ∙S 0S b₁ L
    ≈⟨ <+S> a L ih ih₁ ⟩
      0S a L +S 0S a L
    ≈⟨ identSˡ a L (0S _ _) ⟩
      0S a L
    ∎) ,
    (let
      open EqReasoning (setoidS _ _)
      ih = zeroSʳ a₁ b L x₂
      ih₁ = zeroSʳ a₁ b₁ L x₃
    in begin
      x₂ ∙S 0S b L +S x₃ ∙S 0S b₁ L
    ≈⟨ <+S> a₁ L ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ L (0S _ _) ⟩
      0S a₁ L
    ∎)
  zeroSʳ (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (let
      open EqReasoning (setoidS _ _)
      ih = zeroSʳ a b c x
      ih₁ = zeroSʳ a b₁ c x₁
    in begin
      x ∙S 0S b c +S x₁ ∙S 0S b₁ c
    ≈⟨ <+S> a c ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a c (0S _ _) ⟩
      0S _ _
    ∎) ,
    (let
      -- open EqReasoning (setoidS _ _)
      ih = zeroSʳ a b c₁ x
      ih₁ = zeroSʳ a b₁ c₁ x₁
    in transS a c₁ (<+S> a c₁ ih ih₁) (identSˡ a c₁ (0S _ _))
    -- begin
    --   x ∙S 0S b c₁ +S x₁ ∙S 0S b₁ c₁
    -- ≈⟨ <+S> a c₁ ih ih₁ ⟩
    --   0S _ _ +S 0S _ _
    -- ≈⟨ identSˡ a c₁ (0S _ _) ⟩
    --   0S a c₁
    -- ∎
    ) ,
    (let
      open EqReasoning (setoidS _ _)
      ih = zeroSʳ a₁ b c x₂
      ih₁ = zeroSʳ a₁ b₁ c x₃
    in begin
      x₂ ∙S 0S b c +S x₃ ∙S 0S b₁ c
    ≈⟨ <+S> a₁ c ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ c (0S _ _) ⟩
      0S a₁ c
    ∎) ,
    (let
      open EqReasoning (setoidS _ _)
      ih = zeroSʳ a₁ b c₁ x₂
      ih₁ = zeroSʳ a₁ b₁ c₁ x₃
    in begin
      x₂ ∙S 0S b c₁ +S x₃ ∙S 0S b₁ c₁
    ≈⟨ <+S> a₁ c₁ ih ih₁ ⟩
      0S _ _ +S 0S _ _
    ≈⟨ identSˡ a₁ c₁ (0S _ _) ⟩
      0S a₁ c₁
    ∎)

  <∙S> : (a b c : Shape) {x y : M s a b} {u v : M s b c} →
    x ≃S' y → u ≃S' v → (x ∙S u) ≃S' (y ∙S v)
  <∙S> L L L {One x} {One x₁} {One x₂} {One x₃} p q = p <∙> q
  <∙S> L L (B c c₁) {One x} {One x₁} {Row u u₁} {Row v v₁} p (q , q₁) =
    (<∙S> L L c {One x} {One x₁} {u} {v} p q) ,
    <∙S> L L c₁ {One x} {One x₁} {u₁} {v₁} p q₁
  <∙S> L (B b b₁) L {Row x x₁} {Row y y₁} {Col u u₁} {Col v v₁} (p , p₁) (q , q₁) =
    -- Row x x₁ ∙S Col u u₁ ≃S' Row y y₁ ∙S Col v v₁
    let
      open EqReasoning (setoidS _ _)
      ih = <∙S> _ _ _ {x} {y} {u} {v} p q
      ih₁ = <∙S> _ _ _ {x₁} {y₁} {u₁} {v₁} p₁ q₁
    in begin
      Row x x₁ ∙S Col u u₁
    ≡⟨ refl-≡ ⟩
      x ∙S u +S x₁ ∙S u₁
    ≈⟨ <+S> L L {x ∙S u} {y ∙S v} {x₁ ∙S u₁} {y₁ ∙S v₁} ih ih₁ ⟩
      y ∙S v +S y₁ ∙S v₁
    ∎
  <∙S> L (B b b₁) (B c c₁) {Row x x₁} {Row y y₁} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁) (q , q₁ , q₂ , q₃) =
    (let
      ih = <∙S> L b c p q
      ih₁ = <∙S> L b₁ c p₁ q₂
    in <+S> L c ih ih₁) ,
    <+S> L c₁ (<∙S> L b c₁ p q₁) (<∙S> L b₁ c₁ p₁ q₃)
  <∙S> (B a a₁) L L {Col x x₁} {Col y y₁} {One x₂} {One x₃} (p , p₁) q =
    <∙S> a L L p q ,
    <∙S> a₁ L L p₁ q
  <∙S> (B a a₁) L (B c c₁) {Col x x₁} {Col y y₁} {Row u u₁} {Row v v₁} (p , p₁) (q , q₁) =
    <∙S> a L c p q ,
    <∙S> a L c₁ p q₁  ,
    <∙S> a₁ L c p₁ q ,
    <∙S> a₁ L c₁ p₁ q₁
  <∙S> (B a a₁) (B b b₁) L {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Col u u₁} {Col v v₁} (p , p₁ , p₂ , p₃) (q , q₁) =
    <+S> a L (<∙S> a b L p q) (<∙S> a b₁ L p₁ q₁) ,
    <+S> a₁ L (<∙S> a₁ b L p₂ q) (<∙S> a₁ b₁ L p₃ q₁ )
  <∙S> (B a a₁) (B b b₁) (B c c₁) {Q x x₁ x₂ x₃} {Q y y₁ y₂ y₃} {Q u u₁ u₂ u₃} {Q v v₁ v₂ v₃} (p , p₁ , p₂ , p₃) (q , q₁ , q₂ , q₃) =
    <+S> a c (<∙S> a b c p q) (<∙S> a b₁ c p₁ q₂) ,
    <+S> a c₁ (<∙S> a b c₁ p q₁) (<∙S> a b₁ c₁ p₁ q₃) ,
    <+S> a₁ c (<∙S> a₁ b c p₂ q) (<∙S> a₁ b₁ c p₃ q₂) ,
    <+S> a₁ c₁ (<∙S> a₁ b c₁ p₂ q₁) (<∙S> a₁ b₁ c₁ p₃ q₃)

  idemS : (r c : Shape) (x : M s r c) → x +S x ≃S' x
  idemS L L (One x) = idem x
  idemS L (B c c₁) (Row x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) L (Col x x₁) = (idemS _ _ x) , (idemS _ _ x₁)
  idemS (B r r₁) (B c c₁) (Q x x₁ x₂ x₃) =
    (idemS _ _ x) , (idemS _ _ x₁ , (idemS _ _ x₂  , idemS _ _ x₃))

  distlS : (a b c : Shape) (x : M s a b) (y z : M s b c) →
    (x ∙S (y +S z)) ≃S' ((x ∙S y) +S (x ∙S z))
  distlS L L L (One x) (One y) (One z) = distl x y z
  distlS L L (B c c₁) (One x) (Row y y₁) (Row z z₁) =
    distlS L L c (One x) y z ,
    distlS L L c₁ (One x) y₁ z₁
  distlS L (B b b₁) L (Row x x₁) (Col y y₁) (Col z z₁) =
    {!!}
  distlS L (B b b₁) (B c c₁) (Row x x₁) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) =
    {!!} ,
    {!!}
  distlS (B a a₁) L L (Col x x₁) (One x₂) (One x₃) = {!!}
  distlS (B a a₁) L (B c c₁) (Col x x₁) (Row y y₁) (Row z z₁) = {!!}
  distlS (B a a₁) (B b b₁) L (Q x x₁ x₂ x₃) (Col y y₁) (Col z z₁) = {!!}
  distlS (B a a₁) (B b b₁) (B c c₁) (Q x x₁ x₂ x₃) (Q y y₁ y₂ y₃) (Q z z₁ z₂ z₃) = {!!}

  SNR : SemiNearRing
  SNR =
    record
      { s = S
      ; _≃ₛ_ = ≃S shape shape
      ; 0ₛ = 0S shape shape
      ; _+ₛ_ = _+S_
      ; _∙ₛ_ = _∙S_
      ; isCommMon = isCommMonS
      ; zeroˡ = zeroSˡ shape shape shape
      ; zeroʳ = zeroSʳ shape shape shape
      ; _<∙>_ = <∙S> shape shape shape
      ; idem = idemS shape shape
      ; distl = {!!}
      ; distr = {!!}
      }