------------------------------------------------------------------------
-- The Agda standard library
--
-- A categorical view of N-ary products
------------------------------------------------------------------------

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

module Data.Product.N-ary.Categorical where

open import Agda.Builtin.Nat
open import Data.Product hiding (map)
open import Data.Product.N-ary
open import Function

open import Category.Functor
open import Category.Applicative
open import Category.Monad

------------------------------------------------------------------------
-- Functor and applicative

functor : ∀ {ℓ} n → RawFunctor {ℓ} (_^ n)
functor n = record { _<$>_ = λ f → map f n }

applicative : ∀ {ℓ} n → RawApplicative {ℓ} (_^ n)
applicative n = record
  { pure = replicate n
  ; _⊛_  = ap n
  }

------------------------------------------------------------------------
-- Get access to other monadic functions

module _ {f F} (App : RawApplicative {f} F) where

  open RawApplicative App

  sequenceA : ∀ {n A} → F A ^ n → F (A ^ n)
  sequenceA {0}    _          = pure _
  sequenceA {1}    fa         = fa
  sequenceA {2+ n} (fa , fas) = _,_ <$> fa ⊛ sequenceA fas

  mapA : ∀ {n a} {A : Set a} {B} → (A → F B) → A ^ n → F (B ^ n)
  mapA f = sequenceA ∘ map f _

  forA : ∀ {n a} {A : Set a} {B} → A ^ n → (A → F B) → F (B ^ n)
  forA = flip mapA

module _ {m M} (Mon : RawMonad {m} M) where

  private App = RawMonad.rawIApplicative Mon

  sequenceM : ∀ {n A} → M A ^ n → M (A ^ n)
  sequenceM = sequenceA App

  mapM : ∀ {n a} {A : Set a} {B} → (A → M B) → A ^ n → M (B ^ n)
  mapM = mapA App

  forM : ∀ {n a} {A : Set a} {B} → A ^ n → (A → M B) → M (B ^ n)
  forM = forA App


module GGT.Group.Definitions
  {a ℓ}
  where

open import Relation.Unary using (Pred)
open import Algebra.Bundles using (Group)
open import Level

IsOpInvClosed : {l : Level} → (G : Group a ℓ) → (Pred (Group.Carrier G) l) → Set (a ⊔ l)
IsOpInvClosed G P = ∀ {x y : Carrier} → P x → P y → P (x - y) where open Group G


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

open import LogicalFormulae
open import Categories.Definition

module Categories.Dual.Definition where

dual : {a b : _} → Category {a} {b} → Category {a} {b}
dual record { objects = objects ; arrows = arrows ; id = id ; _∘_ = _∘_ ; rightId = rightId ; leftId = leftId ; compositionAssociative = associative } = record { objects = objects ; arrows = λ i j → arrows j i ; id = id ; _∘_ = λ {x y z} g f → f ∘ g ; rightId = λ {x y} f → leftId f ; leftId = λ {x y} f → rightId f ; compositionAssociative = λ {x y z w} f g h → equalityCommutative (associative h g f) }


