game: adapt to flipbased

game: adapt to flipbased

module game where

open import Level using (Lift) renaming (_⊔_ to _L⊔_)
open import Function.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Product
open import Data.Maybe.NP
open import Data.List
open import Data.List.Any
open import Data.Bool
open import Relation.Binary.PropositionalEquality
open Membership-≡

{-
-- Game
data ⅁ ...
-}

{-
- cost
- non-det
- queries
- partial (like decryption with a mac)
-}

open import Data.Bits
open import flipbased-implem

Bits⟨_⟩→_ : ∀ {a} → ℕ → Set a → Set a
Bits⟨ n ⟩→ A = Bits n → A

data Strategy (☐_ : Set → Set) (R : Set) : ∀ k → Set₁ where
  say : R → Strategy ☐_ R 0
  ask : ∀ {k} {A : Set} → ☐ A → (A → Strategy ☐_ R k) → Strategy ☐_ R k
  rnd : ∀ {n k} {A : Set} → ↺ n A → (A → Strategy ☐_ R k) → Strategy ☐_ R (n + k)

run : ∀ {k R} → Strategy id R k → ↺ k R
run (say r)    = ⟪ r ⟫
run (ask a f)  = run (f a)
run (rnd nd f) = nd >>= (λ xs → run (f xs))

postulate
      Proba : Set
      Pr[_≡1] : ∀ {k} (EXP : ↺ k Bit) → Proba
      _≡1/2^_ : Proba → ℕ → Set
      Pr[toss≡1] : Pr[ toss ≡1] ≡1/2^ 1
      Pr[random≡_] : ∀ {n} (x : Bits n) → Pr[ ⟪ _==_ x · random ⟫ ≡1] ≡1/2^ n
      negligible-proba : Proba
      negligible-advantage-proba : Proba → Proba → Set

_is-negligible : Proba → Set
p is-negligible = negligible-advantage-proba p negligible-proba

negligible-advantage : ∀ {k} (EXP : Bit → ↺ k Bit) → Set
negligible-advantage EXP = negligible-advantage-proba Pr[ EXP 0b ≡1] Pr[ EXP 1b ≡1]

postulate
  negligible-advantage-xor : ∀ {k} (EXP₁ EXP₂ : ↺ k Bit) → EXP₁ ≡ ⟪ _xor_ 1b · EXP₂ ⟫ → negligible-advantage-proba Pr[ EXP₁ ≡1] Pr[ EXP₂ ≡1]

  -- whatch out
  negligible-advantage-trans : ∀ {p₁ p₂ p₃} → negligible-advantage-proba p₁ p₂ → negligible-advantage-proba p₂ p₃ → negligible-advantage-proba p₁ p₃

pattern looks-random = 0b
pattern not-random   = 1b

EXP : ∀ {a b} {A : Set a} {B : Set b} → Bit → (A → B) → (A × A → B)
EXP 0b f (x₀ , x₁) = f x₀
EXP 1b f (x₀ , x₁) = f x₁

module CryptoGames where

  module CipherGames (|K| |M| |C| : ℕ) where
    K = Bits |K|
    M = Bits |M|
    C = Bits |C|

    record SemSecAdv k : Set where
      constructor mk
      field
        {k₀ k₁}   : ℕ
        k≡k₀+k₁  : k ≡ k₀ + k₁
        gen-m₀m₁  : ↺ k₀ (M × M)
        stat-test : C → ↺ k₁ Bit

    mk′ : ∀ {k₀ k₁} → ↺ k₀ (M × M) → (C → ↺ k₁ Bit) → SemSecAdv (k₀ + k₁)
    mk′ = mk refl

    module DeterministicSemanticSecurity where
      runDetSemSec : ∀ {k} (enc : M → C) → SemSecAdv k → Bit → ↺ k Bit
      runDetSemSec enc (mk refl gen-m₀m₁ f) b = gen-m₀m₁ >>= λ m₀m₁ → f (EXP b enc m₀m₁)

      DetSemSecWinner : ∀ (enc : M → C) b {k} (Adv : SemSecAdv k) → ↺ k Set
      DetSemSecWinner enc b Adv = T↺ (runDetSemSec enc Adv b)

      DetSemSec : ∀ k (enc : M → C) → Set
      DetSemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runDetSemSec enc Adv)

      luckySemSec : SemSecAdv 1
      luckySemSec = mk′ ⟪ 0ⁿ , 0ⁿ ⟫ᴰ (λ _ → toss)

      -- see OTPDetSemSec

    module DeterministicCPASecurity where
      DetCPAAdv : ∀ k → Set₁
      DetCPAAdv k = ∀ {☐_} (enc : M × M → ☐ C) → Strategy ☐_ Bit k

      data DetCPAWinner (enc : M × M → C) b (ms : List (M × M)) : ∀ {k} (q : ℕ) → Strategy id Bit k → Set₁ where
        win : ∀ {q} → DetCPAWinner enc b ms q (say b)
        ask : ∀ {k q m₀m₁ f} → m₀m₁ ∉ ms → DetCPAWinner enc b (m₀m₁ ∷ ms) q (f (enc m₀m₁)) →
              DetCPAWinner enc b ms {k} (suc q) (ask (enc m₀m₁) f)
        rnd : ∀ {A : Set} {n k q bs} {r : ↺ n A} {f : A → _}
              → DetCPAWinner enc b ms {k} q (f bs) → DetCPAWinner enc b ms q (rnd r f)

      runDetCPA : ∀ {k} (enc : M → C) (Adv : DetCPAAdv k) → Bit → ↺ k Bit
      runDetCPA enc Adv b = run (Adv (EXP b enc))

      -- no use of CPAWinner
      DetCPASec : ∀ k (enc : M → C) → Set₁
      DetCPASec k enc = ∀ (Adv : DetCPAAdv k) → negligible-advantage (runDetCPA enc Adv)

    CPAAdv : ∀ k → Set₁
    CPAAdv k = ∀ {☐_} (enc : M × M → ☐ (↺ |K| C)) → Strategy ☐_ Bit k

    sem2CPAAdv : ∀ {k} → SemSecAdv k → CPAAdv (|K| + k)
    sem2CPAAdv (mk {k₀} {k₁} refl gen-m₀m₁ f) {☐_} enc =
      subst (Strategy ☐_ Bit) helper
        (rnd gen-m₀m₁ (λ m₀m₁ →
          ask (enc m₀m₁) (λ c →
            rnd c (λ c' → rnd (f c') say))))
      where open import Data.Nat.Properties
            open SemiringSolver
            helper : k₀ + (|K| + (k₁ + 0)) ≡ |K| + (k₀ + k₁)
            helper = solve 3 (λ k₀ |K| k₁ → k₀ :+ (|K| :+ (k₁ :+ con 0)) := |K| :+ (k₀ :+ k₁))
                             refl k₀ |K| k₁

    data CPAWinner (enc : M × M → ↺ |K| C) b : ∀ {k} q → Strategy id Bit k → Set₁ where
      win : ∀ {q} → CPAWinner enc b q (say b)
      ask : ∀ {k q m₀m₁ f} → CPAWinner enc b {k} q (f (enc m₀m₁)) →
            CPAWinner enc b (suc q) (ask (enc m₀m₁) f)
      rnd : ∀ {A : Set} {n k q bs} {r : ↺ n A} {f : A → _}
            → CPAWinner enc b {k} q (f bs) → CPAWinner enc b q (rnd r f)

    det : ∀ {k a b} {A : Set a} {B : Set b} → (A → B) → A → ↺ k B
    det f x = ⟪ f x ⟫

    runCPA : ∀ {k} (enc : M → ↺ |K| C) (Adv : CPAAdv k) → Bit → ↺ k Bit
    runCPA enc Adv b = run (Adv (EXP b enc))

    -- no use of CPAWinner
    CPASec : ∀ k (enc : M → ↺ |K| C) → Set₁
    CPASec k enc = ∀ (Adv : CPAAdv k) → negligible-advantage (runCPA enc Adv)

    SemSecWinner : ∀ (enc : M × M → ↺ |K| C) b k → SemSecAdv k → Set₁
    SemSecWinner enc b k Adv = CPAWinner enc b 1 (sem2CPAAdv Adv enc)

    runSemSec : ∀ {k} (enc : M → ↺ |K| C) → SemSecAdv k → Bit → ↺ (|K| + k) Bit
    runSemSec enc Adv = runCPA enc (sem2CPAAdv Adv)

    -- no use of SemSecWinner
    SemSec : ∀ k (enc : M → ↺ |K| C) → Set
    SemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runSemSec enc Adv)

    weakenWinner : ∀ {enc b k q₀ q₁} {s : Strategy id Bit k} → CPAWinner enc b q₀ s → CPAWinner enc b (q₀ + q₁) s
    weakenWinner win     = win
    weakenWinner (ask w) = ask (weakenWinner w)
    weakenWinner (rnd {n = n} {k} {bs = bs} w) = rnd {n = n} {k} {bs = bs} (weakenWinner w)

    CPA2Sem-correct : ∀ {enc b k q} {semAdv : SemSecAdv k}
                      → SemSecWinner enc b k semAdv → CPAWinner enc b (suc q) (sem2CPAAdv semAdv enc)
    CPA2Sem-correct = weakenWinner

  record Forgery {a} {A : Set a} (P : A → Set) (queries : List A) : Set a where
    field
      forgery         : A
      fresh-forgery   : forgery ∉ queries
      correct-forgery : P forgery
  open Forgery public

  module MACGames (|M| |Tag| : ℕ) where
    M = Bits |M|
    Tag = Bits |Tag|

    -- One might also want that the adversary sends the trials to the challenger.
    -- The challenger might then either end the game or maybe return the info to
    -- the adversary.
    MACAdv : Set₁
    MACAdv = ∀ {☐_} (mac : M → ☐ Tag) → Strategy ☐_ (M × Tag) 0

    -- or
    -- MACAdv = ∀ {☐_ Done} (mac : M → ☐ Tag) (submit : M × Tag → ☐ Done) → Strategy ☐_ Done

    -- or
    -- MACAdv = ∀ {☐_ Done} (mac : M → ☐ Tag)
    --                       (try : M × Tag → ☐ Bool)
    --                       (submit : M × Tag → ☐ Done) → Strategy ☐_ Done

    module MACGames' (mac : M → Tag) where
      CorrectMAC : M × Tag → Set
      CorrectMAC (m , t) = mac m ≡ t

      correctMAC? : M × Tag → Bool
      correctMAC? (m , t) = mac m == t

      data MACWinner (mts : List (M × Tag)) : (q : ℕ) → Strategy id (M × Tag) 0 → Set₁ where
        win : ∀ {q} (f : Forgery CorrectMAC mts) → MACWinner mts q (say (forgery f))
        ask : ∀ {m f q} → MACWinner ((m , mac m) ∷ mts) q (f (mac m))
                        → MACWinner mts (suc q) (ask (mac m) f)

      SecMAC : Set₁
      SecMAC = ∀ (A : MACAdv) → Pr[ ⟪ correctMAC? · run (A mac) ⟫ ≡1] ≡1/2^ |Tag| -- check that bound

  module CiphertextIntegrity (M C : Set) where
    CIAdv : Set₁
    CIAdv = ∀ {☐_} (enc : M → ☐ C) → Strategy ☐_ C 0

    module CiphertextIntegrity' (enc : M → C) (dec : C →? M) where
      CorrectCiphertext : C → Set
      CorrectCiphertext c = IsJust (dec c)

      data CIWinner (cs : List C) : (q : ℕ) → Strategy id C 0 → Set₁ where
        win : ∀ {q} (f : Forgery CorrectCiphertext cs) → CIWinner cs q (say (forgery f))
        ask : ∀ {m f q} → CIWinner (enc m ∷ cs) q (f (enc m))
                        → CIWinner cs (suc q) (ask (enc m) f)

  module AuthenticatedEncryption (|K| |M| |C| : ℕ) where
    open CipherGames |K| |M| |C|
    open CiphertextIntegrity M C

    data AERes : Set where
      distinguish   : Bit → AERes
      found-forgery : C → AERes

    AEAdv : Set₁
    AEAdv = ∀ {☐_} (enc : M × M → ☐ C) → Strategy ☐_ AERes 0

    CCAAdv : Set₁
    CCAAdv = ∀ {☐_} (enc : M × M → ☐ C) (dec : C → ☐ (Maybe M)) → Strategy ☐_ Bit 0

    module AE' (enc : M × M → C) (dec : C →? M) where
      open CiphertextIntegrity' (λ m → enc (m , m)) dec

      data AEWinner (cs : List C) b : (q : ℕ) → Strategy id AERes 0 → Set₁ where
        win-distinguish : ∀ {q} → AEWinner cs b q (say (distinguish b))
        win-forgery : ∀ {q} (f : Forgery CorrectCiphertext cs)
                       → AEWinner cs b q (say (found-forgery (forgery f)))
        ask : ∀ {m₀m₁ f q} → AEWinner cs b q (f (enc m₀m₁)) →
              AEWinner cs b (suc q) (ask (enc m₀m₁) f)

      data CCAWinner b : (q : ℕ) → Strategy id Bit 0 → Set₁ where
        win : ∀ {q} → CCAWinner b q (say b)
        ask-enc : ∀ {m₀m₁ f q} → CCAWinner b q (f (enc m₀m₁)) →
                    CCAWinner b (suc q) (ask (enc m₀m₁) f)
        ask-dec : ∀ {c f q} → CCAWinner b q (f (dec c)) →
                    CCAWinner b (suc q) (ask (dec c) f)

  -- CBC with rand IV is not CCA secure

      -- AE ⇒ CCA Secure

  module OTPDetSemSec {n} (key : Bits n) where
    open CipherGames n n n
    open DeterministicSemanticSecurity

    postulate
      OTPDetSemSec : ∀ {k} → DetSemSec k (OTP key)
{-
    OTPDetSemSec (mk refl gen-m₀m₁ stat-test) = {!!}
    -- DetSemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runDetSemSec enc Adv)
    -- runDetSemSec enc (mk refl gen-m₀m₁ f) b = gen-m₀m₁ >>= λ m₀m₁ → f (EXP b enc m₀m₁)

