Added a non-required totality hypothesis.

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- The main properties proved of the McCarthy 91 function (called
-- f₉₁) are

-- 1. The function always terminates.
-- 2. For all n, n < f₉₁ n + 11.
-- 3. For all n > 100, then f₉₁ n = n - 10.
-- 4. For all n <= 100, then f₉₁ n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesATP
  using ( x>y→x≤y→⊥ )
open import FOTC.Data.Nat.Inequalities.PropertiesATP
  using ( x>y∨x≯y
        ; x≯y→x≤y
        ; x≯Sy→x≯y∨x≡Sy
        ; x+k<y+k→x<y
        ; <-trans
        )
open import FOTC.Data.Nat.PropertiesATP
  using ( ∸-N
        ; +-N
        )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
  using ( x<x+11 )
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
  using ( 10-N
        ; 11-N
        ; 89-N
        ; 90-N
        ; 91-N
        ; 92-N
        ; 93-N
        ; 94-N
        ; 95-N
        ; 96-N
        ; 97-N
        ; 98-N
        ; 99-N
        ; 100-N
        )
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

------------------------------------------------------------------------------
-- For all n > 100, then f₉₁ n = n - 10.
--
-- N.B. (21 November 2013). The hypothesis N n is not necessary.
postulate f₉₁-x>100 : ∀ n → N n → n > 100' → f₉₁ n ≡ n ∸ 10'
{-# ATP prove f₉₁-x>100 #-}

-- For all n <= 100, then f₉₁ n = 91.
f₉₁-x≯100 : ∀ {n} → N n → n ≯ 100' → f₉₁ n ≡ 91'
f₉₁-x≯100 = ◁-wfind A h
  where
  A : D → Set
  A d = d ≯ 100' → f₉₁ d ≡ 91'

  h : ∀ {m} → N m → (∀ {k} → N k → k ◁ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = λ m≯100 →
                     ⊥-elim (x>y→x≤y→⊥ Nm 100-N m>100 (x≯y→x≤y Nm 100-N m≯100))
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = λ _ → f₉₁-x≡y f₉₁-100 m≡100
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = λ _ → f₉₁-x≡y f₉₁-99 m≡99
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = λ _ → f₉₁-x≡y f₉₁-98 m≡98
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = λ _ → f₉₁-x≡y f₉₁-97 m≡97
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = λ _ → f₉₁-x≡y f₉₁-96 m≡96
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = λ _ → f₉₁-x≡y f₉₁-95 m≡95
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = λ _ → f₉₁-x≡y f₉₁-94 m≡94
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = λ _ → f₉₁-x≡y f₉₁-93 m≡93
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = λ _ → f₉₁-x≡y f₉₁-92 m≡92
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = λ _ → f₉₁-x≡y f₉₁-91 m≡91
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = λ _ → f₉₁-x≡y f₉₁-90 m≡90
  ... | inj₁ m≯89 = λ _ → f₉₁-m≯89
    where
    m≤89 : m ≤ 89'
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    f₉₁-m+11 : m + 11' ≯ 100' → f₉₁ (m + 11') ≡ 91'
    f₉₁-m+11 = f (x+11-N Nm) (<→◁ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

    f₉₁-m≯89 : f₉₁ m ≡ 91'
    f₉₁-m≯89 = f₉₁-x≯100-helper m 91' m≯100
                                (f₉₁-m+11 (x≤89→x+11≯100 Nm m≤89))
                                f₉₁-91
-- The function always terminates.
f₉₁-N : ∀ {n} → N n → N (f₉₁ n)
f₉₁-N {n} Nn with x>y∨x≯y Nn 100-N
... | inj₁ n>100 = subst N (sym (f₉₁-x>100 n Nn n>100)) (∸-N Nn 10-N)
... | inj₂ n≯100 = subst N (sym (f₉₁-x≯100 Nn n≯100)) 91-N

-- For all n, n < f₉₁ n + 11.
f₉₁-ineq : ∀ {n} → N n → n < f₉₁ n + 11'
f₉₁-ineq = ◁-wfind A h
  where
  A : D → Set
  A d = d < f₉₁ d + 11'

  h : ∀ {m} → N m → (∀ {k} → N k → k ◁ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = x>100→x<f₉₁-x+11 Nm m>100
  ... | inj₂ m≯100 =
    let f₉₁-m+11-N : N (f₉₁ (m + 11'))
        f₉₁-m+11-N = f₉₁-N (+-N Nm 11-N)

        h₁ : A (m + 11')
        h₁ = f (x+11-N Nm) (<→◁ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

        m<f₉₁m+11 : m < f₉₁ (m + 11')
        m<f₉₁m+11 = x+k<y+k→x<y Nm f₉₁-m+11-N 11-N h₁

        h₂ : A (f₉₁ (m + 11'))
        h₂ = f f₉₁-m+11-N (<→◁ f₉₁-m+11-N Nm m≯100 m<f₉₁m+11)

    in (<-trans Nm f₉₁-m+11-N (x+11-N (f₉₁-N Nm))
                m<f₉₁m+11
                (f₉₁x+11<f₉₁x+11 m m≯100 h₂))

------------------------------------------------------------------------------
-- Main properties of the McCarthy 91 function
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- The main properties proved of the McCarthy 91 function (called
-- f₉₁) are

-- 1. The function always terminates.
-- 2. For all n, n < f₉₁ n + 11.
-- 3. For all n > 100, then f₉₁ n = n - 10.
-- 4. For all n <= 100, then f₉₁ n = 91.

-- N.B This module does not contain combined proofs, but it imports
-- modules which contain combined proofs.

module FOTC.Program.McCarthy91.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesATP
  using ( x>y→x≤y→⊥ )
open import FOTC.Data.Nat.Inequalities.PropertiesATP
  using ( x>y∨x≯y
        ; x≯y→x≤y
        ; x≯Sy→x≯y∨x≡Sy
        ; x+k<y+k→x<y
        ; <-trans
        )
open import FOTC.Data.Nat.PropertiesATP
  using ( ∸-N
        ; +-N
        )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
  using ( x<x+11 )
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP
  using ( 10-N
        ; 11-N
        ; 89-N
        ; 90-N
        ; 91-N
        ; 92-N
        ; 93-N
        ; 94-N
        ; 95-N
        ; 96-N
        ; 97-N
        ; 98-N
        ; 99-N
        ; 100-N
        )
open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.AuxiliaryPropertiesATP
open import FOTC.Program.McCarthy91.McCarthy91
open import FOTC.Program.McCarthy91.WF-Relation
open import FOTC.Program.McCarthy91.WF-Relation.LT2WF-RelationATP
open import FOTC.Program.McCarthy91.WF-Relation.Induction.Acc.WF-ATP

------------------------------------------------------------------------------
-- For all n > 100, then f₉₁ n = n - 10.
postulate f₉₁-x>100 : ∀ n → n > 100' → f₉₁ n ≡ n ∸ 10'
{-# ATP prove f₉₁-x>100 #-}

-- For all n <= 100, then f₉₁ n = 91.
f₉₁-x≯100 : ∀ {n} → N n → n ≯ 100' → f₉₁ n ≡ 91'
f₉₁-x≯100 = ◁-wfind A h
  where
  A : D → Set
  A d = d ≯ 100' → f₉₁ d ≡ 91'

  h : ∀ {m} → N m → (∀ {k} → N k → k ◁ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = λ m≯100 →
                     ⊥-elim (x>y→x≤y→⊥ Nm 100-N m>100 (x≯y→x≤y Nm 100-N m≯100))
  ... | inj₂ m≯100 with x≯Sy→x≯y∨x≡Sy Nm 99-N m≯100
  ... | inj₂ m≡100 = λ _ → f₉₁-x≡y f₉₁-100 m≡100
  ... | inj₁ m≯99 with x≯Sy→x≯y∨x≡Sy Nm 98-N m≯99
  ... | inj₂ m≡99 = λ _ → f₉₁-x≡y f₉₁-99 m≡99
  ... | inj₁ m≯98 with x≯Sy→x≯y∨x≡Sy Nm 97-N m≯98
  ... | inj₂ m≡98 = λ _ → f₉₁-x≡y f₉₁-98 m≡98
  ... | inj₁ m≯97 with x≯Sy→x≯y∨x≡Sy Nm 96-N m≯97
  ... | inj₂ m≡97 = λ _ → f₉₁-x≡y f₉₁-97 m≡97
  ... | inj₁ m≯96 with x≯Sy→x≯y∨x≡Sy Nm 95-N m≯96
  ... | inj₂ m≡96 = λ _ → f₉₁-x≡y f₉₁-96 m≡96
  ... | inj₁ m≯95 with x≯Sy→x≯y∨x≡Sy Nm 94-N m≯95
  ... | inj₂ m≡95 = λ _ → f₉₁-x≡y f₉₁-95 m≡95
  ... | inj₁ m≯94 with x≯Sy→x≯y∨x≡Sy Nm 93-N m≯94
  ... | inj₂ m≡94 = λ _ → f₉₁-x≡y f₉₁-94 m≡94
  ... | inj₁ m≯93 with x≯Sy→x≯y∨x≡Sy Nm 92-N m≯93
  ... | inj₂ m≡93 = λ _ → f₉₁-x≡y f₉₁-93 m≡93
  ... | inj₁ m≯92 with x≯Sy→x≯y∨x≡Sy Nm 91-N m≯92
  ... | inj₂ m≡92 = λ _ → f₉₁-x≡y f₉₁-92 m≡92
  ... | inj₁ m≯91 with x≯Sy→x≯y∨x≡Sy Nm 90-N m≯91
  ... | inj₂ m≡91 = λ _ → f₉₁-x≡y f₉₁-91 m≡91
  ... | inj₁ m≯90 with x≯Sy→x≯y∨x≡Sy Nm 89-N m≯90
  ... | inj₂ m≡90 = λ _ → f₉₁-x≡y f₉₁-90 m≡90
  ... | inj₁ m≯89 = λ _ → f₉₁-m≯89
    where
    m≤89 : m ≤ 89'
    m≤89 = x≯y→x≤y Nm 89-N m≯89

    f₉₁-m+11 : m + 11' ≯ 100' → f₉₁ (m + 11') ≡ 91'
    f₉₁-m+11 = f (x+11-N Nm) (<→◁ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

    f₉₁-m≯89 : f₉₁ m ≡ 91'
    f₉₁-m≯89 = f₉₁-x≯100-helper m 91' m≯100
                                (f₉₁-m+11 (x≤89→x+11≯100 Nm m≤89))
                                f₉₁-91
-- The function always terminates.
f₉₁-N : ∀ {n} → N n → N (f₉₁ n)
f₉₁-N {n} Nn with x>y∨x≯y Nn 100-N
... | inj₁ n>100 = subst N (sym (f₉₁-x>100 n n>100)) (∸-N Nn 10-N)
... | inj₂ n≯100 = subst N (sym (f₉₁-x≯100 Nn n≯100)) 91-N

-- For all n, n < f₉₁ n + 11.
f₉₁-ineq : ∀ {n} → N n → n < f₉₁ n + 11'
f₉₁-ineq = ◁-wfind A h
  where
  A : D → Set
  A d = d < f₉₁ d + 11'

  h : ∀ {m} → N m → (∀ {k} → N k → k ◁ m → A k) → A m
  h {m} Nm f with x>y∨x≯y Nm 100-N
  ... | inj₁ m>100 = x>100→x<f₉₁-x+11 Nm m>100
  ... | inj₂ m≯100 =
    let f₉₁-m+11-N : N (f₉₁ (m + 11'))
        f₉₁-m+11-N = f₉₁-N (+-N Nm 11-N)

        h₁ : A (m + 11')
        h₁ = f (x+11-N Nm) (<→◁ (x+11-N Nm) Nm m≯100 (x<x+11 Nm))

        m<f₉₁m+11 : m < f₉₁ (m + 11')
        m<f₉₁m+11 = x+k<y+k→x<y Nm f₉₁-m+11-N 11-N h₁

        h₂ : A (f₉₁ (m + 11'))
        h₂ = f f₉₁-m+11-N (<→◁ f₉₁-m+11-N Nm m≯100 m<f₉₁m+11)

    in (<-trans Nm f₉₁-m+11-N (x+11-N (f₉₁-N Nm))
                m<f₉₁m+11
                (f₉₁x+11<f₉₁x+11 m m≯100 h₂))


add ×≃ to Identities

add ×≃ to Identities


Updated draft on setoids.

Updated draft on setoids.

Ignore-this: 5f576ada50b5215ca1047d8405d00d77

darcs-hash:20120323173333-3bd4e-10f837bce125614a6f86ac0911b2c66f81ff3c1b.gz

------------------------------------------------------------------------------
-- Using setoids for formalizing the FOTC
------------------------------------------------------------------------------

-- Tested with the development version of Agda on 23 March 2012.

{-
From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For = : The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.
-}

module FOTC where

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

module PeterEquality where

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  infix 7 _≡_

  data _≡_ : D → D → Set where
    refl  : ∀ x →                                       x ≡ x
    sym   : ∀ {x y} → x ≡ y →                           y ≡ x
    trans : ∀ {x y z} → x ≡ y → y ≡ z →                 x ≡ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≡ x
    Sax   : ∀ x y z →                      S · x · y · z  ≡ x · z · (y · z)

  -- It seems we cannot define the identity elimination using the setoid
  -- equality.
  --
  -- subst : ∀ {x y} (A : D → Set) → x ≡ y → A x → A y

module PeterD where

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.

  data D : Set where
    zero succ true false : D
    _·_             : D → D → D
    loop            : D

  data _≡_ (x : D) : D → Set where
    refl : x ≡ x

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A refl Ax = Ax

  data N : D → Set where
    zN :               N zero
    sN : ∀ {n} → N n → N (succ · n)

  -- 2012-03-23: Why the inductive structure makes 0 + 0 different
  -- from 0? How to define _+_ ?

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

module LeibnizEquality where

  -- We add 3 to the fixities of the standard library.
  infixl 9 _·_  -- The symbol is '\cdot'.

  data D : Set where
    K S : D
    _·_ : D → D → D

  -- (Barthe et al. 2003, p. 262) use the Leibniz equality when
  -- they talk about setoids.

  -- • Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
  --   type theory. Journal of Functional Programming, 13(2):261–293,
  --   2003

  -- Using the Leibniz equality
  -- (Adapted from Agda/examples/lib/Logic/Leibniz.agda)

  infix 7 _≡_

  _≡_ : D → D → Set₁
  x ≡ y = (A : D → Set) → A x → A y

  -- we can prove the setoids properties

  refl : ∀ x → x ≡ x
  refl x A Ax = Ax

  sym : ∀ {x y} → x ≡ y → y ≡ x
  sym {x} x≡y A Ay = x≡y (λ z → A z → A x) (λ Ax → Ax) Ay

  trans : ∀ x y z → x ≡ y → y ≡ z → x ≡ z
  trans x y z x≡y y≡z A Ax = y≡z A (x≡y A Ax)

  -- and the identity elimination

  subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
  subst A x≡y = x≡y A

  -- but it seems we cannot prove the congruency

  -- cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≡ x₂ → y₁ ≡ y₂ → x₁ · y₁ ≡ x₂ · y₂
  -- cong x₁≡x₂ y₁≡y₂ A Ax₁y₁ = {!!}

------------------------------------------------------------------------------
-- Using setoids to formalize the FOTC
------------------------------------------------------------------------------

-- Tested with the development version of Agda on 07 February 2012.

{-
From Peter emails:

At that time I was considering an inductive data type D and an
inductively defined equality on D. But I think what we are doing now
is better.

For = : The reason is that with the propositional identity we have
identity elimination which lets us replace equals by equals. We cannot
do that in general if we have setoid equality.

For D: the reason why I prefer to postulate D is that we have no use
for the inductive structure of D, and this inductive structure would
make e g 0 + 0 different from 0. So in that case we need setoid
equality.
-}

module FOTC where

-- We add 3 to the fixities of the standard library.
infixl 9 _·_  -- The symbol is '\cdot'.

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

data D : Set where
  K S : D
  _·_ : D → D → D

module PeterEquality where

  -- From Peter's slides
  -- http://www.cse.chalmers.se/~peterd/slides/Amagasaki.pdf

  infix 7 _≐_

  data _≐_ : D → D → Set where
    refl  : ∀ x →                                       x ≐ x
    sym   : ∀ {x y} → x ≐ y →                           y ≐ x
    trans : ∀ {x y z} → x ≐ y → y ≐ z →                 x ≐ z
    cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
    Kax   : ∀ x y →                            K · x · y  ≐ x
    Sax   : ∀ x y z →                      S · x · y · z  ≐ x · z · (y · z)

  -- It seems we cannot define the identity elimination using the setoid
  -- equality
  -- subst : ∀ {x y} (P : D → Set) → x ≐ y → P x → P y
  -- subst P x≐y Px = {!!}

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

module LeibnizEquality where

  -- Barthe et al. [*, p. 262] use the Leibniz equality when
  -- they talk about setoids.

  -- [*] Gilles Barthe, Venanzio Capretta, and Olivier Pons. Setoids in
  -- type theory. Journal of Functional Programming, 13(2):261–293, 2003

  -- Using the Leibniz equality
  -- (Adapted from Agda/examples/lib/Logic/Leibniz.agda)

  infix 7 _≐_

  _≐_ : D → D → Set₁
  x ≐ y = (P : D → Set) → P x → P y

  -- We can proof the setoids properties

  ≐-refl : ∀ x → x ≐ x
  ≐-refl x P Px = Px

  ≐-sym : ∀ {x y} → x ≐ y → y ≐ x
  ≐-sym {x} x≐y P Py = x≐y (λ z → P z → P x) (λ Px → Px) Py

  ≐-trans : ∀ x y z → x ≐ y → y ≐ z → x ≐ z
  ≐-trans x y z x≐y y≐z P Px = y≐z P (x≐y P Px)

  -- and the identity elimination

  ≐-subst : (P : D → Set) → ∀ {x y} → x ≐ y → P x → P y
  ≐-subst P x≐y = x≐y P

  -- but it seems we cannot prove the congruency

  -- ≐-cong  : ∀ {x₁ x₂ y₁ y₂} → x₁ ≐ x₂ → y₁ ≐ y₂ → x₁ · y₁ ≐ x₂ · y₂
  -- ≐-cong x₁≐x₂ y₁≐y₂ P Px₁y₁ = {!!}


Missing file added

Missing file added

-- 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

-- Lifting a SNR to a to a Square matrix of some shape
-- TODO: need to look at shape to make this one work?
Square : SemiNearRing → Shape → SemiNearRing
Square snr L = SNR
  where
  open SemiNearRing snr

  S = Sq s L

  _+S_ : S → S → S
  One x +S One x₁ = One (x +ₛ x₁)

  _∙S_ : S → S → S
  One x ∙S One x₁ = One (x ∙ₛ x₁)

  0S = One 0ₛ

  _≃S_ : S → S → Set
  One x ≃S One x₁ = x ≃ₛ x₁

  SNR : SemiNearRing
  SNR = record
          { s = S
          ; _≃ₛ_ = _≃S_
          ; 0ₛ = 0S
          ; _+ₛ_ = _+S_
          ; _∙ₛ_ = _∙S_
          ; isCommMon = {!!}
          ; zeroˡ = {!!}
          ; zeroʳ = {!!}
          ; _<∙>_ = {!!}
          }
Square snr (B shape shape₁) = {!!}
  -- where
  -- open SemiNearRing snr

  -- S = Sq s shape

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

  -- 0S = One 0ₛ

  -- -- _≃S_ : S → S → Set
  -- -- _≃S_ m n with shape
  -- -- ... | sh = ?

  -- SNR : SemiNearRing
  -- SNR =
  --   record
  --     { s = S
  --     ; _≃ₛ_ = {!!}
  --     ; 0ₛ = {!!}
  --     ; _+ₛ_ = {!!}
  --     ; _∙ₛ_ = {!!}
  --     ; isCommMon = {!!}
  --     ; zeroˡ = {!!}
  --     ; zeroʳ = {!!}
  --     ; _<∙>_ = {!!}
  --     }

-- 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
-- TODO: imported module missing?

-- Lifting a SNR to a to a Square matrix of some shape
-- TODO: need to look at shape to make this one work?
Square : SemiNearRing → Shape → SemiNearRing
Square snr L = SNR
  where
  open SemiNearRing snr

  S = Sq s L

  _+S_ : S → S → S
  One x +S One x₁ = One (x +ₛ x₁)

  _∙S_ : S → S → S
  One x ∙S One x₁ = One (x ∙ₛ x₁)

  0S = One 0ₛ

  _≃S_ : S → S → Set
  One x ≃S One x₁ = x ≃ₛ x₁

  SNR : SemiNearRing
  SNR = record
          { s = S
          ; _≃ₛ_ = _≃S_
          ; 0ₛ = 0S
          ; _+ₛ_ = _+S_
          ; _∙ₛ_ = _∙S_
          ; isCommMon = {!!}
          ; zeroˡ = {!!}
          ; zeroʳ = {!!}
          ; _<∙>_ = {!!}
          }
Square snr (B shape shape₁) = {!!}
  -- where
  -- open SemiNearRing snr

  -- S = Sq s shape

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

  -- 0S = One 0ₛ

  -- -- _≃S_ : S → S → Set
  -- -- _≃S_ m n with shape
  -- -- ... | sh = ?

  -- SNR : SemiNearRing
  -- SNR =
  --   record
  --     { s = S
  --     ; _≃ₛ_ = {!!}
  --     ; 0ₛ = {!!}
  --     ; _+ₛ_ = {!!}
  --     ; _∙ₛ_ = {!!}
  --     ; isCommMon = {!!}
  --     ; zeroˡ = {!!}
  --     ; zeroʳ = {!!}
  --     ; _<∙>_ = {!!}
  --     }


lift-+ forgot to add this one

lift-+ forgot to add this one

module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
import Algebra.FunctionProperties as FP
open L using (Lift; lower; lift)
open import Type

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_) renaming (_^_ to _**_)
open import Data.Maybe.NP
open import Data.Product renaming (map to map×)
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty

import Function as F
import Function.Equality as FE
open FE using (_⟨$⟩_)
open import Function.Related as FR
open import Function.Related.TypeIsomorphisms public
import Function.Inverse as Inv
open Inv using (_↔_; _∘_; sym; id; module Inverse)
open import Relation.Binary
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (→-to-⟶)

Inv-isEquivalence : IsEquivalence (Inv.Inverse {f₁ = L.zero} {f₂ = L.zero})
Inv-isEquivalence = record
   { refl = Inv.id
   ; sym = Inv.sym
   ; trans = F.flip Inv._∘_ }

SEToid : Set _
SEToid = Setoid L.zero L.zero

SEToid₁ : Setoid _ _
SEToid₁ = record
  { Carrier = Setoid L.zero L.zero
  ; _≈_ = Inv.Inverse
  ; isEquivalence = Inv-isEquivalence }

⊎-ICommutativeMonoid : CommutativeMonoid _ _
⊎-ICommutativeMonoid = record {
                         Carrier = SEToid ;
                         _≈_ = Inv.Inverse;
                         _∙_ = _⊎-setoid_;
                         ε = ≡.setoid ⊥;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv-isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _⊎-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊥) _⊎-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = [ (λ ()) , F.id ]
      ; cong  = cong-to
      }
    ; from = record
      { _⟨$⟩_ = inj₂
      ; cong = ₂∼₂
      }
    ; inverse-of = record
      { left-inverse-of = [ (λ ()) , (λ x → ₂∼₂ refl) ]
      ; right-inverse-of = λ x → refl
      }
    } where open Setoid A
            cong-to : Setoid._≈_ (≡.setoid ⊥ ⊎-setoid A) =[ _ ]⇒ _≈_
            cong-to (₁∼₂ ())
            cong-to (₁∼₁ x∼₁y) rewrite x∼₁y = refl
            cong-to (₂∼₂ x∼₂y) = x∼₂y

  assoc : Associative _⊎-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = [ [ inj₁ , inj₂ F.∘ inj₁ ] , inj₂ F.∘ inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = [ inj₁ F.∘ inj₁ , [ inj₁ F.∘ inj₂ , inj₂ ] ]
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of = [ [ (λ _ → ₁∼₁ (₁∼₁ (refl A))) , (λ _ → ₁∼₁ (₂∼₂ (refl B)) ) ] , (λ _ → ₂∼₂ (refl C)) ]
      ; right-inverse-of = [ (λ _ → ₁∼₁ (refl A)) , [ (λ _ → ₂∼₂ (₁∼₁ (refl B))) , (λ _ → ₂∼₂ (₂∼₂ (refl C))) ] ]
      }
    } where
      open Setoid
      cong-to : _≈_ ((A ⊎-setoid B) ⊎-setoid C) =[ _ ]⇒ _≈_ (A ⊎-setoid (B ⊎-setoid C))
      cong-to (₁∼₂ ())
      cong-to (₁∼₁ (₁∼₂ ()))
      cong-to (₁∼₁ (₁∼₁ x∼₁y)) = ₁∼₁ x∼₁y
      cong-to (₁∼₁ (₂∼₂ x∼₂y)) = ₂∼₂ (₁∼₁ x∼₂y)
      cong-to (₂∼₂ x∼₂y) = ₂∼₂ (₂∼₂ x∼₂y)

      cong-from : _≈_ (A ⊎-setoid (B ⊎-setoid C)) =[ _ ]⇒ _≈_ ((A ⊎-setoid B) ⊎-setoid C)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ x∼₁y) = ₁∼₁ (₁∼₁ x∼₁y)
      cong-from (₂∼₂ (₁∼₂ ()))
      cong-from (₂∼₂ (₁∼₁ x∼₁y)) = ₁∼₁ (₂∼₂ x∼₁y)
      cong-from (₂∼₂ (₂∼₂ x∼₂y)) = ₂∼₂ x∼₂y

  comm : Commutative _⊎-setoid_
  comm A B = record
    { to = swap'
    ; from = swap'
    ; inverse-of = record
      { left-inverse-of  = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B : SEToid} → A ⊎-setoid B FE.⟶ B ⊎-setoid A
      swap' {A} {B} = record
        { _⟨$⟩_ = [ inj₂ , inj₁ ]
        ; cong = cong
        } where
          cong : Setoid._≈_ (A ⊎-setoid B) =[ _ ]⇒ Setoid._≈_ (B ⊎-setoid A)
          cong (₁∼₂ ())
          cong (₁∼₁ x∼₁y) = ₂∼₂ x∼₁y
          cong (₂∼₂ x∼₂y) = ₁∼₁ x∼₂y

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ⊎-setoid B) (swap' FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = [ (λ _ → ₁∼₁ (Setoid.refl A)) , (λ _ → ₂∼₂ (Setoid.refl B)) ]

×-ICommutativeMonoid : CommutativeMonoid _ _
×-ICommutativeMonoid = record {
                         Carrier = SEToid ;
                         _≈_ = Inv.Inverse;
                         _∙_ = _×-setoid_;
                         ε = ≡.setoid ⊤;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv-isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _×-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊤) _×-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = proj₂
      ; cong = proj₂
      }
    ; from = record
      { _⟨$⟩_ = λ x → _ , x
      ; cong = λ x → ≡.refl , x
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ≡.refl , (Setoid.refl A)
      ; right-inverse-of = λ x → Setoid.refl A
      }
    }

  assoc : Associative _×-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      ; cong  = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      }
    ; from = record
      { _⟨$⟩_ = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      ; cong  = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      }
    ; inverse-of = record
      { left-inverse-of = λ _ → Setoid.refl ((A ×-setoid B) ×-setoid C)
      ; right-inverse-of = λ _ → Setoid.refl (A ×-setoid (B ×-setoid C))
      }
    }

  comm : Commutative _×-setoid_
  comm A B = record
    { to = swap' {A} {B}
    ; from = swap' {B} {A}
    ; inverse-of = record
      { left-inverse-of = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B : SEToid} → A ×-setoid B FE.⟶ B ×-setoid A
      swap' {A}{B} = record { _⟨$⟩_ = swap; cong = swap }

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ×-setoid B) (swap' {B} {A} FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = λ x → Setoid.refl (A ×-setoid B)

×⊎-ICommutativeSemiring : CommutativeSemiring _ _
×⊎-ICommutativeSemiring = record
  { Carrier = SEToid
  ; _≈_ = Inv.Inverse
  ; _+_ = _⊎-setoid_
  ; _*_ = _×-setoid_
  ; 0# = ≡.setoid ⊥
  ; 1# = ≡.setoid ⊤
  ; isCommutativeSemiring = record
    { +-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ⊎-ICommutativeMonoid
    ; *-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ×-ICommutativeMonoid
    ; distribʳ = distribʳ
    ; zeroˡ = zeroˡ
    }
  }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  distribʳ : _×-setoid_ DistributesOverʳ _⊎-setoid_
  distribʳ A B C = record
    { to = record
      { _⟨$⟩_ = uncurry [ curry inj₁ , curry inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = from
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of  = uncurry [ (λ x y → (₁∼₁ (refl B)) , (refl A)) , (λ x y → (₂∼₂ (refl C)) , (refl A)) ]
      ; right-inverse-of = [ uncurry (λ x y → ₁∼₁ ((refl B {x}) , (refl A {y})))
                           , uncurry (λ x y → ₂∼₂ ((refl C {x}) , (refl A {y}))) ]
      }
    } where
      open Setoid
      A' = Carrier A
      B' = Carrier B
      C' = Carrier C

      cong-to : _≈_ ((B ⊎-setoid C) ×-setoid A) =[ _ ]⇒ _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A))
      cong-to (₁∼₂ () , _)
      cong-to (₁∼₁ x∼₁y , A-rel) = ₁∼₁ (x∼₁y , A-rel)
      cong-to (₂∼₂ x∼₂y , A-rel) = ₂∼₂ (x∼₂y , A-rel)

      from : B' × A' ⊎ C' × A' → (B' ⊎ C') × A'
      from = [ map× inj₁ F.id , map× inj₂ F.id ]

      cong-from : _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A)) =[ _ ]⇒ _≈_ ((B ⊎-setoid C) ×-setoid A)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ (B-rel , A-rel)) = (₁∼₁ B-rel , A-rel)
      cong-from (₂∼₂ (C-rel , A-rel)) = ₂∼₂ C-rel , A-rel

  zeroˡ : LeftZero (≡.setoid ⊥) _×-setoid_
  zeroˡ A = record
    { to = record
      { _⟨$⟩_ = proj₁
      ; cong = proj₁
      }
    ; from = record
      { _⟨$⟩_ = ⊥-elim
      ; cong = λ { {()} x }
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ⊥-elim (proj₁ x)
      ; right-inverse-of = λ x → ⊥-elim x
      }
    }

module ×-CMon = CommutativeMonoid (×-CommutativeMonoid FR.bijection L.zero)
module ⊎-CMon = CommutativeMonoid (⊎-CommutativeMonoid FR.bijection L.zero)
module ×⊎°    = CommutativeSemiring (×⊎-CommutativeSemiring FR.bijection L.zero)

module ×-ICMon = CommutativeMonoid ×-ICommutativeMonoid
module ⊎-ICMon = CommutativeMonoid ⊎-ICommutativeMonoid
module ×⊎°I    = CommutativeSemiring ×⊎-ICommutativeSemiring

lift-⊎ : ∀ {A B : Set} → Inv.Inverse ((≡.setoid A) ⊎-setoid (≡.setoid B)) (≡.setoid (A ⊎ B))
lift-⊎ {A}{B} = record
  { to = record
    { _⟨$⟩_ = λ x → x
    ; cong = cong
    }
  ; from = record
    { _⟨$⟩_ = λ x → x
    ; cong = λ x → Setoid.reflexive (≡.setoid A ⊎-setoid ≡.setoid B) x
    }
  ; inverse-of = record
    { left-inverse-of = λ x → Setoid.refl (≡.setoid A ⊎-setoid ≡.setoid B)
    ; right-inverse-of = λ x → Setoid.refl (≡.setoid (A ⊎ B))
    }
  } where
    cong : Setoid._≈_ (≡.setoid A ⊎-setoid ≡.setoid B)  =[ _ ]⇒ Setoid._≈_ (≡.setoid (A ⊎ B))
    cong (₁∼₂ ())
    cong (₁∼₁ x∼₁y) = ≡.cong inj₁ x∼₁y
    cong (₂∼₂ x∼₂y) = ≡.cong inj₂ x∼₂y

swap-iso : ∀ {A B} → (A × B) ↔ (B × A)
swap-iso = ×-CMon.comm _ _

Maybe↔⊤⊎ : ∀ {a} {A : Set a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = record { to   = →-to-⟶ (maybe inj₂ (inj₁ _))
           ; from = →-to-⟶ [ F.const nothing , just ]
           ; inverse-of
           = record { left-inverse-of = maybe (λ _ → ≡.refl) ≡.refl
                    ; right-inverse-of = [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ] } }

Maybe-cong : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {A} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {A B} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔⊤ : ∀ {a} {A : Set a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = record { to         = →-to-⟶ _
                ; from       = →-to-⟶ (F.const [])
                ; inverse-of = record { left-inverse-of  = λ { [] → ≡.refl }
                                      ; right-inverse-of = λ _ → ≡.refl } }

Vec∘suc↔A×Vec : ∀ {a} {A : Set a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = record { to         = →-to-⟶ (λ { (x ∷ xs) → x , xs })
           ; from       = →-to-⟶ (uncurry _∷_)
           ; inverse-of = record { left-inverse-of  = λ { (x ∷ xs) → ≡.refl }
                                 ; right-inverse-of = λ _ → ≡.refl } }

infix 8 _^_

_^_ : ★ → ℕ → ★
A ^ 0     = ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {A} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = record { to   = →-to-⟶ λ()
                ; from = →-to-⟶ λ()
                ; inverse-of = record { left-inverse-of  = λ()
                                      ; right-inverse-of = λ() } }

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = record { to   = →-to-⟶ to
           ; from = →-to-⟶ (maybe suc zero)
           ; inverse-of
           = record { left-inverse-of = λ { zero → ≡.refl ; (suc n) → ≡.refl }
                    ; right-inverse-of = maybe (λ _ → ≡.refl) ≡.refl } }
  where to : Fin (suc n) → Maybe (Fin n)
        to zero = nothing
        to (suc n) = just n

Lift↔id : ∀ {a} {A : Set a} → Lift {a} {a} A ↔ A
Lift↔id = record { to = →-to-⟶ lower
                 ; from = →-to-⟶ lift
                 ; inverse-of = record { left-inverse-of = λ { (lift x) → ≡.refl }
                                       ; right-inverse-of = λ _ → ≡.refl } }

⊤×A↔A : ∀ {A : ★} → (⊤ × A) ↔ A
⊤×A↔A = proj₁ ×-CMon.identity _ ∘ sym Lift↔id ×-cong id

A×⊤↔A : ∀ {A : ★} → (A × ⊤) ↔ A
A×⊤↔A = proj₂ ×-CMon.identity _ ∘ id ×-cong sym Lift↔id

⊥⊎A↔A : ∀ {A : ★} → (⊥ ⊎ A) ↔ A
⊥⊎A↔A = proj₁ ⊎-CMon.identity _ ∘ sym Lift↔id ⊎-cong id

A⊎⊥↔A : ∀ {A : ★} → (A ⊎ ⊥) ↔ A
A⊎⊥↔A = proj₂ ⊎-CMon.identity _ ∘ id ⊎-cong sym Lift↔id

⊥×A↔⊥ : ∀ {A : ★} → (⊥ × A) ↔ ⊥
⊥×A↔⊥ = Lift↔id ∘ proj₁ ×⊎°.zero _ ∘ sym (Lift↔id ×-cong id)

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = A⊎⊥↔A ∘ Maybe↔⊤⊎

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Maybe-⊎ : ∀ {A B : ★} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ = sym Maybe↔⊤⊎ ∘ ⊎-CMon.assoc ⊤ _ _ ∘ (Maybe↔⊤⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m ⊥ ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = ⊥⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎

Fin-⊎-+ : ∀ m n → (Fin m ⊎ Fin n) ↔ Fin (m + n)
Fin-⊎-+ m n = Maybe^⊥↔Fin (m + n)
            ∘ Maybe^-⊎-+ m n
            ∘ sym (Maybe^⊥↔Fin m ⊎-cong Maybe^⊥↔Fin n)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin

Fin-×-* : ∀ m n → (Fin m × Fin n) ↔ Fin (m * n)
Fin-×-* zero n = (Fin 0 × Fin n) ↔⟨ Fin0↔⊥ ×-cong id ⟩
                 (⊥ × Fin n) ↔⟨ ⊥×A↔⊥ ⟩
                 ⊥ ↔⟨ sym Fin0↔⊥ ⟩
                 Fin 0 ∎
  where open EquationalReasoning hiding (sym)
Fin-×-* (suc m) n = (Fin (suc m) × Fin n) ↔⟨ Fin∘suc↔⊤⊎Fin ×-cong id ⟩
                    ((⊤ ⊎ Fin m) × Fin n) ↔⟨ ×⊎°.distribʳ (Fin n) ⊤ (Fin m) ⟩
                    ((⊤ × Fin n) ⊎ (Fin m × Fin n)) ↔⟨ ⊤×A↔A ⊎-cong Fin-×-* m n ⟩
                    (Fin n ⊎ Fin (m * n)) ↔⟨ Fin-⊎-+ n (m * n) ⟩
                    Fin (suc m * n) ∎
  where open EquationalReasoning hiding (sym)

module Function.Related.TypeIsomorphisms.NP where

import Level as L
open import Algebra
import Algebra.FunctionProperties as FP
open L using (Lift; lower; lift)
open import Type

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Nat.NP using (ℕ; zero; suc; _+_; _*_) renaming (_^_ to _**_)
open import Data.Maybe.NP
open import Data.Product renaming (map to map×)
--open import Data.Product.N-ary
open import Data.Sum renaming (map to map⊎)
open import Data.Unit
open import Data.Empty

import Function as F
import Function.Equality as FE
open FE using (_⟨$⟩_)
open import Function.Related as FR
open import Function.Related.TypeIsomorphisms public
import Function.Inverse as Inv
open Inv using (_↔_; _∘_; sym; id; module Inverse)
open import Relation.Binary
open import Relation.Binary.Product.Pointwise
open import Relation.Binary.Sum
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (→-to-⟶)

Inv-isEquivalence : IsEquivalence (Inv.Inverse {f₁ = L.zero} {f₂ = L.zero})
Inv-isEquivalence = record
   { refl = Inv.id
   ; sym = Inv.sym
   ; trans = F.flip Inv._∘_ }

SEToid : Set _
SEToid = Setoid L.zero L.zero

SEToid₁ : Setoid _ _
SEToid₁ = record
  { Carrier = Setoid L.zero L.zero
  ; _≈_ = Inv.Inverse
  ; isEquivalence = Inv-isEquivalence }

⊎-ICommutativeMonoid : CommutativeMonoid _ _
⊎-ICommutativeMonoid = record {
                         Carrier = SEToid ;
                         _≈_ = Inv.Inverse;
                         _∙_ = _⊎-setoid_;
                         ε = ≡.setoid ⊥;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv-isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _⊎-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊥) _⊎-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = [ (λ ()) , F.id ]
      ; cong  = cong-to
      }
    ; from = record
      { _⟨$⟩_ = inj₂
      ; cong = ₂∼₂
      }
    ; inverse-of = record
      { left-inverse-of = [ (λ ()) , (λ x → ₂∼₂ refl) ]
      ; right-inverse-of = λ x → refl
      }
    } where open Setoid A
            cong-to : Setoid._≈_ (≡.setoid ⊥ ⊎-setoid A) =[ _ ]⇒ _≈_
            cong-to (₁∼₂ ())
            cong-to (₁∼₁ x∼₁y) rewrite x∼₁y = refl
            cong-to (₂∼₂ x∼₂y) = x∼₂y

  assoc : Associative _⊎-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = [ [ inj₁ , inj₂ F.∘ inj₁ ] , inj₂ F.∘ inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = [ inj₁ F.∘ inj₁ , [ inj₁ F.∘ inj₂ , inj₂ ] ]
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of = [ [ (λ _ → ₁∼₁ (₁∼₁ (refl A))) , (λ _ → ₁∼₁ (₂∼₂ (refl B)) ) ] , (λ _ → ₂∼₂ (refl C)) ]
      ; right-inverse-of = [ (λ _ → ₁∼₁ (refl A)) , [ (λ _ → ₂∼₂ (₁∼₁ (refl B))) , (λ _ → ₂∼₂ (₂∼₂ (refl C))) ] ]
      }
    } where
      open Setoid
      cong-to : _≈_ ((A ⊎-setoid B) ⊎-setoid C) =[ _ ]⇒ _≈_ (A ⊎-setoid (B ⊎-setoid C))
      cong-to (₁∼₂ ())
      cong-to (₁∼₁ (₁∼₂ ()))
      cong-to (₁∼₁ (₁∼₁ x∼₁y)) = ₁∼₁ x∼₁y
      cong-to (₁∼₁ (₂∼₂ x∼₂y)) = ₂∼₂ (₁∼₁ x∼₂y)
      cong-to (₂∼₂ x∼₂y) = ₂∼₂ (₂∼₂ x∼₂y)

      cong-from : _≈_ (A ⊎-setoid (B ⊎-setoid C)) =[ _ ]⇒ _≈_ ((A ⊎-setoid B) ⊎-setoid C)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ x∼₁y) = ₁∼₁ (₁∼₁ x∼₁y)
      cong-from (₂∼₂ (₁∼₂ ()))
      cong-from (₂∼₂ (₁∼₁ x∼₁y)) = ₁∼₁ (₂∼₂ x∼₁y)
      cong-from (₂∼₂ (₂∼₂ x∼₂y)) = ₂∼₂ x∼₂y

  comm : Commutative _⊎-setoid_
  comm A B = record
    { to = swap'
    ; from = swap'
    ; inverse-of = record
      { left-inverse-of  = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B : SEToid} → A ⊎-setoid B FE.⟶ B ⊎-setoid A
      swap' {A} {B} = record
        { _⟨$⟩_ = [ inj₂ , inj₁ ]
        ; cong = cong
        } where
          cong : Setoid._≈_ (A ⊎-setoid B) =[ _ ]⇒ Setoid._≈_ (B ⊎-setoid A)
          cong (₁∼₂ ())
          cong (₁∼₁ x∼₁y) = ₂∼₂ x∼₁y
          cong (₂∼₂ x∼₂y) = ₁∼₁ x∼₂y

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ⊎-setoid B) (swap' FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = [ (λ _ → ₁∼₁ (Setoid.refl A)) , (λ _ → ₂∼₂ (Setoid.refl B)) ]

×-ICommutativeMonoid : CommutativeMonoid _ _
×-ICommutativeMonoid = record {
                         Carrier = SEToid ;
                         _≈_ = Inv.Inverse;
                         _∙_ = _×-setoid_;
                         ε = ≡.setoid ⊤;
                         isCommutativeMonoid = record
                            { isSemigroup = record
                              { isEquivalence = Inv-isEquivalence
                              ; assoc = assoc
                              ; ∙-cong = _×-inverse_
                              }
                            ; identityˡ = left-identity
                            ; comm = comm
                            }
                         }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  left-identity : LeftIdentity (≡.setoid ⊤) _×-setoid_
  left-identity A = record
    { to = record
      { _⟨$⟩_ = proj₂
      ; cong = proj₂
      }
    ; from = record
      { _⟨$⟩_ = λ x → _ , x
      ; cong = λ x → ≡.refl , x
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ≡.refl , (Setoid.refl A)
      ; right-inverse-of = λ x → Setoid.refl A
      }
    }

  assoc : Associative _×-setoid_
  assoc A B C = record
    { to = record
      { _⟨$⟩_ = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      ; cong  = < proj₁ F.∘ proj₁ , < proj₂ F.∘ proj₁ , proj₂ > >
      }
    ; from = record
      { _⟨$⟩_ = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      ; cong  = < < proj₁ , proj₁ F.∘ proj₂ > , proj₂ F.∘ proj₂ >
      }
    ; inverse-of = record
      { left-inverse-of = λ _ → Setoid.refl ((A ×-setoid B) ×-setoid C)
      ; right-inverse-of = λ _ → Setoid.refl (A ×-setoid (B ×-setoid C))
      }
    }

  comm : Commutative _×-setoid_
  comm A B = record
    { to = swap' {A} {B}
    ; from = swap' {B} {A}
    ; inverse-of = record
      { left-inverse-of = inv A B
      ; right-inverse-of = inv B A
      }
    } where
      swap' : ∀ {A B : SEToid} → A ×-setoid B FE.⟶ B ×-setoid A
      swap' {A}{B} = record { _⟨$⟩_ = swap; cong = swap }

      inv : ∀ A B → ∀ x → Setoid._≈_ (A ×-setoid B) (swap' {B} {A} FE.∘ swap' {A} {B}⟨$⟩ x) x
      inv A B = λ x → Setoid.refl (A ×-setoid B)

×⊎-ICommutativeSemiring : CommutativeSemiring _ _
×⊎-ICommutativeSemiring = record
  { Carrier = SEToid
  ; _≈_ = Inv.Inverse
  ; _+_ = _⊎-setoid_
  ; _*_ = _×-setoid_
  ; 0# = ≡.setoid ⊥
  ; 1# = ≡.setoid ⊤
  ; isCommutativeSemiring = record
    { +-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ⊎-ICommutativeMonoid
    ; *-isCommutativeMonoid = CommutativeMonoid.isCommutativeMonoid ×-ICommutativeMonoid
    ; distribʳ = distribʳ
    ; zeroˡ = zeroˡ
    }
  }
  where
  open FP (Inv.Inverse {f₁ = L.zero}{f₂ = L.zero})

  distribʳ : _×-setoid_ DistributesOverʳ _⊎-setoid_
  distribʳ A B C = record
    { to = record
      { _⟨$⟩_ = uncurry [ curry inj₁ , curry inj₂ ]
      ; cong = cong-to
      }
    ; from = record
      { _⟨$⟩_ = from
      ; cong = cong-from
      }
    ; inverse-of = record
      { left-inverse-of  = uncurry [ (λ x y → (₁∼₁ (refl B)) , (refl A)) , (λ x y → (₂∼₂ (refl C)) , (refl A)) ]
      ; right-inverse-of = [ uncurry (λ x y → ₁∼₁ ((refl B {x}) , (refl A {y})))
                           , uncurry (λ x y → ₂∼₂ ((refl C {x}) , (refl A {y}))) ]
      }
    } where
      open Setoid
      A' = Carrier A
      B' = Carrier B
      C' = Carrier C

      cong-to : _≈_ ((B ⊎-setoid C) ×-setoid A) =[ _ ]⇒ _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A))
      cong-to (₁∼₂ () , _)
      cong-to (₁∼₁ x∼₁y , A-rel) = ₁∼₁ (x∼₁y , A-rel)
      cong-to (₂∼₂ x∼₂y , A-rel) = ₂∼₂ (x∼₂y , A-rel)

      from : B' × A' ⊎ C' × A' → (B' ⊎ C') × A'
      from = [ map× inj₁ F.id , map× inj₂ F.id ]

      cong-from : _≈_ ((B ×-setoid A) ⊎-setoid (C ×-setoid A)) =[ _ ]⇒ _≈_ ((B ⊎-setoid C) ×-setoid A)
      cong-from (₁∼₂ ())
      cong-from (₁∼₁ (B-rel , A-rel)) = (₁∼₁ B-rel , A-rel)
      cong-from (₂∼₂ (C-rel , A-rel)) = ₂∼₂ C-rel , A-rel

  zeroˡ : LeftZero (≡.setoid ⊥) _×-setoid_
  zeroˡ A = record
    { to = record
      { _⟨$⟩_ = proj₁
      ; cong = proj₁
      }
    ; from = record
      { _⟨$⟩_ = ⊥-elim
      ; cong = λ { {()} x }
      }
    ; inverse-of = record
      { left-inverse-of = λ x → ⊥-elim (proj₁ x)
      ; right-inverse-of = λ x → ⊥-elim x
      }
    }

module ×-CMon = CommutativeMonoid (×-CommutativeMonoid FR.bijection L.zero)
module ⊎-CMon = CommutativeMonoid (⊎-CommutativeMonoid FR.bijection L.zero)
module ×⊎°    = CommutativeSemiring (×⊎-CommutativeSemiring FR.bijection L.zero)

module ×-ICMon = CommutativeMonoid ×-ICommutativeMonoid
module ⊎-ICMon = CommutativeMonoid ⊎-ICommutativeMonoid
module ×⊎°I    = CommutativeSemiring ×⊎-ICommutativeSemiring

swap-iso : ∀ {A B} → (A × B) ↔ (B × A)
swap-iso = ×-CMon.comm _ _

Maybe↔⊤⊎ : ∀ {a} {A : Set a} → Maybe A ↔ (⊤ ⊎ A)
Maybe↔⊤⊎
  = record { to   = →-to-⟶ (maybe inj₂ (inj₁ _))
           ; from = →-to-⟶ [ F.const nothing , just ]
           ; inverse-of
           = record { left-inverse-of = maybe (λ _ → ≡.refl) ≡.refl
                    ; right-inverse-of = [ (λ _ → ≡.refl) , (λ _ → ≡.refl) ] } }

Maybe-cong : ∀ {a b} {A : Set a} {B : Set b} → A ↔ B → Maybe A ↔ Maybe B
Maybe-cong A↔B = sym Maybe↔⊤⊎ ∘ id ⊎-cong A↔B ∘ Maybe↔⊤⊎

Maybe∘Maybe^↔Maybe^∘Maybe : ∀ {A} n → Maybe (Maybe^ n A) ↔ Maybe^ n (Maybe A)
Maybe∘Maybe^↔Maybe^∘Maybe zero    = id
Maybe∘Maybe^↔Maybe^∘Maybe (suc n) = Maybe-cong (Maybe∘Maybe^↔Maybe^∘Maybe n)

Maybe^-cong : ∀ {A B} n → A ↔ B → Maybe^ n A ↔ Maybe^ n B
Maybe^-cong zero    = F.id
Maybe^-cong (suc n) = Maybe-cong F.∘ Maybe^-cong n

Vec0↔⊤ : ∀ {a} {A : Set a} → Vec A 0 ↔ ⊤
Vec0↔⊤ = record { to         = →-to-⟶ _
                ; from       = →-to-⟶ (F.const [])
                ; inverse-of = record { left-inverse-of  = λ { [] → ≡.refl }
                                      ; right-inverse-of = λ _ → ≡.refl } }

Vec∘suc↔A×Vec : ∀ {a} {A : Set a} {n} → Vec A (suc n) ↔ (A × Vec A n)
Vec∘suc↔A×Vec
  = record { to         = →-to-⟶ (λ { (x ∷ xs) → x , xs })
           ; from       = →-to-⟶ (uncurry _∷_)
           ; inverse-of = record { left-inverse-of  = λ { (x ∷ xs) → ≡.refl }
                                 ; right-inverse-of = λ _ → ≡.refl } }

infix 8 _^_

_^_ : ★ → ℕ → ★
A ^ 0     = ⊤
A ^ suc n = A × A ^ n

^↔Vec : ∀ {A} n → (A ^ n) ↔ Vec A n
^↔Vec zero    = sym Vec0↔⊤
^↔Vec (suc n) = sym Vec∘suc↔A×Vec ∘ (id ×-cong (^↔Vec n))

Fin0↔⊥ : Fin 0 ↔ ⊥
Fin0↔⊥ = record { to   = →-to-⟶ λ()
                ; from = →-to-⟶ λ()
                ; inverse-of = record { left-inverse-of  = λ()
                                      ; right-inverse-of = λ() } }

Fin∘suc↔Maybe∘Fin : ∀ {n} → Fin (suc n) ↔ Maybe (Fin n)
Fin∘suc↔Maybe∘Fin {n}
  = record { to   = →-to-⟶ to
           ; from = →-to-⟶ (maybe suc zero)
           ; inverse-of
           = record { left-inverse-of = λ { zero → ≡.refl ; (suc n) → ≡.refl }
                    ; right-inverse-of = maybe (λ _ → ≡.refl) ≡.refl } }
  where to : Fin (suc n) → Maybe (Fin n)
        to zero = nothing
        to (suc n) = just n

Lift↔id : ∀ {a} {A : Set a} → Lift {a} {a} A ↔ A
Lift↔id = record { to = →-to-⟶ lower
                 ; from = →-to-⟶ lift
                 ; inverse-of = record { left-inverse-of = λ { (lift x) → ≡.refl }
                                       ; right-inverse-of = λ _ → ≡.refl } }

⊤×A↔A : ∀ {A : ★} → (⊤ × A) ↔ A
⊤×A↔A = proj₁ ×-CMon.identity _ ∘ sym Lift↔id ×-cong id

A×⊤↔A : ∀ {A : ★} → (A × ⊤) ↔ A
A×⊤↔A = proj₂ ×-CMon.identity _ ∘ id ×-cong sym Lift↔id

⊥⊎A↔A : ∀ {A : ★} → (⊥ ⊎ A) ↔ A
⊥⊎A↔A = proj₁ ⊎-CMon.identity _ ∘ sym Lift↔id ⊎-cong id

A⊎⊥↔A : ∀ {A : ★} → (A ⊎ ⊥) ↔ A
A⊎⊥↔A = proj₂ ⊎-CMon.identity _ ∘ id ⊎-cong sym Lift↔id

⊥×A↔⊥ : ∀ {A : ★} → (⊥ × A) ↔ ⊥
⊥×A↔⊥ = Lift↔id ∘ proj₁ ×⊎°.zero _ ∘ sym (Lift↔id ×-cong id)

Maybe⊥↔⊤ : Maybe ⊥ ↔ ⊤
Maybe⊥↔⊤ = A⊎⊥↔A ∘ Maybe↔⊤⊎

Maybe^⊥↔Fin : ∀ n → Maybe^ n ⊥ ↔ Fin n
Maybe^⊥↔Fin zero    = sym Fin0↔⊥
Maybe^⊥↔Fin (suc n) = sym Fin∘suc↔Maybe∘Fin ∘ Maybe-cong (Maybe^⊥↔Fin n)

Maybe^⊤↔Fin1+ : ∀ n → Maybe^ n ⊤ ↔ Fin (suc n)
Maybe^⊤↔Fin1+ n = Maybe^⊥↔Fin (suc n) ∘ sym (Maybe∘Maybe^↔Maybe^∘Maybe n) ∘ Maybe^-cong n (sym Maybe⊥↔⊤)

Maybe-⊎ : ∀ {A B : ★} → (Maybe A ⊎ B) ↔ Maybe (A ⊎ B)
Maybe-⊎ = sym Maybe↔⊤⊎ ∘ ⊎-CMon.assoc ⊤ _ _ ∘ (Maybe↔⊤⊎ ⊎-cong id)

Maybe^-⊎-+ : ∀ {A} m n → (Maybe^ m ⊥ ⊎ Maybe^ n A) ↔ Maybe^ (m + n) A
Maybe^-⊎-+ zero    n = ⊥⊎A↔A
Maybe^-⊎-+ (suc m) n = Maybe-cong (Maybe^-⊎-+ m n) ∘ Maybe-⊎

Fin-⊎-+ : ∀ m n → (Fin m ⊎ Fin n) ↔ Fin (m + n)
Fin-⊎-+ m n = Maybe^⊥↔Fin (m + n)
            ∘ Maybe^-⊎-+ m n
            ∘ sym (Maybe^⊥↔Fin m ⊎-cong Maybe^⊥↔Fin n)

Fin∘suc↔⊤⊎Fin : ∀ {n} → Fin (suc n) ↔ (⊤ ⊎ Fin n)
Fin∘suc↔⊤⊎Fin = Maybe↔⊤⊎ ∘ Fin∘suc↔Maybe∘Fin


most of the type assignment rules

most of the type assignment rules

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_]    : (Nat × subst) → ë
    ⦇_⦈[_]   : ë → (Nat × subst) → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< e2' > t2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u , id Γ ] ⊣  ⟦ u ::[ Γ ] ⦇⦈ ⟧
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u , id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< e' > t) ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      EALam : ∀{Γ x t1 t2 e e' t2' Δ } →
              (Γ ,, (x , t1)) ⊢ e ⇐ t2 ~> e' :: t2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ (t1 ==> t2) ~> ·λ x [ t1 ] e' :: (t1 ==> t2') ⊣ Δ
      EASubsume : ∀{e u m Γ t' e' Δ t} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ m ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                  t ~ t' →
                  Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ
      EAEHole : ∀{ Γ u t  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ t ~> ⦇⦈[ u , id Γ ] :: t ⊣ ⟦ u ::[ Γ ] t ⟧
      EANEHole : ∀{ Γ e u t e' t' Δ  } →
                 Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                 t ~ t' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ t ~> ⦇ e' ⦈[ u , id Γ ] :: t ⊣ (Δ ,, u ::[ Γ ] t)

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where
    TAConst : ∀{Δ Γ} → Δ , Γ ⊢ c :: b
    TAVar : ∀{Δ Γ x t} → Δ , (Γ ,, (x , t)) ⊢ X x :: t
    TALam : ∀{ Δ Γ x t1 e t2} →
            Δ , (Γ ,, (x , t1)) ⊢ e :: t2 →
            Δ , Γ ⊢ ·λ x [ t1 ] e :: (t1 ==> t2)
    TAAp : ∀{ Δ Γ e1 e2 t1 t2 t} →
           Δ , Γ ⊢ e1 :: t1 →
           t1 ▸arr (t2 ==> t) →
           Δ , Γ ⊢ e2 :: t2 →
           Δ , Γ ⊢ e1 ∘ e2 :: t
    -- TAEHole : ∀{ Δ Γ σ u Γ' } → -- todo: overloaded form in the paper here
    -- TANEHole : ∀ { Δ Γ e t' Γ' u σ t }
    TACast : ∀{ Δ Γ e t t'} →
           Δ , Γ ⊢ e :: t' →
           t ~ t' →
           Δ , Γ ⊢ < e > t :: t

  -- todo: substition goes here

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  -- error
  data _err[_] : ë → hctx → Set where

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u , σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u , σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- small step semantics
  data _↦_ : ë → ë → Set where

open import Nat
open import Prelude
open import contexts

module core where
  -- types
  data τ̇ : Set where
    b     : τ̇
    ⦇⦈    : τ̇
    _==>_ : τ̇ → τ̇ → τ̇

  -- arrow type constructors bind very tightly
  infixr 25  _==>_

  -- expressions
  data ė : Set where
    c       : ė
    _·:_    : ė → τ̇ → ė
    X       : Nat → ė
    ·λ      : Nat → ė → ė
    ·λ_[_]_ : Nat → τ̇ → ė → ė
    ⦇⦈[_]   : Nat → ė
    ⦇_⦈[_]  : ė → Nat → ė
    _∘_     : ė → ė → ė

  subst : Set -- todo: no idea if this is right
  subst = ė ctx

  -- expressions without ascriptions but with casts
  data ë : Set where
    c        : ë
    X        : Nat → ë
    ·λ_[_]_  : Nat → τ̇ → ë → ë
    ⦇⦈[_&_]  : Nat → subst → ë
    ⦇_⦈[_&_] : ë → Nat → subst → ë
    _∘_      : ë → ë → ë
    <_>_     : ë → τ̇ → ë

  -- type consistency
  data _~_ : (t1 : τ̇) → (t2 : τ̇) → Set where
    TCRefl : {t : τ̇} → t ~ t
    TCHole1 : {t : τ̇} → t ~ ⦇⦈
    TCHole2 : {t : τ̇} → ⦇⦈ ~ t
    TCArr : {t1 t2 t1' t2' : τ̇} →
               t1 ~ t1' →
               t2 ~ t2' →
               t1 ==> t2 ~ t1' ==> t2'

  -- type inconsistency
  data _~̸_ : τ̇ → τ̇ → Set where
    ICBaseArr1 : {t1 t2 : τ̇} → b ~̸ t1 ==> t2
    ICBaseArr2 : {t1 t2 : τ̇} → t1 ==> t2 ~̸ b
    ICArr1 : {t1 t2 t3 t4 : τ̇} →
               t1 ~̸ t3 →
               t1 ==> t2 ~̸ t3 ==> t4
    ICArr2 : {t1 t2 t3 t4 : τ̇} →
               t2 ~̸ t4 →
               t1 ==> t2 ~̸ t3 ==> t4

  --- matching for arrows, sums, and products
  data _▸arr_ : τ̇ → τ̇ → Set where
    MAHole : ⦇⦈ ▸arr ⦇⦈ ==> ⦇⦈
    MAArr  : {t1 t2 : τ̇} → t1 ==> t2 ▸arr t1 ==> t2

  -- aliases for type and hole contexts
  tctx : Set
  tctx = τ̇ ctx

  hctx : Set
  hctx = (τ̇ ctx × τ̇) ctx

  postulate -- todo: write this stuff later
    id : {A : Set} → A ctx → subst
    [_]_ : subst → ë → ë

  -- this is just fancy notation to match the paper
  _::[_]_ : Nat → tctx → τ̇ → (Nat × tctx × τ̇)
  u ::[ Γ ] t = u , Γ , t

  -- bidirectional type checking judgements for ė
  mutual
    -- synthesis
    data _⊢_=>_ : (Γ : tctx) → (e : ė) → (t : τ̇) → Set where
      SConst  : {Γ : tctx} → Γ ⊢ c => b
      SAsc    : {Γ : tctx} {e : ė} {t : τ̇} →
                 Γ ⊢ e <= t →
                 Γ ⊢ (e ·: t) => t
      SVar    : {Γ : tctx} {t : τ̇} {n : Nat} →
                 (n , t) ∈ Γ →
                 Γ ⊢ X n => t
      SAp     : {Γ : tctx} {e1 e2 : ė} {t t' t2 : τ̇} →
                 Γ ⊢ e1 => t →
                 t ▸arr t2 ==> t' →
                 Γ ⊢ e2 <= t2 →
                 Γ ⊢ (e1 ∘ e2) => t'
      SEHole  : {Γ : tctx} {u : Nat} → Γ ⊢ ⦇⦈[ u ] => ⦇⦈ -- todo: uniqueness of n?
      SNEHole : {Γ : tctx} {e : ė} {t : τ̇} {u : Nat} → -- todo: uniqueness of n?
                 Γ ⊢ e => t →
                 Γ ⊢ ⦇ e ⦈[ u ] => ⦇⦈
      SLam    : {Γ : tctx} {e : ė} {t1 t2 : τ̇} {x : Nat} →
                 x # Γ → -- todo
                 (Γ ,, (x , t1)) ⊢ e => t2 →
                 Γ ⊢ ·λ x [ t1 ] e => t1 ==> t2

    -- analysis
    data _⊢_<=_ : (Γ : τ̇ ctx) → (e : ė) → (t : τ̇) → Set where
      ASubsume : {Γ : tctx} {e : ė} {t t' : τ̇} →
                 Γ ⊢ e => t' →
                 t ~ t' →
                 Γ ⊢ e <= t
      ALam : {Γ : tctx} {e : ė} {t t1 t2 : τ̇} {x : Nat} →
                 x # Γ →
                 t ▸arr t1 ==> t2 →
                 (Γ ,, (x , t1)) ⊢ e <= t2 →
                 Γ ⊢ (·λ x e) <= t

  -- todo: do we care about completeness of ė or e-umlauts?
  -- those types without holes anywhere
  tcomplete : τ̇ → Set
  tcomplete b         = ⊤
  tcomplete ⦇⦈        = ⊥
  tcomplete (t1 ==> t2) = tcomplete t1 × tcomplete t2

  -- those expressions without holes anywhere
  ecomplete : ė → Set
  ecomplete c = ⊤
  ecomplete (e1 ·: t)  = ecomplete e1 × tcomplete t
  ecomplete (X _)      = ⊤
  ecomplete (·λ _ e1)  = ecomplete e1
  ecomplete ⦇⦈[ u ]       = ⊥
  ecomplete ⦇ e1 ⦈[ u ]   = ⊥
  ecomplete (e1 ∘ e2)  = ecomplete e1 × ecomplete e2
  ecomplete (·λ x [ t ] e) = tcomplete t × ecomplete e

  -- expansion
  mutual
    data _⊢_⇒_~>_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (Δ : hctx) → Set where
      ESConst : ∀{Γ} → Γ ⊢ c ⇒ b ~> c ⊣ ∅
      ESVar   : ∀{Γ x t} → (Γ ,, (x , t)) ⊢ X x ⇒ t ~> X x ⊣ ∅
      ESLam   : ∀{Γ x t1 t2 e e' Δ } →
                     (Γ ,, (x , t1)) ⊢ e ⇒ t2 ~> e' ⊣ Δ →
                      Γ ⊢ ·λ x [ t1 ] e ⇒ (t1 ==> t2) ~> ·λ x [ t1 ] e' ⊣ ∅

      -- todo: really ought to check disjointness of domains here ..
      ESAp1   : ∀{Γ e1 e2 e2' e1' Δ1 t2 t1 Δ2} →
                Γ ⊢ e1 => ⦇⦈ →
                Γ ⊢ e2 ⇐ ⦇⦈ ~> e2' :: t2 ⊣ Δ2 →
                Γ ⊢ e1 ⇐ (t2 ==> ⦇⦈) ~> e1' :: t1 ⊣ Δ1 →
                Γ ⊢ e1 ∘ e2 ⇒ ⦇⦈ ~> (< e1' > t2) ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESAp2 : ∀{Γ e1 t2 t e1' e2' Δ1 Δ2 t2' e2} →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2' ⊣ Δ2 →
              (t2 == t2' → ⊥) →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ (< e2' > t2) ⊣ (Δ1 ∪ Δ2)
      ESAp3 : ∀{Γ e1 t e1' Δ1 e2 t2 e2' Δ2 } →
              Γ ⊢ e1 ⇒ (t2 ==> t) ~> e1' ⊣ Δ1 →
              Γ ⊢ e2 ⇐ t2 ~> e2' :: t2 ⊣ Δ2 →
              Γ ⊢ e1 ∘ e2 ⇒ t ~> e1' ∘ e2' ⊣ (Δ1 ∪ Δ2)
      ESEHole : ∀{ Γ u } →
                Γ ⊢ ⦇⦈[ u ] ⇒ ⦇⦈ ~> ⦇⦈[ u & id Γ ] ⊣  ⟦ u ::[ Γ ] ⦇⦈ ⟧
      ESNEHole : ∀{ Γ e t e' u Δ } →
                 Γ ⊢ e ⇒ t ~> e' ⊣ Δ →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇒ ⦇⦈ ~> ⦇ e' ⦈[ u & id Γ ] ⊣ (Δ ,, u ::[ Γ ] ⦇⦈)
      ESAsc1 : ∀ {Γ e t e' t' Δ} →
                 Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
                 (t == t' → ⊥) →
                 Γ ⊢ (e ·: t) ⇒ t ~> (< e' > t) ⊣ Δ
      ESAsc2 : ∀{Γ e t e' t' Δ } →
               Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ →
               Γ ⊢ (e ·: t) ⇒ t ~> e' ⊣ Δ

    data _⊢_⇐_~>_::_⊣_ : (Γ : tctx) (e : ė) (t : τ̇) (e' : ë) (t' : τ̇)(Δ : hctx) → Set where
      EALam : ∀{Γ x t1 t2 e e' t2' Δ } →
              (Γ ,, (x , t1)) ⊢ e ⇐ t2 ~> e' :: t2' ⊣ Δ →
              Γ ⊢ ·λ x e ⇐ (t1 ==> t2) ~> ·λ x [ t1 ] e' :: (t1 ==> t2') ⊣ Δ
      EASubsume : ∀{e u m Γ t' e' Δ t} →
                  (e == ⦇⦈[ u ] → ⊥) →
                  (e == ⦇ m ⦈[ u ] → ⊥) →
                  Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                  t ~ t' →
                  Γ ⊢ e ⇐ t ~> e' :: t' ⊣ Δ
      EAEHole : ∀{ Γ u t  } →
                Γ ⊢ ⦇⦈[ u ] ⇐ t ~> ⦇⦈[ u & id Γ ] :: t ⊣ ⟦ u ::[ Γ ] t ⟧
      EANEHole : ∀{ Γ e u t e' t' Δ  } →
                 Γ ⊢ e ⇒ t' ~> e' ⊣ Δ →
                 t ~ t' →
                 Γ ⊢ ⦇ e ⦈[ u ] ⇐ t ~> ⦇ e' ⦈[ u & id Γ ] :: t ⊣ (Δ ,, u ::[ Γ ] t)

  -- type assignment
  data _,_⊢_::_ : (Δ : hctx) (Γ : tctx) (e' : ë) (t : τ̇) → Set where

  -- value
  data _val : ë → Set where
    VConst : c val
    VLam   : ∀{x t e} → (·λ x [ t ] e) val

  -- error
  data _err[_] : ë → hctx → Set where -- todo not a context

  mutual
    -- indeterminate
    data _indet : ë → Set where
      IEHole : ∀{u σ} → ⦇⦈[ u & σ ] indet
      INEHole : ∀{e u σ} → e final → ⦇ e ⦈[ u & σ ] indet
      IAp : ∀{e1 e2} → e1 indet → e2 final → (e1 ∘ e2) indet
      ICast : ∀{e t} → e indet → (< e > t) indet

    -- final
    data _final : ë → Set where
      FVal : ∀{e} → e val → e final
      FIndet : ∀{e} → e indet → e final

  -- small step semantics
  data _↦_ : ë → ë → Set where


More Squared proofs

More Squared proofs

-- 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 = {!!}
      }

-- 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₃) =
    {!!} ,
    {!!}
  <∙S> (B a a₁) L L {Col x x₁} {Col y y₁} {One x₂} {One x₃} (p , 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> (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> (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₃) =
    {!!}

  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₃))

  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 = {!!}
      }


Fixed iterate-Stream.

Fixed iterate-Stream.

------------------------------------------------------------------------------
-- The map-iterate property: A property using co-induction
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- The map-iterate property (Gibbons and Hutton, 2005):
-- map f (iterate f x) = iterate f (f · x)

module FOTC.Program.MapIterate.MapIterateI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream.Type
open import FOTC.Relation.Binary.Bisimilarity.Type

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

unfoldMapIterate : ∀ f x →
                   map f (iterate f x) ≡ f · x ∷ map f (iterate f (f · x))
unfoldMapIterate f x =
  map f (iterate f x)               ≡⟨ mapCong₂ (iterate-eq f x) ⟩
  map f (x ∷ iterate f (f · x))     ≡⟨ map-∷ f x (iterate f (f · x)) ⟩
  f · x ∷ map f (iterate f (f · x)) ∎

map-iterate-Stream : ∀ f x → Stream (map f (iterate f x))
map-iterate-Stream f x = Stream-coind A h (x , refl)
  where
  A : D → Set
  A xs = ∃[ y ] xs ≡ map f (iterate f y)

  h : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h (y , prf) = f · y
                , map f (iterate f (f · y))
                , trans prf (unfoldMapIterate f y)
                , f · y , refl

iterate-Stream : ∀ f x → Stream (iterate f (f · x))
iterate-Stream f x = Stream-coind A h (x , refl)
  where
  A : D → Set
  A xs = ∃[ y ] xs ≡ iterate f (f · y)

  h : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h (y , prf) = f · y
                , iterate f (f · (f · y))
                , trans prf (iterate-eq f (f · y))
                , f · y , refl

-- The map-iterate property.
≈-map-iterate : ∀ f x → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-coind B h (x , refl , refl)
  where
  -- Based on the relation used by (Giménez and Castéran, 2007).
  B : D → D → Set
  B xs ys = ∃[ y ] xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y)

  h : ∀ {xs} {ys} → B xs ys →
      ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ B xs' ys'
  h (y , prf₁ , prf₂) =
      f · y
    , map f (iterate f (f · y))
    , iterate f (f · (f · y))
    , trans prf₁ (unfoldMapIterate f y)
    , trans prf₂ (iterate-eq f (f · y))
    , ((f · y) , refl , refl)

------------------------------------------------------------------------------
-- References
--
-- Giménez, Eduardo and Casterán, Pierre (2007). A Tutorial on
-- [Co-]Inductive Types in Coq.
--
-- Gibbons, Jeremy and Hutton, Graham (2005). Proof Methods for
-- Corecursive Programs. In: Fundamenta Informaticae XX, pp. 1–14.

------------------------------------------------------------------------------
-- The map-iterate property: A property using co-induction
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- The map-iterate property (Gibbons and Hutton, 2005):
-- map f (iterate f x) = iterate f (f · x)

module FOTC.Program.MapIterate.MapIterateI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.Stream.Type
open import FOTC.Relation.Binary.Bisimilarity.Type

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

unfoldMapIterate : ∀ f x →
                   map f (iterate f x) ≡ f · x ∷ map f (iterate f (f · x))
unfoldMapIterate f x =
  map f (iterate f x)               ≡⟨ mapCong₂ (iterate-eq f x) ⟩
  map f (x ∷ iterate f (f · x))     ≡⟨ map-∷ f x (iterate f (f · x)) ⟩
  f · x ∷ map f (iterate f (f · x)) ∎

map-iterate-Stream : ∀ f x → Stream (map f (iterate f x))
map-iterate-Stream f x = Stream-coind A h (x , refl)
  where
  A : D → Set
  A xs = ∃[ y ] xs ≡ map f (iterate f y)

  h : ∀ {xs} → A xs → ∃[ x' ] ∃[ xs' ] xs ≡ x' ∷ xs' ∧ A xs'
  h (y , prf) = f · y
                , map f (iterate f (f · y))
                , (trans prf ((unfoldMapIterate f y)))
                , f · y , refl

-- TODO (23 December 2013).
-- map-iterate-Stream₂ : ∀ f x → Stream (iterate f (f · x))

-- The map-iterate property.
≈-map-iterate : ∀ f x → map f (iterate f x) ≈ iterate f (f · x)
≈-map-iterate f x = ≈-coind B h (x , refl , refl)
  where
  -- Based on the relation used by (Giménez and Castéran, 2007).
  B : D → D → Set
  B xs ys = ∃[ y ] xs ≡ map f (iterate f y) ∧ ys ≡ iterate f (f · y)

  h : ∀ {xs} {ys} → B xs ys →
      ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys' ∧ B xs' ys'
  h (y , prf₁ , prf₂) =
      f · y
    , map f (iterate f (f · y))
    , iterate f (f · (f · y))
    , trans prf₁ (unfoldMapIterate f y)
    , trans prf₂ (iterate-eq f (f · y))
    , ((f · y) , refl , refl)

------------------------------------------------------------------------------
-- References
--
-- Giménez, Eduardo and Casterán, Pierre (2007). A Tutorial on
-- [Co-]Inductive Types in Coq.
--
-- Gibbons, Jeremy and Hutton, Graham (2005). Proof Methods for
-- Corecursive Programs. In: Fundamenta Informaticae XX, pp. 1–14.


Success on Nehemiah.Syntax.Term

Success on Nehemiah.Syntax.Term

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Syntax.Term where

open import Nehemiah.Syntax.Type

open import Data.Integer

import Parametric.Syntax.Term Base as Term

data Const : Term.Structure where
  intlit-const : (n : ℤ) → Const ∅ int
  add-const : Const (int • int • ∅) int
  minus-const : Const (int • ∅) (int)

  empty-const : Const ∅ (bag)
  insert-const : Const (int • bag • ∅) (bag)
  union-const : Const (bag • bag • ∅) (bag)
  negate-const : Const (bag • ∅) (bag)

  flatmap-const : Const ((int ⇒ bag) • bag • ∅) (bag)
  sum-const : Const (bag • ∅) (int)

open Term.Structure Const public

-- Import Base.Data.DependentList again here, as part of the workaround for
-- agda/agda#1985; see Parametric.Syntax.Term for info.
--
-- XXX This import is needed to define the patterns in the right scope; if we
-- don't, • gets bound to a different occurrence, and we notice that during
-- typechecking, which happens at use site.
open import Base.Data.DependentList public

-- Shorthands of constants

pattern intlit n = const (intlit-const n) ∅
pattern add s t = const add-const (s • t • ∅)
pattern minus t = const minus-const (t • ∅)
pattern empty = const empty-const ∅
pattern insert s t = const insert-const (s • t • ∅)
pattern union s t = const union-const (s • t • ∅)
pattern negate t = const negate-const (t • ∅)
pattern flatmap s t = const flatmap-const (s • t • ∅)
pattern sum t = const sum-const (t • ∅)

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- The syntax of terms with the Nehemiah plugin.
------------------------------------------------------------------------

module Nehemiah.Syntax.Term where

open import Nehemiah.Syntax.Type

open import Data.Integer

import Parametric.Syntax.Term Base as Term

data Const : Term.Structure where
  intlit-const : (n : ℤ) → Const ∅ int
  add-const : Const (int • int • ∅) int
  minus-const : Const (int • ∅) (int)

  empty-const : Const ∅ (bag)
  insert-const : Const (int • bag • ∅) (bag)
  union-const : Const (bag • bag • ∅) (bag)
  negate-const : Const (bag • ∅) (bag)

  flatmap-const : Const ((int ⇒ bag) • bag • ∅) (bag)
  sum-const : Const (bag • ∅) (int)

--open Term.Structure --works
open Term.Structure Const --fails, even with the rest disabled.
{-
An internal error has occurred. Please report this as a bug.
Location of the error: src/full/Agda/TypeChecking/Substitute.hs:183
-}

{-
-- Shorthands of constants

pattern intlit n = const (intlit-const n) ∅
pattern add s t = const add-const (s • t • ∅)
pattern minus t = const minus-const (t • ∅)
pattern empty = const empty-const ∅
pattern insert s t = const insert-const (s • t • ∅)
pattern union s t = const union-const (s • t • ∅)
pattern negate t = const negate-const (t • ∅)
pattern flatmap s t = const flatmap-const (s • t • ∅)
pattern sum t = const sum-const (t • ∅)
-}