-- {-# OPTIONS -v tc.meta:30 #-}

module GiveSize where

{-# BUILTIN SIZE Size #-}

postulate
  A : Size → Set
  c : ∀ i → A i

k : ∀ i → A i
k i = c {!i!}


{-# OPTIONS --safe #-}

module Cubical.Data.SumFin.Properties where

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

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit
import Cubical.Data.Fin as Fin
open import Cubical.Data.Nat
open import Cubical.Data.SumFin.Base as SumFin
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation

private
  variable
    ℓ : Level
    k : ℕ

SumFin→Fin : Fin k → Fin.Fin k
SumFin→Fin = SumFin.elim (λ {k} _ → Fin.Fin k) Fin.fzero Fin.fsuc

Fin→SumFin : Fin.Fin k → Fin k
Fin→SumFin = Fin.elim (λ {k} _ → Fin k) fzero fsuc

Fin→SumFin-fsuc : (fk : Fin.Fin k) → Fin→SumFin (Fin.fsuc fk) ≡ fsuc (Fin→SumFin fk)
Fin→SumFin-fsuc = Fin.elim-fsuc (λ {k} _ → Fin k) fzero fsuc

SumFin→Fin→SumFin : (fk : Fin k) → Fin→SumFin (SumFin→Fin fk) ≡ fk
SumFin→Fin→SumFin = SumFin.elim (λ fk → Fin→SumFin (SumFin→Fin fk) ≡ fk)
                                refl λ {k} {fk} eq →
  Fin→SumFin (Fin.fsuc (SumFin→Fin fk)) ≡⟨ Fin→SumFin-fsuc (SumFin→Fin fk) ⟩
  fsuc (Fin→SumFin (SumFin→Fin fk))     ≡⟨ cong fsuc eq ⟩
  fsuc fk                               ∎

Fin→SumFin→Fin : (fk : Fin.Fin k) → SumFin→Fin (Fin→SumFin fk) ≡ fk
Fin→SumFin→Fin = Fin.elim (λ fk → SumFin→Fin (Fin→SumFin fk) ≡ fk)
                          refl λ {k} {fk} eq →
  SumFin→Fin (Fin→SumFin (Fin.fsuc fk)) ≡⟨ cong SumFin→Fin (Fin→SumFin-fsuc fk) ⟩
  Fin.fsuc (SumFin→Fin (Fin→SumFin fk)) ≡⟨ cong Fin.fsuc eq ⟩
  Fin.fsuc fk                           ∎

SumFin≃Fin : ∀ k → Fin k ≃ Fin.Fin k
SumFin≃Fin _ =
  isoToEquiv (iso SumFin→Fin Fin→SumFin Fin→SumFin→Fin SumFin→Fin→SumFin)

SumFin≡Fin : ∀ k → Fin k ≡ Fin.Fin k
SumFin≡Fin k = ua (SumFin≃Fin k)

-- Closure properties of SumFin under type constructors

private
  _⋆_ = compEquiv

infixr 30 _⋆_

SumFin⊎≃ : (m n : ℕ) → (Fin m ⊎ Fin n) ≃ (Fin (m + n))
SumFin⊎≃ 0 n = ⊎-swap-≃ ⋆ ⊎-⊥-≃
SumFin⊎≃ (suc m) n = ⊎-assoc-≃ ⋆ ⊎-equiv (idEquiv ⊤) (SumFin⊎≃ m n)

SumFinΣ≃ : (n : ℕ)(f : Fin n → ℕ) → (Σ (Fin n) (λ x → Fin (f x))) ≃ (Fin (totalSum f))
SumFinΣ≃ 0 f = ΣEmpty _
SumFinΣ≃ (suc n) f =
    Σ⊎≃
  ⋆ ⊎-equiv (ΣUnit (λ tt → Fin (f (inl tt)))) (SumFinΣ≃ n (λ x → f (inr x)))
  ⋆ SumFin⊎≃ (f (inl tt)) (totalSum (λ x → f (inr x)))

SumFin×≃ : (m n : ℕ) → (Fin m × Fin n) ≃ (Fin (m · n))
SumFin×≃ m n = SumFinΣ≃ m (λ _ → n) ⋆ pathToEquiv (λ i → Fin (totalSumConst {m = m} n i))

SumFinΠ≃ : (n : ℕ)(f : Fin n → ℕ) → ((x : Fin n) → Fin (f x)) ≃ (Fin (totalProd f))
SumFinΠ≃ 0 f = isContr→≃Unit (isContrΠ⊥) ⋆ invEquiv (⊎-⊥-≃)
SumFinΠ≃ (suc n) f =
    Π⊎≃
  ⋆ Σ-cong-equiv (ΠUnit (λ tt → Fin (f (inl tt)))) (λ _ → SumFinΠ≃ n (λ x → f (inr x)))
  ⋆ SumFin×≃ (f (inl tt)) (totalProd (λ x → f (inr x)))

isNotZero : ℕ → ℕ
isNotZero 0 = 0
isNotZero (suc n) = 1

SumFin∥∥≃ : (n : ℕ) → ∥ Fin n ∥ ≃ Fin (isNotZero n)
SumFin∥∥≃ 0 = propTruncIdempotent≃ (isProp⊥)
SumFin∥∥≃ (suc n) =
    isContr→≃Unit (inhProp→isContr ∣ inl tt ∣ isPropPropTrunc)
  ⋆ isContr→≃Unit (isContrUnit) ⋆ invEquiv (⊎-⊥-≃)


------------------------------------------------------------------------------
-- The Booleans properties
------------------------------------------------------------------------------

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

module FOTC.Data.Bool.PropertiesI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Bool
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.Type

------------------------------------------------------------------------------
-- Congruence properties

&&-leftCong : ∀ {a b c} → a ≡ b → a && c ≡ b && c
&&-leftCong refl = refl

&&-rightCong : ∀ {a b c} → b ≡ c → a && b ≡ a && c
&&-rightCong refl = refl

&&-cong : ∀ {a b c d } → a ≡ c → b ≡ d → a && b ≡ c && d
&&-cong refl refl = refl

notCong : ∀ {a b} → a ≡ b → not a ≡ not b
notCong refl = refl

------------------------------------------------------------------------------
-- Basic properties

t&&x≡x : ∀ b → true && b ≡ b
t&&x≡x b = if-true b

f&&x≡f : ∀ b → false && b ≡ false
f&&x≡f b = if-false false

not-t : not true ≡ false
not-t = if-true false

not-f : not false ≡ true
not-f = if-false true

&&-Bool : ∀ {a b} → Bool a → Bool b → Bool (a && b)
&&-Bool {b = b} btrue  Bb = subst Bool (sym (t&&x≡x b)) Bb
&&-Bool {b = b} bfalse Bb = subst Bool (sym (f&&x≡f b)) bfalse

not-Bool : ∀ {b} → Bool b → Bool (not b)
not-Bool btrue  = subst Bool (sym not-t) bfalse
not-Bool bfalse = subst Bool (sym not-f) btrue

&&-comm : ∀ {a b} → Bool a → Bool b → a && b ≡ b && a
&&-comm btrue  btrue  = refl
&&-comm btrue  bfalse = trans (t&&x≡x false) (sym (f&&x≡f true))
&&-comm bfalse btrue  = trans (f&&x≡f true) (sym (t&&x≡x false))
&&-comm bfalse bfalse = refl

&&-assoc : ∀ {a b c} → Bool a → Bool b → Bool c → (a && b) && c ≡ a && b && c
&&-assoc btrue btrue btrue = &&-cong (t&&x≡x true) (sym (t&&x≡x true))
&&-assoc btrue btrue bfalse = &&-cong (t&&x≡x true) (sym (t&&x≡x false))
&&-assoc btrue bfalse btrue =
  (true && false) && true ≡⟨ &&-comm (&&-Bool btrue bfalse) btrue ⟩
  true && (true && false) ≡⟨ t&&x≡x (true && false) ⟩
  true && false           ≡⟨ &&-rightCong (sym (f&&x≡f true)) ⟩
  true && false && true   ∎
&&-assoc btrue bfalse bfalse =
  (true && false) && false ≡⟨ &&-comm (&&-Bool btrue bfalse) bfalse ⟩
  false && (true && false) ≡⟨ f&&x≡f (true && false) ⟩
  false                    ≡⟨ sym (f&&x≡f false) ⟩
  false && false           ≡⟨ sym (t&&x≡x (false && false)) ⟩
  true && false && false   ∎
&&-assoc bfalse btrue btrue = &&-cong (f&&x≡f true) (sym (t&&x≡x true))
&&-assoc bfalse btrue bfalse = &&-cong (f&&x≡f true) (sym (t&&x≡x false))
&&-assoc bfalse bfalse btrue =
  (false && false) && true ≡⟨ &&-comm (&&-Bool bfalse bfalse) btrue ⟩
  true && (false && false) ≡⟨ t&&x≡x (false && false) ⟩
  false && false           ≡⟨ f&&x≡f false ⟩
  false                    ≡⟨ sym (f&&x≡f (false && true)) ⟩
  false && false && true   ∎
&&-assoc bfalse bfalse bfalse = &&-cong (f&&x≡f false) (sym (f&&x≡f false))

&&-list₂-t : ∀ {a b} → Bool a → Bool b → a && b ≡ true → a ≡ true ∧ b ≡ true
&&-list₂-t btrue  btrue  h = refl , refl
&&-list₂-t btrue  bfalse h = ⊥-elim (t≢f (trans (sym h) (t&&x≡x false)))
&&-list₂-t bfalse btrue  h = ⊥-elim (t≢f (trans (sym h) (f&&x≡f true)))
&&-list₂-t bfalse bfalse h = ⊥-elim (t≢f (trans (sym h) (f&&x≡f false)))

&&-list₂-t₁ : ∀ {a b} → Bool a → Bool b → a && b ≡ true → a ≡ true
&&-list₂-t₁ Ba Bb h = ∧-proj₁ (&&-list₂-t Ba Bb h)

&&-list₂-t₂ : ∀ {a b} → Bool a → Bool b → a && b ≡ true → b ≡ true
&&-list₂-t₂ Ba Bb h = ∧-proj₂ (&&-list₂-t Ba Bb h)

&&-list₂-all-t : ∀ {a b} → Bool a → Bool b →
                 (a ≡ true ∧ b ≡ true) →
                 a && b ≡ true
&&-list₂-all-t btrue  btrue  h         = t&&x≡x true
&&-list₂-all-t btrue  bfalse (h₁ , h₂) = ⊥-elim (t≢f (sym h₂))
&&-list₂-all-t bfalse Bb     (h₁ , h₂) = ⊥-elim (t≢f (sym h₁))

&&-list₃-all-t : ∀ {a b c} → Bool a → Bool b → Bool c →
                 a ≡ true ∧ b ≡ true ∧ c ≡ true →
                 a && b && c ≡ true
&&-list₃-all-t btrue btrue btrue h = trans (t&&x≡x (true && true)) (t&&x≡x true)
&&-list₃-all-t btrue btrue bfalse (h₁ , h₂ , h₃) = ⊥-elim (t≢f (sym h₃))
&&-list₃-all-t btrue bfalse Bc (h₁ , h₂ , h₃) = ⊥-elim (t≢f (sym h₂))
&&-list₃-all-t bfalse Bb Bc (h₁ , h₂ , h₃) = ⊥-elim (t≢f (sym h₁))

&&-list₄-all-t : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
                 a ≡ true ∧ b ≡ true ∧ c ≡ true ∧ d ≡ true →
                 a && b && c && d ≡ true
&&-list₄-all-t btrue btrue btrue btrue h =
  trans₂ (t&&x≡x (true && true && true)) (t&&x≡x (true && true)) (t&&x≡x true)
&&-list₄-all-t btrue btrue btrue bfalse (h₁ , h₂ , h₃ , h₄) = ⊥-elim (t≢f (sym h₄))
&&-list₄-all-t btrue btrue bfalse Bd (h₁ , h₂ , h₃ , h₄) = ⊥-elim (t≢f (sym h₃))
&&-list₄-all-t btrue bfalse Bc Bd (h₁ , h₂ , h₃ , h₄) = ⊥-elim (t≢f (sym h₂))
&&-list₄-all-t bfalse Bb Bc Bd (h₁ , h₂ , h₃ , h₄) = ⊥-elim (t≢f (sym h₁))

&&-list₄-some-f : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
                  a ≡ false ∨ b ≡ false ∨ c ≡ false ∨ d ≡ false →
                  a && b && c && d ≡ false
&&-list₄-some-f btrue Bb Bc Bd (inj₁ h) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue Bc Bd (inj₂ (inj₁ h)) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue Bd (inj₂ (inj₂ (inj₁ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue btrue (inj₂ (inj₂ (inj₂ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue btrue bfalse (inj₂ (inj₂ (inj₂ h))) =
  trans (t&&x≡x (true && true && false))
        (trans (t&&x≡x (true && false)) (t&&x≡x false))
&&-list₄-some-f btrue btrue bfalse btrue (inj₂ (inj₂ (inj₁ h))) =
  trans (t&&x≡x (true && false && true))
        (trans (t&&x≡x (false && true)) (f&&x≡f true))
&&-list₄-some-f btrue btrue bfalse btrue (inj₂ (inj₂ (inj₂ h))) = ⊥-elim (t≢f h)
&&-list₄-some-f btrue btrue bfalse bfalse (inj₂ (inj₂ h)) =
  trans (t&&x≡x (true && false && false))
        (trans (t&&x≡x (false && false)) (f&&x≡f false))
&&-list₄-some-f {c = c} {d} btrue bfalse Bc Bd (inj₂ h) =
  trans (t&&x≡x (false && c && d)) (f&&x≡f (c && d))
&&-list₄-some-f {b = b} {c} {d} bfalse Bb Bc Bd _ = f&&x≡f (b && c && d)

&&-list₄-t : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
             a && b && c && d ≡ true →
             a ≡ true ∧ b ≡ true ∧ c ≡ true ∧ d ≡ true
&&-list₄-t btrue btrue btrue btrue h = refl , refl , refl , refl
&&-list₄-t btrue btrue btrue bfalse h =
  ⊥-elim (t≢f
           (trans (sym h)
                  (&&-list₄-some-f btrue btrue btrue bfalse (inj₂ (inj₂ (inj₂ refl))))))
&&-list₄-t btrue btrue bfalse Bd h =
  ⊥-elim (t≢f
           (trans (sym h)
                  (&&-list₄-some-f btrue btrue bfalse Bd (inj₂ (inj₂ (inj₁ refl))))))
&&-list₄-t btrue bfalse Bc Bd h =
  ⊥-elim (t≢f
           (trans (sym h) (&&-list₄-some-f btrue bfalse Bc Bd (inj₂ (inj₁ refl)))))
&&-list₄-t bfalse Bb Bc Bd h =
  ⊥-elim (t≢f (trans (sym h) (&&-list₄-some-f bfalse Bb Bc Bd (inj₁ refl))))

&&-list₄-t₁ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → a ≡ true
&&-list₄-t₁ Ba Bb Bc Bd h = ∧-proj₁ (&&-list₄-t Ba Bb Bc Bd h)

&&-list₄-t₂ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → b ≡ true
&&-list₄-t₂ Ba Bb Bc Bd h = ∧-proj₁ (∧-proj₂ (&&-list₄-t Ba Bb Bc Bd h))

&&-list₄-t₃ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → c ≡ true
&&-list₄-t₃ Ba Bb Bc Bd h =
  ∧-proj₁ (∧-proj₂ (∧-proj₂ (&&-list₄-t Ba Bb Bc Bd h)))

&&-list₄-t₄ : ∀ {a b c d} → Bool a → Bool b → Bool c → Bool d →
              a && b && c && d ≡ true → d ≡ true
&&-list₄-t₄ Ba Bb Bc Bd h =
  ∧-proj₂ (∧-proj₂ (∧-proj₂ (&&-list₄-t Ba Bb Bc Bd h)))

x≢not-x : ∀ {b} → Bool b → b ≢ not b
x≢not-x btrue  h = t≢f (trans h not-t)
x≢not-x bfalse h = t≢f (sym (trans h not-f))

not-x≢x : ∀ {b} → Bool b → not b ≢ b
not-x≢x Bb h = x≢not-x Bb (sym h)

not-involutive : ∀ {b} → Bool b → not (not b) ≡ b
not-involutive btrue  = trans (notCong not-t) not-f
not-involutive bfalse = trans (notCong not-f) not-t

------------------------------------------------------------------------------
-- Properties with inequalities

lt-Bool : ∀ {m n} → N m → N n → Bool (lt m n)
lt-Bool nzero          nzero          = subst Bool (sym lt-00) bfalse
lt-Bool nzero          (nsucc {n} Nn) = subst Bool (sym (lt-0S n)) btrue
lt-Bool (nsucc {m} Nm) nzero          = subst Bool (sym (lt-S0 m)) bfalse
lt-Bool (nsucc {m} Nm) (nsucc {n} Nn) = subst Bool (sym (lt-SS m n)) (lt-Bool Nm Nn)

le-Bool : ∀ {m n} → N m → N n → Bool (le m n)
le-Bool {n = n} nzero          Nn             = subst Bool (sym (lt-0S n)) btrue
le-Bool         (nsucc Nm)     nzero          = subst Bool (sym (Sx≰0 Nm)) bfalse
le-Bool         (nsucc {m} Nm) (nsucc {n} Nn) =
  subst Bool (sym (lt-SS m (succ₁ n))) (le-Bool Nm Nn)


-- Copyright:  (c) 2016 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <esz@posteo.de>

module Algebra.Category.Category where

open import Algebra.Category.Semigroupoid
open import Core

-- A category is a semigroupoid with an identity morphism on every
-- object.

record Category {c h r} : Set (lsuc (c ⊔ h ⊔ r)) where
  field semigroupoid : Semigroupoid {c} {h} {r}
  open Semigroupoid semigroupoid public

  field
    id : ∀ {A} → Hom A A
    left-id  : ∀ {A B} (f : Hom A B) → id ∘ f ≈ f
    right-id : ∀ {A B} (f : Hom A B) → f ∘ id ≈ f

  -- The identity morphism is unique for each object.
  id-unique :
    ∀ {A} {id' : Hom A A}
    → id' ∘ id ≈ id
    → id' ≈ id
  id-unique {id' = id'} left-id' =
    begin
      id'      ≈[ sym (right-id _) ]
      id' ∘ id ≈[ left-id' ]
      id
    qed

  private
    ∘-monic :
      ∀ {A B C} {f : Hom B C} {g : Hom A B}
      → Monic f
      → Monic g
      → Monic (f ∘ g)
    ∘-monic {f = f} {g} pf pg {g1 = g1} {g2} p =
      pg $ pf $
      begin
        f ∘ (g ∘ g1)  ≈[ sym (assoc f g g1) ]
        f ∘ g ∘ g1    ≈[ p ]
        f ∘ g ∘ g2    ≈[ assoc f g g2 ]
        f ∘ (g ∘ g2)
      qed

  BimonicEq : Equiv Ob
  BimonicEq =
    record {
      _≈_ = _bimonic_;
      refl = record {
        to = id;
        from = id;
        to-monic = id-monic;
        from-monic = id-monic
      };
      sym = λ m →
        let module m = _bimonic_ m in
        record {
          to = m.from;
          from = m.to;
          to-monic = m.from-monic;
          from-monic = m.to-monic
        };
      trans = λ m1 m2 →
        let module m1 = _bimonic_ m1
            module m2 = _bimonic_ m2 in
        record {
          to = m2.to ∘ m1.to;
          from = m1.from ∘ m2.from;
          to-monic = ∘-monic m2.to-monic m1.to-monic;
          from-monic = ∘-monic m1.from-monic m2.from-monic
        }
    }

    where
    id-monic : ∀ {A} → Monic (id {A})
    id-monic {g1 = g1} {g2} p =
      begin
        g1       ≈[ sym (left-id g1) ]
        id ∘ g1  ≈[ p ]
        id ∘ g2  ≈[ left-id g2 ]
        g2
      qed

  module BimonicEq = Equiv BimonicEq

  -- Isomorphisms
  record Iso {A B} (f : Hom A B) : Set (h ⊔ r) where
    field
      inv : Hom B A
      left-inv  : inv ∘ f ≈ id
      right-inv : f ∘ inv ≈ id

    -- Inverses are unique for each morphism.
    inv-unique : ∀ g → f ∘ g ≈ id → g ≈ inv
    inv-unique g right-inv' =
      begin
        g              ≈[ sym (left-id g) ]
        id ∘ g         ≈[ ∘-cong (sym left-inv) refl ]
        (inv ∘ f) ∘ g  ≈[ assoc inv f g ]
        inv ∘ (f ∘ g)  ≈[ ∘-cong refl right-inv' ]
        inv ∘ id       ≈[ right-id inv ]
        inv
      qed

    inv-iso : Iso inv
    inv-iso =
      record {
        inv = f;
        left-inv = right-inv;
        right-inv = left-inv
      }

    inv-invol : ∀ g h → g ∘ f ≈ id → h ∘ g ≈ id → f ≈ h
    inv-invol g h g-left-inv h-left-inv =
      begin
        f            ≈[ sym (left-id f) ]
        id ∘ f       ≈[ ∘-cong (sym h-left-inv) refl ]
        (h ∘ g) ∘ f  ≈[ assoc h g f ]
        h ∘ (g ∘ f)  ≈[ ∘-cong refl g-left-inv ]
        h ∘ id       ≈[ right-id h ]
        h
      qed

  record _≃_ A B : Set (h ⊔ r) where
    field
      to : Hom A B
      iso : Iso to

    open Iso iso public

  IsoEq : Equiv Ob
  IsoEq =
    record {
      _≈_ = _≃_;
      refl = irefl;
      sym = isym;
      trans = itrans
    }

    where
    irefl : ∀ {A} → A ≃ A
    irefl =
      record {
        to = id;
        iso = record {
          inv = id;
          left-inv = left-id id;
          right-inv = left-id id
        }
      }

    isym : ∀ {A B} → A ≃ B → B ≃ A
    isym iso =
      record {
        to = iso.inv;
        iso = record {
          inv = iso.to;
          left-inv = iso.right-inv;
          right-inv = iso.left-inv
        }
      }

      where
      module iso = _≃_ iso

    itrans : ∀ {A B C} → A ≃ B → B ≃ C → A ≃ C
    itrans iso1 iso2 =
      record {
        to = iso2.to ∘ iso1.to;
        iso = record {
          inv = iso1.inv ∘ iso2.inv;
          left-inv =
            begin
              iso1.inv ∘ iso2.inv ∘ (iso2.to ∘ iso1.to)   ≈[ assoc iso1.inv iso2.inv (iso2.to ∘ iso1.to) ]
              iso1.inv ∘ (iso2.inv ∘ (iso2.to ∘ iso1.to)) ≈[ ∘-cong refl (sym (assoc iso2.inv iso2.to iso1.to)) ]
              iso1.inv ∘ (iso2.inv ∘ iso2.to ∘ iso1.to)   ≈[ ∘-cong refl (∘-cong iso2.left-inv refl) ]
              iso1.inv ∘ (id ∘ iso1.to)                   ≈[ ∘-cong refl (left-id iso1.to) ]
              iso1.inv ∘ iso1.to                          ≈[ iso1.left-inv ]
              id
            qed;
          right-inv =
            begin
              iso2.to ∘ iso1.to ∘ (iso1.inv ∘ iso2.inv)   ≈[ assoc iso2.to iso1.to (iso1.inv ∘ iso2.inv) ]
              iso2.to ∘ (iso1.to ∘ (iso1.inv ∘ iso2.inv)) ≈[ ∘-cong refl (sym (assoc iso1.to iso1.inv iso2.inv)) ]
              iso2.to ∘ (iso1.to ∘ iso1.inv ∘ iso2.inv)   ≈[ ∘-cong refl (∘-cong iso1.right-inv refl) ]
              iso2.to ∘ (id ∘ iso2.inv)                   ≈[ ∘-cong refl (left-id iso2.inv) ]
              iso2.to ∘ iso2.inv                          ≈[ iso2.right-inv ]
              id
            qed
        }
      }

      where
      module iso1 = _≃_ iso1
      module iso2 = _≃_ iso2

  Iso→Epic : ∀ {A B} {f : Hom A B} → Iso f → Epic f
  Iso→Epic {f = f} iso {g1 = g1} {g2} p =
    begin
      g1                  ≈[ sym (right-id g1) ]
      g1 ∘ id             ≈[ ∘-cong refl (sym iso.right-inv) ]
      g1 ∘ (f ∘ iso.inv)  ≈[ sym (assoc g1 f iso.inv) ]
      g1 ∘ f ∘ iso.inv    ≈[ ∘-cong p refl ]
      g2 ∘ f ∘ iso.inv    ≈[ assoc g2 f iso.inv ]
      g2 ∘ (f ∘ iso.inv)  ≈[ ∘-cong refl iso.right-inv ]
      g2 ∘ id             ≈[ right-id g2 ]
      g2
    qed

    where
    module iso = Iso iso

  Iso→Monic : ∀ {A B} {f : Hom A B} → Iso f → Monic f
  Iso→Monic {f = f} iso {g1 = g1} {g2} p =
    begin
      g1                 ≈[ sym (left-id g1) ]
      id ∘ g1            ≈[ ∘-cong (sym iso.left-inv) refl ]
      iso.inv ∘ f ∘ g1   ≈[ assoc iso.inv f g1 ]
      iso.inv ∘ (f ∘ g1) ≈[ ∘-cong refl p ]
      iso.inv ∘ (f ∘ g2) ≈[ sym (assoc iso.inv f g2) ]
      iso.inv ∘ f ∘ g2   ≈[ ∘-cong iso.left-inv refl ]
      id ∘ g2            ≈[ left-id g2 ]
      g2
    qed

    where
    module iso = Iso iso

  MonicOrd : PartialOrder Ob
  MonicOrd =
    record {
      Eq = BimonicEq;
      _≤_ = _≤_;
      antisym = antisym;
      refl' = refl';
      trans = mtrans
    }

    where
    _≤_ : Ob → Ob → Set _
    A ≤ B = ∃ (λ (f : Hom A B) → Monic f)

    antisym : ∀ {A B} → A ≤ B → B ≤ A → A bimonic B
    antisym A≤B B≤A =
      record {
        to = fst A≤B;
        from = fst B≤A;
        to-monic = snd A≤B;
        from-monic = snd B≤A
      }

    refl' : ∀ {A B} → A bimonic B → A ≤ B
    refl' bi = _bimonic_.to bi , _bimonic_.to-monic bi

    mtrans : ∀ {A B C} → A ≤ B → B ≤ C → A ≤ C
    mtrans (f , p) (g , q) = g ∘ f , ∘-monic q p

-- A functor is a structure-preserving mapping from one category to
-- another.

record Functor
           {cc ch cr dc dh dr}
           (C : Category {cc} {ch} {cr})
           (D : Category {dc} {dh} {dr})
           : Set (cc ⊔ ch ⊔ cr ⊔ dc ⊔ dh ⊔ dr)
       where

  private
    module C = Category C
    module D = Category D

  field semifunctor : Semifunctor C.semigroupoid D.semigroupoid
  open Semifunctor semifunctor public

  field
    id-preserving : ∀ {A} → map (C.id {A}) D.≈ D.id {F A}

  Iso-preserving : ∀ {A B} {f : C.Hom A B} → C.Iso f → D.Iso (map f)
  Iso-preserving {f = f} p =
    record {
      inv = map inv;
      left-inv =
        D.begin
          map inv D.∘ map f  D.≈[ D.sym (∘-preserving inv f) ]
          map (inv C.∘ f)    D.≈[ map-cong left-inv ]
          map C.id           D.≈[ id-preserving ]
          D.id
        D.qed;
      right-inv =
        D.begin
          map f D.∘ map inv  D.≈[ D.sym (∘-preserving f inv) ]
          map (f C.∘ inv)    D.≈[ map-cong right-inv ]
          map C.id           D.≈[ id-preserving ]
          D.id
        D.qed
    }

    where
    open Category.Iso p

-- Category of types and functions.

Sets : ∀ {r} → Category
Sets {r} =
  record {
    semigroupoid = record {
      Ob = Set r;
      Hom = λ A B → A → B;
      Eq = λ {A B} → FuncEq A B;
      _∘_ = _∘_;
      ∘-cong = ∘-cong;
      assoc = λ _ _ _ _ → PropEq.refl
    };
    id = λ x → x;
    left-id = λ _ _ → PropEq.refl;
    right-id = λ _ _ → PropEq.refl
  }

  where
  open module MyEquiv {A} {B} = Equiv (FuncEq A B)

  _∘_ : {A B C : Set r} (f : B → C) (g : A → B) → A → C
  (f ∘ g) x = f (g x)

  infixl 6 _∘_

  ∘-cong :
    ∀ {A B C}
      {f1 f2 : B → C} {g1 g2 : A → B}
    → f1 ≈ f2 → g1 ≈ g2 → f1 ∘ g1 ≈ f2 ∘ g2
  ∘-cong {f1 = f1} f1≈f2 g1≈g2 x =
    PropEq.trans (cong f1 (g1≈g2 _)) (f1≈f2 _)

module Sets {r} = Category (Sets {r})

injective→monic :
  ∀ {a} {A B : Set a}
    {f : A → B}
  → (∀ {x y} → f x ≡ f y → x ≡ y)
  → Sets.Monic f
injective→monic inj p x = inj (p x)

monic→injective :
  ∀ {a} {A B : Set a}
    {f : A → B}
  → Sets.Monic f
  → ∀ {x y} → f x ≡ f y → x ≡ y
monic→injective monic p = monic Sets.id p

surjective→epic :
  ∀ {a} {A B : Set a}
    {f : A → B}
  → (∀ y → ∃ (λ x → f x ≡ y))
  → Sets.Epic f
surjective→epic {f = f} surj {g1 = g1} {g2} p y with surj y
surjective→epic {f = f} surj {g1 = g1} {g2} p y | x , q =
  begin
    g1 y      ≈[ cong g1 (sym q) ]
    g1 (f x)  ≈[ p x ]
    g2 (f x)  ≈[ cong g2 q ]
    g2 y
  qed

  where
  open module MyEquiv {A} = Equiv (PropEq A)


module _ (X : Set) where

open import Agda.Builtin.Equality

postulate
  A : Set

data D : Set where
  c : A → D

variable
  P : D → Set

postulate
  p : (f : ∀ x → P (c x)) (x y : A) → f x ≡ f y


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

open import lib.Basics
open import lib.types.TLevel
open import lib.types.Pi
open import lib.types.Truncation

-- This module is dedicated to [Trunc 0 (x == y)]

module lib.types.PathSet where

_=₀_ : ∀ {i} {A : Type i} → A → A → Type i
_=₀_ x y = Trunc 0 (x == y)

_=0_ : ∀ {i} {A : Type i} → A → A → Type i
_=0_ = _=₀_

infix 80 _∙₀_ _∙₀'_ -- \.\0
_∙₀_ : ∀ {i} {A : Type i} {x y z : A} → x =₀ y → y =₀ z → x =₀ z
_∙₀_ = Trunc-fmap2 _∙_

_∙₀'_ : ∀ {i} {A : Type i} {x y z : A} → x =₀ y → y =₀ z → x =₀ z
_∙₀'_ = Trunc-fmap2 _∙'_

!₀ : ∀ {i} {A : Type i} {x y : A} → x =₀ y → y =₀ x
!₀ = Trunc-fmap !

idp₀ : ∀ {i} {A : Type i} {a : A} → a =₀ a
idp₀ = [ idp ]

ap₀ : ∀ {i j} {A : Type i} {B : Type j} {x y : A} (f : A → B)
  → x =₀ y → f x =₀ f y
ap₀ f = Trunc-rec Trunc-level ([_] ∘ ap f)

coe₀ : ∀ {i} {A B : Type i} (_ : is-set B) (p : A =₀ B) → A → B
coe₀ B-level = Trunc-rec (→-is-set B-level) coe

transport₀ : ∀ {i j} {A : Type i} (B : A → Type j) {x y : A}
  (B-level : is-set (B y)) (p : x =₀ y) → (B x → B y)
transport₀ B B-level p = coe₀ B-level (ap₀ B p)

module _ {i} {A : Type i} where

  abstract
    ∙₀-unit-r : ∀ {x y : A} (q : x =₀ y) → (q ∙₀ idp₀) == q
    ∙₀-unit-r = Trunc-elim
      (λ _ →  =-preserves-level 0 Trunc-level)
      (λ p → ap [_] $ ∙-unit-r p)

    ∙₀-unit-l : ∀ {x y : A} (q : x =₀ y) → (idp₀ ∙₀ q) == q
    ∙₀-unit-l = Trunc-elim
      (λ _ →  =-preserves-level 0 Trunc-level)
      (λ _ → idp)

    ∙₀-assoc : {x y z t : A} (p : x =₀ y) (q : y =₀ z) (r : z =₀ t)
      → (p ∙₀ q) ∙₀ r == p ∙₀ (q ∙₀ r)
    ∙₀-assoc = Trunc-elim
      (λ _ → Π-is-set λ _ → Π-is-set λ _ → =-preserves-level 0 Trunc-level)
      (λ p → Trunc-elim
        (λ _ → Π-is-set λ _ → =-preserves-level 0 Trunc-level)
        (λ q → Trunc-elim
          (λ _ → =-preserves-level 0 Trunc-level)
          (λ r → ap [_] $ ∙-assoc p q r)))

    !₀-inv-l : {x y : A} (p : x =₀ y) → (!₀ p) ∙₀ p == idp₀
    !₀-inv-l = Trunc-elim
      (λ _ →  =-preserves-level 0 Trunc-level)
      (λ p → ap [_] $ !-inv-l p)

    !₀-inv-r : {x y : A} (p : x =₀ y) → p ∙₀ (!₀ p) == idp₀
    !₀-inv-r = Trunc-elim
      (λ _ →  =-preserves-level 0 Trunc-level)
      (λ p → ap [_] $ !-inv-r p)

    ∙₀-ap₀ : ∀ {j} {B : Type j} (f : A → B) {x y z : A} (p : x =₀ y) (q : y =₀ z)
      → ap₀ f p ∙₀ ap₀ f q == ap₀ f (p ∙₀ q)
    ∙₀-ap₀ f = Trunc-elim
      (λ _ → Π-is-set λ _ → =-preserves-level 0 Trunc-level)
      (λ p → Trunc-elim
        (λ _ → =-preserves-level 0 Trunc-level)
        (λ q → ap [_] $ ∙-ap f p q))

    ap₀-∘ : ∀ {j k} {B : Type j} {C : Type k} (g : B → C) (f : A → B)
      {x y : A} (p : x =₀ y) → ap₀ (g ∘ f) p == ap₀ g (ap₀ f p)
    ap₀-∘ f g = Trunc-elim
      (λ _ → =-preserves-level 0 Trunc-level)
      (λ p → ap [_] $ ap-∘ f g p)

    coe₀-∙₀ : {B C : Type i} (B-level : is-set B) (C-level : is-set C)
      → (p : A =₀ B) (q : B =₀ C) (a : A)
      → coe₀ C-level (p ∙₀ q) a == coe₀ C-level q (coe₀ B-level p a)
    coe₀-∙₀ B-level C-level = Trunc-elim
      (λ _ → Π-is-set λ _ → Π-is-set λ _ → =-preserves-level 0 C-level)
      (λ p → Trunc-elim
        (λ _ → Π-is-set λ _ → =-preserves-level 0 C-level)
        (λ q a → coe-∙ p q a))

    trans₀-∙₀ : ∀ {j} {B : A → Type j}
      → (B-level : ∀ a → is-set (B a))
      → {x y z : A} (p : x =₀ y) (q : y =₀ z) (b : B x)
      → transport₀ B (B-level _) (p ∙₀ q) b
      == transport₀ B (B-level _) q (transport₀ B (B-level _) p b)
    trans₀-∙₀ B-level = Trunc-elim
      (λ _ → Π-is-set λ _ → Π-is-set λ _ → =-preserves-level 0 $ B-level _)
      (λ p → Trunc-elim
        (λ _ → Π-is-set λ _ → =-preserves-level 0 $ B-level _)
        (λ q b → trans-∙ p q b))

    trans₀-∙₀' : ∀ {j} {B : A → Type j}
      → (B-level : ∀ a → is-set (B a))
      → {x y z : A} (p : x =₀ y) (q : y =₀ z) (b : B x)
      → transport₀ B (B-level _) (p ∙₀' q) b
      == transport₀ B (B-level _) q (transport₀ B (B-level _) p b)
    trans₀-∙₀' B-level = Trunc-elim
      (λ _ → Π-is-set λ _ → Π-is-set λ _ → =-preserves-level 0 $ B-level _)
      (λ p → Trunc-elim
        (λ _ → Π-is-set λ _ → =-preserves-level 0 $ B-level _)
        (λ q b → trans-∙' p q b))

{-
module _ {i} {A : Type i} where
  trans-id≡₀cst : {a b c : A} (p : b ≡ c) (q : b ≡₀ a)
    → transport (λ x → x ≡₀ a) p q ≡ proj (! p) ∘₀ q
  trans-id≡₀cst refl q = ! $ refl₀-left-unit q

  trans-cst≡₀id : {a b c : A} (p : b ≡ c) (q : a ≡₀ b)
    → transport (λ x → a ≡₀ x) p q ≡ q ∘₀ proj p
  trans-cst≡₀id refl q = ! $ refl₀-right-unit q

module _ {i} {A : Set i} where
  homotopy₀-naturality : ∀ {j} {B : Set j} (f g : A → B)
    (p : (x : A) → f x ≡₀ g x) {x y : A} (q : x ≡₀ y)
    → ap₀ f q ∘₀ p y ≡ p x ∘₀ ap₀ g q
  homotopy₀-naturality f g p {x} {y} q = π₀-extend
    ⦃ λ q → ≡-is-set {x = ap₀ f q ∘₀ p y} {y = p x ∘₀ ap₀ g q}
            $ π₀-is-set (f x ≡ g y) ⦄
    (lemma {x} {y}) q
    where
      lemma : ∀ {x y : A} (q : x ≡ y) → ap₀ f (proj q) ∘₀ p y ≡ p x ∘₀ ap₀ g (proj q)
      lemma refl =
        refl₀ ∘₀ p _
          ≡⟨ refl₀-left-unit (p _) ⟩
        p _
          ≡⟨ ! $ refl₀-right-unit _ ⟩∎
        p _ ∘₀ refl₀
          ∎

-- Loop space commutes with truncation in the sense that
-- τ n (Ω X) = Ω (τ (S n) X)
-- (actually, this is true more generally for paths spaces and we need this
-- level of generality to prove it)

module _ {i} {n : ℕ₋₂} {A : Set i} where

  private
    to : (x y : A) → (τ n (x ≡ y)) → ((proj {n = S n} x) ≡ (proj y))
    to x y = τ-extend-nondep ⦃ τ-is-truncated (S n) A _ _ ⦄ (ap proj)

    -- [truncated-path-space (proj x) (proj y)] is [τ n (x ≡ y)]
    truncated-path-space : (u v : τ (S n) A) → Type≤ n i
    truncated-path-space = τ-extend-nondep
                             ⦃ →-is-truncated (S n) (Type≤-is-truncated n _) ⦄
                             (λ x → τ-extend-nondep ⦃ Type≤-is-truncated n _ ⦄
                               (λ y → τ n (x ≡ y) , τ-is-truncated n _))

    -- We now extend [to] to the truncation of [A], and this is why we needed to
    -- first extend the return type of [to]
    to' : (u v : τ (S n) A) → (π₁ (truncated-path-space u v) → u ≡ v)
    to' = τ-extend ⦃ λ x → Π-is-truncated (S n) (λ a →
                             Π-is-truncated (S n) (λ b →
                               ≡-is-truncated (S n)
                                 (τ-is-truncated (S n) A)))⦄
            (λ x → τ-extend ⦃ λ t → Π-is-truncated (S n) (λ a →
                                      ≡-is-truncated (S n)
                                        (τ-is-truncated (S n) A))⦄
              (λ y → to x y))

    from'-refl : (u : τ (S n) A) → (π₁ (truncated-path-space u u))
    from'-refl = τ-extend ⦃ λ x → truncated-is-truncated-S n
                                    (π₂ (truncated-path-space x x))⦄
                   (λ x → proj refl)

    from' : (u v : τ (S n) A) → (u ≡ v → π₁ (truncated-path-space u v))
    from' u .u refl = from'-refl u

    from : (x y : A) → (proj {n = S n} x ≡ proj y → τ n (x ≡ y))
    from x y p = from' (proj x) (proj y) p

    from-to : (x y : A) (p : τ n (x ≡ y)) → from x y (to x y p) ≡ p
    from-to x y = τ-extend ⦃ λ _ → ≡-is-truncated n (τ-is-truncated n _)⦄
                    (from-to' x y) where

      from-to' : (x y : A) (p : x ≡ y) → from x y (to x y (proj p)) ≡ proj p
      from-to' x .x refl = refl

    to'-from' : (u v : τ (S n) A) (p : u ≡ v) → to' u v (from' u v p) ≡ p
    to'-from' x .x refl = to'-from'-refl x where
      to'-from'-refl : (u : τ (S n) A) → to' u u (from' u u refl) ≡ refl
      to'-from'-refl = τ-extend ⦃ λ _ → ≡-is-truncated (S n)
                                          (≡-is-truncated (S n)
                                            (τ-is-truncated (S n) A))⦄
                         (λ _ → refl)

    to-from : (x y : A) (p : proj {n = S n} x ≡ proj y) → to x y (from x y p) ≡ p
    to-from x y p = to'-from' (proj x) (proj y) p

  τ-path-equiv-path-τ-S : {x y : A} → τ n (x ≡ y) ≃ (proj {n = S n} x ≡ proj y)
  τ-path-equiv-path-τ-S {x} {y} =
    (to x y , iso-is-eq _ (from x y) (to-from x y) (from-to x y))

  module _ where
    open import Homotopy.Connected

    abstract
      connected-has-connected-paths : is-connected (S n) A → (p q : A) → is-connected n (p ≡ q)
      connected-has-connected-paths conn p q =
        equiv-types-truncated ⟨-2⟩ (τ-path-equiv-path-τ-S ⁻¹) (contr-is-prop conn (proj p) (proj q))

    connected-has-all-τ-paths : is-connected (S n) A → (p q : A) → τ n (p ≡ q)
    connected-has-all-τ-paths conn p q = π₁ $ connected-has-connected-paths conn p q
-}


module Avionics.SafetyEnvelopes.Properties where

open import Data.Bool using (Bool; true; false; _∧_; T)
open import Data.Empty using (⊥; ⊥-elim)
open import Data.List as List using (List; []; _∷_; any)
open import Data.List.Relation.Unary.Any as Any using (Any; here; there; satisfied)
open import Data.Maybe using (Maybe; just; nothing; is-just; _>>=_)
open import Data.Product as Prod using (∃-syntax; _×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; cong; cong₂; inspect; [_]; sym; trans)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _≡˘⟨_⟩_; _≡⟨_⟩_; _∎)
open import Relation.Nullary using (Dec; yes; no; ¬_)
open import Relation.Nullary.Decidable using (toWitness; fromWitness)
open import Relation.Unary using (_∈_)

open import Avionics.Bool using (≡→T; T∧→×; ×→T∧; lem∧)
open import Avionics.List using (≡→any; any-map; any-map-rev; any→≡)
open import Avionics.Real
    using (ℝ; _+_; _-_; -_; _*_; _÷_; _^_; _<ᵇ_; _≤_; _<_; _<?_; _≤?_; _≢0;
           0ℝ; 1ℝ; 2ℝ; 1/2; abs; 1/_; _^2; √_; fromℕ;
           double-neg;
           ⟨0,∞⟩; [0,∞⟩;
           <-transˡ; 2>0; ⟨0,∞⟩→0<; 0<→⟨0,∞⟩; >0→≢0; >0→≥0;
           0≟0≡yes0≡0;
           abs<x→<x∧-x<; neg-involutive; neg-distrib-+; neg-mono-<->; neg-def; m-m≡0;
           +-comm; +-assoc; *-comm; *-assoc; +-monoˡ-<; m÷n<o≡m<o*n; m<o÷n≡m*n<o; neg-distribˡ-*; √x^2≡absx;
           x*x≡x^2; x^2*y^2≡⟨xy⟩^2; 1/x^2≡⟨1/x⟩^2)
open import Avionics.Probability using (NormalDist; Dist)
open import Avionics.SafetyEnvelopes
    using (inside; inside'; mahalanobis1; z-predictable'; P[_|X=_]_; classify''; classify; M→pbs;
           StallClasses; Stall; NoStall; Uncertain;
           no-uncertain;
           safety-envelope; z-predictable; Model; τ-confident;
           Stall≡1-NoStall; NoStall≡1-Stall; ≤p→¬≤1-p; ≤1-p→¬≤p
           )

open NormalDist using (σ; μ)

--<ᵇ→< : ∀ {x y} → T (x <ᵇ y) → x < y
--<ᵇ→< = toWitness

-- Preliminary defitinions

-- `pi` is the prediction interval for the z score, i.e.,
-- pi(N (μ, σ), z) = [μ − zσ, μ + zσ]
pi : NormalDist → ℝ → ℝ → Set
pi nd z x =  (μ nd) - z * (σ nd) < x
          ×  x < (μ nd) + z * (σ nd)

extractDists : Model → List NormalDist
extractDists M = List.map (proj₁ ∘ proj₂) (Model.fM M)

------------------------------ Starting point - Theorem 2 ------------------------------
-- Theorem 1 says:
-- In the case of univariate normal distributions, the z-predictability condition
-- >   mahalanobis(μ, x, σ²-¹) < z
-- reduces to
-- >   μ - zσ < x <ᵇ (μ + zσ)
-- the prediction interval with a z-score of z
z-pred-interval≡mahalanobis<z : ∀ (nd z x)
                              → inside nd z x ≡ inside' nd z x
z-pred-interval≡mahalanobis<z nd z x =
  begin
    inside nd z x
  ≡⟨⟩
    (u - z * s <ᵇ x) ∧ (x <ᵇ (u + z * s))
  ≡⟨ cong (λ e → ((u - z * s) <ᵇ x) ∧ (x <ᵇ e)) (
    begin
      u + z * s
    ≡˘⟨ cong₂ (_+_) (neg-involutive _) (neg-involutive _) ⟩
      -(- u) + -(-(z * s))
    ≡˘⟨ neg-distrib-+ _ _ ⟩
      -((- u) + (- (z * s)))
    ≡⟨⟩
      -(- u - z * s)
    ∎
  ) ⟩
    (u - z * s <ᵇ x) ∧ (x <ᵇ -(- u - z * s))
  ≡⟨ cong (λ e → (e <ᵇ x) ∧ (x <ᵇ -(- u - z * s))) (
    begin
      u - z * s
    ≡˘⟨ cong (_+ (- (z * s))) (neg-involutive _) ⟩
      -(- u) + (- (z * s))
    ≡˘⟨ neg-distrib-+ _ _ ⟩
      -(- u + z * s)
    ∎
  ) ⟩
    (-(- u + z * s) <ᵇ x) ∧ (x <ᵇ -(- u - z * s))
  ≡˘⟨ cong (λ e → (-(- u + z * s) <ᵇ e) ∧ (e <ᵇ -(- u - z * s))) (neg-involutive _) ⟩
    (-(- u + z * s) <ᵇ -(- x)) ∧ (-(- x) <ᵇ -(- u - z * s))
  ≡˘⟨ cong ((-(- u + z * s) <ᵇ -(- x)) ∧_) (neg-mono-<-> _ _) ⟩
    (-(- u + z * s) <ᵇ -(- x)) ∧ (- u - z * s <ᵇ - x)
  ≡˘⟨ cong (_∧ (- u - z * s <ᵇ - x)) (neg-mono-<-> _ _) ⟩
    (- x <ᵇ - u + z * s) ∧ (- u - z * s <ᵇ - x)
  ≡⟨ cong (_∧ (- u - z * s <ᵇ - x)) (
    begin
      - x <ᵇ - u + z * s
    ≡˘⟨ cong (_<ᵇ - u + z * s) (neg-def _) ⟩
      0ℝ - x <ᵇ - u + z * s
    ≡˘⟨ cong (λ e → e - x <ᵇ - u + z * s) (trans (+-comm _ _) (m-m≡0 _)) ⟩
      (- u + u) - x <ᵇ - u + z * s
    ≡˘⟨ cong (_<ᵇ - u + z * s) (+-assoc _ _ _) ⟩
      (- u) + (u - x) <ᵇ - u + z * s
    ≡˘⟨ +-monoˡ-< _ _ _ ⟩
      u - x <ᵇ z * s
    ∎
  ) ⟩
    (u - x <ᵇ z * s) ∧ (- u - z * s <ᵇ - x)
  ≡⟨ cong ((u - x <ᵇ z * s) ∧_) (
    begin
      - u - z * s <ᵇ - x
    ≡˘⟨ cong (- u - z * s <ᵇ_) (neg-def _) ⟩
      - u - z * s <ᵇ 0ℝ - x
    ≡˘⟨ cong (λ e → - u - z * s <ᵇ e - x) (trans (+-comm _ _) (m-m≡0 _)) ⟩
      - u - z * s <ᵇ (- u + u) - x
    ≡˘⟨ cong (- u - z * s <ᵇ_) (+-assoc _ _ _) ⟩
      - u - z * s <ᵇ - u + (u - x)
    ≡˘⟨ +-monoˡ-< _ _ _ ⟩
      - (z * s) <ᵇ u - x
    ∎
  ) ⟩
    (u - x <ᵇ z * s) ∧ (- (z * s) <ᵇ u - x)
  ≡˘⟨ cong ((u - x <ᵇ z * s) ∧_) (
    begin
      - z <ᵇ (u - x) ÷ s
    ≡⟨ m<o÷n≡m*n<o _ _ _ ⟩
      (- z) * s <ᵇ (u - x)
    ≡˘⟨ cong (_<ᵇ (u - x)) (neg-distribˡ-* _ _) ⟩
      - (z * s) <ᵇ u - x
    ∎
  ) ⟩
    (u - x <ᵇ z * s) ∧ (- z <ᵇ (u - x) ÷ s)
  ≡˘⟨ cong (_∧ (- z <ᵇ (u - x) ÷ s)) (m÷n<o≡m<o*n _ _ _) ⟩
    ((u - x) ÷ s <ᵇ z) ∧ (- z <ᵇ (u - x) ÷ s)
  ≡˘⟨ abs<x→<x∧-x< ⟩
    abs ((u - x) ÷ s) <ᵇ z
  ≡˘⟨ cong (_<ᵇ z) (√x^2≡absx _) ⟩
    √(((u - x) ÷ s)^2) <ᵇ z
  ≡⟨⟩
    √(((u - x) * (1/ s))^2) <ᵇ z
  ≡˘⟨ cong (λ e → √ e <ᵇ z) (
    begin
      (u - x) * (1/ (s * s)) * (u - x)
    ≡⟨ *-comm _ _ ⟩
      (u - x) * ((u - x) * (1/ (s * s)))
    ≡⟨ *-assoc _ _ _ ⟩
      (u - x) * (u - x) * (1/ (s * s))
    ≡⟨ cong (λ e → (u - x) * (u - x) * (1/ e)) (x*x≡x^2 _) ⟩
      (u - x) * (u - x) * (1/ (s ^2))
    ≡⟨ cong ((u - x) * (u - x) *_) (1/x^2≡⟨1/x⟩^2 _) ⟩
      (u - x) * (u - x) * (1/ s) ^2
    ≡⟨ cong (_* (1/ s) ^2) (x*x≡x^2 _) ⟩
      (u - x)^2 * (1/ s) ^2
    ≡⟨ x^2*y^2≡⟨xy⟩^2 _ _ ⟩
      ((u - x) * (1/ s))^2
    ∎
  )⟩
    √((u - x) * (1/ (s * s)) * (u - x)) <ᵇ z
  ≡⟨⟩
    mahalanobis1 u x (1/ (s * s)) <ᵇ z
  ≡⟨⟩
    inside' nd z x
  ∎
  where u = μ nd
        s = σ nd
---- ############ Theorem 1 END ############

------------------------------ Starting point - Theorem 2 ------------------------------
-- Proof of Theorem 2 (paper)
--
-- In words, the Property 1 says that:
--    The energy signal x is z-predictable iff there exist ⟨α, v⟩ s.t.
--    M(⟨α, v⟩)1 = di and x ∈ pi(di , z).
--
-- Notice that `Any (λ nd → x ∈ pi nd z) nds` translates to:
-- there exists nd such that `nd ∈ nds` and `x ∈ pi(nd, z)`
follows-def←' : ∀ (nds z x)
              → z-predictable' nds z x ≡ ⟨ x , true ⟩
              → Any (λ nd → x ∈ pi nd z) nds
follows-def←' nds z x res≡x,true = Any-x∈pi
  where
    res≡true = cong proj₂ res≡x,true

    -- the first `toWitness` takes a result `(μ nd - z * σ nd) <ᵇ x` (a
    -- boolean) and produces a proof of the type `(μ nd) - z * (σ nd) < x`
    -- assuming we have provided an operator `<?`
    toWitness' = λ nd → Prod.map (toWitness {Q = (μ nd - z * σ nd) <? x})
                                 (toWitness {Q = x <? (μ nd + z * σ nd)})

    -- We find the value for which `inside z x` becomes true in the list `nds`
    Any-bool = ≡→any (λ nd → inside nd z x) nds res≡true
    -- Converting the boolean proof into a proof at the type level
    Any-x∈pi = Any.map (λ {nd} → toWitness' nd ∘ T∧→×) Any-bool

-- forward proof
follows-def→' : ∀ (nds z x)
              → Any (λ nd → x ∈ pi nd z) nds
              → z-predictable' nds z x ≡ ⟨ x , true ⟩
follows-def→' nds z x any[x∈pi-z]nds = let
    -- converts a tuple of `(μ nd) - z * (σ nd) < x , x < (μ nd + z * σ nd)`
    -- (a proof) into a boolean
    fromWitness' nd = λ{⟨ μ-zσ<x , x<μ+zσ ⟩ →
                ×→T∧ ⟨ (fromWitness {Q = (μ nd - z * σ nd) <? x} μ-zσ<x)
                     , (fromWitness {Q = x <? (μ nd + z * σ nd)} x<μ+zσ)
                     ⟩}

    -- Converting from a proof on `_<_` to a proof on `_<ᵇ_`
    any[inside]nds = (Any.map (λ {nd} → fromWitness' nd) any[x∈pi-z]nds)

    -- Transforming the prove from Any into equality (_≡_)
    z-pred-x≡⟨x,true⟩ = any→≡ (λ nd → inside nd z x) nds any[inside]nds

     -- Extending the result from a single Bool value to a pair `ℝ × Bool`
  in cong (⟨ x ,_⟩) z-pred-x≡⟨x,true⟩

-- From the prove above we can obtain the value `nd` and its prove `x ∈ pi nd z`
-- Note: An element of ∃[ nd ] (x ∈ pi nd z) is a tuple of the form ⟨ nd , proof ⟩
--prop1← : ∀ (nds z x)
--       → z-predictable' nds z x ≡ ⟨ x , true ⟩
--       → ∃[ nd ] (x ∈ pi nd z)
--prop1← nds z x res≡x,true = satisfied (follows-def←' nds z x res≡x,true)

-- This proofs is telling us that `z-predictable` follows from the definition
follows-def← : ∀ (M z x)
             → z-predictable M z x ≡ ⟨ x , true ⟩
             → Any (λ nd → x ∈ pi nd z) (extractDists M)
follows-def← M z x res≡x,true = follows-def←' (extractDists M) z x res≡x,true

follows-def→ : ∀ (M z x)
             → Any (λ nd → x ∈ pi nd z) (extractDists M)
             → z-predictable M z x ≡ ⟨ x , true ⟩
follows-def→ M z x Any[x∈pi-nd-z]M = follows-def→' (extractDists M) z x Any[x∈pi-nd-z]M

-- ############ FINAL RESULT - Theorem 1 ############

-- In words: Given a Model `M` and parameter `z`, if `x` is z-predictable, then
-- there exists θ (a flight state) such that they are associated to a `nd`
-- (Normal Distribution) and `x` falls withing the Predictable Interval
theorem1← : ∀ (M z x)
          → z-predictable M z x ≡ ⟨ x , true ⟩
          → Any (λ{⟨ θ , ⟨ nd , p ⟩ ⟩ → x ∈ pi nd z}) (Model.fM M)
theorem1← M z x res≡x,true = any-map (proj₁ ∘ proj₂) (follows-def← M z x res≡x,true)

-- The reverse of theorem1←
theorem1→ : ∀ (M z x)
          → Any (λ{⟨ θ , ⟨ nd , p ⟩ ⟩ → x ∈ pi nd z}) (Model.fM M)
          → z-predictable M z x ≡ ⟨ x , true ⟩
theorem1→ M z x Any[θ→x∈pi-nd-z]M = follows-def→ M z x (any-map-rev (proj₁ ∘ proj₂) Any[θ→x∈pi-nd-z]M)

-- ################# Theorem 2 END ##################

------------------------------ Starting point - Theorem 2 ------------------------------
lem← : ∀ (pbs τ x k)
     → classify'' pbs τ x ≡ k
     → k ≡ Uncertain ⊎ ∃[ p ] ((P[ k |X= x ] pbs ≡ just p) × (τ ≤ p))
lem← pbs τ x k _ with P[ Stall |X= x ] pbs | inspect (P[ Stall |X=_] pbs) x
lem← _ _ _ Uncertain _ | nothing | [ P[k|X=x]≡nothing ] = inj₁ refl
lem← _ τ _ _       _   | just p  | [ _ ] with τ ≤? p | τ ≤? (1ℝ - p)
lem← _ _ _ Stall   _   | just p  | [ P[k|X=x]≡justp ] | yes τ≤p | no ¬τ≤1-p = inj₂ ⟨ p , ⟨ P[k|X=x]≡justp , τ≤p ⟩ ⟩
lem← _ _ _ NoStall _   | just p  | [ P[k|X=x]≡justp ] | no ¬τ≤p | yes τ≤1-p =
  let P[NoStall|X=x]≡just1-p = Stall≡1-NoStall P[k|X=x]≡justp
  in inj₂ ⟨ 1ℝ - p , ⟨ P[NoStall|X=x]≡just1-p , τ≤1-p ⟩ ⟩
lem← _ _ _ Uncertain _ | _       | _ | _ | _ = inj₁ refl

lem→' : ∀ (pbs τ x p)
      -- This line is asking for the main assumptions for the code to work properly:
      --   * 0.5 < τ ≤ 1
      --   * 0 ≤ p ≤ 1
      → (1/2 < τ × τ ≤ 1ℝ) × (0ℝ ≤ p × p ≤ 1ℝ)
      → (P[ Stall |X= x ] pbs) ≡ just p
      → τ ≤ (1ℝ - p)
      → classify'' pbs τ x ≡ NoStall
lem→' pbs _ x _ _ _ _ with P[ Stall |X= x ] pbs
lem→' _ τ _ _ _ _    _     | just p with τ ≤? p | τ ≤? (1ℝ - p)
lem→' _ _ _ _ _ _    _     | just p | no _    | yes _     = refl
lem→' _ _ _ _ _ refl τ≤1-p | just p | _       | no ¬τ≤1-p = ⊥-elim (¬τ≤1-p τ≤1-p)
lem→' _ _ _ _ assumpts refl τ≤1-p | just p | yes τ≤p | yes _     = ⊥-elim (¬τ≤p τ≤p)
  where
    1/2<τ = proj₁ (proj₁ assumpts)
    τ≤1 = proj₂ (proj₁ assumpts)
    0≤p = proj₁ (proj₂ assumpts)
    p≤1 = proj₂ (proj₂ assumpts)
    ¬τ≤p = ≤1-p→¬≤p 1/2<τ τ≤1 0≤p p≤1 τ≤1-p

τ≤p→τ≤1-⟨1-p⟩ : ∀ τ p → τ ≤ p → τ ≤ 1ℝ - (1ℝ - p)
τ≤p→τ≤1-⟨1-p⟩ τ p τ≤p rewrite double-neg p 1ℝ = τ≤p

lem→ : ∀ (pbs τ x k)
     → (1/2 < τ × τ ≤ 1ℝ)
     → ∃[ p ] (((P[ k |X= x ] pbs) ≡ just p) × (τ ≤ p))
     → classify'' pbs τ x ≡ k
lem→ pbs _ x Stall _ _ with P[ Stall |X= x ] pbs
lem→ _ τ _ _ _       _                      | just p with τ ≤? p | τ ≤? (1ℝ - p)
lem→ _ _ _ _ _       _                      | just p | yes _   | no  _     = refl
lem→ _ _ _ _ _       ⟨ _ , ⟨ refl , τ≤p ⟩ ⟩ | just p | no ¬τ≤p | _         = ⊥-elim (¬τ≤p τ≤p)
lem→ _ _ _ _ 1/2<τ≤1 ⟨ _ , ⟨ refl , τ≤p ⟩ ⟩ | just p | yes _   | yes τ≤1-p = ⊥-elim (¬τ≤1-p τ≤1-p)
  where 1/2<τ = proj₁ 1/2<τ≤1
        τ≤1 = proj₂ 1/2<τ≤1
        postulate 0≤p : 0ℝ ≤ p
                  p≤1 : p ≤ 1ℝ
        ¬τ≤1-p = ≤p→¬≤1-p 1/2<τ τ≤1 0≤p p≤1 τ≤p
lem→ pbs τ x NoStall 1/2<τ≤1 ⟨ p , ⟨ P[k|X=x]≡justp , τ≤p ⟩ ⟩ = let
    P[S|X=x]≡just1-p = NoStall≡1-Stall P[k|X=x]≡justp
    τ≤1-⟨1-p⟩ = τ≤p→τ≤1-⟨1-p⟩ τ p τ≤p
    assumptions = ⟨ 1/2<τ≤1 , 0≤p≤1 ⟩
  in lem→' pbs τ x (1ℝ - p) assumptions P[S|X=x]≡just1-p τ≤1-⟨1-p⟩
  where postulate 0≤p≤1 : (0ℝ ≤ 1ℝ - p × 1ℝ - p ≤ 1ℝ)

prop2M-prior← : ∀ (M τ x k)
              → classify M τ x ≡ k
              → k ≡ Uncertain ⊎ ∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p))
prop2M-prior← M = lem← (M→pbs M)

prop2M-prior←' : ∀ (M τ x k)
               → k ≡ Stall ⊎ k ≡ NoStall
               → classify M τ x ≡ k
               → ∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p))
prop2M-prior←' M τ x k _ cMτx≡k with prop2M-prior← M τ x k cMτx≡k
prop2M-prior←' _ _ _ Stall   (inj₁ _) _ | inj₂ P[k|X=x]≥τ = P[k|X=x]≥τ
prop2M-prior←' _ _ _ NoStall _        _ | inj₂ P[k|X=x]≥τ = P[k|X=x]≥τ

prop2M-prior→ : ∀ (M τ x k)
              → (1/2 < τ × τ ≤ 1ℝ)
              → ∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p))
              → classify M τ x ≡ k
prop2M-prior→ M τ x k 1/2<τ≤1 = lem→ (M→pbs M) τ x k 1/2<τ≤1

prop2M← : ∀ (M τ x)
       → τ-confident M τ x ≡ true
       → ∃[ k ] ((classify M τ x ≡ k) × (k ≡ Stall ⊎ k ≡ NoStall))
prop2M← M τ x τconf≡true with classify M τ x
... | Stall   = ⟨ Stall ,   ⟨ refl , inj₁ refl ⟩ ⟩
... | NoStall = ⟨ NoStall , ⟨ refl , inj₂ refl ⟩ ⟩

prop2M→ : ∀ (M τ x k)
        → k ≡ Stall ⊎ k ≡ NoStall
        → classify M τ x ≡ k
        → τ-confident M τ x ≡ true
prop2M→ M τ x Stall   (inj₁ k≡Stall)   cMτx≡k = cong no-uncertain cMτx≡k
prop2M→ M τ x NoStall (inj₂ k≡NoStall) cMτx≡k = cong no-uncertain cMτx≡k

---- ############ FINAL RESULT - Theorem 3 ############
-- Theorem 3 says:
-- a classification k is τ-confident iff τ ≤ P[ k | X = x ]
theorem2← : ∀ (M τ x)
          → τ-confident M τ x ≡ true
          → ∃[ k ] (∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p))) -- which means: τ ≤ P[ k | X = x ]
theorem2← M τ x τconf≡true = let -- prop2M-prior← M τ x k (prop2M← M τ x k τconf≡true)
  ⟨ k , ⟨ cMτx≡k , k≢Uncertain ⟩ ⟩ = prop2M← M τ x τconf≡true
  in ⟨ k , prop2M-prior←' M τ x k k≢Uncertain cMτx≡k ⟩

theorem2→ : ∀ (M τ x k)
          → (1/2 < τ × τ ≤ 1ℝ)
          → k ≡ Stall ⊎ k ≡ NoStall
          → ∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p)) -- which means: τ ≤ P[ k | X = x ]
          → τ-confident M τ x ≡ true
theorem2→ M τ x k 1/2<τ≤1 k≢Uncertain ⟨p,⟩ =
    prop2M→ M τ x k k≢Uncertain (prop2M-prior→ M τ x k 1/2<τ≤1 ⟨p,⟩)
---- ############ Theorem 3 END ############

------------------------------ Starting point - Theorem 3 ------------------------------
---- ############ FINAL RESULT - Theorem 4 ############
-- The final theorem is more a corolary. It follows from Theorem 1 and 2
prop3M← : ∀ (M z τ x)
        → safety-envelope M z τ x ≡ true
        → (Any (λ{⟨ θ , ⟨ nd , p ⟩ ⟩ → x ∈ pi nd z}) (Model.fM M))
          × ∃[ k ] (∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p)))
prop3M← M z τ x seM≡true = let
    -- Taking from the safety-envelope definition its components
    ⟨ left , τ-conf ⟩ =
              lem∧ {a = proj₂ (z-predictable M z x)}
                   {b = τ-confident M τ x}
                   seM≡true
    z-pred-x≡⟨x,true⟩ = cong (⟨ x ,_⟩) left
  in ⟨ theorem1← M z x z-pred-x≡⟨x,true⟩ , theorem2← M τ x τ-conf ⟩

prop3M→ : ∀ (M z τ x k)
        → (1/2 < τ × τ ≤ 1ℝ)
        → k ≡ Stall ⊎ k ≡ NoStall
        → (Any (λ{⟨ θ , ⟨ nd , p ⟩ ⟩ → x ∈ pi nd z}) (Model.fM M))
          × ∃[ p ] (((P[ k |X= x ] (M→pbs M)) ≡ just p) × (τ ≤ p))
        → safety-envelope M z τ x ≡ true
prop3M→ M z τ x k 1/2<τ≤1 k≢Uncertain ⟨ Any[θ→x∈pi-nd-z]M , ⟨p,⟩ ⟩ = let
  z-pred≡⟨x,true⟩ = theorem1→ M z x Any[θ→x∈pi-nd-z]M
  τ-conf          = theorem2→ M τ x k 1/2<τ≤1 k≢Uncertain ⟨p,⟩
  in cong₂ (_∧_) (cong proj₂ z-pred≡⟨x,true⟩) τ-conf
---- ############ Theorem 4 END ############


module Basic.Compiler.Code where

open import Basic.AST
open import Basic.BigStep
open import Utils.Decidable
open import Utils.Monoid

open import Data.Fin using (Fin; #_)
open import Data.Vec hiding (_∷ʳ_; _++_; [_])
open import Data.Nat
open import Data.Bool renaming (not to notBool; if_then_else_ to ifBool_then_else)
open import Data.List hiding ([_])
open import Data.List.Properties
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Product
open import Relation.Nullary
open import Relation.Nullary.Decidable
open import Data.Empty
open import Algebra
import Level as L
private
  module LM {a A} = Algebra.Monoid (Data.List.monoid {a} A)

{-
Chapter 3.1 and 3.2.

Semantics of an abstract machine and specification of the translation from
While syntax to the abstract machine syntax.
-}

{-
Definition of the stack and the AM

We follow the book closely here.

"nat-inj" and "bool-inj" just establish injectivity of context entry
constructors.

That we have to prove them is something of a limitation of the current Agda.
In contrast, Coq derives injectivity of constructors automatically.
-}

data StackEntry : Set where
  nat  : ℕ → StackEntry
  bool : Bool → StackEntry

nat-inj : ∀ {n m} → (StackEntry ∋ nat n) ≡ nat m → n ≡ m
nat-inj refl = refl

bool-inj : ∀ {b b'} → (StackEntry ∋ bool b) ≡ bool b' → b ≡ b'
bool-inj refl = refl

Stack : Set
Stack = List StackEntry

mutual
  data Inst (n : ℕ) : Set where
    PUSH : ℕ → Inst n
    FETCH STORE : Fin n → Inst n
    ADD MUL SUB TRUE FALSE EQ LTE LT AND NOT NOOP : Inst n
    BRANCH LOOP : Code n → Code n → Inst n

  Code : ℕ → Set
  Code = List ∘ Inst

-- Semantics
------------------------------------------------------------

data ⟨_,_,_⟩▷⟨_,_,_⟩ {n} : Code n → Stack → State n → Code n → Stack → State n → Set where

  PUSH :
                    ∀ n {c e s}
    → --------------------------------------------
      ⟨ PUSH n ∷ c , e , s ⟩▷⟨ c , nat n ∷ e , s ⟩

  ADD :
                              ∀ a b {c e s}
    → ---------------------------------------------------------------
      ⟨ ADD ∷ c , nat a ∷ nat b ∷ e , s ⟩▷⟨ c , nat (a + b) ∷ e , s ⟩

  MUL :
                              ∀ a b {c e s}
    → ----------------------------------------------------------------
      ⟨ MUL ∷ c , nat a ∷ nat b ∷ e , s ⟩▷⟨ c , nat (a * b) ∷ e , s ⟩

  SUB :
                              ∀ a b {c e s}
    → ----------------------------------------------------------------
      ⟨ SUB ∷ c , nat a ∷ nat b ∷ e , s ⟩▷⟨ c , nat (a ∸ b) ∷ e , s ⟩

  TRUE :
                         ∀ {c e s}
    → -----------------------------------------------
      ⟨ TRUE ∷ c , e , s ⟩▷⟨ c , bool true ∷ e , s ⟩

  FALSE :
                         ∀ {c e s}
    → ------------------------------------------------
      ⟨ FALSE ∷ c , e , s ⟩▷⟨ c , bool false ∷ e , s ⟩

  EQ :
                               ∀ a b {c e s}
    → -------------------------------------------------------------------
      ⟨ EQ ∷ c , nat a ∷ nat b ∷ e , s ⟩▷⟨ c , bool ⌊ a ≡⁇ b ⌋ ∷ e , s ⟩

  LT :
                               ∀ a b {c e s}
    → -------------------------------------------------------------------
      ⟨ LT ∷ c , nat a ∷ nat b ∷ e , s ⟩▷⟨ c , bool ⌊ a <⁇ b ⌋ ∷ e , s ⟩

  LTE :
                               ∀ a b {c e s}
    → --------------------------------------------------------------------
      ⟨ LTE ∷ c , nat a ∷ nat b ∷ e , s ⟩▷⟨ c , bool ⌊ a ≤⁇ b ⌋ ∷ e , s ⟩

  AND :
                               ∀ a b {c e s}
    → -------------------------------------------------------------------
      ⟨ AND ∷ c , bool a ∷ bool b ∷ e , s ⟩▷⟨ c , bool (a ∧ b) ∷ e , s ⟩

  NOT :
                             ∀ b {c e s}
    → -----------------------------------------------------------
      ⟨ NOT ∷ c , bool b ∷ e , s ⟩▷⟨ c , bool (notBool b) ∷ e , s ⟩

  FETCH :
                             ∀ x {c e s}
    → ---------------------------------------------------------
      ⟨ FETCH x ∷ c , e , s ⟩▷⟨ c , nat (lookup x s) ∷ e , s ⟩

  STORE :
                         ∀ x {n c e s}
    → ------------------------------------------------------
      ⟨ STORE x ∷ c , nat n ∷ e , s ⟩▷⟨ c , e , s [ x ]≔ n ⟩

  BRANCH :
       ∀ {c₁ c₂ c t e s} → let c' = (ifBool t then c₁ else c₂) <> c in
      --------------------------------------------------------------
          ⟨ BRANCH c₁ c₂ ∷ c , bool t ∷ e , s ⟩▷⟨ c' , e , s ⟩

  NOOP :
                   ∀ {c e s}
    → ------------------------------------
       ⟨ NOOP ∷ c , e , s ⟩▷⟨ c , e , s ⟩

  LOOP :
        ∀ {c₁ c₂ c e s} → let c' = c₁ <> BRANCH (c₂ ∷ʳ LOOP c₁ c₂ ) (NOOP ∷ []) ∷ c in
      -----------------------------------------------------------------------------------
                     ⟨ LOOP c₁ c₂ ∷ c , e , s ⟩▷⟨ c' , e , s ⟩

-- Computation sequences
------------------------------------------------------------

infixr 5 _∷_
data ⟨_,_,_⟩▷*⟨_,_,_⟩ {n} : Code n → Stack → State n → Code n → Stack → State n → Set where

  done :
                 ∀ {e s}
    → ---------------------------------
      ⟨ [] , e , s ⟩▷*⟨ [] , e , s ⟩

  {- We define "being stuck" explicitly as a configuration from which no transitions exist -}
  stuck :
       ∀ {c cs e s} → (∀ c' e' s' → ¬ ⟨ c ∷ cs , e , s ⟩▷⟨ c' , e' , s' ⟩)
    → ------------------------------------------------------------
                   ⟨ c ∷ cs , e , s ⟩▷*⟨ c ∷ cs , e , s ⟩

  _∷_ :
                          ∀ {c e s c' e' s' c'' e'' s''} →
       ⟨ c , e , s ⟩▷⟨ c' , e' , s' ⟩ → ⟨ c' , e' , s' ⟩▷*⟨ c'' , e'' , s'' ⟩
    → ------------------------------------------------------------------------
                      ⟨ c , e , s ⟩▷*⟨ c'' , e'' , s'' ⟩

{- We will need the length of computation sequences for the compiler correctness proof -}
▷*-length : ∀ {n}{c c' e e'}{s s' : State n} → ⟨ c , e , s ⟩▷*⟨ c' , e' , s' ⟩ → ℕ
▷*-length done      = 0
▷*-length (stuck x) = 0
▷*-length (x ∷ p)   = suc (▷*-length p)

-- Determinism (exercise 3.6)
------------------------------------------------------------

▷-deterministic :
  ∀ {n}{c c' c'' e e' e''}{s s' s'' : State n}
  → ⟨ c , e , s ⟩▷⟨ c' , e' , s' ⟩ → ⟨ c , e , s ⟩▷⟨ c'' , e'' , s'' ⟩
  → (c' ≡ c'') × (e' ≡ e'') × (s' ≡ s'')
▷-deterministic (PUSH n₁) (PUSH .n₁)  = refl , refl , refl
▷-deterministic (ADD a b) (ADD .a .b) = refl , refl , refl
▷-deterministic (MUL a b) (MUL .a .b) = refl , refl , refl
▷-deterministic (SUB a b) (SUB .a .b) = refl , refl , refl
▷-deterministic TRUE      TRUE        = refl , refl , refl
▷-deterministic FALSE     FALSE       = refl , refl , refl
▷-deterministic (EQ a b)  (EQ .a .b)  = refl , refl , refl
▷-deterministic (LT a b)  (LT .a .b)  = refl , refl , refl
▷-deterministic (LTE a b) (LTE .a .b) = refl , refl , refl
▷-deterministic (AND a b) (AND .a .b) = refl , refl , refl
▷-deterministic (NOT b)   (NOT .b)    = refl , refl , refl
▷-deterministic (FETCH x) (FETCH .x)  = refl , refl , refl
▷-deterministic (STORE x) (STORE .x)  = refl , refl , refl
▷-deterministic BRANCH    BRANCH      = refl , refl , refl
▷-deterministic NOOP      NOOP        = refl , refl , refl
▷-deterministic LOOP      LOOP        = refl , refl , refl

▷*-deterministic :
  ∀ {n}{c c' c'' e e' e''}{s s' s'' : State n}
  → ⟨ c , e , s ⟩▷*⟨ c' , e' , s' ⟩ → ⟨ c , e , s ⟩▷*⟨ c'' , e'' , s'' ⟩
  → (c' ≡ c'') × (e' ≡ e'') × (s' ≡ s'')
▷*-deterministic done done = refl , refl , refl
▷*-deterministic done (() ∷ p2)
▷*-deterministic (stuck x) (stuck x₁) = refl , refl , refl
▷*-deterministic (stuck x) (x₁ ∷ p2) = ⊥-elim (x _ _ _ x₁)
▷*-deterministic (() ∷ p1) done
▷*-deterministic (x ∷ p1) (stuck x₁) = ⊥-elim (x₁ _ _ _ x)
▷*-deterministic (x ∷ p1) (x₁ ∷ p2) with ▷-deterministic x x₁
... | eq1 , eq2 , eq3 rewrite eq1 | eq2 | eq3 = ▷*-deterministic p1 p2

-- Compilation (chapter 3.2)
------------------------------------------------------------

𝓒⟦_⟧ᵉ : ∀ {n t} → Exp n t → Code n
𝓒⟦ lit x       ⟧ᵉ = PUSH x ∷ []
𝓒⟦ add a b     ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ ADD
𝓒⟦ mul a b     ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ MUL
𝓒⟦ sub a b     ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ SUB
𝓒⟦ var x       ⟧ᵉ = FETCH x ∷ []
𝓒⟦ tt          ⟧ᵉ = TRUE ∷ []
𝓒⟦ ff          ⟧ᵉ = FALSE ∷ []
𝓒⟦ eq  a b     ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ EQ
𝓒⟦ lte a b     ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ LTE
𝓒⟦ lt  a b     ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ LT
𝓒⟦ Exp.and a b ⟧ᵉ = 𝓒⟦ b ⟧ᵉ <> 𝓒⟦ a ⟧ᵉ ∷ʳ AND
𝓒⟦ not e       ⟧ᵉ = 𝓒⟦ e ⟧ᵉ ∷ʳ NOT

𝓒⟦_⟧ˢ : ∀ {n} → St n → Code n
𝓒⟦ x := e                 ⟧ˢ = 𝓒⟦ e ⟧ᵉ ∷ʳ STORE x
𝓒⟦ skip                   ⟧ˢ = NOOP ∷ []
𝓒⟦ s₁ , s₂                ⟧ˢ = 𝓒⟦ s₁ ⟧ˢ <> 𝓒⟦ s₂ ⟧ˢ
𝓒⟦ if b then st₁ else st₂ ⟧ˢ = 𝓒⟦ b ⟧ᵉ ∷ʳ BRANCH 𝓒⟦ st₁ ⟧ˢ 𝓒⟦ st₂ ⟧ˢ
𝓒⟦ while b do st          ⟧ˢ = LOOP 𝓒⟦ b ⟧ᵉ 𝓒⟦ st ⟧ˢ ∷ []

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

{-
Some additional lemmas needed to the compiler correctness proofs.
-}

{- A weaker variant of exercise 3.4 -}
weaken-step-code :
  ∀ {n}{c c' c'' e e'}{s s' : State n}
  → ⟨ c        , e , s ⟩▷⟨ c'        , e' , s' ⟩
  → ⟨ c <> c'' , e , s ⟩▷⟨ c' <> c'' , e' , s' ⟩
weaken-step-code (PUSH n₁) = PUSH n₁
weaken-step-code (ADD a b) = ADD a b
weaken-step-code (MUL a b) = MUL a b
weaken-step-code (SUB a b) = SUB a b
weaken-step-code TRUE      = TRUE
weaken-step-code FALSE     = FALSE
weaken-step-code (EQ a b)  = EQ a b
weaken-step-code (LT a b)  = LT a b
weaken-step-code (LTE a b) = LTE a b
weaken-step-code (AND a b) = AND a b
weaken-step-code (NOT b)   = NOT b
weaken-step-code (FETCH x) = FETCH x
weaken-step-code (STORE x) = STORE x
weaken-step-code {c'' = c''}(BRANCH {c₁}{c₂}{c}{t})
  rewrite LM.assoc (ifBool t then c₁ else c₂) c c'' = BRANCH
weaken-step-code {c'' = c''}(LOOP {c₁}{c₂}{c})
  rewrite LM.assoc c₁ (BRANCH (c₂ ∷ʳ LOOP c₁ c₂) (NOOP ∷ []) ∷ c) c'' = LOOP
weaken-step-code NOOP = NOOP

{-
This lemma is not in the book, but it's very convenient to use in the following
proofs. It's just the analogue of Basic.SmallStep.append for the computation
sequences here.
-}
infixr 5 _▷*<>_
_▷*<>_ :
  ∀ {n c c' e e' e''}{s s' s'' : State n}
  → ⟨ c       , e  , s  ⟩▷*⟨ [] , e'  , s'  ⟩
  → ⟨ c'      , e' , s' ⟩▷*⟨ [] , e'' , s'' ⟩
  → ⟨ c <> c' , e  , s  ⟩▷*⟨ [] , e'' , s'' ⟩
_▷*<>_ done        p2 = p2
_▷*<>_ (step ∷ p1) p2 = weaken-step-code step ∷ p1 ▷*<> p2

{- Lemma 3.18 -}
𝓒-Exp-nat :
  ∀ {n e}{s : State n} exp -> ⟨ 𝓒⟦ exp ⟧ᵉ , e , s ⟩▷*⟨ [] , nat (⟦ exp ⟧ᵉ s) ∷ e , s ⟩
𝓒-Exp-nat (lit x)   = PUSH x ∷ done
𝓒-Exp-nat (add a b) = (𝓒-Exp-nat b ▷*<> 𝓒-Exp-nat a) ▷*<> (ADD _ _ ∷ done)
𝓒-Exp-nat (mul a b) = (𝓒-Exp-nat b ▷*<> 𝓒-Exp-nat a) ▷*<> (MUL _ _ ∷ done)
𝓒-Exp-nat (sub a b) = (𝓒-Exp-nat b ▷*<> 𝓒-Exp-nat a) ▷*<> (SUB _ _ ∷ done)
𝓒-Exp-nat (var x)   = FETCH x ∷ done

{- Lemma 3.19 -}
𝓒-Exp-bool :
  ∀ {n e}{s : State n} exp -> ⟨ 𝓒⟦ exp ⟧ᵉ , e , s ⟩▷*⟨ [] , bool (⟦ exp ⟧ᵉ s) ∷ e , s ⟩
𝓒-Exp-bool tt            = TRUE ∷ done
𝓒-Exp-bool ff            = FALSE ∷ done
𝓒-Exp-bool (eq a b)      = (𝓒-Exp-nat  b ▷*<> 𝓒-Exp-nat a) ▷*<> EQ  _ _ ∷ done
𝓒-Exp-bool (lte a b)     = (𝓒-Exp-nat  b ▷*<> 𝓒-Exp-nat a) ▷*<> LTE _ _ ∷ done
𝓒-Exp-bool (lt a b)      = (𝓒-Exp-nat  b ▷*<> 𝓒-Exp-nat a) ▷*<> LT  _ _ ∷ done
𝓒-Exp-bool (Exp.and a b) = (𝓒-Exp-bool b ▷*<> 𝓒-Exp-bool a) ▷*<> AND _ _ ∷ done
𝓒-Exp-bool (not e)       = 𝓒-Exp-bool  e ▷*<> NOT _ ∷ done

{-
A "smart constructor" that gets rid of the trailing (++[]) at the end of the branch.
This is not mentioned in the book, because it (rightfully) assumes that appendding an
empty list to the end of a list results in the same list, while here we have to make
this property explicit
-}

BRANCH-[] :
  ∀ {n c₁ c₂ e t}{s : State n} → let c' = ifBool t then c₁ else c₂ in
  ⟨ BRANCH c₁ c₂ ∷ [] , bool t ∷ e , s ⟩▷⟨ c' , e , s ⟩
BRANCH-[] {n}{c₁}{c₂}{e}{t}{s} =
  subst
    (λ b → ⟨ BRANCH c₁ c₂ ∷ [] , bool t ∷ e , s ⟩▷⟨ b , e , s ⟩)
    (proj₂ LM.identity (ifBool t then c₁ else c₂))
    BRANCH


{-# OPTIONS --allow-unsolved-metas #-}

record Sg (A : Set) (B : A → Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst

app : {A : Set} {B : A → Set} → ((x' : A) → B x') → (x : A) → B x
app f x = f x

ppa : {A : Set} {B : A → Set} → (x : A) → ((x' : A) → B x') → B x
ppa x f = f x

postulate
  Bool : Set
  bar : ((Sg Bool (λ _ → Bool)) → Bool) → Bool

foo : Bool
-- foo = app bar (λ (_ , _) → {!!}) -- accepted
foo = ppa (λ (_ , _) → {!!}) bar -- rejected


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

-- This should really be called FinSet. From nlab:

-- FinSet is the category of finite sets and all functions between
-- them: the full subcategory of Set on finite sets. It is easy (and
-- thus common) to make FinSet skeletal; there is one object for each
-- natural number n (including n=0), and a morphism from m to n is an
-- m-tuple (f0,…,fm−1) of numbers satisfying 0≤fi<n. This amounts to
-- identifying n with the set {0,…,n−1}. (Sometimes {1,…,n} is used
-- instead.) This is exactly what we do below

-- Definition of the Operations on permutations, based on the Vector representation
-- There are 2 sets of definitions here:
-- 1. pure Vector, in which the contents are arbitrary sets
-- 2. specialized to Fin contents.

-- Some notes:
--   - There are operations (such as sequential composition) which 'lift' more
--     awkwardly.
--   - To avoid a proliferation of bad names, we use sub-modules

-- Cauchy representation Vec (Fin m) n without checks that m=n or
-- checks of uniqueness and completeness has a commutative semiring
-- structure (modulo a postulate about sym). This is the main building
-- block of ConcretePermutation

module FinVec where

open import Data.Nat using (ℕ; _+_; _*_)
open import Data.Vec renaming (map to mapV; _++_ to _++V_; concat to concatV)
open import Data.Fin using (Fin; inject+; raise; zero; suc)
open import Function using (_∘_; id; _$_)
open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_]′) renaming (map to map⊎)
open import Data.Product using (_×_; _,′_; proj₁; proj₂)

open import Equiv
open import TypeEquiv using (swap₊; swap⋆)
import TypeEquiv as TE
open import FinEquiv using (module Plus; module Times; module PlusTimes)
open import Proofs using (
  -- VectorLemmas
     _!!_; concat-map; map-map-map; lookup-map; map-∘
     )
import Level
open import Algebra
open import Algebra.Structures
open import Relation.Binary.Core
open import Relation.Binary.PropositionalEquality using (subst; sym; trans; cong₂)
open import Groupoid

------------------------------------------------------------------------------
-- Pure vector operations
-- Does not involve Fin at all.
-- Note: not exported!

private

  module V where
    _⊎v_ : ∀ {m n} {A B : Set} → Vec A m → Vec B n → Vec (A ⊎ B) (m + n)
    α ⊎v β = tabulate (inj₁ ∘ _!!_ α) ++V tabulate (inj₂ ∘ _!!_ β)

    swap+ : {m n : ℕ} {A B : Set} → Vec (A ⊎ B) (m + n) → Vec (B ⊎ A) (m + n)
    swap+ v = tabulate (swap₊ ∘ _!!_ v)

    _×v_ : ∀ {m n} {A B : Set} → Vec A m → Vec B n → Vec (A × B) (m * n)
    α ×v β = α >>= (λ b → mapV (_,′_ b) β)

    0v : {A : Set} → Vec A 0
    0v = []

------------------------------------------------------------------------------
-- Elementary permutations, Fin version
-- Cauchy Representation Vec (Fin m) n without checks of uniqueness
-- and completeness

-- We need to define (at least) 0, 1, +, *, ∘, swap+, swap*

module F where

  open import Data.Nat.Properties.Simple using (+-right-identity)
  open import Data.Vec.Properties
    using (lookup-allFin; tabulate∘lookup; lookup∘tabulate; tabulate-∘; lookup-++-inject+)
  open import Relation.Binary.PropositionalEquality
    using (_≡_; refl; sym; trans; cong; cong₂; subst; module ≡-Reasoning)
  open ≡-Reasoning

  open import Equiv using (_∼_)
  open import Proofs using (congD!;
    -- FinNatLemmas
       inject+0≡uniti+;
    -- FiniteFunctions
       finext;
    -- VectorLemmas
       lookupassoc; map-++-commute; tabulate-split; left!!; right!!;
       lookup-++-raise; unSplit; tab++[]≡tab∘̂unite+
       )

  open V

  -- convenient abbreviations
  FinVec : ℕ → ℕ → Set
  FinVec m n = Vec (Fin m) n

  private
    fwd : {m n : ℕ} → (Fin m ⊎ Fin n) → Fin (m + n)
    fwd = proj₁ Plus.fwd-iso

    bwd : {m n : ℕ} → Fin (m + n) → (Fin m ⊎ Fin n)
    bwd = Equiv.qinv.g (proj₂ Plus.fwd-iso)

    bwd∘fwd~id : {m n : ℕ} → bwd {m} {n} ∘ fwd ∼ id
    bwd∘fwd~id = Equiv.qinv.β (proj₂ Plus.fwd-iso)

  -- make all the definitions abstract.  Note that the type isn't,
  -- otherwise we could not do anything at all with it!

  abstract
    -- principal component of the identity permutation
    1C : {n : ℕ} → FinVec n n
    1C {n} = allFin n

    -- corresponds to ⊥ ≃ (⊥ × A) and other impossibilities
    -- but don't use it, as it is abstract and will confuse external proofs!
    0C : FinVec 0 0
    0C = 1C {0}

    -- Sequential composition
    _∘̂_ : {n₀ n₁ n₂ : ℕ} → Vec (Fin n₁) n₀ → Vec (Fin n₂) n₁ → Vec (Fin n₂) n₀
    π₁ ∘̂ π₂ = tabulate (_!!_ π₂ ∘ _!!_ π₁)

    -- swap the first m elements with the last n elements
    -- [ v₀ , v₁   , v₂   , ... , vm-1 ,     vm , vm₊₁ , ... , vm+n-1 ]
    -- ==>
    -- [ vm , vm₊₁ , ... , vm+n-1 ,     v₀ , v₁   , v₂   , ... , vm-1 ]

    swap+cauchy : (m n : ℕ) → FinVec (n + m) (m + n)
    swap+cauchy m n = tabulate (Plus.swapper m n)

    -- Parallel additive composition
    -- conceptually, what we want is
    _⊎c'_ : ∀ {m₁ n₁ m₂ n₂} → FinVec m₁ m₂ → FinVec n₁ n₂ → FinVec (m₁ + n₁) (m₂ + n₂)
    _⊎c'_ α β = mapV fwd (α ⊎v β)
    -- but the above is tedious to work with.  Instead, inline a bit to get
    _⊎c_ : ∀ {m₁ n₁ m₂ n₂} → FinVec m₁ m₂ → FinVec n₁ n₂ → FinVec (m₁ + n₁) (m₂ + n₂)
    _⊎c_ {m₁} α β = tabulate (fwd ∘ inj₁ ∘ _!!_ α) ++V
                     tabulate (fwd {m₁} ∘ inj₂ ∘ _!!_ β)
    -- see ⊎c≡⊎c' lemma below

    _⊎fv_ : ∀ {m₁ n₁ m₂ n₂} → FinVec m₁ m₂ → FinVec n₁ n₂ → FinVec (m₁ + n₁) (m₂ + n₂)
    _⊎fv_ {m₁} α β = tabulate (λ j → fwd (map⊎ (_!!_ α) (_!!_ β) (bwd j)))

    ⊎-equiv : ∀ {m₁ n₁ m₂ n₂} → (α : FinVec m₁ m₂) → (β : FinVec n₁ n₂) → α ⊎c β ≡ α ⊎fv β
    ⊎-equiv {m₁} {n₁} {m₂} {n₂} α β =
      let mm s = map⊎ (_!!_ α) (_!!_ β) s in
      let g = fwd ∘ mm ∘ bwd in
      begin (
      tabulate (λ j → fwd (inj₁ (α !! j))) ++V tabulate (λ j → fwd {m₁} (inj₂ (β !! j)))
        ≡⟨ refl ⟩ -- map⊎ evaluates on inj₁/inj₂
      tabulate (fwd ∘ mm ∘ inj₁) ++V tabulate (fwd ∘ mm ∘ inj₂)
        ≡⟨ cong₂ _++V_ (finext (λ i → cong (fwd ∘ mm) (sym (bwd∘fwd~id (inj₁ i)))))
                       (finext (λ i → cong (fwd ∘ mm) (sym (bwd∘fwd~id (inj₂ i))))) ⟩
      tabulate {m₂} (g ∘ fwd ∘ inj₁) ++V tabulate {n₂} (g ∘ fwd {m₂} ∘ inj₂)
        ≡⟨ sym (tabulate-split {m₂} {n₂} {f = g}) ⟩
      tabulate g ∎)
      where
        open ≡-Reasoning

    -- Tensor multiplicative composition
    -- Transpositions in α correspond to swapping entire rows
    -- Transpositions in β correspond to swapping entire columns
    _×c_ : ∀ {m₁ n₁ m₂ n₂} → FinVec m₁ m₂ → FinVec n₁ n₂ → FinVec (m₁ * n₁) (m₂ * n₂)
    α ×c β = mapV Times.fwd (α ×v β)

    -- swap⋆
    --
    -- This is essentially the classical problem of in-place matrix transpose:
    -- "http://en.wikipedia.org/wiki/In-place_matrix_transposition"
    -- Given m and n, the desired permutation in Cauchy representation is:
    -- P(i) = m*n-1 if i=m*n-1
    --      = m*i mod m*n-1 otherwise

    -- transposeIndex : {m n : ℕ} → Fin m × Fin n → Fin (n * m)
    -- transposeIndex = Times.fwd ∘ swap
      -- inject≤ (fromℕ (toℕ d * m + toℕ b)) (i*n+k≤m*n d b)

    swap⋆cauchy : (m n : ℕ) → FinVec (n * m) (m * n)
    swap⋆cauchy m n = tabulate (Times.swapper m n)
      -- mapV transposeIndex (V.tcomp 1C 1C)

    -------------------------------------------------------------------------------------------
    -- Things which are the foundations of other permutations, but coming
    -- from properties, rather than being operators

    unite+ : {m : ℕ} → FinVec m (0 + m)
    unite+ {m} = tabulate (proj₁ (Plus.unite+ {m}))

    uniti+ : {m : ℕ} → FinVec (0 + m) m
    uniti+ {m} = tabulate (proj₁ (Plus.uniti+ {m}))

    unite+r : {m : ℕ} → FinVec m (m + 0)
    unite+r {m} = tabulate (proj₁ (Plus.unite+r {m}))

    uniti+r : {m : ℕ} → FinVec (m + 0) m
    uniti+r {m} = tabulate (proj₁ (Plus.uniti+r {m}))

    assocl+ : {m n o : ℕ} → FinVec  ((m + n) + o) (m + (n + o))
    assocl+ {m} {n} {o} = tabulate (proj₁ (Plus.assocl+ {m} {n} {o}))

    assocr+ : {m n o : ℕ} → FinVec  (m + (n + o)) (m + n + o)
    assocr+ {m} {n} {o} = tabulate (proj₁ (Plus.assocr+ {m} {n} {o}))

    unite* : {m : ℕ} → FinVec m (1 * m)
    unite* {m} = tabulate (proj₁ (Times.unite* {m}))

    uniti* : {m : ℕ} → FinVec (1 * m) m
    uniti* {m} = tabulate (proj₁ (Times.uniti* {m}))

    unite*r : {m : ℕ} → FinVec m (m * 1)
    unite*r {m} = tabulate (proj₁ (Times.unite*r {m}))

    uniti*r : {m : ℕ} → FinVec (m * 1) m
    uniti*r {m} = tabulate (proj₁ (Times.uniti*r {m}))

    assocl* : {m n o : ℕ} → FinVec  ((m * n) * o) (m * (n * o))
    assocl* {m} {n} {o} = tabulate (proj₁ (Times.assocl* {m} {n} {o}))

    assocr* : {m n o : ℕ} → FinVec  (m * (n * o)) (m * n * o)
    assocr* {m} {n} {o} = tabulate (proj₁ (Times.assocr* {m} {n} {o}))

    dist*+ : ∀ {m n o} → FinVec (m * o + n * o) ((m + n) * o)
    dist*+ {m} {n} {o} = tabulate (proj₁ (PlusTimes.dist {m} {n} {o}))

    factor*+ : ∀ {m n o} → FinVec ((m + n) * o) (m * o + n * o)
    factor*+ {m} {n} {o} = tabulate (proj₁ (PlusTimes.factor {m} {n} {o}))

    distl*+ : ∀ {m n o} → FinVec (m * n + m * o) (m * (n + o))
    distl*+ {m} {n} {o} = tabulate (proj₁ (PlusTimes.distl {m} {n} {o}))

    factorl*+ : ∀ {m n o} → FinVec (m * (n + o)) (m * n + m * o)
    factorl*+ {m} {n} {o} = tabulate (proj₁ (PlusTimes.factorl {m} {n} {o}))

    right-zero*l : ∀ {m} → FinVec 0 (m * 0)
    right-zero*l {m} = tabulate (proj₁ (Times.distzr {m}))

    right-zero*r : ∀ {m} → FinVec (m * 0) 0
    right-zero*r {m} = tabulate (proj₁ (Times.factorzr {m}))

    -------------------------------------------------------------------------------------------
    -- Below here, we start with properties

    -- Useful stuff
    infix 4 _∼p_

    _∼p_ : {n m : ℕ} (p₁ p₂ : Vec (Fin m) n) → Set
    _∼p_ {n} p₁ p₂ = (i : Fin n) → p₁ !! i ≡ p₂ !! i

    ∼p⇒≡ : {n : ℕ} {p₁ p₂ : Vec (Fin n) n} → (p₁ ∼p p₂) → p₁ ≡ p₂
    ∼p⇒≡ {n} {p₁} {p₂} eqv =
      begin (
        p₁                            ≡⟨ sym (tabulate∘lookup p₁) ⟩
        tabulate (_!!_ p₁)            ≡⟨ finext eqv ⟩
        tabulate (_!!_ p₂)            ≡⟨ tabulate∘lookup p₂ ⟩
        p₂ ∎)
      where open ≡-Reasoning

    -- note the flip!
    ∘̂⇒∘ : {m n o : ℕ} → (f : Fin m → Fin n) → (g : Fin n → Fin o) →
              tabulate f ∘̂ tabulate g ∼p tabulate (g ∘ f)
    ∘̂⇒∘ f g i =
      begin (
        (tabulate f ∘̂ tabulate g) !! i
          ≡⟨ lookup∘tabulate _ i ⟩
        (tabulate g) !! (tabulate f !! i)
          ≡⟨ lookup∘tabulate _ (tabulate f !! i) ⟩
        g (tabulate f !! i)
          ≡⟨ cong g (lookup∘tabulate f i) ⟩
        g (f i)
          ≡⟨ sym (lookup∘tabulate (g ∘ f) i) ⟩
        tabulate (g ∘ f) !! i ∎)
      where open ≡-Reasoning

    -- this is just tabulate∘lookup, but it hides the details; should this be
    -- called 'join' or 'flatten' ?
    cauchyext : {m n : ℕ} (π : FinVec m n) → tabulate (_!!_ π) ≡ π
    cauchyext π = tabulate∘lookup π

    -- we could go through ~p, but this works better in practice
    ~⇒≡ : {m n : ℕ} {f : Fin m → Fin n} {g : Fin n → Fin m} →
               (f ∘ g ∼ id) → (tabulate g ∘̂ tabulate f ≡ 1C)
    ~⇒≡ {f = f} {g} β = ∼p⇒≡ (λ i → trans (∘̂⇒∘ g f i) (cong (λ x → x !! i) (finext β)))

    -- make a permutation from something lower level, directly
    --  ~⇒≡ {m} {n = m} {o = m} (p∘!p≡id {p = Plus.unite+ {m}})

    -- properties of sequential composition
    ∘̂-assoc : {m₁ m₂ m₃ m₄ : ℕ} →
             (a : Vec (Fin m₂) m₁) (b : Vec (Fin m₃) m₂) (c : Vec (Fin m₄) m₃) →
             a ∘̂ (b ∘̂ c) ≡ (a ∘̂ b) ∘̂ c
    ∘̂-assoc a b c = finext (lookupassoc a b c)

    ∘̂-rid : {m n : ℕ} → (π : Vec (Fin m) n) → π ∘̂ 1C ≡ π
    ∘̂-rid π = trans (finext (λ i → lookup-allFin (π !! i))) (cauchyext π)

    ∘̂-lid : {m n : ℕ} → (π : Vec (Fin m) n) → 1C ∘̂ π ≡ π
    ∘̂-lid π = trans (finext (λ i → cong (_!!_ π) (lookup-allFin i))) (cauchyext π)

    !!⇒∘̂ : {n₁ n₂ n₃ : ℕ} →
            (π₁ : Vec (Fin n₁) n₂) → (π₂ : Vec (Fin n₂) n₃) → (i : Fin n₃) →
            π₁ !! (π₂ !! i) ≡ (π₂ ∘̂ π₁) !! i
    !!⇒∘̂ π₁ π₂ i =
      begin (
        π₁ !! (π₂ !! i)
              ≡⟨ sym (lookup∘tabulate (λ j → (π₁ !! (π₂ !! j))) i) ⟩
        tabulate (λ i → π₁ !! (π₂ !! i)) !! i
              ≡⟨ refl ⟩
        (π₂ ∘̂ π₁) !! i ∎)
      where open ≡-Reasoning

    -- properties of sequential composition
    0C∘̂0C≡0C : 1C {0} ∘̂ 1C {0} ≡ 1C {0}
    0C∘̂0C≡0C = refl

    -- properties of parallel composition
    -- trivial ones first
    1C₀⊎x≡x : ∀ {m n} {x : FinVec m n} → 1C {0} ⊎c x ≡ x
    1C₀⊎x≡x {x = x} = cauchyext x

    unite+∘[0⊎x]≡x∘unite+ : ∀ {m n} {x : FinVec m n} → unite+ ∘̂ (1C {0} ⊎c x) ≡ x ∘̂ unite+
    unite+∘[0⊎x]≡x∘unite+ {m} {n} {x} = finext pf
      where
        pf : (i : Fin n) → (0C ⊎c x) !! (unite+ !! i) ≡ unite+ !! (x !! i)
        pf i =
          begin (
            tabulate (λ y → x !! y) !! (tabulate id !! i)
              ≡⟨ cong (λ j → tabulate (λ y → x !! y) !! j) (lookup∘tabulate id i) ⟩
            tabulate (λ y → x !! y) !! i
              ≡⟨ lookup∘tabulate (_!!_ x) i ⟩
            x !! i
              ≡⟨ sym (lookup∘tabulate id (x !! i)) ⟩
            tabulate id !! (x !! i) ∎)

    uniti+∘x≡[0⊎x]∘uniti+ : ∀ {m n} {x : FinVec m n} →
      uniti+ ∘̂ x ≡ (1C {0} ⊎c x) ∘̂ uniti+
    uniti+∘x≡[0⊎x]∘uniti+ {m} {n} {x} = finext pf
      where
        pf : (i : Fin n) → x !! (uniti+ !! i) ≡ uniti+ !! ((0C ⊎c x) !! i)
        pf i = begin (
          x !! (tabulate id !! i)
            ≡⟨ cong (_!!_ x) (lookup∘tabulate id i) ⟩
          x !! i
            ≡⟨ sym (lookup∘tabulate (λ y → x !! y) i) ⟩
          tabulate (λ y → x !! y) !! i
            ≡⟨ sym (lookup∘tabulate id _) ⟩
          tabulate id !! (tabulate (λ y → x !! y) !! i) ∎)

{-
    x⊎1C₀≡x : ∀ {m n} {x : FinVec m n} → x ⊎c (1C {0}) ≡ ?
    x⊎1C₀≡x {m} {n} {x = x} =
      let e = proj₁ (Plus.unite+) in
      let i = proj₁ (Plus.uniti+) in
      let eq = sym (+-right-identity m) in
      begin (
        tabulate (λ j → inject+ 0 (x !! j)) ++V []
          ≡⟨ cong (λ x → x ++V []) (finext (λ j → inject+0≡uniti+ (x !! j) eq)) ⟩
        tabulate (λ j → i (x !! j)) ++V []
          ≡⟨ tab++[]≡tab∘̂unite+ (λ j → i (x !! j)) (+-right-identity n) ⟩
        tabulate (λ j → i (x !! e j))
          ≡⟨ finext (λ j → sym (lookup∘tabulate (λ k → i (x !! k)) (e j))) ⟩
        tabulate (λ j → tabulate (λ k → i (x !! k)) !! (e j))
          ≡⟨ finext (λ j → cong₂ _!!_
                           (finext (λ k → sym (lookup∘tabulate i (x !! k))))
                           (sym (lookup∘tabulate e j))) ⟩
        tabulate (λ j →
           (tabulate (λ k → tabulate i !! (x !! k))) !! ((tabulate e) !! j))
         ∎)
      where open ≡-Reasoning -}

    1C⊎1C≡1C : ∀ {m n} → 1C {m} ⊎c 1C {n} ≡ 1C
    1C⊎1C≡1C {m} {n} =
      begin (
         tabulate {m} (inject+ n ∘ _!!_ 1C) ++V tabulate {n} (raise m ∘ _!!_ 1C)
           ≡⟨ cong₂ (_++V_ {m = m}) (finext (λ i → cong (inject+ n) (lookup-allFin i)))
                                      (finext (λ i → cong (raise m) (lookup-allFin i))) ⟩
         tabulate {m} (inject+ n) ++V tabulate {n} (raise m)
           ≡⟨ unSplit {m} id ⟩
         tabulate {m + n} id ∎)
      where open ≡-Reasoning

    1C!!i≡i : ∀ {m} {i : Fin m} → 1C {m} !! i ≡ i
    1C!!i≡i = lookup∘tabulate id _

    unite+∘̂uniti+~id : ∀ {m} → (unite+ {m}) ∘̂ uniti+ ≡ 1C {m}
    unite+∘̂uniti+~id {m} = ~⇒≡ {m} {n = m} (p∘!p≡id {p = Plus.unite+ {m}})

    uniti+∘̂unite+~id : ∀ {m} → (uniti+ {m}) ∘̂ unite+ ≡ 1C {m}
    uniti+∘̂unite+~id {m} = ~⇒≡ {m} {n = m} (p∘!p≡id {p = Plus.uniti+})

    unite+r∘̂uniti+r~id : ∀ {m} → (unite+r {m}) ∘̂ uniti+r ≡ 1C {m + 0}
    unite+r∘̂uniti+r~id {m} = ~⇒≡ {m} (p∘!p≡id {p = Plus.unite+r {m}})

    uniti+r∘̂unite+r~id : ∀ {m} → (uniti+r {m}) ∘̂ unite+r ≡ 1C {m}
    uniti+r∘̂unite+r~id {m} = ~⇒≡ (p∘!p≡id {p = Plus.uniti+r})

    assocl+∘̂assocr+~id : ∀ {m n o} → assocl+ {m} {n} {o} ∘̂ assocr+ {m} ≡ 1C
    assocl+∘̂assocr+~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = Plus.assocl+ {m}})

    assocr+∘̂assocl+~id : ∀ {m n o} → assocr+ {m} {n} {o} ∘̂ assocl+ {m} ≡ 1C
    assocr+∘̂assocl+~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = Plus.assocr+ {m}})

    swap+-inv : ∀ {m n} → swap+cauchy m n ∘̂ swap+cauchy n m ≡ 1C
    swap+-inv {m} {n} = ~⇒≡ (Plus.swap-inv m n)

    idˡ⊕ : ∀ {m n} {x : FinVec m n} → uniti+ ∘̂ (1C {0} ⊎c x) ≡ x ∘̂ uniti+
    idˡ⊕ {m} {n} {x} = finext pf
      where
        open ≡-Reasoning
        pf : (i : Fin n) → (1C {0} ⊎c x) !! (uniti+ !! i) ≡ (uniti+ !! (x !! i))
        pf i =  begin (
          tabulate (λ y → x !! y) !! (tabulate id !! i)
            ≡⟨ cong (_!!_ (tabulate λ y → x !! y)) (lookup∘tabulate id i) ⟩
          (tabulate (λ y → x !! y)) !! i
            ≡⟨ lookup∘tabulate (λ y → x !! y) i ⟩
          x !! i
            ≡⟨ sym (lookup∘tabulate id (x !! i)) ⟩
          tabulate id !! (x !! i) ∎)

    [,]-commute : {A B C D E : Set} → {f : A → C} → {g : B → C} → {h : C → D} →
      ∀ x → h ([ f , g ]′ x) ≡ [ (h ∘ f) , (h ∘ g) ]′ x
    [,]-commute (inj₁ x) = refl
    [,]-commute (inj₂ y) = refl

{-
    assocl-commute : ∀ {m₁ m₂ m₃ n₁ n₂ n₃} {a : FinVec m₁ n₁} {b : FinVec m₂ n₂}
      {c : FinVec m₃ n₃} → assocl+ {n₁} ∘̂ ((a ⊎c b) ⊎c c) ≡ (a ⊎c (b ⊎c c)) ∘̂ assocl+ {m₁}
    assocl-commute {m₁} {m₂} {m₃} {n₁} {n₂} {n₃} {a} {b} {c} = begin (
      assocl+ {n₁} ∘̂ ((a ⊎c b) ⊎c c)
        ≡⟨ cong (λ x → assocl+ {n₁} ∘̂ x) (trans (⊎-equiv (a ⊎c b) c) (cong (λ x → x ⊎fv c) (⊎-equiv a b))) ⟩
      assocl+ {n₁} ∘̂ ((a ⊎fv b) ⊎fv c)
        ≡⟨ refl ⟩
      tabulate (λ i → ((a ⊎fv b) ⊎fv c) !! (assocl+ {n₁} !! i))
        ≡⟨ finext pf₁ ⟩
      tabulate (λ i → assocl+ {m₁} !! ((a ⊎fv (b ⊎fv c)) !! i) )
        ≡⟨ refl ⟩
      (a ⊎fv (b ⊎fv c)) ∘̂ assocl+ {m₁}
        ≡⟨ cong (λ x → x ∘̂ assocl+ {m₁}) (sym (trans (cong (λ x → a ⊎c x) (⊎-equiv b c)) (⊎-equiv a (b ⊎fv c)))) ⟩
      (a ⊎c (b ⊎c c)) ∘̂ assocl+ {m₁} ∎)
      where
        pf₁ : ∀ i →  ((a ⊎fv b) ⊎fv c) !! (assocl+ {n₁} !! i) ≡ assocl+ {m₁} !! ((a ⊎fv (b ⊎fv c)) !! i)
        pf₁ i =
          let assoc1 k = proj₁ (Plus.assocl+ {n₁}) k in
          let assoc2 k = proj₁ (Plus.assocl+ {m₁} {m₂}) k in
          let abc!! = (_!!_ ((a ⊎fv b) ⊎fv c)) in
          let a!! = (_!!_ a) in let b!! = (_!!_ b) in let c!! = (_!!_ c) in
          let ab!! = (_!!_ (a ⊎fv b)) in
          let bc!! = (_!!_ (b ⊎fv c)) in
          let iso4 = ((sym≃ (Plus.fwd-iso {n₁})) ● ((path⊎ id≃ (sym≃ Plus.fwd-iso)) ● (TE.assocl₊equiv ● (path⊎ Plus.fwd-iso id≃)))) in
          let iso3 = (sym≃ (Plus.fwd-iso {n₁})) ● ((path⊎ id≃ (sym≃ Plus.fwd-iso)) ● (TE.assocl₊equiv)) in
          let iso4b = (path⊎ id≃ (sym≃ Plus.fwd-iso) ● ((TE.assocl₊equiv ● path⊎ Plus.fwd-iso id≃) ● Plus.fwd-iso)) in
          begin (
          ((a ⊎fv b) ⊎fv c) !! (assocl+ {n₁} !! i)
            ≡⟨ cong abc!! (lookup∘tabulate _ i) ⟩
          abc!! (assoc1 i)
            ≡⟨ lookup∘tabulate _ (assoc1 i) ⟩
          fwd (map⊎ ab!! c!! (bwd (assoc1 i)))
            ≡⟨ cong (fwd ∘ map⊎ ab!! c!!) (bwd∘fwd~id (iso4 ⋆ i)) ⟩
          fwd (map⊎ ab!! c!! (iso4 ⋆ i))
            ≡⟨ cong fwd (merge-[,] {h = fwd} {i = id} (iso3 ⋆ i)) ⟩
          fwd (map⊎ (ab!! ∘ fwd) c!! (iso3 ⋆ i))
            ≡⟨ {!!} ⟩
          iso4b ⋆ (map⊎ a!! bc!! (bwd i))
            ≡⟨ sym (cong (λ x → iso4b ⋆ x) (bwd∘fwd~id (map⊎ a!! bc!! (bwd i)))) ⟩
          assoc2 (fwd (map⊎ a!! bc!! (bwd i)))
            ≡⟨ sym (cong assoc2 (lookup∘tabulate _ i)) ⟩
          assoc2 ((a ⊎fv (b ⊎fv c)) !! i)
            ≡⟨ sym (lookup∘tabulate assoc2 _) ⟩
          assocl+ {m₁} !! ((a ⊎fv (b ⊎fv c)) !! i) ∎)
-}
    -- properties of multiplicative composition
    unite*∘̂uniti*~id : ∀ {m} → (unite* {m}) ∘̂ uniti* ≡ 1C {1 * m}
    unite*∘̂uniti*~id {m} = ~⇒≡ {m} {n = 1 * m} (p∘!p≡id {p = Times.unite* {m}})

    uniti*∘̂unite*~id : ∀ {m} → (uniti* {m}) ∘̂ unite* ≡ 1C {m}
    uniti*∘̂unite*~id {m} = ~⇒≡ {1 * m} {n = m} (p∘!p≡id {p = Times.uniti* {m}})

    unite*r∘̂uniti*r~id : ∀ {m} → (unite*r {m}) ∘̂ uniti*r ≡ 1C {m * 1}
    unite*r∘̂uniti*r~id {m} = ~⇒≡ {m} {n = m * 1} (p∘!p≡id {p = Times.unite*r {m}})

    uniti*r∘̂unite*r~id : ∀ {m} → (uniti*r {m}) ∘̂ unite*r ≡ 1C {m}
    uniti*r∘̂unite*r~id {m} = ~⇒≡ {m * 1} {n = m} (p∘!p≡id {p = Times.uniti*r {m}})

    assocl*∘̂assocr*~id : ∀ {m n o} → assocl* {m} {n} {o} ∘̂ assocr* {m} ≡ 1C
    assocl*∘̂assocr*~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = Times.assocl* {m}})

    assocr*∘̂assocl*~id : ∀ {m n o} → assocr* {m} {n} {o} ∘̂ assocl* {m} ≡ 1C
    assocr*∘̂assocl*~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = Times.assocr* {m}})

    dist*+∘̂factor*+~id : ∀ {m n o} → dist*+ {m} {n} {o} ∘̂ factor*+ {m} ≡ 1C
    dist*+∘̂factor*+~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = PlusTimes.dist {m}})

    factor*+∘̂dist*+~id : ∀ {m n o} → factor*+ {m} {n} {o} ∘̂ dist*+ {m} ≡ 1C
    factor*+∘̂dist*+~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = PlusTimes.factor {m}})

    distl*+∘̂factorl*+~id : ∀ {m n o} → distl*+ {m} {n} {o} ∘̂ factorl*+ {m} ≡ 1C
    distl*+∘̂factorl*+~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = PlusTimes.distl {m}})

    factorl*+∘̂distl*+~id : ∀ {m n o} → factorl*+ {m} {n} {o} ∘̂ distl*+ {m} ≡ 1C
    factorl*+∘̂distl*+~id {m} {_} {o} = ~⇒≡ (p∘!p≡id {p = PlusTimes.factorl {m}})

    right-zero*l∘̂right-zero*r~id : ∀ {m} → right-zero*l {m} ∘̂ right-zero*r {m} ≡ 1C {m * 0}
    right-zero*l∘̂right-zero*r~id {m} = ~⇒≡ {f = proj₁ (Times.factorzr {m})} (p∘!p≡id {p = Times.distzr {m}})

    right-zero*r∘̂right-zero*l~id : ∀ {m} → right-zero*r {m} ∘̂ right-zero*l {m} ≡ 1C
    right-zero*r∘̂right-zero*l~id {m} = ~⇒≡ { f = proj₁ (Times.factorz {m})} (p∘!p≡id {p = Times.distz {m}})

    private
      left⊎⊎!! :  ∀ {m₁ m₂ m₃ m₄ n₁ n₂} → (p₁ : FinVec m₁ n₁) → (p₂ : FinVec m₂ n₂)
        → (p₃ : FinVec m₃ m₁) → (p₄ : FinVec m₄ m₂) → (i : Fin n₁) →
        (p₃ ⊎c p₄) !! ( (p₁ ⊎c p₂) !! inject+ n₂ i ) ≡ inject+ m₄ ( (p₁ ∘̂ p₃) !! i)
      left⊎⊎!! {m₁} {m₂} {_} {m₄} {_} {n₂} p₁ p₂ p₃ p₄ i =
        let pp = p₃ ⊎c p₄ in
        let qq = p₁ ⊎c p₂ in
        begin (
            pp !! (qq !! inject+ n₂ i)
              ≡⟨ cong
                   (_!!_ pp)
                   (lookup-++-inject+
                     (tabulate (inject+ m₂ ∘ _!!_ p₁))
                     (tabulate (raise m₁ ∘ _!!_ p₂))
                     i) ⟩
           pp !! (tabulate (inject+ m₂ ∘ _!!_ p₁ ) !! i)
              ≡⟨ cong (_!!_ pp) (lookup∘tabulate _ i) ⟩
           pp !! (inject+ m₂ (p₁ !! i))
              ≡⟨ left!! (p₁ !! i) (inject+ m₄ ∘ (_!!_ p₃)) ⟩
            inject+ m₄ (p₃ !! (p₁ !! i))
              ≡⟨ cong (inject+ m₄) (sym (lookup∘tabulate _ i)) ⟩
            inject+ m₄ ((p₁ ∘̂ p₃) !! i) ∎ )

      right⊎⊎!! :  ∀ {m₁ m₂ m₃ m₄ n₁ n₂} → (p₁ : FinVec m₁ n₁) → (p₂ : FinVec m₂ n₂)
        → (p₃ : FinVec m₃ m₁) → (p₄ : FinVec m₄ m₂) → (i : Fin n₂) →
        (p₃ ⊎c p₄) !! ( (p₁ ⊎c p₂) !! raise n₁ i ) ≡ raise m₃ ( (p₂ ∘̂ p₄) !! i)
      right⊎⊎!! {m₁} {m₂} {m₃} {_} {n₁} {_} p₁ p₂ p₃ p₄ i =
        let pp = p₃ ⊎c p₄ in
        let qq = p₁ ⊎c p₂ in
        begin (
          pp !! (qq !! raise n₁ i)
            ≡⟨ cong
                 (_!!_ pp)
                 (lookup-++-raise
                   (tabulate (inject+ m₂ ∘ _!!_ p₁))
                   (tabulate (raise m₁ ∘ _!!_ p₂))
                   i) ⟩
          pp !! (tabulate (raise m₁ ∘ _!!_ p₂) !! i)
            ≡⟨ cong (_!!_ pp) (lookup∘tabulate _ i) ⟩
          pp !! raise m₁ (p₂ !! i)
            ≡⟨ right!! {m₁} (p₂ !! i) (raise m₃ ∘ (_!!_ p₄)) ⟩
          raise m₃ (p₄ !! (p₂ !! i))
            ≡⟨ cong (raise m₃) (sym (lookup∘tabulate _ i)) ⟩
          raise m₃ ((p₂ ∘̂ p₄) !! i) ∎ )

    ⊎c-distrib : ∀ {m₁ m₂ m₃ m₄ n₁ n₂} → {p₁ : FinVec m₁ n₁} → {p₂ : FinVec m₂ n₂}
      → {p₃ : FinVec m₃ m₁} → {p₄ : FinVec m₄ m₂} →
        (p₁ ⊎c p₂) ∘̂ (p₃ ⊎c p₄) ≡ (p₁ ∘̂ p₃) ⊎c (p₂ ∘̂ p₄)
    ⊎c-distrib {m₁} {m₂} {m₃} {m₄} {n₁} {n₂} {p₁} {p₂} {p₃} {p₄} =
      let p₃₄ = p₃ ⊎c p₄ in let p₁₂ = p₁ ⊎c p₂ in
      let lhs = λ i → p₃₄ !! (p₁₂ !! i) in
      begin (
        tabulate lhs
          ≡⟨ tabulate-split {n₁} {n₂} ⟩
        tabulate {n₁} (lhs ∘ inject+ n₂) ++V tabulate {n₂} (lhs ∘ raise n₁)
          ≡⟨ cong₂ _++V_ (finext (left⊎⊎!! p₁ _ _ _)) (finext (right⊎⊎!! p₁ _ _ _)) ⟩
        tabulate {n₁} (λ i → inject+ m₄ ((p₁ ∘̂ p₃) !! i)) ++V
        tabulate {n₂} (λ i → raise m₃ ((p₂ ∘̂ p₄) !! i))
          ≡⟨ refl ⟩
        (p₁ ∘̂ p₃) ⊎c (p₂ ∘̂ p₄) ∎)

    ------------------------------------------------------------------------------
    -- properties of ×c

    private
      concat!! : {A : Set} {m n : ℕ} → (a : Fin m) → (b : Fin n) → (xss : Vec (Vec A n) m) →
        concatV xss !! (Times.fwd (a ,′ b)) ≡ (xss !! a) !! b
      concat!! zero b (xs ∷ xss) = lookup-++-inject+ xs (concatV xss) b
      concat!! (suc a) b (xs ∷ xss) =
        trans (lookup-++-raise xs (concatV xss) (Times.fwd (a ,′ b))) (concat!! a b xss)

      ×c-equiv : {m₁ m₂ n₁ n₂ : ℕ} (p₁ : FinVec m₁ n₁) (p₂ : FinVec m₂ n₂) →
        (p₁ ×c p₂) ≡ concatV (mapV (λ y → mapV Times.fwd (mapV (λ x → y ,′ x) p₂)) p₁)
      ×c-equiv p₁ p₂ =
        let zss = mapV  (λ b → mapV (λ x → b ,′ x) p₂) p₁ in
        begin (
          (p₁ ×c p₂)
            ≡⟨ refl ⟩
          mapV Times.fwd (concatV zss)
            ≡⟨ sym (concat-map zss Times.fwd) ⟩
          concatV (mapV (mapV Times.fwd) zss)
            ≡⟨ cong concatV (map-map-map Times.fwd (λ b → mapV (λ x → b ,′ x) p₂) p₁) ⟩
           concatV (mapV (λ y → mapV Times.fwd (mapV (λ x → y ,′ x) p₂)) p₁) ∎)

      lookup-2d : {A : Set} (m n : ℕ) → (k : Fin (m * n)) → {f : Fin m × Fin n → A} →
         concatV (tabulate {m} (λ i → tabulate {n} (λ j → f (i ,′ j)))) !! k ≡ f (Times.bwd k)
      lookup-2d m n k {f} =
        let lhs =  concatV (tabulate {m} (λ i → tabulate {n} (λ j → f (i ,′ j)))) in
        let a = proj₁ (Times.bwd {m} {n} k) in
        let b = proj₂ (Times.bwd {m} {n} k) in
        begin (
          lhs !! k
            ≡⟨ cong (_!!_ lhs) (sym (Times.fwd∘bwd~id {m} k)) ⟩
          lhs !! (Times.fwd (a ,′ b))
            ≡⟨ concat!! a b _ ⟩
          (tabulate {m} (λ i → tabulate {n} (λ j → f (i ,′ j))) !! a) !! b
            ≡⟨ cong (λ x → x !! b) (lookup∘tabulate _ a) ⟩
          tabulate {n} (λ j → f (a ,′ j)) !! b
            ≡⟨ lookup∘tabulate _ b ⟩
          f (a ,′ b)
            ≡⟨ refl ⟩
          f (Times.bwd k) ∎)

      ×c!! : {m₁ m₂ n₁ n₂ : ℕ} (p₁ : FinVec m₁ n₁) (p₂ : FinVec m₂ n₂) (k : Fin (n₁ * n₂)) →
        (p₁ ×c p₂) !! k ≡ Times.fwd (p₁ !! proj₁ (Times.bwd k) ,′ p₂ !! proj₂ (Times.bwd {n₁} k))
      ×c!! {n₁ = n₁} p₁ p₂ k =
        let a = proj₁ (Times.bwd {n₁} k) in
        let b = proj₂ (Times.bwd {n₁} k) in
        begin (
          (p₁ ×c p₂) !! k
            ≡⟨ cong₂ _!!_ (×c-equiv p₁ p₂) (sym (Times.fwd∘bwd~id {n₁} k)) ⟩
          concatV (mapV (λ y → mapV Times.fwd (mapV (λ x → y ,′ x) p₂)) p₁) !! Times.fwd (a ,′ b)
            ≡⟨ concat!! a b _ ⟩
          ((mapV (λ y → mapV Times.fwd (mapV (λ x → y ,′ x) p₂)) p₁) !! a) !! b
            ≡⟨ cong (λ x → x !! b) (lookup-map a _ p₁) ⟩
          mapV Times.fwd (mapV (λ x → p₁ !! a ,′ x) p₂) !! b
            ≡⟨ cong (λ x → x !! b) (sym (map-∘ Times.fwd _ p₂)) ⟩
          mapV (Times.fwd ∘ (λ x → p₁ !! a ,′ x)) p₂ !! b
            ≡⟨ lookup-map b _ p₂ ⟩
          Times.fwd (p₁ !! a ,′ p₂ !! b) ∎)

    ×c-distrib : ∀ {m₁ m₂ m₃ m₄ n₁ n₂} → {p₁ : FinVec m₁ n₁} → {p₂ : FinVec m₂ n₂}
      → {p₃ : FinVec m₃ m₁} → {p₄ : FinVec m₄ m₂} →
        (p₁ ×c p₂) ∘̂ (p₃ ×c p₄) ≡ (p₁ ∘̂ p₃) ×c (p₂ ∘̂ p₄)
    ×c-distrib {m₁} {m₂} {m₃} {m₄} {n₁} {n₂} {p₁} {p₂} {p₃} {p₄} =
      let p₃₄ = p₃ ×c p₄ in let p₁₂ = p₁ ×c p₂ in
      let p₂₄ = p₂ ∘̂ p₄ in let p₁₃ = p₁ ∘̂ p₃ in
      let lhs = λ i → p₃₄ !! (p₁₂ !! i) in
      let zss = mapV  (λ b → mapV (λ x → b ,′ x) (p₂ ∘̂ p₄)) (p₁ ∘̂ p₃) in
      begin (
         tabulate {n₁ * n₂} (λ i → p₃₄ !! (p₁₂ !! i))
           ≡⟨ finext (λ j → cong (_!!_ p₃₄) (×c!! p₁ p₂ j)) ⟩
         tabulate {n₁ * n₂}
           (λ i → p₃₄ !! Times.fwd (p₁ !! proj₁ (Times.bwd i) ,′ p₂ !! proj₂ (Times.bwd i)))
           ≡⟨ finext (λ j → ×c!! p₃ p₄ _) ⟩
         tabulate (λ i →
           let k = Times.fwd (p₁ !! proj₁ (Times.bwd i) ,′ p₂ !! proj₂ (Times.bwd i)) in
           Times.fwd (p₃ !! proj₁ (Times.bwd k) ,′ p₄ !! proj₂ (Times.bwd k)))
           ≡⟨ finext (λ i → cong₂ (λ x y → Times.fwd (p₃ !! proj₁ x ,′ p₄ !! proj₂ y))
                     (Times.bwd∘fwd~id {m₁} {m₂} (p₁ !! proj₁ (Times.bwd i) ,′ _))
                     (Times.bwd∘fwd~id (_ ,′ p₂ !! proj₂ (Times.bwd i)))) ⟩
         tabulate (λ i → Times.fwd (p₃ !! (p₁ !! proj₁ (Times.bwd i)) ,′
                                    (p₄ !! (p₂ !! proj₂ (Times.bwd i)))))
           ≡⟨ finext (λ k → sym (lookup-2d n₁ n₂ k)) ⟩
         tabulate (λ k →
           concatV (tabulate {n₁} (λ z →
                    tabulate {n₂} (λ w →
                    Times.fwd ((p₃ !! (p₁ !! z)) ,′ (p₄ !! (p₂ !! w))))))
           !! k)

           ≡⟨ tabulate∘lookup _ ⟩
         concatV (tabulate {n₁} (λ z →
                  tabulate {n₂} (λ w →
                  Times.fwd ((p₃ !! (p₁ !! z)) ,′ (p₄ !! (p₂ !! w))))))
           ≡⟨ cong
               concatV
               (finext (λ i →
                 tabulate-∘ Times.fwd (λ w → ((p₃ !! (p₁ !! i)) ,′ (p₄ !! (p₂ !! w)))) )) ⟩
         concatV (tabulate (λ z →
                  mapV Times.fwd (tabulate (λ w → (p₃ !! (p₁ !! z)) ,′ (p₄ !! (p₂ !! w))))))
           ≡⟨ cong
               concatV
               (finext (λ i →
                 cong
                   (mapV Times.fwd)
                   (tabulate-∘ (λ x → (p₃ !! (p₁ !! i)) ,′ x) (_!!_ p₄ ∘ _!!_ p₂)))) ⟩
         concatV (tabulate (λ z → mapV Times.fwd (mapV (λ x → (p₃ !! (p₁ !! z)) ,′ x) p₂₄)))
           ≡⟨ cong concatV (tabulate-∘ _ (_!!_ p₃ ∘ _!!_ p₁)) ⟩
         concatV (mapV (λ y → mapV Times.fwd (mapV (λ x → y ,′ x) p₂₄)) p₁₃)
           ≡⟨ sym (×c-equiv p₁₃ p₂₄) ⟩
         (p₁ ∘̂ p₃) ×c (p₂ ∘̂ p₄) ∎)

    -- there might be a simpler proofs of this using tablate∘lookup right
    -- at the start.

    1C×1C≡1C : ∀ {m n} → (1C {m} ×c 1C {n}) ≡ 1C {m * n}
    1C×1C≡1C {m} {n} =
      begin (
        1C {m} ×c 1C
          ≡⟨ ×c-equiv 1C 1C ⟩
        concatV (mapV (λ y → mapV Times.fwd (mapV (_,′_ y) (1C {n}))) (1C {m}))
          ≡⟨ cong (concatV {n = m}) (sym (tabulate-∘ _ id)) ⟩
        concatV {n = m} (tabulate (λ y → mapV Times.fwd (mapV (_,′_ y) (1C {n}))))
          ≡⟨ cong (concatV {n = m}) (finext (λ y → sym (map-∘ Times.fwd (λ x → y ,′ x) 1C))) ⟩
        concatV (tabulate {n = m} (λ y → mapV (Times.fwd ∘ (_,′_ y)) (1C {n})))
          ≡⟨ cong
              (concatV {m = n} {m})
              (finext (λ y → sym (tabulate-∘ (Times.fwd ∘ (_,′_ y)) id))) ⟩
        concatV (tabulate {n = m} (λ a → tabulate {n = n} (λ b → Times.fwd (a ,′ b))))
          ≡⟨ sym (tabulate∘lookup _) ⟩
        tabulate (λ k →
        concatV (tabulate {n = m} (λ a → tabulate {n = n} (λ b → Times.fwd (a ,′ b)))) !! k)
          ≡⟨ finext (λ k → lookup-2d m n k) ⟩
        tabulate (λ k → Times.fwd {m} {n} (Times.bwd k))
          ≡⟨ finext (Times.fwd∘bwd~id {m} {n}) ⟩
        1C {m * n} ∎ )

    swap*-inv : ∀ {m n} → swap⋆cauchy m n ∘̂ swap⋆cauchy n m ≡ 1C
    swap*-inv {m} {n} = ~⇒≡ (Times.swap-inv m n)

    ------------------------
    -- A few "reveal" functions, to let us peek into the representation
    reveal1C : ∀ {m} → allFin m ≡ 1C
    reveal1C = refl

    reveal0C : [] ≡ 1C {0}
    reveal0C = refl

    reveal⊎c :  ∀ {m₁ n₁ m₂ n₂} → {α : FinVec m₁ m₂} → {β : FinVec n₁ n₂} →
      α ⊎c β ≡
        tabulate (fwd ∘ inj₁ ∘ _!!_ α) ++V
        tabulate (fwd {m₁} ∘ inj₂ ∘ _!!_ β)
    reveal⊎c = refl