Pr[ runDetSemSec enc Adv b ≡ b ]
-}

  Enc : ∀ |K| |M| |C| → Set
  Enc |K| |M| |C| = Bits |K| → Bits |M| → Bits |C|

  module DerivedBlockCiphers
    {|K| |M| |C|} {E : Enc |K| |M| |C|}
    (E-sec : ∀ {k} key → CipherGames.DeterministicSemanticSecurity.DetSemSec |K| |M| |C| k (E key)) where

    open module CipherGames' {|M| |C|} = CipherGames |K| |M| |C|
    open DeterministicSemanticSecurity

    E₀ : Enc |K| |M| |C|
    E₀ k m = 1ⁿ ⊕ E k m

    postulate
      lem' : ∀ {k} (Adv : SemSecAdv k) b (f : Bits k → Bits |C|) → runDetSemSec {k} (_⊕_ 1ⁿ ∘ f) Adv b ≡ ⟪ _xor_ 1b · runDetSemSec f Adv b ⟫
    -- lem' Adv b f = {!!}

      lem'' : ∀ {k} (Adv : SemSecAdv k) b (f : Bits k → Bits |C|) → ⟪ _xor_ 1b · runDetSemSec {k} (_⊕_ 1ⁿ ∘ f) Adv b ⟫ ≡ runDetSemSec f Adv b
    -- lem'' Adv b f = {!!}

    -- postulate
    E₀-sec : ∀ key → DetSemSec |M| (E₀ key)
    E₀-sec key Adv = negligible-advantage-trans (negligible-advantage-xor (runDetSemSec (E₀ key) Adv 0b) (runDetSemSec (E key) Adv 0b) (lem' Adv 0b (E key))) (negligible-advantage-trans (E-sec key Adv) (negligible-advantage-xor (runDetSemSec (E key) Adv 1b) (runDetSemSec (E₀ key) Adv 1b) (sym (lem'' Adv 1b (E key)))))

    E₁ : Enc |K| |M| (1 + |C|)
    E₁ k m = 0∷ E k m

    -- E₁-adv : ∀ {k} key → SemSecAdv k (E key) → SemSecAdv k (E₁ key)
    -- E₁-adv key Adv = {!E-sec!}

    postulate
      E₁-sec : ∀ {k} key → DetSemSec k (E₁ key)
    -- E₁-sec key Adv = {!E-sec key ?!}

    -- runDetSemSec enc adv b ≈ runDetSemSec enc' adv b

module game where

open import Level using (Lift) renaming (_⊔_ to _L⊔_)
open import Function.NP
open import Data.Nat.NP hiding (_==_)
open import Data.Product
open import Data.Maybe.NP
open import Data.List
open import Data.List.Any
open import Data.Bool
open import Relation.Binary.PropositionalEquality
open Membership-≡

{-
-- Game
data ⅁ ...
-}

{-
- cost
- non-det
- queries
- partial (like decryption with a mac)
-}

open import Data.Bits
open import flipbased

Bits⟨_⟩→_ : ∀ {a} → ℕ → Set a → Set a
Bits⟨ n ⟩→ A = Bits n → A

data Strategy (☐_ : Set → Set) (R : Set) : ∀ k → Set₁ where
  say : R → Strategy ☐_ R 0
  ask : ∀ {k} {A : Set} → ☐ A → (A → Strategy ☐_ R k) → Strategy ☐_ R k
  rnd : ∀ {n k} {A : Set} → ↺ n A → (A → Strategy ☐_ R k) → Strategy ☐_ R (n + k)

run : ∀ {k R} → Strategy id R k → ↺ k R
run (say r)    = ⟪ r ⟫
run (ask a f)  = run (f a)
run (rnd nd f) = nd >>= (λ xs → run (f xs))

postulate
      Proba : Set
      Pr[_≡1] : ∀ {k} (EXP : ↺ k Bit) → Proba
      _≡1/2^_ : Proba → ℕ → Set
      Pr[toss≡1] : Pr[ toss ≡1] ≡1/2^ 1
      Pr[random≡_] : ∀ {n} (x : Bits n) → Pr[ ⟪ _==_ x · random ⟫ ≡1] ≡1/2^ n
      negligible-proba : Proba
      negligible-advantage-proba : Proba → Proba → Set

_is-negligible : Proba → Set
p is-negligible = negligible-advantage-proba p negligible-proba

negligible-advantage : ∀ {k} (EXP : Bit → ↺ k Bit) → Set
negligible-advantage EXP = negligible-advantage-proba Pr[ EXP 0b ≡1] Pr[ EXP 1b ≡1]

postulate
  negligible-advantage-xor : ∀ {k} (EXP₁ EXP₂ : ↺ k Bit) → EXP₁ ≡ ⟪ _xor_ 1b · EXP₂ ⟫ → negligible-advantage-proba Pr[ EXP₁ ≡1] Pr[ EXP₂ ≡1]

  -- whatch out
  negligible-advantage-trans : ∀ {p₁ p₂ p₃} → negligible-advantage-proba p₁ p₂ → negligible-advantage-proba p₂ p₃ → negligible-advantage-proba p₁ p₃

pattern looks-random = 0b
pattern not-random   = 1b

EXP : ∀ {a b} {A : Set a} {B : Set b} → Bit → (A → B) → (A × A → B)
EXP 0b f (x₀ , x₁) = f x₀
EXP 1b f (x₀ , x₁) = f x₁

module CryptoGames where

  module CipherGames (|K| |M| |C| : ℕ) where
    K = Bits |K|
    M = Bits |M|
    C = Bits |C|

    record SemSecAdv k : Set where
      constructor mk
      field
        {k₀ k₁}   : ℕ
        k≡k₀+k₁  : k ≡ k₀ + k₁
        gen-m₀m₁  : ↺ k₀ (M × M)
        stat-test : C → ↺ k₁ Bit

    mk′ : ∀ {k₀ k₁} → ↺ k₀ (M × M) → (C → ↺ k₁ Bit) → SemSecAdv (k₀ + k₁)
    mk′ = mk refl

    module DeterministicSemanticSecurity where
      runDetSemSec : ∀ {k} (enc : M → C) → SemSecAdv k → Bit → ↺ k Bit
      runDetSemSec enc (mk refl gen-m₀m₁ f) b = gen-m₀m₁ >>= λ m₀m₁ → f (EXP b enc m₀m₁)

      DetSemSecWinner : ∀ (enc : M → C) b {k} (Adv : SemSecAdv k) → ↺ k Set
      DetSemSecWinner enc b Adv = ↺T (runDetSemSec enc Adv b)

      DetSemSec : ∀ k (enc : M → C) → Set
      DetSemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runDetSemSec enc Adv)

      luckySemSec : SemSecAdv 1
      luckySemSec = mk′ ⟪ 0ⁿ , 0ⁿ ⟫ᴰ (λ _ → toss)

      -- see OTPDetSemSec

    module DeterministicCPASecurity where
      DetCPAAdv : ∀ k → Set₁
      DetCPAAdv k = ∀ {☐_} (enc : M × M → ☐ C) → Strategy ☐_ Bit k

      data DetCPAWinner (enc : M × M → C) b (ms : List (M × M)) : ∀ {k} (q : ℕ) → Strategy id Bit k → Set₁ where
        win : ∀ {q} → DetCPAWinner enc b ms q (say b)
        ask : ∀ {k q m₀m₁ f} → m₀m₁ ∉ ms → DetCPAWinner enc b (m₀m₁ ∷ ms) q (f (enc m₀m₁)) →
              DetCPAWinner enc b ms {k} (suc q) (ask (enc m₀m₁) f)
        rnd : ∀ {A : Set} {n k q bs} {r : ↺ n A} {f : A → _}
              → DetCPAWinner enc b ms {k} q (f bs) → DetCPAWinner enc b ms q (rnd r f)

      runDetCPA : ∀ {k} (enc : M → C) (Adv : DetCPAAdv k) → Bit → ↺ k Bit
      runDetCPA enc Adv b = run (Adv (EXP b enc))

      -- no use of CPAWinner
      DetCPASec : ∀ k (enc : M → C) → Set₁
      DetCPASec k enc = ∀ (Adv : DetCPAAdv k) → negligible-advantage (runDetCPA enc Adv)

    CPAAdv : ∀ k → Set₁
    CPAAdv k = ∀ {☐_} (enc : M × M → ☐ (↺ |K| C)) → Strategy ☐_ Bit k

    sem2CPAAdv : ∀ {k} → SemSecAdv k → CPAAdv (|K| + k)
    sem2CPAAdv (mk {k₀} {k₁} refl gen-m₀m₁ f) {☐_} enc =
      subst (Strategy ☐_ Bit) helper
        (rnd gen-m₀m₁ (λ m₀m₁ →
          ask (enc m₀m₁) (λ c →
            rnd c (λ c' → rnd (f c') say))))
      where open import Data.Nat.Properties
            open SemiringSolver
            helper : k₀ + (|K| + (k₁ + 0)) ≡ |K| + (k₀ + k₁)
            helper = solve 3 (λ k₀ |K| k₁ → k₀ :+ (|K| :+ (k₁ :+ con 0)) := |K| :+ (k₀ :+ k₁))
                             refl k₀ |K| k₁

    data CPAWinner (enc : M × M → ↺ |K| C) b : ∀ {k} q → Strategy id Bit k → Set₁ where
      win : ∀ {q} → CPAWinner enc b q (say b)
      ask : ∀ {k q m₀m₁ f} → CPAWinner enc b {k} q (f (enc m₀m₁)) →
            CPAWinner enc b (suc q) (ask (enc m₀m₁) f)
      rnd : ∀ {A : Set} {n k q bs} {r : ↺ n A} {f : A → _}
            → CPAWinner enc b {k} q (f bs) → CPAWinner enc b q (rnd r f)

    det : ∀ {k a b} {A : Set a} {B : Set b} → (A → B) → A → ↺ k B
    det f x = ⟪ f x ⟫

    runCPA : ∀ {k} (enc : M → ↺ |K| C) (Adv : CPAAdv k) → Bit → ↺ k Bit
    runCPA enc Adv b = run (Adv (EXP b enc))

    -- no use of CPAWinner
    CPASec : ∀ k (enc : M → ↺ |K| C) → Set₁
    CPASec k enc = ∀ (Adv : CPAAdv k) → negligible-advantage (runCPA enc Adv)

    SemSecWinner : ∀ (enc : M × M → ↺ |K| C) b k → SemSecAdv k → Set₁
    SemSecWinner enc b k Adv = CPAWinner enc b 1 (sem2CPAAdv Adv enc)

    runSemSec : ∀ {k} (enc : M → ↺ |K| C) → SemSecAdv k → Bit → ↺ (|K| + k) Bit
    runSemSec enc Adv = runCPA enc (sem2CPAAdv Adv)

    -- no use of SemSecWinner
    SemSec : ∀ k (enc : M → ↺ |K| C) → Set
    SemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runSemSec enc Adv)

    weakenWinner : ∀ {enc b k q₀ q₁} {s : Strategy id Bit k} → CPAWinner enc b q₀ s → CPAWinner enc b (q₀ + q₁) s
    weakenWinner win     = win
    weakenWinner (ask w) = ask (weakenWinner w)
    weakenWinner (rnd {n = n} {k} {bs = bs} w) = rnd {n = n} {k} {bs = bs} (weakenWinner w)

    CPA2Sem-correct : ∀ {enc b k q} {semAdv : SemSecAdv k}
                      → SemSecWinner enc b k semAdv → CPAWinner enc b (suc q) (sem2CPAAdv semAdv enc)
    CPA2Sem-correct = weakenWinner

  record Forgery {a} {A : Set a} (P : A → Set) (queries : List A) : Set a where
    field
      forgery         : A
      fresh-forgery   : forgery ∉ queries
      correct-forgery : P forgery
  open Forgery public

  module MACGames (|M| |Tag| : ℕ) where
    M = Bits |M|
    Tag = Bits |Tag|

    -- One might also want that the adversary sends the trials to the challenger.
    -- The challenger might then either end the game or maybe return the info to
    -- the adversary.
    MACAdv : Set₁
    MACAdv = ∀ {☐_} (mac : M → ☐ Tag) → Strategy ☐_ (M × Tag) 0

    -- or
    -- MACAdv = ∀ {☐_ Done} (mac : M → ☐ Tag) (submit : M × Tag → ☐ Done) → Strategy ☐_ Done

    -- or
    -- MACAdv = ∀ {☐_ Done} (mac : M → ☐ Tag)
    --                       (try : M × Tag → ☐ Bool)
    --                       (submit : M × Tag → ☐ Done) → Strategy ☐_ Done

    module MACGames' (mac : M → Tag) where
      CorrectMAC : M × Tag → Set
      CorrectMAC (m , t) = mac m ≡ t

      correctMAC? : M × Tag → Bool
      correctMAC? (m , t) = mac m == t

      data MACWinner (mts : List (M × Tag)) : (q : ℕ) → Strategy id (M × Tag) 0 → Set₁ where
        win : ∀ {q} (f : Forgery CorrectMAC mts) → MACWinner mts q (say (forgery f))
        ask : ∀ {m f q} → MACWinner ((m , mac m) ∷ mts) q (f (mac m))
                        → MACWinner mts (suc q) (ask (mac m) f)

      SecMAC : Set₁
      SecMAC = ∀ (A : MACAdv) → Pr[ ⟪ correctMAC? · run (A mac) ⟫ ≡1] ≡1/2^ |Tag| -- check that bound

  module CiphertextIntegrity (M C : Set) where
    CIAdv : Set₁
    CIAdv = ∀ {☐_} (enc : M → ☐ C) → Strategy ☐_ C 0

    module CiphertextIntegrity' (enc : M → C) (dec : C →? M) where
      CorrectCiphertext : C → Set
      CorrectCiphertext c = IsJust (dec c)

      data CIWinner (cs : List C) : (q : ℕ) → Strategy id C 0 → Set₁ where
        win : ∀ {q} (f : Forgery CorrectCiphertext cs) → CIWinner cs q (say (forgery f))
        ask : ∀ {m f q} → CIWinner (enc m ∷ cs) q (f (enc m))
                        → CIWinner cs (suc q) (ask (enc m) f)

  module AuthenticatedEncryption (|K| |M| |C| : ℕ) where
    open CipherGames |K| |M| |C|
    open CiphertextIntegrity M C

    data AERes : Set where
      distinguish   : Bit → AERes
      found-forgery : C → AERes

    AEAdv : Set₁
    AEAdv = ∀ {☐_} (enc : M × M → ☐ C) → Strategy ☐_ AERes 0

    CCAAdv : Set₁
    CCAAdv = ∀ {☐_} (enc : M × M → ☐ C) (dec : C → ☐ (Maybe M)) → Strategy ☐_ Bit 0

    module AE' (enc : M × M → C) (dec : C →? M) where
      open CiphertextIntegrity' (λ m → enc (m , m)) dec

      data AEWinner (cs : List C) b : (q : ℕ) → Strategy id AERes 0 → Set₁ where
        win-distinguish : ∀ {q} → AEWinner cs b q (say (distinguish b))
        win-forgery : ∀ {q} (f : Forgery CorrectCiphertext cs)
                       → AEWinner cs b q (say (found-forgery (forgery f)))
        ask : ∀ {m₀m₁ f q} → AEWinner cs b q (f (enc m₀m₁)) →
              AEWinner cs b (suc q) (ask (enc m₀m₁) f)

      data CCAWinner b : (q : ℕ) → Strategy id Bit 0 → Set₁ where
        win : ∀ {q} → CCAWinner b q (say b)
        ask-enc : ∀ {m₀m₁ f q} → CCAWinner b q (f (enc m₀m₁)) →
                    CCAWinner b (suc q) (ask (enc m₀m₁) f)
        ask-dec : ∀ {c f q} → CCAWinner b q (f (dec c)) →
                    CCAWinner b (suc q) (ask (dec c) f)

  -- CBC with rand IV is not CCA secure

      -- AE ⇒ CCA Secure

  module OTPDetSemSec {n} (key : Bits n) where
    open CipherGames n n n
    open DeterministicSemanticSecurity

    postulate
      OTPDetSemSec : ∀ {k} → DetSemSec k (OTP key)
{-
    OTPDetSemSec (mk refl gen-m₀m₁ stat-test) = {!!}
    -- DetSemSec k enc = ∀ (Adv : SemSecAdv k) → negligible-advantage (runDetSemSec enc Adv)
    -- runDetSemSec enc (mk refl gen-m₀m₁ f) b = gen-m₀m₁ >>= λ m₀m₁ → f (EXP b enc m₀m₁)

Pr[ runDetSemSec enc Adv b ≡ b ]
-}

  Enc : ∀ |K| |M| |C| → Set
  Enc |K| |M| |C| = Bits |K| → Bits |M| → Bits |C|

  module DerivedBlockCiphers
    {|K| |M| |C|} {E : Enc |K| |M| |C|}
    (E-sec : ∀ {k} key → CipherGames.DeterministicSemanticSecurity.DetSemSec |K| |M| |C| k (E key)) where

    open module CipherGames' {|M| |C|} = CipherGames |K| |M| |C|
    open DeterministicSemanticSecurity

    E₀ : Enc |K| |M| |C|
    E₀ k m = 1ⁿ ⊕ E k m

    postulate
      lem' : ∀ {k} (Adv : SemSecAdv k) b (f : Bits k → Bits |C|) → runDetSemSec {k} (_⊕_ 1ⁿ ∘ f) Adv b ≡ ⟪ _xor_ 1b · runDetSemSec f Adv b ⟫
    -- lem' Adv b f = {!!}

      lem'' : ∀ {k} (Adv : SemSecAdv k) b (f : Bits k → Bits |C|) → ⟪ _xor_ 1b · runDetSemSec {k} (_⊕_ 1ⁿ ∘ f) Adv b ⟫ ≡ runDetSemSec f Adv b
    -- lem'' Adv b f = {!!}

    -- postulate
    E₀-sec : ∀ key → DetSemSec |M| (E₀ key)
    E₀-sec key Adv = negligible-advantage-trans (negligible-advantage-xor (runDetSemSec (E₀ key) Adv 0b) (runDetSemSec (E key) Adv 0b) (lem' Adv 0b (E key))) (negligible-advantage-trans (E-sec key Adv) (negligible-advantage-xor (runDetSemSec (E key) Adv 1b) (runDetSemSec (E₀ key) Adv 1b) (sym (lem'' Adv 1b (E key)))))

    E₁ : Enc |K| |M| (1 + |C|)
    E₁ k m = 0∷ E k m

    -- E₁-adv : ∀ {k} key → SemSecAdv k (E key) → SemSecAdv k (E₁ key)
    -- E₁-adv key Adv = {!E-sec!}

    postulate
      E₁-sec : ∀ {k} key → DetSemSec k (E₁ key)
    -- E₁-sec key Adv = {!E-sec key ?!}

    -- runDetSemSec enc adv b ≈ runDetSemSec enc' adv b


flat-funs: vector combinators!

flat-funs: vector combinators!

module flat-funs where

open import Data.Nat.NP
import Data.Vec as V
open V using (Vec; []; _∷_)
open import Data.Bits using (Bits)
import Level as L
import Function as F
open import composable
open import vcomp
open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    idO : ∀ {A} → A `→ A

    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)

    _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)

    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

    tt : ∀ {_A} → _A `→ `⊤

    nil : ∀ {_A B} → _A `→ `Vec B 0
    cons : ∀ {n A} → (A `× `Vec A n) `→ `Vec A (1 + n)

    uncons : ∀ {n A} → `Vec A (1 + n) `→ (A `× `Vec A n)

    constBits : ∀ {n _A} → Bits n → _A `→ `Bits n

  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > = f &&& g

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = f *** g

  swap : ∀ {A B} → (A `× B) `→ (B `× A)
  swap = < snd , fst >

  first : ∀ {A B C} → (A `→ C) → (A `× B) `→ (C `× B)
  first f = f *** idO

  second : ∀ {A B C} → (B `→ C) → (A `× B) `→ (A `× C)
  second f = idO *** f

  assoc : ∀ {A B C} → ((A `× B) `× C) `→ (A `× (B `× C))
  assoc = < fst >>> fst , first snd >

  assoc′ : ∀ {A B C} → (A `× (B `× C)) `→ ((A `× B) `× C)
  assoc′ = < second fst , snd >>> snd >

  `×-zip : ∀ {A B C D E F} → ((A `× B) `→ C)
                           → ((D `× E) `→ F)
                           → ((A `× D) `× (B `× E)) `→ (C `× F)
  `×-zip f g = < < fst >>> fst , snd >>> fst > >>> f ,
                 < fst >>> snd , snd >>> snd > >>> g >

  head : ∀ {n A} → `Vec A (1 + n) `→ A
  head = uncons >>> fst

  tail : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  tail = uncons >>> snd

  <_∷_> : ∀ {m n A B} → (A `→ B) → (`Vec A m `→ `Vec B n)
                  → `Vec A (1 + m) `→ `Vec B (1 + n)
  < f ∷ g > = uncons >>> < f × g > >>> cons

  <_∷′_> : ∀ {n A B} → (A `→ B) → (A `→ `Vec B n)
                     → A `→ `Vec B (1 + n)
  < f ∷′ g > = < f , g > >>> cons

  foldl : ∀ {n A B} → (B `× A `→ B) → (B `× `Vec A n) `→ B
  foldl {zero}  f = fst
  foldl {suc n} f = second uncons
                >>> assoc′
                >>> first f
                >>> foldl f

  foldl₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldl₁ f = uncons >>> foldl f

  foldr : ∀ {n A B} → (A `× B `→ B) → (`Vec A n `× B) `→ B
  foldr {zero}  f = snd
  foldr {suc n} f = first uncons
                >>> assoc
                >>> second (foldr f)
                >>> f

  foldr₁ : ∀ {n A} → (A `× A `→ A) → `Vec A (1 + n) `→ A
  foldr₁ f = uncons >>> swap >>> foldr f

  map : ∀ {n A B} → (A `→ B) → (`Vec A n `→ `Vec B n)
  map {zero}  f = nil
  map {suc n} f = < f ∷ map f >

  zipWith : ∀ {n A B C} → ((A `× B) `→ C)
                        → (`Vec A n `× `Vec B n) `→ `Vec C n
  zipWith {zero}  f = nil
  zipWith {suc n} f = < uncons × uncons >
                  >>> `×-zip f (zipWith f)
                  >>> cons

  zip : ∀ {n A B} → (`Vec A n `× `Vec B n) `→ `Vec (A `× B) n
  zip = zipWith idO

  singleton : ∀ {A} → A `→ `Vec A 1
  singleton = < idO , nil > >>> cons

  snoc : ∀ {n A} → (`Vec A n `× A) `→ `Vec A (1 + n)
  snoc {zero}  = snd >>> singleton
  snoc {suc n} = first uncons >>> assoc >>> second snoc >>> cons

  reverse : ∀ {n A} → `Vec A n `→ `Vec A n
  reverse {zero}  = nil
  reverse {suc n} = uncons >>> swap >>> first reverse >>> snoc

  append : ∀ {m n A} → (`Vec A m `× `Vec A n) `→ `Vec A (m + n)
  append {zero}  = snd
  append {suc m} = first uncons
               >>> assoc
               >>> second append
               >>> cons

  splitAt : ∀ m {n A} → `Vec A (m + n) `→ (`Vec A m `× `Vec A n)
  splitAt zero    = < nil , idO >
  splitAt (suc m) = uncons
                >>> second (splitAt m)
                >>> assoc′
                >>> first cons

  take : ∀ m {n A} → `Vec A (m + n) `→ `Vec A m
  take zero    = nil
  take (suc m) = < idO ∷ take m >

  drop : ∀ m {n A} → `Vec A (m + n) `→ `Vec A n
  drop zero    = idO
  drop (suc m) = tail >>> drop m

  folda : ∀ n {A} → (A `× A `→ A) → `Vec A (2^ n) `→ A
  folda zero    f = head
  folda (suc n) f = splitAt (2^ n) >>> < folda n f × folda n f > >>> f

  init : ∀ {n A} → `Vec A (1 + n) `→ `Vec A n
  init {zero}  = nil
  init {suc n} = < idO ∷ init >

  last : ∀ {n A} → `Vec A (1 + n) `→ A
  last {zero}  = head
  last {suc n} = tail >>> last

  concat : ∀ {m n A} → `Vec (`Vec A m) n `→ `Vec A (n * m)
  concat {n = zero}  = nil
  concat {n = suc n} = uncons >>> second concat >>> append

  group : ∀ {A} n k → `Vec A (n * k) `→ `Vec (`Vec A k) n
  group zero    k = nil
  group (suc n) k = splitAt k >>> second (group n k) >>> cons

  bind : ∀ {m n A B} → (A `→ `Vec B m) → `Vec A n `→ `Vec B (n * m)
  bind f = map f >>> concat

  ⊛ : ∀ {n A B} → Vec (A `→ B) n → `Vec A n `→ `Vec B n
  ⊛ []       = nil
  ⊛ (f ∷ fs) = uncons >>> < f × ⊛ fs > >>> cons

  replicate : ∀ {n A} → A `→ `Vec A n
  replicate {zero}  = nil
  replicate {suc n} = < idO , replicate > >>> cons

  module WithFin
    (`Fin : ℕ → T)
    (fz : ∀ {n _A} → _A `→ `Fin (suc n))
    (fs : ∀ {n} → `Fin n `→ `Fin (suc n))
    (elim-Fin0 : ∀ {A} → `Fin 0 `→ A)
    (elim-Fin1+ : ∀ {n A B} → (A `→ B) → (`Fin n `× A `→ B) → `Fin (suc n) `× A `→ B) where

    tabulate : ∀ {n A _B} → (`Fin n `→ A) → _B `→ `Vec A n
    tabulate {zero}  f = nil
    tabulate {suc n} f = < fz >>> f , tabulate (fs >>> f) > >>> cons

    lookup : ∀ {n A} → `Fin n `× `Vec A n `→ A
    lookup {zero}  = fst >>> elim-Fin0
    lookup {suc n} = elim-Fin1+ head (second tail >>> lookup)

    allFin : ∀ {n _A} → _A `→ `Vec (`Fin n) n
    allFin = tabulate idO

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
open import Data.Product renaming (zip to ×-zip; map to ×-map)
open import Function

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id (λ f g x → g (f x)) (λ f g → ×-map f g) _&&&_ proj₁ proj₂ _ (const []) (uncurry _∷_) uncons const
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)
  uncons : ∀ {n A} → Vec A (1 + n) → (A × Vec A n)
  uncons (x ∷ xs) = x , xs

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id (λ f g → g ∘ f) (VComposable._***_ bitsFunVComp) _&&&_ (λ {A} → take A)
                    (λ {A} → drop A) (const []) (const []) id id (λ xs _ → concat (map [_] xs) {- ugly? -})
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe
                           (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T = mk (S.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                        (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                        (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.cons)
                        (S.uncons , T.uncons) (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤ = mk (S.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                         (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                         (S.tt , T.tt) (S.nil , T.nil) (S.cons , T.idO)
                         (S.uncons , T.idO) (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ _⊔_ _⊔_ 0 0 0 0 0 0 (const 0)

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ _+_ _+_ 0 0 0 0 0 0 (λ {n} _ → n)

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps

module flat-funs where

open import Data.Nat
open import Data.Bits using (Bits)
import Level as L
import Function as F
open import composable
open import vcomp
open import universe

record FlatFuns {t} (T : Set t) : Set (L.suc t) where
  constructor mk
  field
    universe : Universe T
    _`→_    : T → T → Set
  infix 0 _`→_
  open Universe universe public

record FlatFunsOps {t} {T : Set t} (♭Funs : FlatFuns T) : Set t where
  constructor mk
  open FlatFuns ♭Funs
  infixr 1 _>>>_
  infixr 3 _***_
  infixr 3 _&&&_
  field
    idO : ∀ {A} → A `→ A

    _>>>_ : ∀ {A B C} → (A `→ B) → (B `→ C) → (A `→ C)

    _***_ : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)

    _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C

    fst : ∀ {A B} → A `× B `→ A
    snd : ∀ {A B} → A `× B `→ B

    constBits : ∀ {n} → Bits n → `⊤ `→ `Bits n

  <_,_> : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  < f , g > = f &&& g

  <_×_> : ∀ {A B C D} → (A `→ C) → (B `→ D) → (A `× B) `→ (C `× D)
  < f × g > = f *** g

open import Data.Unit using (⊤)
open import Data.Vec
open import Data.Bits
open import Data.Fin using (Fin) renaming (_+_ to _+ᶠ_)
open import Data.Product renaming (zip to ×-zip; map to ×-map)
open import Function

-→- : Set → Set → Set
-→- A B = A → B

_→ᶠ_ : ℕ → ℕ → Set
_→ᶠ_ i o = Fin i → Fin o

mapArr : ∀ {s t} {S : Set s} {T : Set t} (F G : T → S)
          → (S → S → Set) → (T → T → Set)
mapArr F G _`→_ A B = F A `→ G B

fun♭Funs : FlatFuns Set
fun♭Funs = mk Set-U -→-

bitsFun♭Funs : FlatFuns ℕ
bitsFun♭Funs = mk Bits-U _→ᵇ_

finFun♭Funs : FlatFuns ℕ
finFun♭Funs = mk Fin-U _→ᶠ_

fun♭Ops : FlatFunsOps fun♭Funs
fun♭Ops = mk id (λ f g x → g (f x)) (λ f g → ×-map f g) _&&&_ proj₁ proj₂ const
  where
  _&&&_ : ∀ {A B C : Set} → (A → B) → (A → C) → A → B × C
  (f &&& g) x = (f x , g x)

bitsFun♭Ops : FlatFunsOps bitsFun♭Funs
bitsFun♭Ops = mk id (λ f g → g ∘ f) (VComposable._***_ bitsFunVComp) _&&&_ (λ {A} → take A)
                    (λ {A} → drop A) (λ xs _ → xs ++ [] {- ugly? -})
  where
  open FlatFuns bitsFun♭Funs
  _&&&_ : ∀ {A B C} → (A `→ B) → (A `→ C) → A `→ B `× C
  (f &&& g) x = (f x ++ g x)

×-♭Funs : ∀ {s t} {S : Set s} {T : Set t} → FlatFuns S → FlatFuns T → FlatFuns (S × T)
×-♭Funs funs-S funs-T = mk (×-U S.universe T.universe)
                           (λ { (A₀ , A₁) (B₀ , B₁) → (A₀ S.`→ B₀) × (A₁ T.`→ B₁) })
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×⊤-♭Funs : ∀ {s} {S : Set s} → FlatFuns S → FlatFuns ⊤ → FlatFuns S
×⊤-♭Funs funs-S funs-T = mk S.universe
                           (λ A B → (A S.`→ B) × (_ T.`→ _))
  where module S = FlatFuns funs-S
        module T = FlatFuns funs-T

×-♭Ops : ∀ {s t} {S : Set s} {T : Set t} {funs-S : FlatFuns S} {funs-T : FlatFuns T}
         → FlatFunsOps funs-S → FlatFunsOps funs-T
         → FlatFunsOps (×-♭Funs funs-S funs-T)
×-♭Ops ops-S ops-T = mk (S.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                        (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                        (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-T
        open FlatFunsOps fun♭Ops

×⊤-♭Ops : ∀ {s} {S : Set s} {funs-S : FlatFuns S} {funs-⊤ : FlatFuns ⊤}
         → FlatFunsOps funs-S → FlatFunsOps funs-⊤
         → FlatFunsOps (×⊤-♭Funs funs-S funs-⊤)
×⊤-♭Ops ops-S ops-⊤ = mk (S.idO , T.idO) (×-zip S._>>>_ T._>>>_) (×-zip S._***_ T._***_)
                         (×-zip S._&&&_ T._&&&_) (S.fst , T.fst) (S.snd , T.snd)
                         (S.constBits &&& T.constBits)
  where module S = FlatFunsOps ops-S
        module T = FlatFunsOps ops-⊤
        open FlatFunsOps fun♭Ops

constFuns : Set → FlatFuns ⊤
constFuns A = mk ⊤-U (λ _ _ → A)

timeOps : FlatFunsOps (constFuns ℕ)
timeOps = mk 0 _+_ _⊔_ _⊔_ 0 0 (const 0)

spaceOps : FlatFunsOps (constFuns ℕ)
spaceOps = mk 0 _+_ _+_ _+_ 0 0 (λ {n} _ → n)

time×spaceOps : FlatFunsOps (constFuns (ℕ × ℕ))
time×spaceOps = ×⊤-♭Ops timeOps spaceOps


pisearch: P←Ind

pisearch: P←Ind

{-# OPTIONS --type-in-type #-}
module pisearch where
open import Type hiding (★_)
open import Function
open import Data.Product
open import Data.Sum
open import Data.Bool.NP
open import Search.Type
open import Search.Searchable.Product
open import Search.Searchable
open import sum

Π' : ∀ {A} → Search A → (A → ★) → ★
Π' sA B = sA _×_ B

Π : (A : ★₀) → (B : A → ★₀) → ★₀
Π A B = (x : A) → B x

P→ : ∀ {A} (sA : Search A) → ★₀
P→ {A} sA = ∀ {B} → Π' sA B → Π A B

P← : ∀ {A} (sA : Search A) → ★₀
P← {A} sA = ∀ {B} → Π A B → Π' sA B

P→Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x))
     → P→ sA
     → (∀ {x} → P→ (sB {x}))
     → P→ (ΣSearch sA (λ {x} → sB {x}))
P→Σ _ _ PA PB t = uncurry (PB ∘ PA t)

P←Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x))
      → P← sA
      → (∀ {x} → P← (sB {x}))
      → P← (ΣSearch sA (λ {x} → sB {x}))
P←Σ _ _ PA PB f = PA (PB ∘ curry f)

P→× : ∀ {A B} (sA : Search A) (sB : Search B) → P→ sA → P→ sB → P→ (sA ×Search sB)
P→× sA sB PA PB = P→Σ sA sB PA PB

P←× : ∀ {A B} (sA : Search A) (sB : Search B) → P← sA → P← sB → P← (sA ×Search sB)
P←× sA sB PA PB = P←Σ sA sB PA PB

P→Bit : P→ (search μBit)
P→Bit (f , t) false = f
P→Bit (f , t) true  = t

P←Bit : P← (search μBit)
P←Bit f = f false , f true

P→⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → P→ sA → P→ sB → P→ (sA +Search sB)
P→⊎ sA sB PA PB (t , u) (inj₁ x) = PA t x
P→⊎ sA sB PA PB (t , u) (inj₂ x) = PB u x

P←⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → P← sA → P← sB → P← (sA +Search sB)
P←⊎ sA sB PA PB f = PA (f ∘ inj₁) , PB (f ∘ inj₂)

-- P→Ind : ∀ {A} {sA : Search A} → SearchInd sA → P→ sA
-- P→Ind {A} {sA} indA {B} t = ?

P←Ind : ∀ {A} {sA : Search A} → SearchInd sA → P← sA
P←Ind indA = indA (λ s → Π' s _) _,_

{-# OPTIONS --type-in-type #-}
module pisearch where
open import Type hiding (★_)
open import Function
open import Data.Product
open import Data.Sum
open import Data.Bool.NP
open import Search.Type
open import Search.Searchable.Product
open import Search.Searchable
open import sum

Π' : ∀ {A} → Search A → (B : A → ★) → ★
Π' sA B = sA _×_ B

Π : (A : ★₀) → (B : A → ★₀) → ★₀
Π A B = (x : A) → B x

P→ : ∀ {A} (sA : Search A) → ★₀
P→ {A} sA = ∀ {B} → Π' sA B → Π A B

P← : ∀ {A} (sA : Search A) → ★₀
P← {A} sA = ∀ {B} → Π A B → Π' sA B

P→× : ∀ {A B} (sA : Search A) (sB : Search B) → P→ sA → P→ sB → P→ (sA ×Search sB)
P→× sA sB PA PB t (x , y) = PB (PA t x) y

P←× : ∀ {A B} (sA : Search A) (sB : Search B) → P← sA → P← sB → P← (sA ×Search sB)
P←× sA sB PA PB f = PA (λ x → PB (curry f x))

P→Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x)) → P→ sA → (∀ {x} → P→ (sB {x})) → P→ (ΣSearch sA (λ {x} → sB {x}))
P→Σ sA sB PA PB t (x , y) = PB (PA t x) y

P←Σ : ∀ {A} {B : A → ★} (sA : Search A) (sB : ∀ {x} → Search (B x)) → P← sA → (∀ {x} → P← (sB {x})) → P← (ΣSearch sA (λ {x} → sB {x}))
P←Σ sA sB PA PB f = PA (λ x → PB (curry f x))

P→Bit : P→ (search μBit)
P→Bit (f , t) false = f
P→Bit (f , t) true  = t

P←Bit : P← (search μBit)
P←Bit f = f false , f true

P→⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → P→ sA → P→ sB → P→ (sA +Search sB)
P→⊎ sA sB PA PB (t , u) (inj₁ x) = PA t x
P→⊎ sA sB PA PB (t , u) (inj₂ x) = PB u x

P←⊎ : ∀ {A B} (sA : Search A) (sB : Search B) → P← sA → P← sB → P← (sA +Search sB)
P←⊎ sA sB PA PB f = PA (f ∘ inj₁) , PB (f ∘ inj₂)


Fixed typo.

Fixed typo.

Ignore-this: 4ea02904e3ef7c53e5920ebc03362216

darcs-hash:20110513150633-3bd4e-18969dcf53bcc26c1aa0adf3fbb24637513eb69d.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module FOTC.Data.Nat.Inequalities.PropertiesATP where

open import FOTC.Base

open import Common.Function using ( _$_ )

open import FOTC.Data.Nat
  using ( _+_ ; _∸_ ; ∸-SS
        ; N ; sN ; zN  -- The FOTC natural numbers type
        )
open import FOTC.Data.Nat.Inequalities
  using ( <-00 ; <-0S ; <-S0 ; <-SS
        ; GE ; GT ; LE ; LT ; NGT ; NLE ; NLT
        ; LT₂
        )
open import FOTC.Data.Nat.Inequalities.Properties public
open import FOTC.Data.Nat.PropertiesATP
  using ( +-N ; ∸-N
        ; +-comm
        ; +-rightIdentity
        ; ∸-0x
        )

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

x≥0 : ∀ {n} → N n → GE n zero
x≥0 zN          = <-0S zero
x≥0 (sN {n} Nn) = <-0S $ succ n

0≤x : ∀ {n} → N n → LE zero n
0≤x Nn = x≥0 Nn

0≯x : ∀ {n} → N n → NGT zero n
0≯x zN          = <-00
0≯x (sN {n} Nn) = <-S0 n

x≰x : ∀ {n} → N n → NLT n n
x≰x zN          = <-00
x≰x (sN {n} Nn) = trans (<-SS n n) (x≰x Nn)

S≰0 : ∀ {n} → N n → NLE (succ n) zero
S≰0 zN          = x≰x (sN zN)
S≰0 (sN {n} Nn) = trans (<-SS (succ n) zero) (<-S0 n)

x<Sx : ∀ {n} → N n → LT n (succ n)
x<Sx zN          = <-0S zero
x<Sx (sN {n} Nn) = trans (<-SS n (succ n)) (x<Sx Nn)

postulate
  x<y→Sx<Sy : ∀ {m n} → LT m n → LT (succ m) (succ n)
{-# ATP prove x<y→Sx<Sy #-}

postulate
  Sx<Sy→x<y : ∀ {m n} → LT (succ m) (succ n) → LT m n
{-# ATP prove Sx<Sy→x<y #-}

x≤x : ∀ {n} → N n → LE n n
x≤x zN          = <-0S zero
x≤x (sN {n} Nn) = trans (<-SS n (succ n)) (x≤x Nn)

x≥x : ∀ {n} → N n → GE n n
x≥x Nn = x≤x Nn

x≤y→Sx≤Sy : ∀ {m n} → LE m n → LE (succ m) (succ n)
x≤y→Sx≤Sy {m} {n} m≤n = trans (<-SS m (succ n)) m≤n

postulate
  Sx≤Sy→x≤y : ∀ {m n} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≰y→Sx≰Sy : ∀ m n → NLE m n → NLE (succ m) (succ n)
x≰y→Sx≰Sy m n m≰n = trans (<-SS m (succ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → GT m n → LT n m
x>y→y<x zN          Nn          0>n   = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→y<x (sN {m} Nm) zN          _     = <-0S m
x>y→y<x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS n m) (x>y→y<x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → GE m n → NLT m n
x≥y→x≮y zN          zN          _     = x≰x zN
x≥y→x≮y zN          (sN Nn)     0≥Sn  = ⊥-elim $ 0≥S→⊥ Nn 0≥Sn
x≥y→x≮y (sN {m} Nm) zN          _     = <-S0 m
x≥y→x≮y (sN {m} Nm) (sN {n} Nn) Sm≥Sn =
  trans (<-SS m n) (x≥y→x≮y Nm Nn (trans (sym $ <-SS n (succ m)) Sm≥Sn))

x>y→x≰y : ∀ {m n} → N m → N n → GT m n → NLE m n
x>y→x≰y zN          Nn          0>m   = ⊥-elim $ 0>x→⊥ Nn 0>m
x>y→x≰y (sN Nm)     zN          _     = S≰0 Nm
x>y→x≰y (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

postulate
  x>y→x≤y→⊥ : ∀ {m n} → N m → N n → GT m n → LE m n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

x>y∨x≤y : ∀ {m n} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ <-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m>n → inj₁ (trans (<-SS n m) m>n))
  , (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
  ] (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → LT m n ∨ GE m n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x≤y∨x≰y : ∀ {m n} → N m → N n → LE m n ∨ NLE m n
x≤y∨x≰y zN Nn = inj₁ (0≤x Nn)
x≤y∨x≰y (sN Nm) zN = inj₂ (S≰0 Nm)
x≤y∨x≰y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
  , (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
  ] (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} {Nm : N m} {Nn : N n} → m ≡ n → LE m n
x≡y→x≤y {Nm = Nm} refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x≤y zN (sN {n} Nn)          _     = <-0S $ succ n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x≤y : ∀ {m n} → N m → N n → LT m (succ n) → LE m n
x<Sy→x≤y zN Nn 0<Sn       = 0≤x Nn
x<Sy→x≤y (sN Nm) Nn Sm<Sn = Sm<Sn

x≤y→x<Sy : ∀ {m n} → N m → N n → LE m n → LT m (succ n)
x≤y→x<Sy {n = n} zN      Nn 0≤n  = <-0S n
x≤y→x<Sy         (sN Nm) Nn Sm≤n = Sm≤n

x≤Sx : ∀ {m} → N m → LE m (succ m)
x≤Sx Nm = x<y→x≤y Nm (sN Nm) (x<Sx Nm)

x<y→Sx≤y : ∀ {m n} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→Sx≤y zN          (sN Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = trans (<-SS (succ m) (succ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim $ S≤0→⊥ Nm Sm≤0
Sx≤y→x<y zN          (sN {n} Nn) _      = <-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

x≤y→x≯y : ∀ {m n} → N m → N n → LE m n → NGT m n
x≤y→x≯y zN          Nn          0≤n   = 0≯x Nn
x≤y→x≯y (sN Nm)     zN          Sm≤0  = ⊥-elim (S≤0→⊥ Nm Sm≤0)
x≤y→x≯y (sN {m} Nm) (sN {n} Nn) Sm≤Sn =
  prf (x≤y→x≯y Nm Nn (trans (sym (<-SS m (succ n))) Sm≤Sn))
  where
    postulate prf : NGT m n →  -- IH.
                    NGT (succ m) (succ n)
    {-# ATP prove prf #-}

x≯y→x≤y : ∀ {m n} → N m → N n → NGT m n → LE m n
x≯y→x≤y zN          Nn          _     = 0≤x Nn
x≯y→x≤y (sN {m} Nm) zN          Sm≯0  = ⊥-elim (true≠false
                                                 (trans (sym (<-0S m)) Sm≯0))
x≯y→x≤y (sN {m} Nm) (sN {n} Nn) Sm≯Sn =
  prf (x≯y→x≤y Nm Nn (trans (sym (<-SS n m)) Sm≯Sn))
  where
    postulate prf : LE m n →  -- IH.
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

x>y∨x≯y : ∀ {m n} → N m → N n → GT m n ∨ NGT m n
x>y∨x≯y Nm Nn = [ (λ m>n → inj₁ m>n) ,
                  (λ m≤n → inj₂ (x≤y→x≯y Nm Nn m≤n))
                ] (x>y∨x≤y Nm Nn)

<-trans : ∀ {m n o} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN          _           0<0   _     = ⊥-elim $ 0<0→⊥ 0<0
<-trans zN          (sN Nn)     zN          _     Sn<0  = ⊥-elim $ S<0→⊥ Sn<0
<-trans zN          (sN Nn)     (sN {o} No) _     _     = <-0S o
<-trans (sN Nm)     Nn          zN          _     n<0   = ⊥-elim $ x<0→⊥ Nn n<0
<-trans (sN Nm)     zN          (sN No)     Sm<0  _     = ⊥-elim $ S<0→⊥ Sm<0
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy $ <-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So)

≤-trans : ∀ {m n o} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim $ S≤0→⊥ Nm Sm≤0
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim $ S≤0→⊥ Nn Sn≤0
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf $ x≤x+y Nm Nn
  where
    postulate prf : LE m (m + n) →  -- IH.
                    LE (succ m) (succ m + n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf #-}

x<x+Sy : ∀ {m n} → N m → N n → LT m (m + succ n)
x<x+Sy {n = n} zN Nn = prf0
  where
    postulate prf0 : LT zero (zero + succ n)
    {-# ATP prove prf0 #-}
x<x+Sy {n = n} (sN {m} Nm) Nn = prfS (x<x+Sy Nm Nn)
  where
    postulate prfS : LT m (m + succ n) → LT (succ m) (succ m + succ n)
    {-# ATP prove prfS #-}

k+x<k+y→x<y : ∀ {m n k} → N m → N n → N k → LT (k + m) (k + n) → LT m n
k+x<k+y→x<y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LT m n
    {-# ATP prove prf0 #-}
k+x<k+y→x<y {m} {n} Nm Nn (sN {k} Nk) h = k+x<k+y→x<y Nm Nn Nk prfS
  where
    postulate prfS : LT (k + m) (k + n)
    {-# ATP prove prfS #-}

postulate x+k<y+k→x<y : ∀ {m n k} → N m → N n → N k →
                        LT (m + k) (n + k) → LT m n
{-# ATP prove x+k<y+k→x<y k+x<k+y→x<y +-comm #-}

x≤y→k+x≤k+y : ∀ {m n k} → N m → N n → N k → LE m n → LE (k + m) (k + n)
x≤y→k+x≤k+y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LE (zero + m) (zero + n)
    {-# ATP prove prf0 #-}
x≤y→k+x≤k+y {m} {n} Nm Nn (sN {k} Nk) h = prfS (x≤y→k+x≤k+y Nm Nn Nk h)
  where
    postulate prfS : LE (k + m) (k + n) → LE (succ k + m) (succ k + n)
    {-# ATP prove prfS #-}

postulate x≤y→x+k≤y+k : ∀ {m n k} → N m → N n → N k → LE m n →
                        LE (m + k) (n + k)
{-# ATP prove x≤y→x+k≤y+k x≤y→k+x≤k+y +-comm #-}

x<y→Sx∸y≡0 : ∀ {m n} → N m → N n → LT m n → succ m ∸ n ≡ zero
x<y→Sx∸y≡0 Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→Sx∸y≡0 zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : succ zero ∸ succ n ≡ zero
    {-# ATP prove prf0S ∸-0x #-}
x<y→Sx∸y≡0 (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→Sx∸y≡0 Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : succ m ∸ n ≡ zero → succ (succ m) ∸ succ n ≡ zero
    {-# ATP prove prfSS #-}

postulate x≤y→x-y≡0 : ∀ {m n} → N m → N n → LE m n → (m ∸ n) ≡ zero
{-# ATP prove x≤y→x-y≡0 x<y→Sx∸y≡0 #-}

x<y→0<y∸x : ∀ {m n} → N m → N n → LT m n → LT zero (n ∸ m)
x<y→0<y∸x Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→0<y∸x zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : LT zero (succ n ∸ zero)
    {-# ATP prove prf0S #-}

x<y→0<y∸x (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→0<y∸x Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : LT zero (n ∸ m) → LT zero (succ n ∸ succ m)
    {-# ATP prove prfSS #-}

0<x∸y→0<Sx∸y : ∀ {m n} → N m → N n → LT zero (m ∸ n) → LT zero (succ m ∸ n)
0<x∸y→0<Sx∸y {m} Nm zN h = prfx0
  where
    postulate prfx0 : LT zero (succ m ∸ zero)
    {-# ATP prove prfx0 #-}

0<x∸y→0<Sx∸y zN (sN {n} Nn) h = ⊥-elim (x<0→⊥ zN h')
  where
    postulate h' : LT zero zero
    {-# ATP prove h' #-}

0<x∸y→0<Sx∸y (sN {m} Nm) (sN {n} Nn) h = prfSS (0<x∸y→0<Sx∸y Nm Nn 0<m-n)
  where
    postulate 0<m-n : LT zero (m ∸ n)
    {-# ATP prove 0<m-n #-}

    postulate prfSS : LT zero (succ m ∸ n) → LT zero (succ (succ m) ∸ succ n)
    {-# ATP prove prfSS <-trans #-}

x∸y<Sx : ∀ {m n} → N m → N n → LT (m ∸ n) (succ m)
x∸y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m ∸ zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x∸y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero ∸ succ n) (succ zero)
    {-# ATP prove prf #-}

x∸y<Sx (sN {m} Nm) (sN {n} Nn) = prf $ x∸y<Sx Nm Nn
  where
    postulate prf : LT (m ∸ n) (succ m) →  -- IH.
                    LT (succ m ∸ succ n) (succ (succ m))
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf <-trans ∸-N x<Sx #-}

postulate
  Sx∸Sy<Sx : ∀ {m n} → N m → N n → LT (succ m ∸ succ n) (succ m)
{-# ATP prove Sx∸Sy<Sx x∸y<Sx #-}

x<x∸y→⊥ : ∀ {m n} → N m → N n → ¬ (LT m (m ∸ n))
x<x∸y→⊥ {m} Nm zN m<m∸0 = prf
  where
    postulate prf : ⊥
    {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ zN (sN Nn) 0<0∸Sn = prf
 where
   postulate prf : ⊥
   {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ (sN Nm) (sN Nn) Sm<Sm∸Sn = prf
  where
    postulate prf : ⊥
    {-# ATP prove prf ∸-N x<y→y<x→⊥ x∸y<Sx #-}

x∸Sy≤x∸y : ∀ {m n} → N m → N n → LE (m ∸ succ n) (m ∸ n)
x∸Sy≤x∸y {n = n} zN Nn = prf
  where
    postulate prf : LE (zero ∸ succ n) (zero ∸ n)
    {-# ATP prove prf 0≤x #-}

x∸Sy≤x∸y (sN {m} Nm) zN = prf
  where
    postulate prf : LE (succ m ∸ succ zero) (succ m ∸ zero)
    {-# ATP prove prf x≤Sx #-}

x∸Sy≤x∸y (sN {m} Nm) (sN {n} Nn) = prf (x∸Sy≤x∸y Nm Nn)
  where
    postulate prf : LE (m ∸ succ n) (m ∸ n) →  -- IH.
                    LE (succ m ∸ succ (succ n)) (succ m ∸ (succ n))
    {-# ATP prove prf #-}

x>y→x∸y+y≡x : ∀ {m n} → N m → N n → GT m n → (m ∸ n) + n ≡ m
x>y→x∸y+y≡x zN          Nn 0>n  = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→x∸y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m ∸ zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x∸y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf $ x>y→x∸y+y≡x Nm Nn m>n
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m ∸ n) + n ≡ m →  -- IH.
                    (succ m ∸ succ n) + succ n ≡ succ m
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n ∸ zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y∸x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim $ S≤0→⊥ Nm Sm≤0

x≤y→y∸x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf $ x≤y→y∸x+x≡y Nm Nn m≤n
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                    (succ n ∸ succ m) + succ m ≡ succ n
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}

x<y→x<Sy : ∀ {m n} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = <-0S $ succ n
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (<-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim $ x<0→⊥ Nm (trans (sym $ <-SS m zero) Sm<S0)
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (<-SS m n) m<n))
  , (λ m≡n → inj₂ (cong succ m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym $ <-SS m (succ n)) Sm<SSn)

x≤y→x<y∨x≡y : ∀ {m n} → N m → N n → LE m n → LT m n ∨ m ≡ n
x≤y→x<y∨x≡y = x<Sy→x<y∨x≡y

postulate
  x<y→y≡z→x<z : ∀ {m n o} → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : ∀ {m n o} → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

x≯Sy→x≯y∨x≡Sy : ∀ {m n} → N m → N n → NGT m (succ n) → NGT m n ∨ m ≡ succ n
x≯Sy→x≯y∨x≡Sy {m} {n} Nm Nn m≯Sn =
  [ (λ m<Sn → inj₁ (x≤y→x≯y Nm Nn (x<Sy→x≤y Nm Nn m<Sn)))
  , (λ m≡Sn → inj₂ m≡Sn)
  ]
  (x<Sy→x<y∨x≡y Nm (sN Nn) (x≤y→x<Sy Nm (sN Nn) (x≯y→x≤y Nm (sN Nn) m≯Sn)))

x≥y→y>0→x∸y<x : ∀ {m n} → N m → N n → GE m n → GT n zero → LT (m ∸ n) m
x≥y→y>0→x∸y<x Nm          zN          _     0>0  = ⊥-elim $ x>x→⊥ zN 0>0
x≥y→y>0→x∸y<x zN          (sN Nn)     0≥Sn  _    = ⊥-elim $ S≤0→⊥ Nn 0≥Sn
x≥y→y>0→x∸y<x (sN {m} Nm) (sN {n} Nn) Sm≥Sn Sn>0 = prf
  where
    postulate prf : LT (succ m ∸ succ n) (succ m)
    {-# ATP prove prf x∸y<Sx #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → LE n o → LT m o
x<y→y≤z→x<z Nm Nn No m<n n≤o =
  [ (λ n<o → <-trans Nm Nn No m<n n<o)
  , (λ n≡o → x<y→y≡z→x<z m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)

x≤y+x∸y : ∀ {m n} → N m → N n → LE m (n + (m ∸ n))
x≤y+x∸y {n = n} zN Nn = prf0
  where postulate prf0 : LE zero (n + (zero ∸ n))
        {-# ATP prove prf0 0≤x +-N  #-}
x≤y+x∸y (sN {m} Nm) zN = prfx0
  where postulate prfx0 : LE (succ m) (zero + (succ m ∸ zero))
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x∸y (sN {m} Nm) (sN {n} Nn) = prfSS (x≤y+x∸y Nm Nn)
  where postulate prfSS : LE m (n + (m ∸ n)) →  -- IH.
                          LE (succ m) (succ n + (succ m ∸ succ n))
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N #-}

x∸y<x∸z→Sx∸y<Sx∸z : ∀ {m n o} → N m → N n → N o →
                    LT (m ∸ n) (m ∸ o) → LT (succ m ∸ n) (succ m ∸ o)
x∸y<x∸z→Sx∸y<Sx∸z {n = n} {o} zN Nn No 0∸n<0∸o = prf
  where
    postulate prf : LT (succ zero ∸ n) (succ zero ∸ o)
    {-# ATP prove prf ∸-0x 0<0→⊥ #-}

x∸y<x∸z→Sx∸y<Sx∸z {o = o} (sN {m} Nm) zN No Sm∸0<Sm∸o = prf
  where
    postulate prf : LT (succ (succ m) ∸ zero) (succ (succ m) ∸ o)
    {-# ATP prove prf x<x∸y→⊥ #-}

x∸y<x∸z→Sx∸y<Sx∸z (sN {m} Nm) (sN {n} Nn) zN Sm∸Sn<Sm∸0 = prf
  where
    postulate prf : LT (succ (succ m) ∸ succ n) (succ (succ m) ∸ zero)
    {-# ATP prove prf Sx∸Sy<Sx #-}

x∸y<x∸z→Sx∸y<Sx∸z (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm∸Sn<Sm∸So =
  prf (x∸y<x∸z→Sx∸y<Sx∸z Nm Nn No)
  where
    postulate
      prf : (LT (m ∸ n) (m ∸ o) → LT (succ m ∸ n) (succ m ∸ o)) →  -- IH.
            LT (succ (succ m) ∸ succ n) (succ (succ m) ∸ succ o)
    {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  xy<00→⊥ : ∀ {m n} → N m → N n → ¬ (LT₂ m n zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy<00→⊥ x<0→⊥ #-}

postulate
  Sxy₁<0y₂→⊥ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove Sxy₁<0y₂→⊥ x<0→⊥ #-}

postulate
  0Sx<00→⊥ : ∀ {m} → N m → ¬ (LT₂ zero (succ m) zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove 0Sx<00→⊥ x<0→⊥ #-}

postulate
  x₁y<x₂0→x₁<x₂ : ∀ {m₁ n m₂} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove x₁y<x₂0→x₁<x₂ x<0→⊥ #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ x<0→⊥ #-}

[Sx∸Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
[Sx∸Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}

[Sx,Sy∸Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
[Sx,Sy∸Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module FOTC.Data.Nat.Inequalities.PropertiesATP where

open import FOTC.Base

open import Common.Function using ( _$_ )

open import FOTC.Data.Nat
  using ( _+_ ; _∸_ ; ∸-SS
        ; N ; sN ; zN  -- The FOTC natural numbers type
        )
open import FOTC.Data.Nat.Inequalities
  using ( <-00 ; <-0S ; <-S0 ; <-SS
        ; GE ; GT ; LE ; LT ; NGT ; NLE ; NLT
        ; LT₂
        )
open import FOTC.Data.Nat.Inequalities.Properties public
open import FOTC.Data.Nat.PropertiesATP
  using ( +-N ; ∸-N
        ; +-comm
        ; +-rightIdentity
        ; ∸-0x
        )

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

x≥0 : ∀ {n} → N n → GE n zero
x≥0 zN          = <-0S zero
x≥0 (sN {n} Nn) = <-0S $ succ n

0≤x : ∀ {n} → N n → LE zero n
0≤x Nn = x≥0 Nn

0≯x : ∀ {n} → N n → NGT zero n
0≯x zN          = <-00
0≯x (sN {n} Nn) = <-S0 n

x≰x : ∀ {n} → N n → NLT n n
x≰x zN          = <-00
x≰x (sN {n} Nn) = trans (<-SS n n) (x≰x Nn)

S≰0 : ∀ {n} → N n → NLE (succ n) zero
S≰0 zN          = x≰x (sN zN)
S≰0 (sN {n} Nn) = trans (<-SS (succ n) zero) (<-S0 n)

x<Sx : ∀ {n} → N n → LT n (succ n)
x<Sx zN          = <-0S zero
x<Sx (sN {n} Nn) = trans (<-SS n (succ n)) (x<Sx Nn)

postulate
  x<y→Sx<Sy : ∀ {m n} → LT m n → LT (succ m) (succ n)
{-# ATP prove x<y→Sx<Sy #-}

postulate
  Sx<Sy→x<y : ∀ {m n} → LT (succ m) (succ n) → LT m n
{-# ATP prove Sx<Sy→x<y #-}

x≤x : ∀ {n} → N n → LE n n
x≤x zN          = <-0S zero
x≤x (sN {n} Nn) = trans (<-SS n (succ n)) (x≤x Nn)

x≥x : ∀ {n} → N n → GE n n
x≥x Nn = x≤x Nn

x≤y→Sx≤Sy : ∀ {m n} → LE m n → LE (succ m) (succ n)
x≤y→Sx≤Sy {m} {n} m≤n = trans (<-SS m (succ n)) m≤n

postulate
  Sx≤Sy→x≤y : ∀ {m n} → LE (succ m) (succ n) → LE m n
{-# ATP prove Sx≤Sy→x≤y #-}

x≰y→Sx≰Sy : ∀ m n → NLE m n → NLE (succ m) (succ n)
x≰y→Sx≰Sy m n m≰n = trans (<-SS m (succ n)) m≰n

x>y→y<x : ∀ {m n} → N m → N n → GT m n → LT n m
x>y→y<x zN          Nn          0>n   = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→y<x (sN {m} Nm) zN          _     = <-0S m
x>y→y<x (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  trans (<-SS n m) (x>y→y<x Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

x≥y→x≮y : ∀ {m n} → N m → N n → GE m n → NLT m n
x≥y→x≮y zN          zN          _     = x≰x zN
x≥y→x≮y zN          (sN Nn)     0≥Sn  = ⊥-elim $ 0≥S→⊥ Nn 0≥Sn
x≥y→x≮y (sN {m} Nm) zN          _     = <-S0 m
x≥y→x≮y (sN {m} Nm) (sN {n} Nn) Sm≥Sn =
  trans (<-SS m n) (x≥y→x≮y Nm Nn (trans (sym $ <-SS n (succ m)) Sm≥Sn))

x>y→x≰y : ∀ {m n} → N m → N n → GT m n → NLE m n
x>y→x≰y zN          Nn          0>m   = ⊥-elim $ 0>x→⊥ Nn 0>m
x>y→x≰y (sN Nm)     zN          _     = S≰0 Nm
x>y→x≰y (sN {m} Nm) (sN {n} Nn) Sm>Sn =
  x≰y→Sx≰Sy m n (x>y→x≰y Nm Nn (trans (sym $ <-SS n m) Sm>Sn))

postulate
  x>y→x≤y→⊥ : ∀ {m n} → N m → N n → GT m n → LE m n → ⊥
{-# ATP prove x>y→x≤y→⊥ x>y→x≰y #-}

x>y∨x≤y : ∀ {m n} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ <-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m>n → inj₁ (trans (<-SS n m) m>n))
  , (λ m≤n → inj₂ (x≤y→Sx≤Sy m≤n))
  ] (x>y∨x≤y Nm Nn)

x<y∨x≥y : ∀ {m n} → N m → N n → LT m n ∨ GE m n
x<y∨x≥y Nm Nn = x>y∨x≤y Nn Nm

x≤y∨x≰y : ∀ {m n} → N m → N n → LE m n ∨ NLE m n
x≤y∨x≰y zN Nn = inj₁ (0≤x Nn)
x≤y∨x≰y (sN Nm) zN = inj₂ (S≰0 Nm)
x≤y∨x≰y (sN {m} Nm) (sN {n} Nn) =
  [ (λ m≤n → inj₁ (x≤y→Sx≤Sy m≤n))
  , (λ m≰n → inj₂ (x≰y→Sx≰Sy m n m≰n))
  ] (x≤y∨x≰y Nm Nn)

x≡y→x≤y : ∀ {m n} {Nm : N m} {Nn : N n} → m ≡ n → LE m n
x≡y→x≤y {Nm = Nm} refl = x≤x Nm

x<y→x≤y : ∀ {m n} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x≤y zN (sN {n} Nn)          _     = <-0S $ succ n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x≤y→Sx≤Sy (x<y→x≤y Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x≤y : ∀ {m n} → N m → N n → LT m (succ n) → LE m n
x<Sy→x≤y zN Nn 0<Sn       = 0≤x Nn
x<Sy→x≤y (sN Nm) Nn Sm<Sn = Sm<Sn

x≤y→x<Sy : ∀ {m n} → N m → N n → LE m n → LT m (succ n)
x≤y→x<Sy {n = n} zN      Nn 0≤n  = <-0S n
x≤y→x<Sy         (sN Nm) Nn Sm≤n = Sm≤n

x≤Sx : ∀ {m} → N m → LE m (succ m)
x≤Sx Nm = x<y→x≤y Nm (sN Nm) (x<Sx Nm)

x<y→Sx≤y : ∀ {m n} → N m → N n → LT m n → LE (succ m) n
x<y→Sx≤y Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→Sx≤y zN          (sN Nn)     0<Sn  = x≤y→Sx≤Sy (0≤x Nn)
x<y→Sx≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = trans (<-SS (succ m) (succ n)) Sm<Sn

Sx≤y→x<y : ∀ {m n} → N m → N n → LE (succ m) n → LT m n
Sx≤y→x<y Nm          zN          Sm≤0   = ⊥-elim $ S≤0→⊥ Nm Sm≤0
Sx≤y→x<y zN          (sN {n} Nn) _      = <-0S n
Sx≤y→x<y (sN {m} Nm) (sN {n} Nn) SSm≤Sn =
  x<y→Sx<Sy (Sx≤y→x<y Nm Nn (Sx≤Sy→x≤y SSm≤Sn))

x≤y→x≯y : ∀ {m n} → N m → N n → LE m n → NGT m n
x≤y→x≯y zN          Nn          0≤n   = 0≯x Nn
x≤y→x≯y (sN Nm)     zN          Sm≤0  = ⊥-elim (S≤0→⊥ Nm Sm≤0)
x≤y→x≯y (sN {m} Nm) (sN {n} Nn) Sm≤Sn =
  prf (x≤y→x≯y Nm Nn (trans (sym (<-SS m (succ n))) Sm≤Sn))
  where
    postulate prf : NGT m n →  -- IH.
                    NGT (succ m) (succ n)
    {-# ATP prove prf #-}

x≯y→x≤y : ∀ {m n} → N m → N n → NGT m n → LE m n
x≯y→x≤y zN          Nn          _     = 0≤x Nn
x≯y→x≤y (sN {m} Nm) zN          Sm≯0  = ⊥-elim (true≠false
                                                 (trans (sym (<-0S m)) Sm≯0))
x≯y→x≤y (sN {m} Nm) (sN {n} Nn) Sm≯Sn =
  prf (x≯y→x≤y Nm Nn (trans (sym (<-SS n m)) Sm≯Sn))
  where
    postulate prf : LE m n →  -- IH.
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

x>y∨x≯y : ∀ {m n} → N m → N n → GT m n ∨ NGT m n
x>y∨x≯y Nm Nn = [ (λ m>n → inj₁ m>n) ,
                  (λ m≤n → inj₂ (x≤y→x≯y Nm Nn m≤n))
                ] (x>y∨x≤y Nm Nn)

<-trans : ∀ {m n o} → N m → N n → N o → LT m n → LT n o → LT m o
<-trans zN          zN          _           0<0   _     = ⊥-elim $ 0<0→⊥ 0<0
<-trans zN          (sN Nn)     zN          _     Sn<0  = ⊥-elim $ S<0→⊥ Sn<0
<-trans zN          (sN Nn)     (sN {o} No) _     _     = <-0S o
<-trans (sN Nm)     Nn          zN          _     n<0   = ⊥-elim $ x<0→⊥ Nn n<0
<-trans (sN Nm)     zN          (sN No)     Sm<0  _     = ⊥-elim $ S<0→⊥ Sm<0
<-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  x<y→Sx<Sy $ <-trans Nm Nn No (Sx<Sy→x<y Sm<Sn) (Sx<Sy→x<y Sn<So)

≤-trans : ∀ {m n o} → N m → N n → N o → LE m n → LE n o → LE m o
≤-trans zN      Nn              No          _     _     = 0≤x No
≤-trans (sN Nm) zN              No          Sm≤0  _     = ⊥-elim $ S≤0→⊥ Nm Sm≤0
≤-trans (sN Nm) (sN Nn)         zN          _     Sn≤0  = ⊥-elim $ S≤0→⊥ Nn Sn≤0
≤-trans (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm≤Sn Sn≤So =
  x≤y→Sx≤Sy (≤-trans Nm Nn No (Sx≤Sy→x≤y Sm≤Sn) (Sx≤Sy→x≤y Sn≤So))

x≤x+y : ∀ {m n} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf $ x≤x+y Nm Nn
  where
    postulate prf : LE m (m + n) →  -- IH.
                    LE (succ m) (succ m + n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf #-}

x<x+Sy : ∀ {m n} → N m → N n → LT m (m + succ n)
x<x+Sy {n = n} zN Nn = prf0
  where
    postulate prf0 : LT zero (zero + succ n)
    {-# ATP prove prf0 #-}
x<x+Sy {n = n} (sN {m} Nm) Nn = prfS (x<x+Sy Nm Nn)
  where
    postulate prfS : LT m (m + succ n) → LT (succ m) (succ m + succ n)
    {-# ATP prove prfS #-}

k+x<k+y→x<y : ∀ {m n k} → N m → N n → N k → LT (k + m) (k + n) → LT m n
k+x<k+y→x<y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LT m n
    {-# ATP prove prf0 #-}
k+x<k+y→x<y {m} {n} Nm Nn (sN {k} Nk) h = k+x<k+y→x<y Nm Nn Nk prfS
  where
    postulate prfS : LT (k + m) (k + n)
    {-# ATP prove prfS #-}

postulate x+k<y+k→x<y : ∀ {m n k} → N m → N n → N k →
                        LT (m + k) (n + k) → LT m n
{-# ATP prove x+k<y+k→x<y k+x<k+y→x<y +-comm #-}

x≤y→k+x≤k+y : ∀ {m n k} → N m → N n → N k → LE m n → LE (k + m) (k + n)
x≤y→k+x≤k+y {m} {n} Nm Nn zN h = prf0
  where
    postulate prf0 : LE (zero + m) (zero + n)
    {-# ATP prove prf0 #-}
x≤y→k+x≤k+y {m} {n} Nm Nn (sN {k} Nk) h = prfS (x≤y→k+x≤k+y Nm Nn Nk h)
  where
    postulate prfS : LE (k + m) (k + n) → LE (succ k + m) (succ k + n)
    {-# ATP prove prfS #-}

postulate x≤y→x+k≤y+k : ∀ {m n k} → N m → N n → N k → LE m n →
                        LE (m + k) (n + k)
{-# ATP prove x≤y→x+k≤y+k x≤y→k+x≤k+y +-comm #-}

x<y→Sx∸y≡0 : ∀ {m n} → N m → N n → LT m n → succ m ∸ n ≡ zero
x<y→Sx∸y≡0 Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→Sx∸y≡0 zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : succ zero ∸ succ n ≡ zero
    {-# ATP prove prf0S ∸-0x #-}
x<y→Sx∸y≡0 (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→Sx∸y≡0 Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : succ m ∸ n ≡ zero → succ (succ m) ∸ succ n ≡ zero
    {-# ATP prove prfSS #-}

postulate x≤y→x-y≡0 : ∀ {m n} → N m → N n → LE m n → (m ∸ n) ≡ zero
{-# ATP prove x≤y→x-y≡0 x<y→Sx∸y≡0 #-}

x<y→0<y∸x : ∀ {m n} → N m → N n → LT m n → LT zero (n ∸ m)
x<y→0<y∸x Nm zN h = ⊥-elim (x<0→⊥ Nm h)
x<y→0<y∸x zN (sN {n} Nn) h = prf0S
  where
    postulate prf0S : LT zero (succ n ∸ zero)
    {-# ATP prove prf0S #-}

x<y→0<y∸x (sN {m} Nm) (sN {n} Nn) h = prfSS (x<y→0<y∸x Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prfSS : LT zero (n ∸ m) → LT zero (succ n ∸ succ m)
    {-# ATP prove prfSS #-}

0<x∸y→0<Sx∸y : ∀ {m n} → N m → N n → LT zero (m ∸ n) → LT zero (succ m ∸ n)
0<x∸y→0<Sx∸y {m} Nm zN h = prfx0
  where
    postulate prfx0 : LT zero (succ m ∸ zero)
    {-# ATP prove prfx0 #-}

0<x∸y→0<Sx∸y zN (sN {n} Nn) h = ⊥-elim (x<0→⊥ zN h')
  where
    postulate h' : LT zero zero
    {-# ATP prove h' #-}

0<x∸y→0<Sx∸y (sN {m} Nm) (sN {n} Nn) h = prfSS (0<x∸y→0<Sx∸y Nm Nn 0<m-n)
  where
    postulate 0<m-n : LT zero (m ∸ n)
    {-# ATP prove 0<m-n #-}

    postulate prfSS : LT zero (succ m ∸ n) → LT zero (succ (succ m) ∸ succ n)
    {-# ATP prove prfSS <-trans #-}

x∸y<Sx : ∀ {m n} → N m → N n → LT (m ∸ n) (succ m)
x∸y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m ∸ zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x∸y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero ∸ succ n) (succ zero)
    {-# ATP prove prf #-}

x∸y<Sx (sN {m} Nm) (sN {n} Nn) = prf $ x∸y<Sx Nm Nn
  where
    postulate prf : LT (m ∸ n) (succ m) →  -- IH.
                    LT (succ m ∸ succ n) (succ (succ m))
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf <-trans ∸-N x<Sx #-}

postulate
  Sx∸Sy<Sx : ∀ {m n} → N m → N n → LT (succ m ∸ succ n) (succ m)
{-# ATP prove Sx∸Sy<Sx x∸y<Sx #-}

x<x∸y→⊥ : ∀ {m n} → N m → N n → ¬ (LT m (m ∸ n))
x<x∸y→⊥ {m} Nm zN m<m∸0 = prf
  where
    postulate prf : ⊥
    {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ zN (sN Nn) 0<0∸Sn = prf
 where
   postulate prf : ⊥
   {-# ATP prove prf x<x→⊥ #-}
x<x∸y→⊥ (sN Nm) (sN Nn) Sm<Sm∸Sn = prf
  where
    postulate prf : ⊥
    {-# ATP prove prf ∸-N x<y→y<x→⊥ x∸y<Sx #-}

x∸Sy≤x∸y : ∀ {m n} → N m → N n → LE (m ∸ succ n) (m ∸ n)
x∸Sy≤x∸y {n = n} zN Nn = prf
  where
    postulate prf : LE (zero ∸ succ n) (zero ∸ n)
    {-# ATP prove prf 0≤x #-}

x∸Sy≤x∸y (sN {m} Nm) zN = prf
  where
    postulate prf : LE (succ m ∸ succ zero) (succ m ∸ zero)
    {-# ATP prove prf x≤Sx #-}

x∸Sy≤x∸y (sN {m} Nm) (sN {n} Nn) = prf (x∸Sy≤x∸y Nm Nn)
  where
    postulate prf : LE (m ∸ succ n) (m ∸ n) →  -- IH.
                    LE (succ m ∸ succ (succ n)) (succ m ∸ (succ n))
    {-# ATP prove prf #-}

x>y→x∸y+y≡x : ∀ {m n} → N m → N n → GT m n → (m ∸ n) + n ≡ m
x>y→x∸y+y≡x zN          Nn 0>n  = ⊥-elim $ 0>x→⊥ Nn 0>n
x>y→x∸y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m ∸ zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x>y→x∸y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf $ x>y→x∸y+y≡x Nm Nn m>n
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m ∸ n) + n ≡ m →  -- IH.
                    (succ m ∸ succ n) + succ n ≡ succ m
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}

x≤y→y∸x+x≡y : ∀ {m n} → N m → N n → LE m n → (n ∸ m) + m ≡ n
x≤y→y∸x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n ∸ zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity ∸-N #-}

x≤y→y∸x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim $ S≤0→⊥ Nm Sm≤0

x≤y→y∸x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf $ x≤y→y∸x+x≡y Nm Nn m≤n
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n ∸ m) + m ≡ n →  -- IH.
                    (succ n ∸ succ m) + succ m ≡ succ n
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    -- Vampire 0.6 (revision 903): No-success (using timeout 180 sec).
    {-# ATP prove prf +-comm ∸-N #-}

x<y→x<Sy : ∀ {m n} → N m → N n → LT m n → LT m (succ n)
x<y→x<Sy Nm          zN          m<0   = ⊥-elim $ x<0→⊥ Nm m<0
x<y→x<Sy zN          (sN {n} Nn) 0<Sn  = <-0S $ succ n
x<y→x<Sy (sN {m} Nm) (sN {n} Nn) Sm<Sn =
  x<y→Sx<Sy (x<y→x<Sy Nm Nn (Sx<Sy→x<y Sm<Sn))

x<Sy→x<y∨x≡y : ∀ {m n} → N m → N n → LT m (succ n) → LT m n ∨ m ≡ n
x<Sy→x<y∨x≡y zN zN 0<S0 = inj₂ refl
x<Sy→x<y∨x≡y zN (sN {n} Nn) 0<SSn = inj₁ (<-0S n)
x<Sy→x<y∨x≡y (sN {m} Nm) zN Sm<S0 =
  ⊥-elim $ x<0→⊥ Nm (trans (sym $ <-SS m zero) Sm<S0)
x<Sy→x<y∨x≡y (sN {m} Nm) (sN {n} Nn) Sm<SSn =
  [ (λ m<n → inj₁ (trans (<-SS m n) m<n))
  , (λ m≡n → inj₂ (cong succ m≡n))
  ]
  m<n∨m≡n

  where
    m<n∨m≡n : LT m n ∨ m ≡ n
    m<n∨m≡n = x<Sy→x<y∨x≡y Nm Nn (trans (sym $ <-SS m (succ n)) Sm<SSn)

x≤y→x<y∨x≡y : ∀ {m n} → N m → N n → LE m n → LT m n ∨ m ≡ n
x≤y→x<y∨x≡y = x<Sy→x<y∨x≡y

postulate
  x<y→y≡z→x<z : ∀ {m n o} → LT m n → n ≡ o → LT m o
{-# ATP prove x<y→y≡z→x<z #-}

postulate
  x≡y→y<z→x<z : ∀ {m n o} → m ≡ n → LT n o → LT m o
{-# ATP prove x≡y→y<z→x<z #-}

x≯Sy→x≯y∨x≡y : ∀ {m n} → N m → N n → NGT m (succ n) → NGT m n ∨ m ≡ succ n
x≯Sy→x≯y∨x≡y {m} {n} Nm Nn m≯Sn =
  [ (λ m<Sn → inj₁ (x≤y→x≯y Nm Nn (x<Sy→x≤y Nm Nn m<Sn)))
  , (λ m≡Sn → inj₂ m≡Sn)
  ]
  (x<Sy→x<y∨x≡y Nm (sN Nn) (x≤y→x<Sy Nm (sN Nn) (x≯y→x≤y Nm (sN Nn) m≯Sn)))

x≥y→y>0→x∸y<x : ∀ {m n} → N m → N n → GE m n → GT n zero → LT (m ∸ n) m
x≥y→y>0→x∸y<x Nm          zN          _     0>0  = ⊥-elim $ x>x→⊥ zN 0>0
x≥y→y>0→x∸y<x zN          (sN Nn)     0≥Sn  _    = ⊥-elim $ S≤0→⊥ Nn 0≥Sn
x≥y→y>0→x∸y<x (sN {m} Nm) (sN {n} Nn) Sm≥Sn Sn>0 = prf
  where
    postulate prf : LT (succ m ∸ succ n) (succ m)
    {-# ATP prove prf x∸y<Sx #-}

x<y→y≤z→x<z : ∀ {m n o} → N m → N n → N o → LT m n → LE n o → LT m o
x<y→y≤z→x<z Nm Nn No m<n n≤o =
  [ (λ n<o → <-trans Nm Nn No m<n n<o)
  , (λ n≡o → x<y→y≡z→x<z m<n n≡o)
  ] (x<Sy→x<y∨x≡y Nn No n≤o)

x≤y+x∸y : ∀ {m n} → N m → N n → LE m (n + (m ∸ n))
x≤y+x∸y {n = n} zN Nn = prf0
  where postulate prf0 : LE zero (n + (zero ∸ n))
        {-# ATP prove prf0 0≤x +-N  #-}
x≤y+x∸y (sN {m} Nm) zN = prfx0
  where postulate prfx0 : LE (succ m) (zero + (succ m ∸ zero))
        {-# ATP prove prfx0 x<Sx #-}
x≤y+x∸y (sN {m} Nm) (sN {n} Nn) = prfSS (x≤y+x∸y Nm Nn)
  where postulate prfSS : LE m (n + (m ∸ n)) →  -- IH.
                          LE (succ m) (succ n + (succ m ∸ succ n))
        {-# ATP prove prfSS x≤y→Sx≤Sy ≤-trans +-N ∸-N #-}

x∸y<x∸z→Sx∸y<Sx∸z : ∀ {m n o} → N m → N n → N o →
                    LT (m ∸ n) (m ∸ o) → LT (succ m ∸ n) (succ m ∸ o)
x∸y<x∸z→Sx∸y<Sx∸z {n = n} {o} zN Nn No 0∸n<0∸o = prf
  where
    postulate prf : LT (succ zero ∸ n) (succ zero ∸ o)
    {-# ATP prove prf ∸-0x 0<0→⊥ #-}

x∸y<x∸z→Sx∸y<Sx∸z {o = o} (sN {m} Nm) zN No Sm∸0<Sm∸o = prf
  where
    postulate prf : LT (succ (succ m) ∸ zero) (succ (succ m) ∸ o)
    {-# ATP prove prf x<x∸y→⊥ #-}

x∸y<x∸z→Sx∸y<Sx∸z (sN {m} Nm) (sN {n} Nn) zN Sm∸Sn<Sm∸0 = prf
  where
    postulate prf : LT (succ (succ m) ∸ succ n) (succ (succ m) ∸ zero)
    {-# ATP prove prf Sx∸Sy<Sx #-}

x∸y<x∸z→Sx∸y<Sx∸z (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm∸Sn<Sm∸So =
  prf (x∸y<x∸z→Sx∸y<Sx∸z Nm Nn No)
  where
    postulate
      prf : (LT (m ∸ n) (m ∸ o) → LT (succ m ∸ n) (succ m ∸ o)) →  -- IH.
            LT (succ (succ m) ∸ succ n) (succ (succ m) ∸ succ o)
    {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Properties about LT₂

postulate
  xy<00→⊥ : ∀ {m n} → N m → N n → ¬ (LT₂ m n zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy<00→⊥ x<0→⊥ #-}

postulate
  Sxy₁<0y₂→⊥ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → ¬ (LT₂ (succ m) n₁ zero n₂)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove Sxy₁<0y₂→⊥ x<0→⊥ #-}

postulate
  0Sx<00→⊥ : ∀ {m} → N m → ¬ (LT₂ zero (succ m) zero zero)
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove 0Sx<00→⊥ x<0→⊥ #-}

postulate
  x₁y<x₂0→x₁<x₂ : ∀ {m₁ n m₂} → N m₁ → N n → N m₂ → LT₂ m₁ n m₂ zero → LT m₁ m₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove x₁y<x₂0→x₁<x₂ x<0→⊥ #-}

postulate
  xy₁<0y₂→x≡0∧y₁<y₂ : ∀ {m n₁ n₂} → N m → N n₁ → N n₂ → LT₂ m n₁ zero n₂ →
                      m ≡ zero ∧ LT n₁ n₂
-- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
{-# ATP prove xy₁<0y₂→x≡0∧y₁<y₂ x<0→⊥ #-}

[Sx∸Sy,Sy]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
[Sx∸Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m ∸ succ n) (succ n) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}

[Sx,Sy∸Sx]<[Sx,Sy] : ∀ {m n} → N m → N n →
                     LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
[Sx,Sy∸Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n ∸ succ m) (succ m) (succ n)
    -- Metis 2.3 (release 20101019): SZS status Unknown (using timeout 180 sec).
    {-# ATP prove prf x∸y<Sx #-}


Lift right zero

Lift right 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
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 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₁
    ∎)

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

-- 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₁ ⟩ -- TODO: make nicer?
      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₁
    ∎)

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