------------------------------------------------------------------------------
-- Commutative semiring structure

open F

_cauchy≃_ : (m n : ℕ) → Set
m cauchy≃ n = FinVec m n

id-iso : {m : ℕ} → FinVec m m
id-iso = 1C

private
  postulate sym-iso : {m n : ℕ} → FinVec m n → FinVec n m

trans-iso : {m n o : ℕ} → FinVec m n → FinVec n o → FinVec m o
trans-iso c₁ c₂ = c₂ ∘̂ c₁

cauchy≃IsEquiv : IsEquivalence {Level.zero} {Level.zero} {ℕ} _cauchy≃_
cauchy≃IsEquiv = record {
  refl = id-iso ;
  sym = sym-iso ;
  trans = trans-iso
  }

cauchyPlusIsSG : IsSemigroup {Level.zero} {Level.zero} {ℕ} _cauchy≃_ _+_
cauchyPlusIsSG = record {
  isEquivalence = cauchy≃IsEquiv ;
  assoc = λ m n o → assocl+ {m} {n} {o} ;
  ∙-cong = _⊎c_
  }

cauchyTimesIsSG : IsSemigroup {Level.zero} {Level.zero} {ℕ} _cauchy≃_ _*_
cauchyTimesIsSG = record {
  isEquivalence = cauchy≃IsEquiv ;
  assoc = λ m n o → assocl* {m} {n} {o} ;
  ∙-cong = _×c_
  }

cauchyPlusIsCM : IsCommutativeMonoid _cauchy≃_ _+_ 0
cauchyPlusIsCM = record {
  isSemigroup = cauchyPlusIsSG ;
  identityˡ = λ m → 1C ;
  comm = λ m n → swap+cauchy n m
  }

cauchyTimesIsCM : IsCommutativeMonoid _cauchy≃_ _*_ 1
cauchyTimesIsCM = record {
  isSemigroup = cauchyTimesIsSG ;
  identityˡ = λ m → uniti* {m} ;
  comm = λ m n → swap⋆cauchy n m
  }

cauchyIsCSR : IsCommutativeSemiring _cauchy≃_ _+_ _*_ 0 1
cauchyIsCSR = record {
  +-isCommutativeMonoid = cauchyPlusIsCM ;
  *-isCommutativeMonoid = cauchyTimesIsCM ;
  distribʳ = λ o m n → factor*+ {m} {n} {o} ;
  zeroˡ = λ m → 0C
  }

cauchyCSR : CommutativeSemiring Level.zero Level.zero
cauchyCSR = record {
  Carrier = ℕ ;
  _≈_ = _cauchy≃_ ;
  _+_ = _+_ ;
  _*_ = _*_ ;
  0# = 0 ;
  1# = 1 ;
  isCommutativeSemiring = cauchyIsCSR
  }

------------------------------------------------------------------------------
-- Groupoid structure

private
  postulate linv : {m n : ℕ} (c : FinVec m n) → (sym-iso c) ∘̂ c ≡ 1C
  postulate rinv : {m n : ℕ} (c : FinVec m n) → c ∘̂ (sym-iso c) ≡ 1C

G : 1Groupoid
G = record {
  set = ℕ ;
  _↝_ = _cauchy≃_ ;
  _≈_ = _≡_ ;
  id  = id-iso ;
  _∘_ = λ c₁ c₂ → trans-iso c₂ c₁ ;
  _⁻¹ = sym-iso ;
  lneutr = ∘̂-lid ;
  rneutr = ∘̂-rid ;
  assoc  = λ c₁ c₂ c₃ → sym (∘̂-assoc c₁ c₂ c₃) ;
  equiv = record {
            refl  = refl ;
            sym   = sym ;
            trans = trans
          } ;
  linv = linv ;
  rinv = rinv ;
  ∘-resp-≈ = cong₂ _∘̂_
  }

{--
-- Move to its own spot later
merge-[,] : {A B C D E : Set} → {h : A → C} → {i : B → D} → {f : C → E}
  → {g : D → E} → (x : A ⊎ B) →
    [ f , g ]′ ( map⊎ h i x ) ≡ [ (f ∘ h) , (g ∘ i) ]′ x
merge-[,] (inj₁ x) = refl
merge-[,] (inj₂ y) = refl
--}