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

module Dodo.Binary.Transitive where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; _≢_; refl)
open import Level using (Level; _⊔_)
open import Function using (flip; _∘_)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_,_; _×_; proj₁; proj₂; ∃-syntax)
open import Relation.Unary using (Pred; _∈_)
open import Relation.Binary using (Rel; REL)
open import Relation.Binary using (Transitive)
open import Relation.Binary.Construct.Closure.Transitive using (TransClosure; [_]; _∷_; _∷ʳ_; _++_)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Binary.Equality
open import Dodo.Binary.Domain

⁺-flip : {a ℓ : Level} {A : Set a} → {R : Rel A ℓ}
  → {x y : A}
  → TransClosure R x y
  → TransClosure (flip R) y x
⁺-flip [ x∼y ]      = [ x∼y ]
⁺-flip (x∼z ∷ z∼⁺y) = ⁺-flip z∼⁺y ∷ʳ x∼z

⁺-map : {a b ℓ₁ ℓ₂ : Level} {A : Set a} {B : Set b}
  → {R : Rel A ℓ₁} {Q : Rel B ℓ₂}
  → (f : A → B)
  → (map : ∀ {x y : A} → R x y → Q (f x) (f y))
  → {x y : A}
  → TransClosure R x y
  → TransClosure Q (f x) (f y)
⁺-map _ map [ Rxy ] = [ map Rxy ]
⁺-map _ map ( Rxz ∷ R⁺zy ) = map Rxz ∷ ⁺-map _ map R⁺zy

⁺-dom : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → {x y : A}
  → TransClosure R x y
    ------------------
  → x ∈ dom R
⁺-dom {R = R} [ Rxy ] = take-dom R Rxy
⁺-dom {R = R} ( Rxz ∷ R⁺zy ) = take-dom R Rxz

⁺-codom : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → {x y : A}
  → TransClosure R x y
    ------------------
  → y ∈ codom R
⁺-codom {R = R} [ Rxy ] = take-codom R Rxy
⁺-codom {R = R} ( Rxz ∷ R⁺zy ) = ⁺-codom R⁺zy

⁺-udrˡ : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → {x y : A}
  → TransClosure R x y
    ------------------
  → x ∈ udr R
⁺-udrˡ = inj₁ ∘ ⁺-dom

⁺-udrʳ : ∀ {a ℓ : Level} {A : Set a} {R : Rel A ℓ}
  → {x y : A}
  → TransClosure R x y
    ------------------
  → y ∈ udr R
⁺-udrʳ = inj₂ ∘ ⁺-codom

⁺-predʳ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {R : Rel A ℓ₂}
  → (f : ∀ {x y : A} → P x → R x y → P y)
  → {x y : A}
  → TransClosure R x y
  → P x
  → P y
⁺-predʳ f [ Rxy ]        Px = f Px Rxy
⁺-predʳ f ( Rxz ∷ R⁺zy ) Px = ⁺-predʳ f R⁺zy (f Px Rxz)

⁺-predˡ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {R : Rel A ℓ₂}
  → (f : ∀ {x y : A} → P y → R x y → P x)
  → {x y : A}
  → TransClosure R x y
  → P y
  → P x
⁺-predˡ f [ Rxy ]        Px = f Px Rxy
⁺-predˡ f ( Rxz ∷ R⁺zy ) Px = f (⁺-predˡ f R⁺zy Px) Rxz

⁺-lift-predʳ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {R : Rel A ℓ₂}
  → (f : ∀ {x y : A} → R x y → P y)
  → {x y : A}
  → TransClosure R x y
  → P y
⁺-lift-predʳ f [ Rxy ] = f Rxy
⁺-lift-predʳ f ( Rxz ∷ R⁺zy ) = ⁺-lift-predʳ f R⁺zy

⁺-lift-predˡ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {R : Rel A ℓ₂}
  → (f : ∀ {x y : A} → R x y → P x)
  → {x y : A}
  → TransClosure R x y
  → P x
⁺-lift-predˡ f [ Rxy ] = f Rxy
⁺-lift-predˡ f ( Rxz ∷ R⁺zy ) = f Rxz

module _ {a ℓ : Level} {A : Set a} {R : Rel A ℓ} where

  ⁺-idem : TransClosure R ⇔₂ TransClosure (TransClosure R)
  ⁺-idem = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : TransClosure R ⊆₂' TransClosure (TransClosure R)
    ⊆-proof _ _ R⁺xy = [ R⁺xy ]

    ⊇-proof : TransClosure (TransClosure R) ⊆₂' TransClosure R
    ⊇-proof _ _ [ R⁺xy ] = R⁺xy
    ⊇-proof _ y ( _∷_ {_} {z} R⁺xz R⁺⁺zy ) = R⁺xz ++ ⊇-proof z y R⁺⁺zy

  ⁺-join : ∀ {x y : A} → TransClosure (TransClosure R) x y → TransClosure R x y
  ⁺-join = ⇔₂-apply-⊇₂ ⁺-idem

module _ {a ℓ : Level} {A : Set a} {R : Rel A ℓ} where

  ⁺-preserves-dom : dom R ⇔₁ dom (TransClosure R)
  ⁺-preserves-dom = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : dom R ⊆₁' dom (TransClosure R)
    ⊆-proof x (y , Rxy) = (y , [ Rxy ])

    ⊇-proof : dom (TransClosure R) ⊆₁' dom R
    ⊇-proof x (y , R⁺xy) = ⁺-dom R⁺xy

  ⁺-preserves-codom : codom R ⇔₁ codom (TransClosure R)
  ⁺-preserves-codom = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : codom R ⊆₁' codom (TransClosure R)
    ⊆-proof y (x , Rxy) = (x , [ Rxy ])

    ⊇-proof : codom (TransClosure R) ⊆₁' codom R
    ⊇-proof y (x , R⁺xy) = ⁺-codom R⁺xy

  ⁺-preserves-udr : udr R ⇔₁ udr (TransClosure R)
  ⁺-preserves-udr = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : udr R ⊆₁' udr (TransClosure R)
    ⊆-proof _ (inj₁ x∈dom)   = inj₁ (⇔₁-apply-⊆₁ ⁺-preserves-dom x∈dom)
    ⊆-proof _ (inj₂ x∈codom) = inj₂ (⇔₁-apply-⊆₁ ⁺-preserves-codom x∈codom)

    ⊇-proof : udr (TransClosure R) ⊆₁' udr R
    ⊇-proof _ (inj₁ x∈dom)   = inj₁ (⇔₁-apply-⊇₁ ⁺-preserves-dom x∈dom)
    ⊇-proof _ (inj₂ x∈codom) = inj₂ (⇔₁-apply-⊇₁ ⁺-preserves-codom x∈codom)

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Rel A ℓ₁} {Q : Rel A ℓ₂} where

  ⁺-preserves-⊆₂ : P ⊆₂ Q → TransClosure P ⊆₂ TransClosure Q
  ⁺-preserves-⊆₂ P⊆Q = ⊆: lemma
    where
    lemma : TransClosure P ⊆₂' TransClosure Q
    lemma _ _ [ Pxy ] = [ ⊆₂-apply P⊆Q Pxy ]
    lemma _ y ( _∷_ {_} {z} Pxz P⁺zy ) = ⊆₂-apply P⊆Q Pxz ∷ lemma z y P⁺zy

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Rel A ℓ₁} {Q : Rel A ℓ₂} where

  ⁺-preserves-⇔₂ : P ⇔₂ Q → TransClosure P ⇔₂ TransClosure Q
  ⁺-preserves-⇔₂ = ⇔₂-compose ⁺-preserves-⊆₂ ⁺-preserves-⊆₂

module _ {a ℓ : Level} {A : Set a} {R : Rel A ℓ} where

  ⁺-trans-⇔₂ : Transitive R → R ⇔₂ TransClosure R
  ⁺-trans-⇔₂ transR = ⇔: ⊆-proof ⊇-proof
    where
    ⊆-proof : R ⊆₂' TransClosure R
    ⊆-proof _ _ = [_]

    ⊇-proof : TransClosure R ⊆₂' R
    ⊇-proof _ _ [ Rxy ] = Rxy
    ⊇-proof _ y (_∷_ {_} {w} Rxw R⁺wy) = transR Rxw (⊇-proof w y R⁺wy)

  ⁺-trans-⊆₂ : Transitive R → TransClosure R ⊆₂ R
  ⁺-trans-⊆₂ transR = ⇔₂-to-⊇₂ (⁺-trans-⇔₂ transR)

  ⁺-join-trans : Transitive R → {x y : A} → TransClosure R x y → R x y
  ⁺-join-trans = ⊆₂-apply ∘ ⁺-trans-⊆₂

  ⁺-unconsʳ :
      {x y : A}
    → TransClosure R x y
    → R x y ⊎ ∃[ z ] (TransClosure R x z × R z y)
  ⁺-unconsʳ [ Rxy ] = inj₁ Rxy
  ⁺-unconsʳ ( Rxz ∷ R⁺zy ) with ⁺-unconsʳ R⁺zy
  ... | inj₁ Rzy = inj₂ (_ , [ Rxz ] , Rzy)
  ... | inj₂ (v , R⁺zv , Rvy) = inj₂ (v , Rxz ∷ R⁺zv , Rvy)


{-# OPTIONS --without-K --safe --no-universe-polymorphism --sized-types
            --no-guardedness --no-subtyping #-}

module Agda.Builtin.Size where

{-# BUILTIN SIZEUNIV SizeUniv #-}
{-# BUILTIN SIZE     Size     #-}
{-# BUILTIN SIZELT   Size<_   #-}
{-# BUILTIN SIZESUC  ↑_       #-}
{-# BUILTIN SIZEINF  ∞        #-}
{-# BUILTIN SIZEMAX  _⊔ˢ_     #-}

{-# FOREIGN GHC
  type SizeLT i = ()
  #-}

{-# COMPILE GHC Size   = type ()     #-}
{-# COMPILE GHC Size<_ = type SizeLT #-}
{-# COMPILE GHC ↑_     = \_ -> ()    #-}
{-# COMPILE GHC ∞      = ()          #-}
{-# COMPILE GHC _⊔ˢ_   = \_ _ -> ()  #-}


{-# OPTIONS --without-K --safe #-}
module PiFracDynDef where
open import Data.Bool
open import Data.Empty
open import Data.Unit
open import Data.Nat
open import Data.Nat.Properties
open import Data.Sum
open import Data.Product
open import Data.Maybe
open import Function
open import Relation.Binary.PropositionalEquality
  renaming ([_] to R[_])
open import Relation.Binary.Core
open import Relation.Nullary

infix  70 _×ᵤ_
infix  60 _+ᵤ_
infix  40 _↔_
infixr 50 _⊚_

data ◯ : Set where
  ○ : ◯

-- Pi

mutual
  data 𝕌 : Set where
    𝟘 : 𝕌
    𝟙 : 𝕌
    _+ᵤ_ : 𝕌 → 𝕌 → 𝕌
    _×ᵤ_ : 𝕌 → 𝕌 → 𝕌
    𝟙/_ : 𝕌 → 𝕌

  ⟦_⟧ : 𝕌 → Set
  ⟦ 𝟘 ⟧ = ⊥
  ⟦ 𝟙 ⟧ = ⊤
  ⟦ t₁ +ᵤ t₂ ⟧ = ⟦ t₁ ⟧ ⊎ ⟦ t₂ ⟧
  ⟦ t₁ ×ᵤ t₂ ⟧ = ⟦ t₁ ⟧ × ⟦ t₂ ⟧
  ⟦ 𝟙/ t ⟧ = ◯

  data _↔_ : 𝕌 → 𝕌 → Set where
    unite₊l : {t : 𝕌} → 𝟘 +ᵤ t ↔ t
    uniti₊l : {t : 𝕌} → t ↔ 𝟘 +ᵤ t
    unite₊r : {t : 𝕌} → t +ᵤ 𝟘 ↔ t
    uniti₊r : {t : 𝕌} → t ↔ t +ᵤ 𝟘
    swap₊   : {t₁ t₂ : 𝕌} → t₁ +ᵤ t₂ ↔ t₂ +ᵤ t₁
    assocl₊ : {t₁ t₂ t₃ : 𝕌} → t₁ +ᵤ (t₂ +ᵤ t₃) ↔ (t₁ +ᵤ t₂) +ᵤ t₃
    assocr₊ : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) +ᵤ t₃ ↔ t₁ +ᵤ (t₂ +ᵤ t₃)
    unite⋆l : {t : 𝕌} → 𝟙 ×ᵤ t ↔ t
    uniti⋆l : {t : 𝕌} → t ↔ 𝟙 ×ᵤ t
    unite⋆r : {t : 𝕌} → t ×ᵤ 𝟙 ↔ t
    uniti⋆r : {t : 𝕌} → t ↔ t ×ᵤ 𝟙
    swap⋆   : {t₁ t₂ : 𝕌} → t₁ ×ᵤ t₂ ↔ t₂ ×ᵤ t₁
    assocl⋆ : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ ×ᵤ t₃) ↔ (t₁ ×ᵤ t₂) ×ᵤ t₃
    assocr⋆ : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₂) ×ᵤ t₃ ↔ t₁ ×ᵤ (t₂ ×ᵤ t₃)
    absorbr : {t : 𝕌} → 𝟘 ×ᵤ t ↔ 𝟘
    absorbl : {t : 𝕌} → t ×ᵤ 𝟘 ↔ 𝟘
    factorzr : {t : 𝕌} → 𝟘 ↔ t ×ᵤ 𝟘
    factorzl : {t : 𝕌} → 𝟘 ↔ 𝟘 ×ᵤ t
    dist    : {t₁ t₂ t₃ : 𝕌} → (t₁ +ᵤ t₂) ×ᵤ t₃ ↔ (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃)
    factor  : {t₁ t₂ t₃ : 𝕌} → (t₁ ×ᵤ t₃) +ᵤ (t₂ ×ᵤ t₃) ↔ (t₁ +ᵤ t₂) ×ᵤ t₃
    distl   : {t₁ t₂ t₃ : 𝕌} → t₁ ×ᵤ (t₂ +ᵤ t₃) ↔ (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃)
    factorl : {t₁ t₂ t₃ : 𝕌 } → (t₁ ×ᵤ t₂) +ᵤ (t₁ ×ᵤ t₃) ↔ t₁ ×ᵤ (t₂ +ᵤ t₃)
    id↔     : {t : 𝕌} → t ↔ t
    _⊚_     : {t₁ t₂ t₃ : 𝕌} → (t₁ ↔ t₂) → (t₂ ↔ t₃) → (t₁ ↔ t₃)
    _⊕_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ↔ t₃) → (t₂ ↔ t₄) → (t₁ +ᵤ t₂ ↔ t₃ +ᵤ t₄)
    _⊗_     : {t₁ t₂ t₃ t₄ : 𝕌} → (t₁ ↔ t₃) → (t₂ ↔ t₄) → (t₁ ×ᵤ t₂ ↔ t₃ ×ᵤ t₄)
    η : {t : 𝕌} {t≠0 : ¬ card t ≡ 0} → 𝟙 ↔ t ×ᵤ (𝟙/ t)
    ε : {t : 𝕌} {t≠0 : ¬ card t ≡ 0} → t ×ᵤ (𝟙/ t) ↔ 𝟙

-- Number of points in type
  card : (t : 𝕌) → ℕ
  card 𝟘 = 0
  card 𝟙 = 1
  card (t₁ +ᵤ t₂) = card t₁ + card t₂
  card (t₁ ×ᵤ t₂) = card t₁ * card t₂
  card (𝟙/ t) = 1

-- If number of points is zero then it is impossible to find a value
-- of the type
0empty : {t : 𝕌} → card t ≡ 0 → (v : ⟦ t ⟧) → ⊥
0empty {𝟘} _ ()
0empty {𝟙} () tt
0empty {t₁ +ᵤ t₂} s (inj₁ v₁)
  with card t₁ | card t₂ | inspect card t₁
0empty {t₁ +ᵤ t₂} refl (inj₁ v₁) | 0 | 0 | R[ s₁ ] =
  0empty {t₁} s₁ v₁
0empty {t₁ +ᵤ t₂} s (inj₂ v₂)
  with card t₁ | card t₂ | inspect card t₂
0empty {t₁ +ᵤ t₂} refl (inj₂ v₂) | ℕ.zero | ℕ.zero | R[ s₂ ] =
  0empty {t₂} s₂ v₂
0empty {t₁ ×ᵤ t₂} s (v₁ , v₂)
  with card t₁ | card t₂ | inspect card t₁ | inspect card t₂
0empty {t₁ ×ᵤ t₂} refl (v₁ , v₂) | ℕ.zero | _ | R[ s₁ ] | _ =
  0empty {t₁} s₁ v₁
0empty {t₁ ×ᵤ t₂} s (v₁ , v₂) | ℕ.suc n₁ | ℕ.zero | R[ s₁ ] | R[ s₂ ] =
  0empty {t₂} s₂ v₂
0empty {𝟙/ t} () f

default : (t : 𝕌) → {t≠0 : ¬ card t ≡ 0} → ⟦ t ⟧
default 𝟘 {t≠0} = ⊥-elim (t≠0 refl)
default 𝟙 = tt
default (t₁ +ᵤ t₂) {p≠0} with card t₁ | card t₂ | inspect card t₁ | inspect card t₂
... | 0 | 0 | R[ s₁ ] | R[ s₂ ] = ⊥-elim (p≠0 refl)
... | 0 | suc n | R[ s₁ ] | R[ s₂ ] =
  inj₂ (default t₂ {λ t2≡0 → ⊥-elim (p≠0 (trans (sym s₂) t2≡0))})
... | suc m | 0 | R[ s₁ ] | R[ s₂ ] =
  inj₁ (default t₁ {λ t1≡0 →
    ⊥-elim (p≠0 ((trans (sym (trans s₁ (sym (+-identityʳ (suc m))))) t1≡0)))})
... | suc m | suc n | R[ s₁ ] | R[ s₂ ] =
  inj₁ (default t₁ {λ t1≡0 → ⊥-elim (1+n≢0 (trans (sym s₁) t1≡0))})
default (t₁ ×ᵤ t₂) {p≠0} with card t₁ | card t₂ | inspect card t₁ | inspect card t₂
... | 0 | 0 | R[ s₁ ] | R[ s₂ ] = ⊥-elim (p≠0 refl)
... | 0 | suc n | R[ s₁ ] | R[ s₂ ] = ⊥-elim (p≠0 refl)
... | suc m | 0 | R[ s₁ ] | R[ s₂ ] = ⊥-elim (p≠0 (*-zeroʳ (suc m)))
... | suc m | suc n | R[ s₁ ] | R[ s₂ ] =
  default t₁ {λ t1≡0 → ⊥-elim (1+n≢0 (trans (sym s₁) t1≡0))},
  default t₂ {λ t2≡0 → ⊥-elim (1+n≢0 (trans (sym s₂) t2≡0))}
default (𝟙/ t) = ○

𝕌dec : (t : 𝕌) → Decidable (_≡_ {A = ⟦ t ⟧})
𝕌dec 𝟘 ()
𝕌dec 𝟙 tt tt = yes refl
𝕌dec (t₁ +ᵤ t₂) (inj₁ x) (inj₁ y) with 𝕌dec t₁ x y
𝕌dec (t₁ +ᵤ t₂) (inj₁ x) (inj₁ .x) | yes refl = yes refl
𝕌dec (t₁ +ᵤ t₂) (inj₁ x) (inj₁ y)  | no ¬p = no (λ {refl → ¬p refl})
𝕌dec (t₁ +ᵤ t₂) (inj₁ x) (inj₂ y) = no (λ ())
𝕌dec (t₁ +ᵤ t₂) (inj₂ x) (inj₁ y) = no (λ ())
𝕌dec (t₁ +ᵤ t₂) (inj₂ x) (inj₂ y) with 𝕌dec t₂ x y
𝕌dec (t₁ +ᵤ t₂) (inj₂ x) (inj₂ .x) | yes refl = yes refl
𝕌dec (t₁ +ᵤ t₂) (inj₂ x) (inj₂ y) | no ¬p = no (λ {refl → ¬p refl})
𝕌dec (t₁ ×ᵤ t₂) (x₁ , y₁) (x₂ , y₂) with 𝕌dec t₁ x₁ x₂ | 𝕌dec t₂ y₁ y₂
𝕌dec (t₁ ×ᵤ t₂) (x₁ , y₁) (.x₁ , .y₁) | yes refl | yes refl = yes refl
𝕌dec (t₁ ×ᵤ t₂) (x₁ , y₁) (.x₁ , y₂) | yes refl | no ¬p = no (λ p → ¬p (cong proj₂ p))
𝕌dec (t₁ ×ᵤ t₂) (x₁ , y₁) (x₂ , .y₁) | no ¬p | yes refl = no (λ p → ¬p (cong proj₁ p))
𝕌dec (t₁ ×ᵤ t₂) (x₁ , y₁) (x₂ , y₂) | no ¬p | no ¬p₁ = no (λ p → ¬p (cong proj₁ p))
𝕌dec (𝟙/ t) ○ ○ = yes refl

_≟ᵤ_ : {t : 𝕌} → Decidable (_≡_ {A = ⟦ t ⟧})
_≟ᵤ_ {t} v w = 𝕌dec t v w

interp : {t₁ t₂ : 𝕌} → (t₁ ↔ t₂) → ⟦ t₁ ⟧ → Maybe ⟦ t₂ ⟧
interp unite₊l (inj₁ ())
interp unite₊l (inj₂ v) = just v
interp uniti₊l v = just (inj₂ v)
interp unite₊r (inj₁ v) = just v
interp unite₊r (inj₂ ())
interp uniti₊r v = just (inj₁ v)
interp swap₊ (inj₁ v) = just (inj₂ v)
interp swap₊ (inj₂ v) = just (inj₁ v)
interp assocl₊ (inj₁ v) = just (inj₁ (inj₁ v))
interp assocl₊ (inj₂ (inj₁ v)) = just (inj₁ (inj₂ v))
interp assocl₊ (inj₂ (inj₂ v)) = just (inj₂ v)
interp assocr₊ (inj₁ (inj₁ v)) = just (inj₁ v)
interp assocr₊ (inj₁ (inj₂ v)) = just (inj₂ (inj₁ v))
interp assocr₊ (inj₂ v) = just (inj₂ (inj₂ v))
interp unite⋆l v = just (proj₂ v)
interp uniti⋆l v = just (tt , v)
interp unite⋆r v = just (proj₁ v)
interp uniti⋆r v = just (v , tt)
interp swap⋆ (v₁ , v₂) = just (v₂ , v₁)
interp assocl⋆ (v₁ , v₂ , v₃) = just ((v₁ , v₂) , v₃)
interp assocr⋆ ((v₁ , v₂) , v₃) = just (v₁ , v₂ , v₃)
interp absorbr (() , v)
interp absorbl (v , ())
interp factorzr ()
interp factorzl ()
interp dist (inj₁ v₁ , v₃) = just (inj₁ (v₁ , v₃))
interp dist (inj₂ v₂ , v₃) = just (inj₂ (v₂ , v₃))
interp factor (inj₁ (v₁ , v₃)) = just (inj₁ v₁ , v₃)
interp factor (inj₂ (v₂ , v₃)) = just (inj₂ v₂ , v₃)
interp distl (v₁ , inj₁ v₂) = just (inj₁ (v₁ , v₂))
interp distl (v₁ , inj₂ v₃) = just (inj₂ (v₁ , v₃))
interp factorl (inj₁ (v₁ , v₂)) = just (v₁ , inj₁ v₂)
interp factorl (inj₂ (v₁ , v₃)) = just (v₁ , inj₂ v₃)
interp id↔ v = just v
interp (c₁ ⊚ c₂) v = interp c₁ v >>= interp c₂
interp (c₁ ⊕ c₂) (inj₁ v) = interp c₁ v >>= just ∘ inj₁
interp (c₁ ⊕ c₂) (inj₂ v) = interp c₂ v >>= just ∘ inj₂
interp (c₁ ⊗ c₂) (v₁ , v₂) = interp c₁ v₁ >>= (λ v₁' → interp c₂ v₂ >>= λ v₂' → just (v₁' , v₂'))
interp (η {t} {t≠0}) tt = just (default t {t≠0} , ○)
interp (ε {t} {t≠0}) (v' , ○) with 𝕌dec t (default t {t≠0}) v'
interp (ε {t}) (v' , ○) | yes _ = just tt
interp (ε {t}) (v' , ○) | no  _ = nothing -- if v ≡ v' then tt else throw Error

--- Examples

𝟚 : 𝕌
𝟚 = 𝟙 +ᵤ 𝟙

𝔽 𝕋 : ⟦ 𝟚 ⟧
𝔽 = inj₁ tt
𝕋 = inj₂ tt

xorr xorl : 𝟚 ×ᵤ 𝟚 ↔ 𝟚 ×ᵤ 𝟚
xorr = dist ⊚ (id↔ ⊕ (id↔ ⊗ swap₊)) ⊚ factor
xorl = distl ⊚ (id↔ ⊕ (swap₊ ⊗ id↔)) ⊚ factorl

𝟚≠0 : ¬ (card 𝟚 ≡ 0)
𝟚≠0 ()

η𝟚 : 𝟙 ↔ 𝟚 ×ᵤ (𝟙/ 𝟚)
η𝟚 = η {t≠0 = 𝟚≠0}

ε𝟚 : 𝟚 ×ᵤ (𝟙/ 𝟚) ↔ 𝟙
ε𝟚 = ε {t≠0 = 𝟚≠0}

--   ─────┬────⊕───  ───────
--        |    |   ⨉
--     ┌──⊕────┴───  ───┐
--     └────────────────┘
id' : 𝟚 ↔ 𝟚
id' = uniti⋆r ⊚ (id↔ ⊗ η𝟚) ⊚ assocl⋆ ⊚
      ((xorr ⊚ xorl ⊚ swap⋆) ⊗ id↔) ⊚
      assocr⋆ ⊚ (id↔ ⊗ ε𝟚) ⊚ unite⋆r

ex1 : interp id' 𝕋 ≡ just 𝕋
ex1 = refl

ex2 : interp id' 𝔽 ≡ just 𝔽
ex2 = refl

--     ┌──────  ───────┐
--     └──────╲╱───────┘
--            ╱╲
--     ┌─────    ──────┐
--     └───────────────┘
switch : 𝟙 ↔ 𝟙
switch = uniti⋆r ⊚ (η𝟚 ⊗ η𝟚) ⊚ assocl⋆ ⊚
         (((swap⋆ ⊗ id↔) ⊚ assocr⋆ ⊚
         (id↔ ⊗ swap⋆) ⊚ assocl⋆ ⊚ (swap⋆ ⊗ id↔)) ⊗ id↔) ⊚
         assocr⋆ ⊚ (ε𝟚 ⊗ ε𝟚) ⊚ unite⋆r

bad : 𝟚 ↔ 𝟚
bad = uniti⋆r ⊚ (id↔ ⊗ η𝟚) ⊚ assocl⋆ ⊚
      ((xorr ⊚ swap⋆) ⊗ id↔) ⊚
      assocr⋆ ⊚ (id↔ ⊗ ε𝟚) ⊚ unite⋆r

ex3 : interp bad 𝔽 ≡ just 𝔽
ex3 = refl

ex4 : interp bad 𝕋 ≡ nothing
ex4 = refl

{--
shouldn't_type_check : 𝟙 ↔ 𝟙
shouldn't_type_check = η {v = 𝔽} ⊚ ε {v = 𝕋}

ex5 : interp shouldn't_type_check tt ≡ nothing
ex5 = refl

more : 𝟙 ↔ 𝟙
more = η {v = 𝔽} ⊚ (swap₊ ⊗ id↔) ⊚ ε {v = 𝕋}

ex6 : interp more tt ≡ just tt
ex6 = refl
--}


------------------------------------------------------------------------
-- The partiality monads in Partiality-monad.Inductive and
-- Partiality-monad.Coinductive are pointwise equivalent, for sets,
-- assuming extensionality and countable choice
------------------------------------------------------------------------

{-# OPTIONS --cubical --sized-types #-}

open import Prelude hiding (⊥; ↑)

module Partiality-monad.Equivalence {a} {A : Type a} where

open import Equality.Propositional.Cubical
open import Logical-equivalence using (_⇔_)
open import Prelude.Size

open import Bijection equality-with-J using (_↔_)
open import Embedding equality-with-J
  using (Is-embedding; Injective≃Is-embedding)
open import Equivalence equality-with-J as Eq
  using (_≃_; Is-equivalence)
open import Function-universe equality-with-J as F hiding (id; _∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional equality-with-paths
  as Trunc
open import Injection equality-with-J using (Injective)
open import Quotient equality-with-paths as Quotient hiding ([_])
open import Univalence-axiom equality-with-J

import Delay-monad as D
open import Delay-monad.Alternative as A using (_↓_; _↑)
import Delay-monad.Alternative.Equivalence as A
import Delay-monad.Alternative.Partial-order as A
import Delay-monad.Alternative.Termination as A
import Delay-monad.Alternative.Weak-bisimilarity as A
import Delay-monad.Bisimilarity as B
import Partiality-monad.Coinductive as C
import Partiality-monad.Coinductive.Alternative as CA
open import Partiality-monad.Inductive as I
  hiding (_⊥; _⊑_; Increasing-sequence; _⇓_)
open import Partiality-monad.Inductive.Alternative-order
open import Partiality-monad.Inductive.Eliminators

------------------------------------------------------------------------
-- A function from the partiality monad defined in
-- Partiality-monad.Coinductive.Alternative to the inductive
-- partiality monad

-- Turns potential values into partial values.

Maybe→⊥ : Maybe A → A I.⊥
Maybe→⊥ nothing  = never
Maybe→⊥ (just y) = now y

-- Maybe→⊥ is monotone.

Maybe→⊥-mono : ∀ {x y} → A.LE x y → Maybe→⊥ x I.⊑ Maybe→⊥ y
Maybe→⊥-mono (inj₁ refl) = ⊑-refl _
Maybe→⊥-mono (inj₂ (refl , y≢n)) = never⊑ _

-- Maybe→⊥ can be used to turn increasing sequences of one kind into
-- increasing sequences of another kind.

Delay→Inc-seq : A.Delay A → I.Increasing-sequence A
Delay→Inc-seq (f , inc) = Maybe→⊥ ∘ f , Maybe→⊥-mono ∘ inc

-- Turns increasing sequences of potential values into partial values.

Delay→⊥ : A.Delay A → A I.⊥
Delay→⊥ = ⨆ ∘ Delay→Inc-seq

-- Delay→⊥ is monotone (if A is a set).

Delay→⊥-mono :
  Is-set A → ∀ x y → x A.∥⊑∥ y → Delay→⊥ x I.⊑ Delay→⊥ y
Delay→⊥-mono A-set x@(f , _) y@(g , _) x⊑y = ∃⊑→⨆⊑⨆ inc
  where
  inc : ∀ m → ∃ λ n → Maybe→⊥ (f m) I.⊑ Maybe→⊥ (g n)
  inc m with inspect (f m)
  inc m | nothing , fm↑  = 0 , (Maybe→⊥ (f m)  ≡⟨ cong Maybe→⊥ fm↑ ⟩⊑
                                never          ⊑⟨ never⊑ _ ⟩■
                                Maybe→⊥ (g 0)  ■)
  inc m | just z  , fm↓z =
    k , (Maybe→⊥ (f m)     ≡⟨ cong Maybe→⊥ fm↓z ⟩⊑
         Maybe→⊥ (just z)  ≡⟨ cong Maybe→⊥ (sym $ proj₂ y⇓z) ⟩⊑
         Maybe→⊥ (g k)     ■)
    where
    y⇓z =        $⟨ ∣ m , fm↓z ∣ ⟩
      x A.∥⇓∥ z  ↝⟨ x⊑y z ⟩
      y A.∥⇓∥ z  ↝⟨ _⇔_.from (A.⇓⇔∥⇓∥ A-set y) ⟩□
      y A.⇓ z    □

    k : ℕ
    k = proj₁ y⇓z

-- Delay→⊥ maps weakly bisimilar values to equal values (if A is a
-- set).

Delay→⊥-≈→≡ : Is-set A → ∀ x y → x A.≈ y → Delay→⊥ x ≡ Delay→⊥ y
Delay→⊥-≈→≡ A-set x y =
  x A.≈ y                                            ↝⟨ Σ-map (Delay→⊥-mono A-set x y) (Delay→⊥-mono A-set y x) ⟩
  Delay→⊥ x I.⊑ Delay→⊥ y × Delay→⊥ x I.⊒ Delay→⊥ y  ↝⟨ uncurry antisymmetry ⟩□
  Delay→⊥ x ≡ Delay→⊥ y                              □

-- If A is a set, then values in A CA.⊥ can be mapped to values in the
-- inductive partiality monad.

⊥→⊥ : Is-set A → A CA.⊥ → A I.⊥
⊥→⊥ A-set = Quotient.rec λ where
  .[]ʳ                                   → Delay→⊥
  .[]-respects-relationʳ {x = x} {y = y} → Delay→⊥-≈→≡ A-set x y
  .is-setʳ                               → ⊥-is-set

------------------------------------------------------------------------
-- A lemma

-- I._⇓_ and A._∥⇓∥_ are pointwise logically equivalent (via Delay→⊥),
-- for sets.

⇓⇔∥⇓∥ :
  Is-set A →
  ∀ x {y} → Delay→⊥ x I.⇓ y ⇔ x A.∥⇓∥ y
⇓⇔∥⇓∥ A-set x@(f , _) {y} =
  Delay→⊥ x I.⇓ y                    ↔⟨⟩
  ⨆ (Delay→Inc-seq x) I.⇓ y          ↔⟨ ⨆⇓≃∥∃⇓∥ ⟩
  ∥ (∃ λ n → Maybe→⊥ (f n) I.⇓ y) ∥  ↝⟨ ∥∥-cong-⇔ (∃-cong λ _ → record { to = to _; from = cong Maybe→⊥ }) ⟩
  ∥ (∃ λ n → f n ↓ y) ∥              ↝⟨ F.id ⟩□
  x A.∥⇓∥ y                          □
  where
  to : ∀ n → Maybe→⊥ (f n) I.⇓ y → f n ↓ y
  to n f⇓y with f n
  ... | nothing = ⊥-elim $ now≢never _ (sym f⇓y)
  ... | just y′ =
    just y′  ≡⟨ cong just y′≡y ⟩∎
    just y   ∎
    where
    y′≡y =            $⟨ f⇓y ⟩
      now y′ ≡ now y  ↔⟨ now≡now≃∥≡∥ ⟩
      ∥ y′ ≡ y ∥      ↝⟨ ∥∥↔ A-set ⟩□
      y′ ≡ y          □

------------------------------------------------------------------------
-- ⊥→⊥ is injective

-- Delay→⊥ is (kind of) injective (if A is a set).

Delay→⊥-injective :
  Is-set A →
  ∀ x y → Delay→⊥ x ≡ Delay→⊥ y → x A.≈ y
Delay→⊥-injective A-set x y x≡y =
    lemma A-set x y (≡→⊑      x≡y)
  , lemma A-set y x (≡→⊑ (sym x≡y))
  where
  ≡→⊑ : ∀ {x y} → x ≡ y → x I.⊑ y
  ≡→⊑ refl = ⊑-refl _

  lemma :
    Is-set A →
    ∀ x y → Delay→⊥ x I.⊑ Delay→⊥ y → x A.∥⊑∥ y
  lemma A-set x y x⊑y z =
    x A.∥⇓∥ z            ↝⟨ _⇔_.from (⇓⇔∥⇓∥ A-set x) ⟩
    Delay→⊥ x I.⇓ z      ↔⟨ ⇓≃now⊑ ⟩
    now z I.⊑ Delay→⊥ x  ↝⟨ flip ⊑-trans x⊑y ⟩
    now z I.⊑ Delay→⊥ y  ↔⟨ inverse ⇓≃now⊑ ⟩
    Delay→⊥ y I.⇓ z      ↝⟨ _⇔_.to (⇓⇔∥⇓∥ A-set y) ⟩□
    y A.∥⇓∥ z            □

-- ⊥→⊥ A-set is injective.

⊥→⊥-injective :
  (A-set : Is-set A) →
  Injective (⊥→⊥ A-set)
⊥→⊥-injective A-set {x} {y} = Quotient.elim-prop
  {P = λ x → ⊥→⊥ A-set x ≡ ⊥→⊥ A-set y → x ≡ y}
  (λ where
     .[]ʳ x → Quotient.elim-prop
       {P = λ y → Delay→⊥ x ≡ ⊥→⊥ A-set y → Quotient.[ x ] ≡ y}
       (λ where
          .[]ʳ y → []-respects-relation ∘
                   Delay→⊥-injective A-set x y
          .is-propositionʳ _ →
            Π-closure ext 1 λ _ →
            /-is-set)
       y
     .is-propositionʳ _ →
       Π-closure ext 1 λ _ →
       /-is-set)
  x

------------------------------------------------------------------------
-- ⊥→⊥ is surjective

-- Delay→⊥ is surjective (if A is a set, assuming countable choice).

Delay→⊥-surjective :
  Is-set A →
  Axiom-of-countable-choice a →
  Surjective Delay→⊥
Delay→⊥-surjective A-set cc =
  ⊥-rec-⊥ (record
    { pe = constant-sequence nothing
    ; po = constant-sequence ∘ just
    ; pl = λ s →
             (∀ n → ∥ (∃ λ x → Delay→⊥ x ≡ s [ n ]) ∥)    ↝⟨ cc ⟩
             ∥ (∀ n → ∃ λ x → Delay→⊥ x ≡ s [ n ]) ∥      ↔⟨ ∥∥-cong ΠΣ-comm ⟩
             ∥ (∃ λ f → ∀ n → Delay→⊥ (f n) ≡ s [ n ]) ∥  ↝⟨ ∥∥-map (uncurry $ flip construct s) ⟩□
             ∥ (∃ λ x → Delay→⊥ x ≡ ⨆ s) ∥                □
    ; pp = λ _ → truncation-is-proposition
    })
  where
  -- The increasing sequences (of type A.Delay A) returned by this
  -- function are constant.

  constant-sequence : ∀ x → ∥ (∃ λ y → Delay→⊥ y ≡ Maybe→⊥ x) ∥
  constant-sequence x = ∣ (const x , const (inj₁ refl)) , ⨆-const ∣

  -- Given a sequence and an increasing sequence s that are pointwise
  -- equal (via Delay→⊥) one can construct an increasing sequence that
  -- is equal (via Delay→⊥) to ⨆ s.

  construct :
    (f : ℕ → A.Delay A)
    (s : I.Increasing-sequence A) →
    (∀ n → Delay→⊥ (f n) ≡ s [ n ]) →
    ∃ λ x → Delay→⊥ x ≡ ⨆ s
  construct f s h = x , x-correct
    where
    -- We use f and an isomorphism between ℕ and ℕ × ℕ to construct a
    -- function from ℕ to Maybe A.

    f₂ : ℕ → ℕ → Maybe A
    f₂ m n = proj₁ (f m) n

    f₁ : ℕ → Maybe A
    f₁ =
      ℕ        ↔⟨ ℕ↔ℕ² ⟩
      ℕ × ℕ    ↝⟨ uncurry f₂ ⟩□
      Maybe A  □

    -- All values that this function can terminate with are equal.

    termination-value-unique-f₂ :
      ∀ {m n y m′ n′ y′} →
      f₂ m n ↓ y × f₂ m′ n′ ↓ y′ →
      y ≡ y′
    termination-value-unique-f₂ {m} {n} {y} {m′} {n′} {y′} =
      f₂ m n ↓ y × f₂ m′ n′ ↓ y′  ↝⟨ f₂↓→⨆s⇓ ×-cong f₂↓→⨆s⇓ ⟩
      ⨆ s I.⇓ y × ⨆ s I.⇓ y′      ↝⟨ uncurry termination-value-merely-unique ⟩
      ∥ y ≡ y′ ∥                  ↔⟨ ∥∥↔ A-set ⟩□
      y ≡ y′                      □
      where
      f₂↓→⨆s⇓ : ∀ {y m n} → f₂ m n ↓ y → ⨆ s I.⇓ y
      f₂↓→⨆s⇓ {y} {m} f₂↓ =
        terminating-element-is-⨆ s
          (s [ m ]        ≡⟨ sym (h m) ⟩
           Delay→⊥ (f m)  ≡⟨ _⇔_.from (⇓⇔∥⇓∥ A-set (f m)) ∣ _ , f₂↓ ∣ ⟩∎
           now y          ∎)

    termination-value-unique-f₁ :
      ∀ {y y′} →
      (∃ λ n → f₁ n ↓ y) →
      (∃ λ n → f₁ n ↓ y′) →
      y ≡ y′
    termination-value-unique-f₁ (_ , ↓y) (_ , ↓y′) =
      termination-value-unique-f₂ (↓y , ↓y′)

    abstract

      -- Thus the function can be completed to an increasing sequence.

      completed-f₁ : ∃ λ x → ∀ {y} → x A.⇓ y ⇔ ∃ λ n → f₁ n ↓ y
      completed-f₁ = A.complete-function f₁ termination-value-unique-f₁

    -- The increasing sequence that is returned above.

    x : A.Delay A
    x = proj₁ completed-f₁

    -- Every potential value in the increasing sequence x is smaller
    -- than or equal to (via Maybe→⊥) some value in s.

    x⊑s : ∀ m → ∃ λ n → Maybe→⊥ (proj₁ x m) I.⊑ s [ n ]
    x⊑s m with inspect (proj₁ x m)
    x⊑s m | nothing , x↑ =
        zero
      , (Maybe→⊥ (proj₁ x m)  ≡⟨ cong Maybe→⊥ x↑ ⟩⊑
         never                ⊑⟨ never⊑ _ ⟩■
         s [ 0 ]              ■)
    x⊑s m | just y , x↓ =
        n₁
      , (Maybe→⊥ (proj₁ x m)  ≡⟨ cong Maybe→⊥ x↓ ⟩⊑
         now y                ≡⟨ sym f⇓ ⟩⊑
         Delay→⊥ (f n₁)       ≡⟨ h n₁ ⟩⊑
         s [ n₁ ]             ■)
      where
      f₁↓ : ∃ λ n → f₁ n ↓ y
      f₁↓ = _⇔_.to (proj₂ completed-f₁) (_ , x↓)

      n  = proj₁ f₁↓
      n₁ = proj₁ (_↔_.to ℕ↔ℕ² n)
      n₂ = proj₂ (_↔_.to ℕ↔ℕ² n)

      f⇓ : Delay→⊥ (f n₁) I.⇓ y
      f⇓ =
        _≃_.from ⇓≃now⊑
          (now y                        ≡⟨ cong Maybe→⊥ $ sym $ proj₂ f₁↓ ⟩⊑
           Maybe→⊥ (f₁ n)               ⊑⟨⟩
           Maybe→⊥ (f₂ n₁ n₂)           ⊑⟨⟩
           Maybe→⊥ (proj₁ (f n₁) n₂)    ⊑⟨⟩
           Delay→Inc-seq (f n₁) [ n₂ ]  ⊑⟨ upper-bound (Delay→Inc-seq (f n₁)) _ ⟩■
           Delay→⊥ (f n₁)               ■)

    -- Furthermore every potential value in f is smaller than or equal
    -- to x.

    f⊑x : ∀ m → f m A.⊑ x
    f⊑x m y =
      f m A.⇓ y                                                 ↝⟨ Σ-map (_↔_.from ℕ↔ℕ² ∘ (m ,_)) (λ {n} →

          f₂ m n ↓ y                                                 ↝⟨ ≡⇒→ (cong ((_↓ y) ∘ uncurry f₂) $ sym $ _↔_.right-inverse-of ℕ↔ℕ² (m , n)) ⟩
          uncurry f₂ (_↔_.to ℕ↔ℕ² (_↔_.from ℕ↔ℕ² (m , n))) ↓ y       ↝⟨ F.id ⟩□
          f₁ (_↔_.from ℕ↔ℕ² (m , n)) ↓ y                             □) ⟩

      (∃ λ n → f₁ n ↓ y)                                        ↝⟨ _⇔_.from (proj₂ completed-f₁) ⟩□
      x A.⇓ y                                                   □

    -- Thus x is correctly defined.

    x-correct : Delay→⊥ x ≡ ⨆ s
    x-correct = antisymmetry
      (⊑→⨆⊑⨆ λ n →
         Delay→Inc-seq x [ n ]  ⊑⟨ proj₂ (x⊑s n) ⟩■
         s [ proj₁ (x⊑s n) ]    ■)
      (least-upper-bound _ _ λ m →
         s [ m ]        ≡⟨ sym (h m) ⟩⊑
         Delay→⊥ (f m)  ⊑⟨ Delay→⊥-mono A-set (f m) x (∥∥-map ∘ f⊑x m) ⟩■
         Delay→⊥ x      ■)

-- ⊥→⊥ A-set is surjective (assuming countable choice).

⊥→⊥-surjective :
  (A-set : Is-set A) →
  Axiom-of-countable-choice a →
  Surjective (⊥→⊥ A-set)
⊥→⊥-surjective A-set cc x =
  ∥∥-map (λ { (pre , can-pre≡x) → Quotient.[ pre ] , can-pre≡x })
         (Delay→⊥-surjective A-set cc x)

------------------------------------------------------------------------
-- ⊥→⊥ is an equivalence

-- ⊥→⊥ A-set is an equivalence (assuming countable choice).

⊥→⊥-equiv :
  (A-set : Is-set A) →
  Axiom-of-countable-choice a →
  Is-equivalence (⊥→⊥ A-set)
⊥→⊥-equiv A-set cc =                                 $⟨ _,_ {B = const _}
                                                            (⊥→⊥-surjective A-set cc)
                                                            (λ {_ _} → ⊥→⊥-injective A-set) ⟩
  Surjective (⊥→⊥ A-set) × Injective (⊥→⊥ A-set)     ↝⟨ Σ-map id (_≃_.to (Injective≃Is-embedding ext /-is-set ⊥-is-set _)) ⟩
  Surjective (⊥→⊥ A-set) × Is-embedding (⊥→⊥ A-set)  ↝⟨ _≃_.to surjective×embedding≃equivalence ⟩□
  Is-equivalence (⊥→⊥ A-set)                         □

-- Thus the inductive definition of the partiality monad is equivalent
-- to the definition in Partiality-monad.Coinductive.Alternative, for
-- sets, assuming countable choice.

⊥≃⊥′ :
  Is-set A →
  Axiom-of-countable-choice a →
  A CA.⊥ ≃ A I.⊥
⊥≃⊥′ A-set choice = Eq.⟨ _ , ⊥→⊥-equiv A-set choice ⟩

------------------------------------------------------------------------
-- The two definitions of the partiality monad are equivalent

-- The inductive and coinductive definitions of the partiality monad
-- are pointwise equivalent, for sets, assuming extensionality and
-- countable choice.

⊥≃⊥ :
  Is-set A →
  B.Extensionality a →
  Axiom-of-countable-choice a →
  A I.⊥ ≃ A C.⊥
⊥≃⊥ A-set delay-ext choice =
  A I.⊥   ↝⟨ inverse (⊥≃⊥′ A-set choice) ⟩
  A CA.⊥  ↔⟨ CA.⊥↔⊥ A-set delay-ext ⟩□
  A C.⊥   □

-- The previous result has a number of preconditions. None of these
-- preconditions are needed to translate from the delay monad to the
-- quotient inductive-inductive partiality monad.

Delay→⊥′ : D.Delay A ∞ → A I.⊥
Delay→⊥′ =
  D.Delay A ∞  ↝⟨ _⇔_.from A.Delay⇔Delay ⟩
  A.Delay A    ↝⟨ Delay→⊥ ⟩□
  A I.⊥        □

-- This translation turns weakly bisimilar computations into equal
-- computations, assuming that the underlying type is a set.

Delay→⊥′-≈→≡ :
  Is-set A →
  ∀ {x y} → x B.≈ y → Delay→⊥′ x ≡ Delay→⊥′ y
Delay→⊥′-≈→≡ A-set {x} {y} =
  x B.≈ y                                                ↝⟨ _⇔_.to (A.≈⇔≈′ A-set) ⟩
  _⇔_.from A.Delay⇔Delay x A.≈ _⇔_.from A.Delay⇔Delay y  ↝⟨ Delay→⊥-≈→≡ A-set (_⇔_.from A.Delay⇔Delay x) (_⇔_.from A.Delay⇔Delay y) ⟩□
  Delay→⊥′ x ≡ Delay→⊥′ y                                □

-- One can also translate from the coinductive to the inductive
-- partiality monad, as long as the underlying type is a set.

⊥→⊥′ : Is-set A → A C.⊥ → A I.⊥
⊥→⊥′ A-set = Quotient.rec λ where
  .[]ʳ                   → Delay→⊥′
  .[]-respects-relationʳ → Trunc.rec I.⊥-is-set (Delay→⊥′-≈→≡ A-set)
  .is-setʳ               → I.⊥-is-set


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

module Strict where

open import Agda.Builtin.Strict public
open import Level

infixr 0 _$!_
_$!_ : {A : Type a} {B : A → Type b} → (∀ x → B x) → ∀ x → B x
f $! x = primForce x f
{-# INLINE _$!_ #-}

infixr 0 let-bang
let-bang : {A : Type a} {B : A → Type b} → ∀ x → (∀ x → B x) → B x
let-bang = primForce
{-# INLINE let-bang #-}

syntax let-bang v (λ x → e) = let! x =! v in! e

infixr 0 lambda-bang
lambda-bang : {A : Type a} {B : A → Type b} → (∀ x → B x) → ∀ x → B x
lambda-bang f x = primForce x f
{-# INLINE lambda-bang #-}

syntax lambda-bang (λ x → e) = λ! x →! e


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

-- | Operations that ensure a cycle traverses a particular element
-- at most once.
module Dodo.Binary.Cycle where

-- Stdlib import
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; _≢_; refl)
open import Level using (Level; _⊔_)
open import Function using (_∘_)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Relation.Nullary using (yes; no)
open import Relation.Binary using (Rel)
open import Relation.Binary.Construct.Closure.Transitive using (TransClosure; [_]; _∷_; _∷ʳ_; _++_)
-- Local imports
open import Dodo.Unary.Dec
open import Dodo.Binary.Transitive

-- # Definitions

-- | The given relation, with proofs that neither element equals `z`.
ExcludeRel : {a ℓ : Level} {A : Set a} → (R : Rel A ℓ) → (z : A) → Rel A (a ⊔ ℓ)
ExcludeRel R z x y = R x y × x ≢ z × y ≢ z

-- | A cycle of R which passes through `z` /exactly once/.
data PassCycle {a ℓ : Level} {A : Set a} (R : Rel A ℓ) (z : A) : Set (a ⊔ ℓ) where
  cycle₁ : R z z → PassCycle R z
  cycle₂ : {x : A} → x ≢ z → R z x → R x z → PassCycle R z
  cycleₙ : {x y : A} → R z x → TransClosure (ExcludeRel R z) x y → R y z → PassCycle R z

-- # Functions

-- | A cycle of a relation either /does not/ pass through an element `y`, or it
-- can be made to pass through `y` /exactly once/.
--
-- Note that if the original cycle passes `y` /more than once/, then only one
-- cycle of the multi-cycle through `y` may be taken.
divert-cycle : {a ℓ : Level} {A : Set a}
  → {R : Rel A ℓ}
  → {x : A}
  → TransClosure R x x
  → {y : A}
  → DecPred (_≡ y)
  → PassCycle R y ⊎ TransClosure (ExcludeRel R y) x x
divert-cycle {x = x} [ Rxx ] eq-xm with eq-xm x
... | yes refl = inj₁ (cycle₁ Rxx)
... | no  x≢y  = inj₂ [ ( Rxx , x≢y , x≢y ) ]
divert-cycle {A = A} {R = R} {x} ( Rxw ∷ R⁺wx ) {y} eq-dec = lemma Rxw R⁺wx
  where
  -- Chain that starts with `y`.
  --
  -- `Ryx` and `R⁺xz` are acculumators.
  lemma-incl : {x z : A} → R y x → TransClosure (ExcludeRel R y) x z → TransClosure R z y → PassCycle R y
  lemma-incl Ryx R⁺xz [ Rzy ] = cycleₙ Ryx R⁺xz Rzy
  lemma-incl Ryx R⁺xz (_∷_ {_} {w} Rzw R⁺wy) with eq-dec w
  lemma-incl Ryx R⁺xz (_∷_ {_} {w} Rzw R⁺wy) | yes refl = cycleₙ Ryx R⁺xz Rzw
  lemma-incl Ryx R⁺xz (_∷_ {_} {w} Rzw R⁺wy) | no  w≢y  =
    let z≢y = ⁺-lift-predʳ (proj₂ ∘ proj₂) R⁺xz
    in lemma-incl Ryx (R⁺xz ∷ʳ (Rzw , z≢y , w≢y)) R⁺wy

  -- First step of a chain that starts with `y`.
  lemma-incl₀ : {x : A} → R y x → TransClosure R x y → PassCycle R y
  lemma-incl₀ {x} Ryx R⁺xy with eq-dec x
  lemma-incl₀ {x} Ryx R⁺xy                   | yes refl = cycle₁ Ryx
  lemma-incl₀ {x} Ryx [ Rxy ]                | no  x≢y  = cycle₂ x≢y Ryx Rxy
  lemma-incl₀ {x} Ryx (_∷_ {_} {z} Rxz R⁺zy) | no x≢y with eq-dec z
  lemma-incl₀ {x} Ryx (_∷_ {x} {z} Rxz R⁺zy) | no x≢y | yes refl = cycle₂ x≢y Ryx Rxz
  lemma-incl₀ {x} Ryx (_∷_ {x} {z} Rxz R⁺zy) | no x≢y | no  z≢y  = lemma-incl Ryx [ Rxz , x≢y , z≢y ] R⁺zy

  -- Chain that does /not/ (yet) pass through `y`.
  lemma-excl : {z : A} → TransClosure (ExcludeRel R y) x z → TransClosure R z x → PassCycle R y ⊎ TransClosure (ExcludeRel R y) x x
  lemma-excl R⁺xz [ Rzx ] =
    let z≢y = ⁺-lift-predʳ (proj₂ ∘ proj₂) R⁺xz
        x≢y = ⁺-lift-predˡ (proj₁ ∘ proj₂) R⁺xz
    in inj₂ (R⁺xz ∷ʳ (Rzx , z≢y , x≢y))
  lemma-excl R⁺xz (_∷_ {_} {w} Rzw R⁺wx) with eq-dec w
  lemma-excl R⁺xz (_∷_ {_} {_} Rzw [ Rwx ])      | yes refl = inj₁ (cycleₙ Rwx R⁺xz Rzw)
  lemma-excl R⁺xz (_∷_ {_} {_} Rzw (Rwq ∷ R⁺qx)) | yes refl = inj₁ (lemma-incl₀ Rwq (R⁺qx ++ (⁺-map _ proj₁ R⁺xz) ∷ʳ Rzw))
  lemma-excl R⁺xz (_∷_ {_} {_} Rzw R⁺wx)         | no  w≢y =
    let z≢y = ⁺-lift-predʳ (proj₂ ∘ proj₂) R⁺xz
    in lemma-excl (R⁺xz ∷ʳ (Rzw , z≢y , w≢y)) R⁺wx

  lemma : {w : A} → R x w → TransClosure R w x → PassCycle R y ⊎ TransClosure (ExcludeRel R y) x x
  lemma {_} Rxw R⁺wx with eq-dec x
  lemma {_} Rxw R⁺wx           | yes refl = inj₁ (lemma-incl₀ Rxw R⁺wx)
  lemma {w} Rxw R⁺wx           | no  x≢y with eq-dec w
  lemma {_} Rxw [ Rwx ]        | no  x≢y | yes refl = inj₁ (cycle₂ x≢y Rwx Rxw)
  lemma {_} Rxw ( Rwz ∷ R⁺zx ) | no  x≢y | yes refl = inj₁ (lemma-incl₀ Rwz (R⁺zx ∷ʳ Rxw))
  lemma {_} Rxw R⁺wx           | no  x≢y | no  w≢y  = lemma-excl [ Rxw , x≢y , w≢y ] R⁺wx


------------------------------------------------------------------------
-- Lemmas related to strong similarity for CCS
------------------------------------------------------------------------

{-# OPTIONS --sized-types #-}

open import Prelude

module Similarity.CCS {ℓ} {Name : Type ℓ} where

open import Equality.Propositional
open import Prelude.Size

open import Function-universe equality-with-J hiding (id; _∘_)

import Bisimilarity.CCS as BL
import Bisimilarity.Equational-reasoning-instances
open import Equational-reasoning
open import Labelled-transition-system.CCS Name
import Similarity.Equational-reasoning-instances

open import Bisimilarity CCS as B using (_∼_; _∼′_)
open import Similarity CCS

------------------------------------------------------------------------
-- Congruence lemmas

private
  module CL {i} = BL.Cong-lemmas [ i ]_≤′_ challenge

mutual

  -- _∣_ preserves similarity.

  infix 6 _∣-cong_ _∣-cong′_

  _∣-cong_ : ∀ {i P P′ Q Q′} →
             [ i ] P ≤ P′ → [ i ] Q ≤ Q′ → [ i ] P ∣ Q ≤ P′ ∣ Q′
  P≤P′ ∣-cong Q≤Q′ = ⟨ CL.∣-cong _∣-cong′_ P≤P′ Q≤Q′ ⟩

  _∣-cong′_ : ∀ {i P P′ Q Q′} →
              [ i ] P ≤′ P′ → [ i ] Q ≤′ Q′ → [ i ] P ∣ Q ≤′ P′ ∣ Q′
  force (P≤P′ ∣-cong′ Q≤Q′) = force P≤P′ ∣-cong force Q≤Q′

-- _⊕_ preserves similarity.

infix 8 _⊕-cong_ _⊕-cong′_

_⊕-cong_ : ∀ {i P P′ Q Q′} →
           [ i ] P ≤ P′ → [ i ] Q ≤ Q′ → [ i ] P ⊕ Q ≤ P′ ⊕ Q′
P≤P′ ⊕-cong Q≤Q′ = ⟨ CL.⊕-cong P≤P′ Q≤Q′ ⟩

_⊕-cong′_ : ∀ {i P P′ Q Q′} →
            [ i ] P ≤′ P′ → [ i ] Q ≤′ Q′ → [ i ] P ⊕ Q ≤′ P′ ⊕ Q′
force (P≤P′ ⊕-cong′ Q≤Q′) = force P≤P′ ⊕-cong force Q≤Q′

-- _·_ preserves similarity.

infix 12 _·-cong_ _·-cong′_

_·-cong_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ≤′ force P′ → [ i ] μ · P ≤ μ′ · P′
_·-cong_ {i} refl P≤P′ = ⟨ CL.·-cong {i = i} P≤P′ ⟩

_·-cong′_ :
  ∀ {i μ μ′ P P′} →
  μ ≡ μ′ → [ i ] force P ≤′ force P′ → [ i ] μ · P ≤′ μ′ · P′
force (μ≡μ′ ·-cong′ P≤P′) = μ≡μ′ ·-cong P≤P′

-- _∙_ preserves similarity.

infix 12 _∙-cong_ _∙-cong′_

_∙-cong_ : ∀ {i μ μ′ P P′} →
           μ ≡ μ′ → [ i ] P ≤ P′ → [ i ] μ ∙ P ≤ μ′ ∙ P′
refl ∙-cong P≤P′ = refl ·-cong convert {a = ℓ} P≤P′

_∙-cong′_ : ∀ {i μ μ′ P P′} →
            μ ≡ μ′ → [ i ] P ≤′ P′ → [ i ] μ ∙ P ≤′ μ′ ∙ P′
force (μ≡μ′ ∙-cong′ P≤P′) = μ≡μ′ ∙-cong force P≤P′

-- _∙ turns equal actions into similar processes.

infix 12 _∙-cong _∙-cong′

_∙-cong : ∀ {μ μ′} → μ ≡ μ′ → μ ∙ ≤ μ′ ∙
refl ∙-cong = reflexive

_∙-cong′ : ∀ {μ μ′} → μ ≡ μ′ → μ ∙ ≤′ μ′ ∙
refl ∙-cong′ = reflexive

mutual

  -- ⟨ν_⟩ preserves similarity.

  ⟨ν_⟩-cong : ∀ {i a a′ P P′} →
              a ≡ a′ → [ i ] P ≤ P′ → [ i ] ⟨ν a ⟩ P ≤ ⟨ν a′ ⟩ P′
  ⟨ν refl ⟩-cong P≤P′ = ⟨ CL.⟨ν⟩-cong ⟨ν refl ⟩-cong′ P≤P′ ⟩

  ⟨ν_⟩-cong′ : ∀ {i a a′ P P′} →
               a ≡ a′ → [ i ] P ≤′ P′ → [ i ] ⟨ν a ⟩ P ≤′ ⟨ν a′ ⟩ P′
  force (⟨ν a≡a′ ⟩-cong′ P≤P′) = ⟨ν a≡a′ ⟩-cong (force P≤P′)

mutual

  -- !_ preserves similarity.

  infix 10 !-cong_ !-cong′_

  !-cong_ : ∀ {i P P′} →
            [ i ] P ≤ P′ → [ i ] ! P ≤ ! P′
  !-cong P≤P′ = ⟨ CL.!-cong BL.6-1-3-2 _∣-cong′_ !-cong′_ P≤P′ ⟩

  !-cong′_ : ∀ {i P P′} → [ i ] P ≤′ P′ → [ i ] ! P ≤′ ! P′
  force (!-cong′ P≤P′) = !-cong force P≤P′

-- _[_] preserves similarity.

mutual

  infix 5 _[_]-cong _[_]-cong′

  _[_]-cong :
    ∀ {i n Ps Qs}
    (C : Context ∞ n) → (∀ x → [ i ] Ps x ≤ Qs x) →
    [ i ] C [ Ps ] ≤ C [ Qs ]
  hole x   [ Ps≤Qs ]-cong = Ps≤Qs x
  ∅        [ Ps≤Qs ]-cong = reflexive
  C₁ ∣ C₂  [ Ps≤Qs ]-cong = (C₁ [ Ps≤Qs ]-cong) ∣-cong (C₂ [ Ps≤Qs ]-cong)
  C₁ ⊕ C₂  [ Ps≤Qs ]-cong = (C₁ [ Ps≤Qs ]-cong) ⊕-cong (C₂ [ Ps≤Qs ]-cong)
  μ · C    [ Ps≤Qs ]-cong = refl ·-cong λ { .force → force C [ Ps≤Qs ]-cong }
  ⟨ν a ⟩ C [ Ps≤Qs ]-cong = ⟨ν refl ⟩-cong (C [ Ps≤Qs ]-cong)
  ! C      [ Ps≤Qs ]-cong = !-cong (C [ Ps≤Qs ]-cong)

  _[_]-cong′ :
    ∀ {i n Ps Qs}
    (C : Context ∞ n) → (∀ x → [ i ] Ps x ≤′ Qs x) →
    [ i ] C [ Ps ] ≤′ C [ Qs ]
  force (C [ Ps≤Qs ]-cong′) = C [ (λ x → force (Ps≤Qs x)) ]-cong

------------------------------------------------------------------------
-- Other results

-- P is similar to P ⊕ Q.

≤-⊕-left : ∀ {i P Q} → [ i ] P ≤ P ⊕ Q
≤-⊕-left = ⟨ (λ P⟶P′ → _ , sum-left P⟶P′ , reflexive) ⟩

-- Q is similar to P ⊕ Q.

≤-⊕-right : ∀ {i P Q} → [ i ] Q ≤ P ⊕ Q
≤-⊕-right = ⟨ (λ Q⟶Q′ → _ , sum-right Q⟶Q′ , reflexive) ⟩

-- If Name is inhabited, then there are two processes that are similar
-- in both directions, but not bisimilar.
--
-- I took this example from Wikipedia; I suspect that it is due to
-- Milner.

≤≥≁ : Name → ∃ λ P → ∃ λ Q → P ≤ Q × Q ≤ P × ¬ P ∼ Q
≤≥≁ x = machine₁ , machine₂
      , machine₁≤machine₂ , machine₂≤machine₁ , machine₁≁machine₂
  where

  -- Some names (with kinds), constructed using x.

  pay coffee tea : Name-with-kind

  pay    = x , true
  coffee = pay
  tea    = x , false

  -- Two vending machines.

  machine₁ machine₂ machine₁′ machine₂′ : Proc ∞

  machine₁′ = name pay ∙ (coffee ∙ ⊕ tea ∙)
  machine₁  = ! machine₁′

  machine₂′ = (name pay ∙ (coffee ∙) ⊕ name pay ∙ (tea ∙))
                ⊕
              machine₁′
  machine₂  = ! machine₂′

  -- A lemma.

  machine₁⟶ :
    ∀ {P μ} → machine₁ [ μ ]⟶ P →
    μ ≡ name pay × P ∼ machine₁ ∣ (coffee ∙ ⊕ tea ∙)
  machine₁⟶ tr = case BL.6-1-3-2 tr of λ where
    (inj₁ (_ , action , P∼))                 → refl , P∼
    (inj₂ (_ , _ , _ , _ , action , tr , _)) →
      ⊥-elim (names-are-not-inverted tr)

  -- The first machine is similar to the second one.

  machine₁≤machine₂ : ∀ {i} → [ i ] machine₁ ≤ machine₂
  machine₁≤machine₂ {i} =
    StepC.⟨ (λ {P} tr →
               case machine₁⟶ tr of λ where
                 (refl , P∼) →
                     _
                   , (machine₂                      [ name pay ]⟶⟨ replication (par-right (sum-right action)) ⟩
                      machine₂ ∣ coffee ∙ ⊕ tea ∙)
                   , (P                            ∼⟨ ≤: convert {a = ℓ} P∼ ⟩
                      machine₁ ∣ coffee ∙ ⊕ tea ∙  ∼⟨ machine₁≤′machine₂ ∣-cong′ (_ ■) ⟩■
                      machine₂ ∣ coffee ∙ ⊕ tea ∙))
          ⟩
    where
    machine₁≤′machine₂ : [ i ] machine₁ ≤′ machine₂
    force machine₁≤′machine₂ = machine₁≤machine₂

  -- The second machine is similar to the first one.

  machine₂≤machine₁ : ∀ {i} → [ i ] machine₂ ≤ machine₁
  machine₂≤machine₁ {i} = StepC.⟨ helper ∘ BL.6-1-3-2 ⟩
    where
    machine₂≤′machine₁ : [ i ] machine₂ ≤′ machine₁
    force machine₂≤′machine₁ = machine₂≤machine₁

    lemma =
      machine₁                     [ name pay ]⟶⟨ replication (par-right action) ⟩
      machine₁ ∣ coffee ∙ ⊕ tea ∙

    helper :
      ∀ {P μ} →
      (∃ λ P′ → machine₂′ [ μ ]⟶ P′ × P ∼ machine₂ ∣ P′)
        ⊎
      (μ ≡ τ × ∃ λ P′ → ∃ λ P″ → ∃ λ a →
       machine₂′ [ name a ]⟶ P′ × machine₂′ [ name (co a) ]⟶ P″ ×
       P ∼ (machine₂ ∣ P′) ∣ P″) →
      ∃ λ Q → machine₁ [ μ ]⟶ Q × [ i ] P ≤′ Q
    helper {P} (inj₁ (_ , sum-left (sum-left action) , P∼)) =
        _
      , lemma
      , (P                            ∼⟨ ≤: convert {a = ℓ} P∼ ⟩
         machine₂ ∣ coffee ∙          ∼⟨ machine₂≤′machine₁ ∣-cong′ convert {a = ℓ} ≤-⊕-left ⟩■
         machine₁ ∣ coffee ∙ ⊕ tea ∙)

    helper {P} (inj₁ (_ , sum-left (sum-right action) , P∼)) =
        _
      , lemma
      , (P                            ∼⟨ ≤: convert {a = ℓ} P∼ ⟩
         machine₂ ∣ tea ∙             ∼⟨ machine₂≤′machine₁ ∣-cong′ convert {a = ℓ} ≤-⊕-right ⟩■
         machine₁ ∣ coffee ∙ ⊕ tea ∙)

    helper {P} (inj₁ (_ , sum-right action , P∼)) =
        _
      , lemma
      , (P                            ∼⟨ ≤: convert {a = ℓ} P∼ ⟩
         machine₂ ∣ coffee ∙ ⊕ tea ∙  ∼⟨ machine₂≤′machine₁ ∣-cong′ (_ ■) ⟩■
         machine₁ ∣ coffee ∙ ⊕ tea ∙)

    helper (inj₂ (_ , _ , _ , _ , sum-left (sum-left action)  , sum-left (sum-left tr)  , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-left (sum-left action)  , sum-left (sum-right tr) , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-left (sum-left action)  , sum-right tr            , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-left (sum-right action) , sum-left (sum-left tr)  , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-left (sum-right action) , sum-left (sum-right tr) , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-left (sum-right action) , sum-right tr            , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-right action            , sum-left (sum-left tr)  , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-right action            , sum-left (sum-right tr) , _)) = ⊥-elim (names-are-not-inverted tr)
    helper (inj₂ (_ , _ , _ , _ , sum-right action            , sum-right tr            , _)) = ⊥-elim (names-are-not-inverted tr)

  -- The two machines are not bisimilar.

  machine₁≁machine₂ : ¬ machine₁ ∼ machine₂
  machine₁≁machine₂ =
    machine₁ ∼ machine₂                                            ↝⟨ (λ hyp → B.right-to-left hyp
                                                                                (replication (par-right (sum-left (sum-left action))))) ⟩

    (∃ λ P → machine₁ [ name pay ]⟶ P × P ∼′ machine₂ ∣ coffee ∙)  ↝⟨ Σ-map id (Σ-map (proj₂ ∘ machine₁⟶) id) ⟩

    (∃ λ P → P ∼ machine₁ ∣ (coffee ∙ ⊕ tea ∙) ×
             P ∼′ machine₂ ∣ coffee ∙)                             ↝⟨ (λ { (_ , P∼ , P∼′) → transitive {a = ℓ} (symmetric P∼) (convert {a = ℓ} P∼′) }) ⟩

    machine₁ ∣ (coffee ∙ ⊕ tea ∙) ∼ machine₂ ∣ coffee ∙            ↝⟨ (λ hyp → Σ-map id proj₁ $
                                                                                B.left-to-right hyp (par-right (sum-right action))) ⟩

    (∃ λ P → machine₂ ∣ coffee ∙ [ name tea ]⟶ P)                  ↝⟨ helper ∘ proj₂ ⟩

    pay ≡ tea ⊎ coffee ≡ tea                                       ↝⟨ [ (λ ()) , (λ ()) ] ⟩□

    ⊥                                                              □
    where
    helper : ∀ {P} →
             machine₂ ∣ coffee ∙ [ name tea ]⟶ P →
             pay ≡ tea ⊎ coffee ≡ tea
    helper (par-right tr) = inj₂ $ cancel-name $ ·-only tr
    helper (par-left  tr) =
      inj₁ $ cancel-name $
        !-only (⊕-only (⊕-only ·-only ·-only) ·-only) tr


{-# OPTIONS --rewriting #-}

module Issue5470.Import where

open import Agda.Builtin.Nat

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite

private
  postulate
    foo : Nat → Nat

bar : Nat → Nat
bar n = foo n

private
  postulate
    lemma : ∀ n → foo n ≡ n
  {-# REWRITE lemma #-}


open import Data.Bool using (Bool; true; false; _∧_)
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; sym; subst)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _≡⟨_⟩_; _∎)
open import Data.Unit using (⊤; tt)
open import Data.Nat using (ℕ; zero; suc; _≤_; _≥_; _>_)
open import Data.Product using (_×_; _,_; proj₁; proj₂; Σ-syntax; ∃; ∃-syntax)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.List using (List; []; [_]; _∷_; _∷ʳ_; _++_)
open import Data.List.Reverse using (Reverse; reverseView)
open import Function using (_$_)

module SnapshotConsistency
  (Addr : Set) (_≟_ : Addr → Addr → Bool) (_≤?MAXADDR : Addr → Bool) (_≤?MAXWCNT : ℕ → Bool)
  (Data : Set) (defaultData : Data)
  where

infixl 20 _•_
infixl 20 _⊙_
infixl 20 _++RTC_
infixl 20 _<≐>_

variable
  addr : Addr
  dat  : Data

_≐_ : {A B : Set} → (A → B) → (A → B) → Set
s ≐ t = ∀ a → s a ≡ t a

sym-≐ : {A B : Set} {s t : A → B} → s ≐ t → t ≐ s
sym-≐ eq = λ{x → sym (eq x)}

_<≐>_ : {A B : Set} {s t u : A → B} → s ≐ t → t ≐ u → s ≐ u
_<≐>_ {A} {B} {s} {t} {u} e q = λ{x → begin s x ≡⟨ e x ⟩ t x ≡⟨ q x ⟩ u x ∎}

data SnocList (A : Set) : Set where
  []  : SnocList A
  _•_ : (as : SnocList A) → (a : A) → SnocList A

_⊙_ : {A : Set} → SnocList A → SnocList A → SnocList A
xs ⊙ []       = xs
xs ⊙ (ys • y) = (xs ⊙ ys) • y

data All {A : Set} (P : A → Set) : SnocList A → Set where
  []  : All P []
  _∷_ : ∀ {xs : SnocList A} {x : A} → All P xs → P x → All P (xs • x)

_++All_ : {A : Set} {P : A → Set} {xs ys : SnocList A} → All P xs → All P ys → All P (xs ⊙ ys)
all₁ ++All [] = all₁
all₁ ++All (all₂ ∷ x) = all₁ ++All all₂ ∷ x

mapAll : {A : Set} {P Q : A → Set} {xs : SnocList A}
       → ({x : A} → P x → Q x) → All P xs → All Q xs
mapAll pq []        = []
mapAll pq (all ∷ x) = (mapAll pq all) ∷ (pq x)

data Action : Set where
  w[_↦_]  : (addr : Addr) (dat : Data) → Action
  f       :                              Action
  r       :                              Action
  wᶜ[_↦_] : (addr : Addr) (dat : Data) → Action
  fᶜ      :                              Action
  rᶜ      :                              Action
  cp      :                              Action
  er      :                              Action
  cpᶜ     :                              Action
  erᶜ     :                              Action

variable
  ac : Action

data Regular : Action → Set where
  w  : Regular w[ addr ↦ dat ]
  cp : Regular cp
  er : Regular er

data Write : Action → Set where
  w  : Write w[ addr ↦ dat ]

data Snapshot : Action → Set where
  f : Snapshot f

data RecoveryCrash : Action → Set where
  rᶜ : RecoveryCrash rᶜ

data RegularSuccess : Action → Set where
  w : RegularSuccess w[ addr ↦ dat ]
  f : RegularSuccess f

data Regular×Snapshot : Action → Set where
  w  : Regular×Snapshot w[ addr ↦ dat ]
  cp : Regular×Snapshot cp
  er : Regular×Snapshot er
  f  : Regular×Snapshot f

data Regular×SnapshotCrash : Action → Set where
  wᶜ  : Regular×SnapshotCrash wᶜ[ addr ↦ dat ]
  fᶜ  : Regular×SnapshotCrash fᶜ
  cpᶜ : Regular×SnapshotCrash cpᶜ
  erᶜ : Regular×SnapshotCrash erᶜ

Trace = SnocList Action

variable
  ef  : Trace
  ef₁ : Trace
  ef₂ : Trace
  ef₃ : Trace
  frag     : Trace
  frag-w   : Trace
  frag-rᶜ  : Trace
  flist    : SnocList Action
  flist-w  : SnocList Action
  flist-rᶜ : SnocList Action

--Reflexive Transitive Closure
data RTC {A S : Set} (R : S → A → S → Set) : S → SnocList A → S → Set where
  ∅   : ∀ {s : S} → RTC R s [] s
  _•_ : ∀ {s t u : S} {acs : SnocList A} {ac : A}
      → RTC R s acs t → R t ac u → RTC R s (acs • ac) u

_++RTC_ : {A S : Set} {R : S → A → S → Set} {s t u : S} {ef₁ ef₂ : SnocList A}
        → RTC R s ef₁ t → RTC R t ef₂ u → RTC R s (ef₁ ⊙ ef₂) u
tc-s-t ++RTC ∅             = tc-s-t
tc-s-t ++RTC (tc-t-u • rr) = (tc-s-t ++RTC tc-t-u) • rr

splitRTC : {A S : Set} {R : S → A → S → Set} {s s' : S} → (splitOn : SnocList A) → {rest : SnocList A}
         → ( fr : RTC R s (splitOn ⊙ rest) s') → Σ[ s'' ∈ S ] Σ[ fr₁ ∈ RTC R s splitOn s'' ] Σ[ fr₂ ∈ RTC R s'' rest s' ] (fr ≡ (fr₁ ++RTC fr₂))
splitRTC ef₁ {rest = []}                t = (_ , t , ∅ , refl)
splitRTC ef₁ {rest = (ef₂ • ac)} (t • rr) with splitRTC ef₁ t
...                                       | s'' , t₁ , t₂ , refl = s'' , t₁ , t₂ • rr , refl

data OneRecovery : Trace → Set where
  wᶜ     : {tr₁ tr₂ tr₃ : Trace} → All Regular×Snapshot tr₁ → All Regular tr₂ → All RecoveryCrash tr₃
         → OneRecovery (tr₁ ⊙ ([] • f ⊙ tr₂) ⊙ ([] • wᶜ[ addr ↦ dat ] ⊙ tr₃ • r))
  fᶜ     : {tr₁ tr₂ tr₃ : Trace} → All Regular×Snapshot tr₁ → All Regular tr₂ → All RecoveryCrash tr₃
         → OneRecovery (tr₁ ⊙ ([] • f ⊙ tr₂) ⊙ ([] • fᶜ ⊙ tr₃ • r))
  wᶜ-nof : {tr₂ tr₃ : Trace} → All Regular tr₂ → All RecoveryCrash tr₃
         → OneRecovery (tr₂ ⊙ ([] • wᶜ[ addr ↦ dat ] ⊙ tr₃ • r))
  fᶜ-nof : {tr₂ tr₃ : Trace} → All Regular tr₂ → All RecoveryCrash tr₃
         → OneRecovery (tr₂ ⊙ ([] • fᶜ ⊙ tr₃ • r))

data MultiRecovery : Trace → Set where
  init : {tr : Trace} → All RecoveryCrash tr → MultiRecovery (tr • r)
  one  : {tr₁ tr₂ : Trace} → MultiRecovery tr₁ → OneRecovery tr₂ → MultiRecovery (tr₁ ⊙ tr₂)

data 1RFrags {S : Set} {R : S → Action → S → Set} : {s s' : S} {tr : Trace} → OneRecovery tr → RTC R s tr s' → Set where
  wᶜ     : {tr₁ tr₂ tr₃ : Trace} {all₁ : All Regular×Snapshot tr₁} {all₂ : All Regular tr₂} {all₃ : All RecoveryCrash tr₃}
         → {s₁ s₂ s₃ s₄ : S} (fr₁ : RTC R s₁ tr₁ s₂) (fr₂ : RTC R s₂ ([] • f ⊙ tr₂) s₃) (fr₃ : RTC R s₃ ([] • wᶜ[ addr ↦ dat ] ⊙ tr₃ • r) s₄)
         → 1RFrags (wᶜ all₁ all₂ all₃) (fr₁ ++RTC fr₂ ++RTC fr₃)
  fᶜ     : {tr₁ tr₂ tr₃ : Trace} {all₁ : All Regular×Snapshot tr₁} {all₂ : All Regular tr₂} {all₃ : All RecoveryCrash tr₃}
         → {s₁ s₂ s₃ s₄ : S} (fr₁ : RTC R s₁ tr₁ s₂) (fr₂ : RTC R s₂ ([] • f ⊙ tr₂) s₃) (fr₃ : RTC R s₃ ([] • fᶜ ⊙ tr₃ • r) s₄)
         → 1RFrags (fᶜ all₁ all₂ all₃) (fr₁ ++RTC fr₂ ++RTC fr₃)
  wᶜ-nof : {tr₂ tr₃ : Trace} {all₂ : All Regular tr₂} {all₃ : All RecoveryCrash tr₃}
         → {s₂ s₃ s₄ : S} (fr₂ : RTC R s₂ tr₂ s₃) (fr₃ : RTC R s₃ ([] • wᶜ[ addr ↦ dat ] ⊙ tr₃ • r) s₄)
         → 1RFrags (wᶜ-nof all₂ all₃) (fr₂ ++RTC fr₃)
  fᶜ-nof : {tr₂ tr₃ : Trace} {all₂ : All Regular tr₂} {all₃ : All RecoveryCrash tr₃}
         → {s₂ s₃ s₄ : S} (fr₂ : RTC R s₂ tr₂ s₃) (fr₃ : RTC R s₃ ([] • fᶜ ⊙ tr₃ • r) s₄)
         → 1RFrags (fᶜ-nof all₂ all₃) (fr₂ ++RTC fr₃)

view1R : {tr : Trace} (1r : OneRecovery tr) {S : Set} {R : S → Action → S → Set} {s s' : S} (fr : RTC R s tr s') → 1RFrags 1r fr
view1R (wᶜ {tr₁ = tr₁} {tr₂ = tr₂} {tr₃ = tr₃} all₁ all₂ all₃) {s = s₁} {s' = s₄} fr
  with splitRTC (tr₁ ⊙ ([] • f ⊙ tr₂)) {rest = [] • wᶜ[ _ ↦ _ ] ⊙ tr₃ • r} fr
...  | s₃ , fr-l , fr₃ , refl with splitRTC tr₁ {rest = [] • f ⊙ tr₂} fr-l
...  | s₂ , fr₁  , fr₂ , refl = wᶜ fr₁ fr₂ fr₃
view1R (fᶜ {tr₁ = tr₁} {tr₂ = tr₂} {tr₃ = tr₃} all₁ all₂ all₃) {s = s₁} {s' = s₄} fr
  with splitRTC (tr₁ ⊙ ([] • f ⊙ tr₂)) {rest = [] • fᶜ ⊙ tr₃ • r} fr
...  | s₃ , fr-l , fr₃ , refl with splitRTC tr₁ {rest = [] • f ⊙ tr₂} fr-l
...  | s₂ , fr₁  , fr₂ , refl = fᶜ fr₁ fr₂ fr₃
view1R (wᶜ-nof {tr₂ = tr₂} {tr₃ = tr₃} all₂ all₃) fr with splitRTC tr₂ fr
...  | _ , fr₁ , fr₂ , refl = wᶜ-nof fr₁ fr₂
view1R (fᶜ-nof {tr₂ = tr₂} {tr₃ = tr₃} all₂ all₃) fr with splitRTC tr₂ fr
...  | _ , fr₁ , fr₂ , refl = fᶜ-nof fr₁ fr₂

data MRFrags {S : Set} {R : S → Action → S → Set} : {s s' : S} {tr : Trace} → MultiRecovery tr → RTC R s tr s' → Set where
  init : {tr : Trace} {all : All RecoveryCrash tr} {s s' : S} (fr : RTC R s (tr • r) s') → MRFrags (init all) fr
  one  : {tr₁ : Trace} {mr : MultiRecovery tr₁} {s₁ s₂ : S} {fr₁ : RTC R s₁ tr₁ s₂} → MRFrags mr fr₁
       → {tr₂ : Trace} {1r : OneRecovery   tr₂} {s₃    : S} (fr₂ : RTC R s₂ tr₂ s₃) → 1RFrags 1r fr₂ → MRFrags (one mr 1r) (fr₁ ++RTC fr₂)

viewMR : {tr : Trace} (mr : MultiRecovery tr) {S : Set} {R : S → Action → S → Set} {s s' : S} (fr : RTC R s tr s') → MRFrags mr fr
viewMR (init all) fr = init fr
viewMR (one  {tr₁ = tr₁} mr all) fr with splitRTC tr₁ fr
...  | _ , fr-l , fr-r , refl = one  (viewMR mr fr-l) fr-r (view1R all fr-r)

lastr : {S : Set} {s s' : S} {R : S → Action → S → Set} {tr : Trace} (mr : MultiRecovery tr)
      → (fr : RTC R s tr s') → (frs : MRFrags mr fr) → Σ[ s'' ∈ S ] (R s'' r s')
lastr .(init _) .fr (init fr) with fr
... | _ • x =  _ , x
lastr ._ ._ (one _ ._ (wᶜ _ _ (fr₃ • x))) = _ , x
lastr ._ ._ (one _ ._ (fᶜ _ _ (fr₃ • x))) = _ , x
lastr ._ ._ (one _ ._ (wᶜ-nof _ (fr₃ • x))) = _ , x
lastr ._ ._ (one _ ._ (fᶜ-nof _ (fr₃ • x))) = _ , x

SnapshotConsistency : {S : Set} {s s' : S} {R : S → Action → S → Set} (ER : S → S → Set)
                      {tr : Trace} → (1r : OneRecovery tr) → (fr : RTC R s tr s') → 1RFrags 1r fr → Set
SnapshotConsistency ER ._ ._ (wᶜ     {s₂ = s₂} {s₄ = s₄} _ _ _) = ER s₂ s₄
SnapshotConsistency ER ._ ._ (fᶜ     {s₂ = s₂} {s₃} {s₄} _ _ _) = ER s₃ s₄ ⊎ ER s₂ s₄
SnapshotConsistency ER ._ ._ (wᶜ-nof {s₂ = s₂} {s₄ = s₄}   _ _) = ER s₂ s₄
SnapshotConsistency ER ._ ._ (fᶜ-nof {s₂ = s₂} {s₃} {s₄}   _ _) = ER s₃ s₄ ⊎ ER s₂ s₄

module Spec where

  record State : Set where
    field
      volatile : Addr → Data
      stable   : Addr → Data
      w-count  : ℕ

  Init : State → Set
  Init s = (addr : Addr) → (State.stable s addr ≡ defaultData)

  variable
    t  : State
    t' : State

  update : (Addr → Data) → ℕ → Addr → Data → (Addr → Data)
  update s wcnt addr dat i with (addr ≤?MAXADDR) ∧ (wcnt ≤?MAXWCNT)
  update s wcnt addr dat i | false = s i
  update s wcnt addr dat i | true with addr ≟ i
  update s wcnt addr dat i | true | true  = dat
  update s wcnt addr dat i | true | false = s i

  data Step (s s' : State) : Action → Set where
    w   : update (State.volatile s) (State.w-count s) addr dat ≐ State.volatile s'
        → State.stable s ≐ State.stable s'
        → suc (State.w-count s) ≡ State.w-count s'
        → Step s s' w[ addr ↦ dat ]
    f   : State.volatile s ≐ State.volatile s'
        → State.volatile s ≐ State.stable s'
        → State.w-count s' ≡ zero
        → Step s s' f
    r   : State.stable s ≐ State.volatile s'
        → State.stable s ≐ State.stable s'
        → State.w-count s' ≡ zero
        → Step s s' r
    wᶜ  : State.stable s ≐ State.stable s'
        → Step s s' (wᶜ[ addr ↦ dat ])
    fᶜ  : State.volatile s ≐ State.stable s' ⊎ State.stable s ≐ State.stable s'
        → Step s s' fᶜ
    rᶜ  : State.stable s ≐ State.stable s'
        → Step s s' rᶜ
    cp  : State.volatile s ≐ State.volatile s'
        → State.stable s ≐ State.stable s'
        → State.w-count s ≡ State.w-count s'
        → Step s s' cp
    er  : State.volatile s ≐ State.volatile s'
        → State.stable s ≐ State.stable s'
        → State.w-count s ≡ State.w-count s'
        → Step s s' er
    cpᶜ : State.stable s ≐ State.stable s' → Step s s' cpᶜ
    erᶜ : State.stable s ≐ State.stable s' → Step s s' erᶜ

  _⟦_⟧▸_ : State → Action → State → Set
  s ⟦ ac ⟧▸ s' = Step s s' ac

  _⟦_⟧*▸_ = RTC  _⟦_⟧▸_

  record StbP (ac : Action) : Set where --Stability Reserving Actions
    field
      preserve : {s s' : State} → s ⟦ ac ⟧▸ s' → (State.stable s ≐ State.stable s')

  instance
    stb-r   : StbP r
    stb-r   = record { preserve = λ{(r _ ss _) → ss} }
    stb-w   : StbP w[ addr ↦ dat ]
    stb-w   = record { preserve = λ{(w _ ss _ ) → ss} }
    stb-wᶜ  : StbP wᶜ[ addr ↦ dat ]
    stb-wᶜ  = record { preserve = λ{(wᶜ ss) → ss} }
    stb-rᶜ  : StbP rᶜ
    stb-rᶜ  = record { preserve = λ{(rᶜ ss) → ss} }
    stb-cp  : StbP cp
    stb-cp  = record { preserve = λ{(cp _ ss _) → ss}}
    stb-er  : StbP er
    stb-er  = record { preserve = λ{(er _ ss _) → ss}}
    stb-cpᶜ : StbP cpᶜ
    stb-cpᶜ = record { preserve = λ{(cpᶜ ss) → ss}}
    stb-erᶜ : StbP erᶜ
    stb-erᶜ = record { preserve = λ{(erᶜ ss) → ss}}

  idemₛ : {tr : Trace} → All StbP tr
        → ∀ {s s' : State} → s ⟦ tr ⟧*▸ s'
        → State.stable s ≐ State.stable s'
  idemₛ [] ∅ = λ{_ → refl}
  idemₛ (all ∷ x) (s2s'' • s''2s') =
    idemₛ all s2s'' <≐> StbP.preserve x s''2s'

  r→rs : Regular ac → Regular×Snapshot ac
  r→rs w = w
  r→rs cp = cp
  r→rs er = er

  n→sp : Regular ac → StbP ac
  n→sp w  = stb-w
  n→sp cp = stb-cp
  n→sp er = stb-er

  rᶜ→sp : RecoveryCrash ac → StbP ac
  rᶜ→sp rᶜ = stb-rᶜ

  SpecSC-wᶜ : ∀ {s₂ s₃ s₄ : State} {tr-w tr-rᶜ}
             → {{_ : All Regular tr-w}} {{_ : All RecoveryCrash tr-rᶜ}}
             → s₂ ⟦ [] • f ⊙ tr-w ⟧*▸ s₃ → s₃ ⟦ [] • wᶜ[ addr ↦ dat ] ⊙ tr-rᶜ • r ⟧*▸ s₄
             → State.volatile s₂ ≐ State.volatile s₄
  SpecSC-wᶜ {{ all₂ }} {{ all₃ }} s₂▸s₃ (s₃▹ • r sv _ _)
        with splitRTC ([] • f) s₂▸s₃ | splitRTC ([] • wᶜ[ _ ↦ _ ]) s₃▹
  ...      | s₂' , ∅ • (f vv vs _) , s₂'▸s₃ , _ | s₃' , ∅ • (wᶜ ss) , s₃'▸s₄▹ , _ =
               vs <≐> idemₛ (mapAll n→sp  all₂) s₂'▸s₃  <≐>
               ss <≐> idemₛ (mapAll rᶜ→sp all₃) s₃'▸s₄▹ <≐> sv

  SpecSC-wᶜ-nof : ∀ {s₁ s₂ s₃ s₄ : State} {tr-w tr-rᶜ}
                → {{_ : All Regular tr-w}} {{_ : All RecoveryCrash tr-rᶜ}}
                → s₁ ⟦ r ⟧▸ s₂ → s₂ ⟦ tr-w ⟧*▸ s₃ → s₃ ⟦ [] • wᶜ[ addr ↦ dat ] ⊙ tr-rᶜ • r ⟧*▸ s₄
                → State.volatile s₂ ≐ State.volatile s₄
  SpecSC-wᶜ-nof {{ all₂ }} {{ all₃ }} (r sv' ss' _) s₂▸s₃ (s₃▹ • r sv _ _)
           with splitRTC ([] • wᶜ[ _ ↦ _ ]) s₃▹
  ...         | s₃' , ∅ • (wᶜ ss) , s₃'▸s₄▹ , _ =
                  sym-≐ sv' <≐> ss' <≐> idemₛ (mapAll n→sp  all₂) s₂▸s₃  <≐>
                  ss <≐> idemₛ (mapAll rᶜ→sp all₃) s₃'▸s₄▹ <≐> sv

  SpecSC-fᶜ : ∀ {s₂ s₃ s : State} {tr-w tr-rᶜ}
             → {{_ : All Regular tr-w}} {{_ : All RecoveryCrash tr-rᶜ}}
             → s₂ ⟦ ([] • f) ⊙ tr-w ⟧*▸ s₃ → s₃ ⟦ ([] • fᶜ) ⊙ tr-rᶜ • r ⟧*▸ s
             → State.volatile s₃ ≐ State.volatile s ⊎ State.volatile s₂ ≐ State.volatile s
  SpecSC-fᶜ {{all₁}} {{all₂}} s₂▸s₃ (s₃▸s • r sv ss _)
        with splitRTC ([] • f) s₂▸s₃ | splitRTC ([] • fᶜ) s₃▸s
  ...      | _ , ∅ • f vv vs _ , ▸s₃ , _ | s₃' , ∅ • fᶜ (inj₁ vsᶜ) , s₃'▸s , _ =
               inj₁ $ vsᶜ <≐> idemₛ (mapAll rᶜ→sp all₂) s₃'▸s <≐> sv
  ...      | _ , ∅ • f vv vs _ , ▸s₃ , _ | s₃' , ∅ • fᶜ (inj₂ ssᶜ) , s₃'▸s , _ =
               inj₂ $ vs <≐>
               idemₛ (mapAll n→sp all₁) ▸s₃ <≐> ssᶜ <≐>
               idemₛ (mapAll rᶜ→sp all₂) s₃'▸s <≐> sv

  SpecSC-fᶜ-nof : ∀ {s₁ s₂ s₃ s₄ : State} {tr-w tr-rᶜ}
                → {{_ : All Regular tr-w}} {{_ : All RecoveryCrash tr-rᶜ}}
                → s₁ ⟦ r ⟧▸ s₂ → s₂ ⟦ tr-w ⟧*▸ s₃ → s₃ ⟦ [] • fᶜ ⊙ tr-rᶜ • r ⟧*▸ s₄
                → State.volatile s₃ ≐ State.volatile s₄ ⊎ State.volatile s₂ ≐ State.volatile s₄
  SpecSC-fᶜ-nof {{ all₂ }} {{ all₃ }} (r sv' ss' _) s₂▸s₃ (s₃▹ • r sv _ _)
           with splitRTC ([] • fᶜ) s₃▹
  ...         | s₃' , ∅ • fᶜ (inj₁ vsᶜ) , s₃'▸s , _ = inj₁ $ vsᶜ <≐> idemₛ (mapAll rᶜ→sp all₃) s₃'▸s <≐> sv
  ...         | s₃' , ∅ • fᶜ (inj₂ ssᶜ) , s₃'▸s , _ = inj₂ $ sym-≐ sv' <≐> ss' <≐>
                                                             idemₛ (mapAll n→sp  all₂) s₂▸s₃ <≐> ssᶜ <≐>
                                                             idemₛ (mapAll rᶜ→sp all₃) s₃'▸s <≐> sv

  SC : {t₀ t t' : State} {tr₀ tr : Trace} → (mr : MultiRecovery tr₀) → (1r : OneRecovery tr)
     → Init t₀ → (fr₀ : t₀ ⟦ tr₀ ⟧*▸ t) → MRFrags mr fr₀ → (fr : t ⟦ tr ⟧*▸ t') → (frs : 1RFrags 1r fr)
     → SnapshotConsistency (λ t t' → State.volatile t ≐ State.volatile t') 1r fr frs
  SC mr _ init-t₀ fr₀ frs₀ ._ (wᶜ {all₂ = all₂} {all₃} fr₁ fr₂ fr₃) = SpecSC-wᶜ {{all₂}} {{all₃}} fr₂ fr₃
  SC mr _ init-t₀ fr₀ frs₀ ._ (fᶜ {all₂ = all₂} {all₃} fr₁ fr₂ fr₃) = SpecSC-fᶜ {{all₂}} {{all₃}} fr₂ fr₃
  SC mr _ init-t₀ fr₀ frs₀ ._ (wᶜ-nof {all₂ = all₂} {all₃} fr₂ fr₃) = SpecSC-wᶜ-nof {{all₂}} {{all₃}} (proj₂ (lastr mr fr₀ frs₀)) fr₂ fr₃
  SC mr _ init-t₀ fr₀ frs₀ ._ (fᶜ-nof {all₂ = all₂} {all₃} fr₂ fr₃) = SpecSC-fᶜ-nof {{all₂}} {{all₃}} (proj₂ (lastr mr fr₀ frs₀)) fr₂ fr₃

open Spec hiding (SC)

module Prog
  (runSpec : (t : State) (ac : Action) → ∃[ t' ] (t ⟦ ac ⟧▸ t'))
  (RawStateᴾ : Set) (_⟦_⟧ᴿ▸_ : RawStateᴾ → Action → RawStateᴾ → Set)
  (RI CI : RawStateᴾ → Set)
  (AR CR : RawStateᴾ → State → Set)
  (RIRI : {s s' : RawStateᴾ} {ac : Action} → Regular×Snapshot ac → s ⟦ ac ⟧ᴿ▸ s' → RI s → RI s')
  (ARAR : {s s' : RawStateᴾ} {t t' : State} {ac : Action} → Regular×Snapshot ac
        → s ⟦ ac ⟧ᴿ▸ s' → t ⟦ ac ⟧▸ t' → RI s × AR s t → AR s' t')
  (RICI : {s s' : RawStateᴾ} {ac : Action} → Regular×SnapshotCrash ac → s ⟦ ac ⟧ᴿ▸ s' → RI s → CI s')
  (ARCR : {s s' : RawStateᴾ} {t t' : State} {ac : Action} → Regular×SnapshotCrash ac
        → s ⟦ ac ⟧ᴿ▸ s' → t ⟦ ac ⟧▸ t' → RI s × AR s t → CR s' t')
  (CIRI : {s s' : RawStateᴾ} → s ⟦ r ⟧ᴿ▸ s' → CI s → RI s')
  (CRAR : {s s' : RawStateᴾ} {t t' : State} → s ⟦ r ⟧ᴿ▸ s' → t ⟦ r ⟧▸ t' → CI s × CR s t → AR s' t')
  (CICI : {s s' : RawStateᴾ} → s ⟦ rᶜ ⟧ᴿ▸ s' → CI s → CI s')
  (CRCR : {s s' : RawStateᴾ} {t t' : State} → s ⟦ rᶜ ⟧ᴿ▸ s' → t ⟦ rᶜ ⟧▸ t' → CI s × CR s t → CR s' t')
  (read : RawStateᴾ → Addr → Data)
  (AR⇒ObsEquiv : {s : RawStateᴾ} {t : State} → RI s × AR s t → read s ≐ State.volatile t)
  (Initᴿ : RawStateᴾ → Set)
  (initᴿ-CI : (s : RawStateᴾ) → Initᴿ s → CI s)
  (initᴿ-CR : (s : RawStateᴾ) → Initᴿ s → (t : State) → Init t → CR s t)
  (t-init : Σ[ t ∈ State ] Init t)
  where

  variable
    rs    : RawStateᴾ
    rs₁   : RawStateᴾ
    rinv  : RI rs
    cinv  : CI rs
    rs'   : RawStateᴾ
    rs''  : RawStateᴾ
    rs''' : RawStateᴾ
    rinv' : RI rs'
    cinv' : CI rs'

  _⟦_⟧ᴿ*▸_ = RTC _⟦_⟧ᴿ▸_

  data Inv (rs : RawStateᴾ) : Set where
    normal : RI rs → Inv rs
    crash  : CI rs → Inv rs

  Stateᴾ : Set
  Stateᴾ = Σ[ rs ∈ RawStateᴾ ] Inv rs

  data Initᴾ : Stateᴾ → Set where
    init : Initᴿ rs → Initᴾ (rs , crash cinv)

  variable
    s    : Stateᴾ
    s'   : Stateᴾ
    s''  : Stateᴾ
    s''' : Stateᴾ

  data _⟦_⟧ᴾ▸_ : Stateᴾ → Action → Stateᴾ → Set where
    w   : rs ⟦ w[ addr ↦ dat ] ⟧ᴿ▸ rs'  → (rs , normal rinv) ⟦ w[ addr ↦ dat ] ⟧ᴾ▸ (rs' , normal rinv')
    f   : rs ⟦ f   ⟧ᴿ▸ rs'              → (rs , normal rinv) ⟦ f  ⟧ᴾ▸ (rs' , normal rinv')
    wᶜ  : rs ⟦ wᶜ[ addr ↦ dat ] ⟧ᴿ▸ rs' → (rs , normal rinv) ⟦ wᶜ[ addr ↦ dat ] ⟧ᴾ▸ (rs' , crash  cinv')
    fᶜ  : rs ⟦ fᶜ  ⟧ᴿ▸ rs'              → (rs , normal rinv) ⟦ fᶜ ⟧ᴾ▸ (rs' , crash  cinv')
    rᶜ  : rs ⟦ rᶜ  ⟧ᴿ▸ rs'              → (rs , crash  cinv) ⟦ rᶜ ⟧ᴾ▸ (rs' , crash  cinv')
    r   : rs ⟦ r   ⟧ᴿ▸ rs'              → (rs , crash  cinv) ⟦ r  ⟧ᴾ▸ (rs' , normal rinv')
    cp  : rs ⟦ cp  ⟧ᴿ▸ rs'              → (rs , normal rinv) ⟦ cp ⟧ᴾ▸ (rs' , normal rinv')
    er  : rs ⟦ er  ⟧ᴿ▸ rs'              → (rs , normal rinv) ⟦ er ⟧ᴾ▸ (rs' , normal rinv')
    cpᶜ : rs ⟦ cpᶜ ⟧ᴿ▸ rs'              → (rs , normal rinv) ⟦ cpᶜ ⟧ᴾ▸ (rs' , crash cinv')
    erᶜ : rs ⟦ erᶜ ⟧ᴿ▸ rs'              → (rs , normal rinv) ⟦ erᶜ ⟧ᴾ▸ (rs' , crash cinv')

  _⟦_⟧ᴾ*▸_ = RTC  _⟦_⟧ᴾ▸_

  lift-n×s : {tr : Trace} {{_ : All Regular×Snapshot tr}} → rs ⟦ tr ⟧ᴿ*▸ rs' →
             ∃[ rinv' ] ((rs , normal rinv) ⟦ tr ⟧ᴾ*▸ (rs' , normal rinv'))
  lift-n×s ∅ = _ , ∅
  lift-n×s {{all ∷ w}} (rs*▸rs'' • rs''▸rs') =
    let (rinv'' , s*▸s'') = lift-n×s {{all}} rs*▸rs''
    in  RIRI w rs''▸rs' rinv'' , s*▸s'' • w rs''▸rs'
  lift-n×s {{all ∷ f}} (rs*▸rs'' • rs''▸rs') =
    let (rinv'' , s*▸s'') = lift-n×s {{all}} rs*▸rs''
    in  RIRI f rs''▸rs' rinv'' , s*▸s'' • f rs''▸rs'
  lift-n×s {{all ∷ cp}} (rs*▸rs'' • rs''▸rs') =
    let (rinv'' , s*▸s'') = lift-n×s {{all}} rs*▸rs''
    in  RIRI cp rs''▸rs' rinv'' , s*▸s'' • cp rs''▸rs'
  lift-n×s {{all ∷ er}} (rs*▸rs'' • rs''▸rs') =
    let (rinv'' , s*▸s'') = lift-n×s {{all}} rs*▸rs''
    in  RIRI er rs''▸rs' rinv'' , s*▸s'' • er rs''▸rs'

  lift-n : {tr : Trace} {{_ : All Regular tr}} → rs ⟦ tr ⟧ᴿ*▸ rs'
         → ∃[ rinv' ] ((rs , normal rinv) ⟦ tr ⟧ᴾ*▸ (rs' , normal rinv'))
  lift-n {{all}} rs*▸rs' =
    lift-n×s {{(mapAll (λ{w → w; cp → cp; er → er}) all)}} rs*▸rs'

  lift-rᶜ : {tr : Trace} {{_ : All RecoveryCrash tr}} → rs ⟦ tr ⟧ᴿ*▸ rs' →
            ∃[ cinv' ] ((rs , crash cinv) ⟦ tr ⟧ᴾ*▸ (rs' , crash cinv'))
  lift-rᶜ ∅ = _ , ∅
  lift-rᶜ {{all ∷ rᶜ}} (rs*▸rs'' • rs''▸rs') =
    let (cinv'' , s*▸s'') = lift-rᶜ {{all}} rs*▸rs''
    in  CICI rs''▸rs' cinv'' , s*▸s'' • rᶜ rs''▸rs'

  lift-mr : {tr : Trace} (mr : MultiRecovery tr) (fr : rs ⟦ tr ⟧ᴿ*▸ rs') → MRFrags mr fr → Initᴿ rs
          → ∃[ cinv ] ∃[ rinv' ] let s = (rs , crash cinv) in (s ⟦ tr ⟧ᴾ*▸ (rs' , normal rinv')) × Initᴾ s
  lift-mr ._ ._ (init {all = all} fr) init-rs with fr
  ... | fr₀ • rr with lift-rᶜ {cinv = initᴿ-CI _ init-rs} {{all}} fr₀
  ... | cinv₀ , fr₀ᴾ = _ , CIRI rr cinv₀ , fr₀ᴾ • r rr , init init-rs
  lift-mr ._ ._ (one frs₀ fr frs) init-rs with lift-mr _ _ frs₀ init-rs
  lift-mr ._ ._ (one frs₀ ._ (wᶜ {tr₃ = tr₃} {all₁ = all₁} {all₂} {all₃} fr₁ fr₂ fr₃)) init-rs | cinv₀ , rinv₀ , fr₀ᴾ , init-s with splitRTC ([] • (wᶜ[ _ ↦ _ ])) {rest = (tr₃ • r)} fr₃
  ...   | rs'' , ∅ • s₃▸s₃' , s₃'▸r • r▸rs' , eq with lift-n×s {rinv = rinv₀} {{all₁}} fr₁
  ...   | rinv₁ , frP₁ with lift-n×s {rinv = rinv₁} {{ ([] ∷ f) ++All mapAll r→rs all₂ }} fr₂
  ...   | rinv₂ , frP₂ with RICI wᶜ s₃▸s₃' rinv₂
  ...   | cinv₂' with lift-rᶜ {cinv = cinv₂'} {{all₃}} s₃'▸r
  ...   | cinv₃ , frP₃ with CIRI r▸rs' cinv₃
  ...   | rinv₄  = cinv₀ , rinv₄ ,  fr₀ᴾ ++RTC (frP₁ ++RTC frP₂ ++RTC ((∅ • wᶜ s₃▸s₃') ++RTC (frP₃ • r r▸rs'))), init-s
  lift-mr ._ ._ (one frs₀ ._ (fᶜ {tr₃ = tr₃} {all₁ = all₁} {all₂} {all₃} fr₁ fr₂ fr₃)) init-rs | cinv₀ , rinv₀ , fr₀ᴾ , init-s with splitRTC ([] • fᶜ) {rest = (tr₃ • r)} fr₃
  ...   | rs'' , ∅ • s₃▸s₃' , s₃'▸r • r▸rs' , eq with lift-n×s {rinv = rinv₀} {{all₁}} fr₁
  ...   | rinv₁ , frP₁ with lift-n×s {rinv = rinv₁} {{ ([] ∷ f) ++All mapAll r→rs all₂ }} fr₂
  ...   | rinv₂ , frP₂ with RICI fᶜ s₃▸s₃' rinv₂
  ...   | cinv₂' with lift-rᶜ {cinv = cinv₂'} {{all₃}} s₃'▸r
  ...   | cinv₃ , frP₃ with CIRI r▸rs' cinv₃
  ...   | rinv₄  = cinv₀ , rinv₄ ,  fr₀ᴾ ++RTC (frP₁ ++RTC frP₂ ++RTC ((∅ • fᶜ s₃▸s₃') ++RTC (frP₃ • r r▸rs'))), init-s
  lift-mr ._ ._ (one frs₀ ._ (wᶜ-nof {tr₃ = tr₃} {all₂ = all₂} {all₃} fr₂ fr₃)) init-rs | cinv₀ , rinv₀ , fr₀ᴾ , init-s with splitRTC ([] • wᶜ[ _ ↦ _ ]) {rest = (tr₃ • r)} fr₃
  ...   | rs'' , ∅ • s₃▸s₃' , s₃'▸r • r▸rs' , eq with lift-n×s {rinv = rinv₀} {{ mapAll r→rs all₂ }} fr₂
  ...   | rinv₂ , frP₂ with RICI wᶜ s₃▸s₃' rinv₂
  ...   | cinv₂' with lift-rᶜ {cinv = cinv₂'} {{all₃}} s₃'▸r
  ...   | cinv₃ , frP₃ with CIRI r▸rs' cinv₃
  ...   | rinv₄  = cinv₀ , rinv₄ ,  fr₀ᴾ ++RTC (frP₂ ++RTC ((∅ • wᶜ s₃▸s₃') ++RTC (frP₃ • r r▸rs'))), init-s
  lift-mr ._ ._ (one frs₀ ._ (fᶜ-nof {tr₃ = tr₃} {all₂ = all₂} {all₃} fr₂ fr₃)) init-rs | cinv₀ , rinv₀ , fr₀ᴾ , init-s with splitRTC ([] • fᶜ) {rest = (tr₃ • r)} fr₃
  ...   | rs'' , ∅ • s₃▸s₃' , s₃'▸r • r▸rs' , eq with lift-n×s {rinv = rinv₀} {{ mapAll r→rs all₂ }} fr₂
  ...   | rinv₂ , frP₂ with RICI fᶜ s₃▸s₃' rinv₂
  ...   | cinv₂' with lift-rᶜ {cinv = cinv₂'} {{all₃}} s₃'▸r
  ...   | cinv₃ , frP₃ with CIRI r▸rs' cinv₃
  ...   | rinv₄  = cinv₀ , rinv₄ ,  fr₀ᴾ ++RTC (frP₂ ++RTC ((∅ • fᶜ s₃▸s₃') ++RTC (frP₃ • r r▸rs'))), init-s

  ObsEquiv : Stateᴾ → State → Set
  ObsEquiv (rs , _) t = read rs ≐ State.volatile t

  data SR : Stateᴾ → State → Set where
    ar : AR rs t → SR (rs , normal rinv) t
    cr : CR rs t → SR (rs , crash  cinv) t

  simSR : SR s t → s ⟦ ac ⟧ᴾ▸ s' → ∃[ t' ] (t ⟦ ac ⟧▸ t' × SR s' t')
  simSR {s , normal rinv} {t} (ar AR-rs-t) (w {addr = addr} {dat = dat} rs▸rs') =
    let (t' , t▸t') = runSpec t w[ addr ↦ dat ]
    in   t' , t▸t' , ar (ARAR w rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (f rs▸rs')  =
    let (t' , t▸t') = runSpec t f
    in   t' , t▸t' , ar (ARAR f rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (wᶜ {addr = addr} {dat = dat} rs▸rs') =
    let (t' , t▸t') = runSpec t wᶜ[ addr ↦ dat ]
    in   t' , t▸t' , cr (ARCR wᶜ rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (fᶜ rs▸rs') =
    let (t' , t▸t') = runSpec t fᶜ
    in   t' , t▸t' , cr (ARCR fᶜ rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , crash  cinv} {t} (cr CR-rs-t) (rᶜ rs▸rs') =
    let (t' , t▸t') = runSpec t rᶜ
    in   t' , t▸t' , cr (CRCR    rs▸rs' t▸t' (cinv , CR-rs-t))
  simSR {s , crash  cinv} {t} (cr CR-rs-t) (r rs▸rs')  =
    let (t' , t▸t') = runSpec t r
    in   t' , t▸t' , ar (CRAR    rs▸rs' t▸t' (cinv , CR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (cp rs▸rs')  =
    let (t' , t▸t') = runSpec t cp
    in   t' , t▸t' , ar (ARAR cp rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (er rs▸rs')  =
    let (t' , t▸t') = runSpec t er
    in   t' , t▸t' , ar (ARAR er rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (cpᶜ rs▸rs') =
    let (t' , t▸t') = runSpec t cpᶜ
    in   t' , t▸t' , cr (ARCR cpᶜ rs▸rs' t▸t' (rinv , AR-rs-t))
  simSR {s , normal rinv} {t} (ar AR-rs-t) (erᶜ rs▸rs') =
    let (t' , t▸t') = runSpec t erᶜ
    in   t' , t▸t' , cr (ARCR erᶜ rs▸rs' t▸t' (rinv , AR-rs-t))

  runSimSR : SR s t → s ⟦ ef ⟧ᴾ*▸ s' → ∃[ t' ] (t ⟦ ef ⟧*▸ t' × SR s' t')
  runSimSR SR-s-t ∅                 = _ , ∅ , SR-s-t
  runSimSR SR-s-t (s*▸s'' • s''▸s') =
    let (t'' , t*▸t'' , SR-s''-t'') = runSimSR SR-s-t s*▸s''
        (t'  , t''▸t' , SR-s'-t'  ) = simSR SR-s''-t'' s''▸s'
    in  _ , (t*▸t'' • t''▸t') , SR-s'-t'

  Conformant-all : {tr : Trace} {s s' : Stateᴾ} → s ⟦ tr ⟧ᴾ*▸ s' → {t t' : State} → t ⟦ tr ⟧*▸ t' → Set
  Conformant-all {s' = s'} ∅         {t' = t'} ∅         = ⊤
  Conformant-all {s' = s'} (frP • _) {t' = t'} (frS • _) = Conformant-all frP frS × ObsEquiv s' t'

  Conformant-1R : {tr : Trace} (1r : OneRecovery tr)
                 → {s s' : Stateᴾ} (frP : s ⟦ tr ⟧ᴾ*▸ s') → 1RFrags 1r frP
                 → {t t' : State } (frS : t ⟦ tr ⟧*▸  t') → 1RFrags 1r frS → Set
  Conformant-1R ._ {s' = s'} ._ (wᶜ frP₁ frP₂ frP₃) {t' = t'} ._ (wᶜ frS₁ frS₂ frS₃) = Conformant-all (frP₁ ++RTC frP₂) (frS₁ ++RTC frS₂) × ObsEquiv s' t'
  Conformant-1R ._ {s' = s'} ._ (fᶜ frP₁ frP₂ frP₃) {t' = t'} ._ (fᶜ frS₁ frS₂ frS₃) = Conformant-all (frP₁ ++RTC frP₂) (frS₁ ++RTC frS₂) × ObsEquiv s' t'
  Conformant-1R ._ {s' = s'} ._ (wᶜ-nof  frP₂ frP₃) {t' = t'} ._ (wᶜ-nof  frS₂ frS₃) = Conformant-all frP₂ frS₂ × ObsEquiv s' t'
  Conformant-1R ._ {s' = s'} ._ (fᶜ-nof  frP₂ frP₃) {t' = t'} ._ (fᶜ-nof  frS₂ frS₃) = Conformant-all frP₂ frS₂ × ObsEquiv s' t'

  Conformant-all-intermediate : {s₁ s₂ s₃ : Stateᴾ} {t₁ t₂ t₃ : State} {tr tr' : Trace}
                                 (frP : s₁ ⟦ tr ⟧ᴾ*▸ s₂) (frS : t₁ ⟦ tr ⟧*▸ t₂) (frP' : s₂ ⟦ tr' ⟧ᴾ*▸ s₃) (frS' : t₂ ⟦ tr' ⟧*▸ t₃)
                               → Conformant-all (frP ++RTC frP') (frS ++RTC frS') → ObsEquiv s₁ t₁ → ObsEquiv s₂ t₂
  Conformant-all-intermediate ∅ ∅ _ _ conf oe = oe
  Conformant-all-intermediate (frP • sP) (frS • sS) ∅ ∅ conf oe = proj₂ conf
  Conformant-all-intermediate (frP • sP) (frS • sS) (frP' • sP') (frS' • sS') conf oe = Conformant-all-intermediate (frP • sP) (frS • sS) frP' frS' (proj₁ conf) oe

  conf-all++ : {s₁ s₂ s₃ : Stateᴾ} {t₁ t₂ t₃ : State} {tr tr' : Trace}
               (frP : s₁ ⟦ tr ⟧ᴾ*▸ s₂) (frS : t₁ ⟦ tr ⟧*▸ t₂) (frP' : s₂ ⟦ tr' ⟧ᴾ*▸ s₃) (frS' : t₂ ⟦ tr' ⟧*▸ t₃)
             → Conformant-all frP frS → Conformant-all frP' frS'
             → Conformant-all (frP ++RTC frP') (frS ++RTC frS')
  conf-all++ frP frS ∅ ∅ conf conf' = conf
  conf-all++ frP frS (frP' • p) (frS' • s) conf (conf' , oe) = conf-all++ frP frS frP' frS' conf conf' , oe

  Conformant : {tr : Trace} (mr : MultiRecovery tr)
                {s s' : Stateᴾ} (frP : s ⟦ tr ⟧ᴾ*▸ s') → MRFrags mr frP
              → {t t' : State } (frS : t ⟦ tr ⟧*▸  t') → MRFrags mr frS → Set
  Conformant (init _) {s' = s'} _ _ {t' = t'} _ _ = ObsEquiv s' t'
  Conformant (one mr 1r) .(_ ++RTC frP₂) (one {s₂ = s''} frPs frP₂ frPs₂) .(_ ++RTC frS₂) (one {s₂ = t''} frSs frS₂ frSs₂) =
    Conformant mr _ frPs _ frSs × ObsEquiv s'' t'' × Conformant-1R 1r frP₂ frPs₂ frS₂ frSs₂

  BC-all : {tr : Trace} → All Regular×Snapshot tr → {s s' : Stateᴾ} {t : State} →
           SR s t → ObsEquiv s t → (frP : s ⟦ tr ⟧ᴾ*▸ s') →
           Σ[ t' ∈ State ] Σ[ frS ∈ t ⟦ tr ⟧*▸ t' ] SR s' t' × ObsEquiv s' t' × Conformant-all frP frS
  BC-all [] sr oe-s-t ∅ = _ , ∅ , sr , oe-s-t , tt
  BC-all (all ∷ _) sr oe-s-t (frP • _) with BC-all all sr oe-s-t frP
  BC-all (all ∷ _) sr oe-s-t (frP • s''▸s') | t'' , frS'' , sr'' , oe'' , conf'' with simSR sr'' s''▸s'
  BC-all (all ∷ w) sr oe-s-t (frP • w {rinv' = rinv'} rs''▸s') | t'' , frS'' , sr'' , oe'' , conf'' | t' , t''▸t' , ar ar' =
    let oe' = AR⇒ObsEquiv (rinv' , ar') in t' , frS'' • t''▸t' , ar ar' , oe' , conf'' , oe'
  BC-all (all ∷ cp) sr oe-s-t (frP • cp {rinv' = rinv'} rs''▸s') | t'' , frS'' , sr'' , oe'' , conf'' | t' , t''▸t' , ar ar' =
    let oe' = AR⇒ObsEquiv (rinv' , ar') in t' , frS'' • t''▸t' , ar ar' , oe' , conf'' , oe'
  BC-all (all ∷ er) sr oe-s-t (frP • er {rinv' = rinv'} rs''▸s') | t'' , frS'' , sr'' , oe'' , conf'' | t' , t''▸t' , ar ar' =
    let oe' = AR⇒ObsEquiv (rinv' , ar') in t' , frS'' • t''▸t' , ar ar' , oe' , conf'' , oe'
  BC-all (all ∷ f) sr oe-s-t (frP • f {rinv' = rinv'} rs''▸s') | t'' , frS'' , sr'' , oe'' , conf'' | t' , t''▸t' , ar ar' =
    let oe' = AR⇒ObsEquiv (rinv' , ar') in t' , frS'' • t''▸t' , ar ar' , oe' , conf'' , oe'

  BC-1R : {tr : Trace} → (1r : OneRecovery tr) → {s s' : Stateᴾ} {t : State} →
          SR s t → ObsEquiv s t → (frP : s ⟦ tr ⟧ᴾ*▸ s') (frPs : 1RFrags 1r frP) →
          Σ[ t' ∈ State ] Σ[ frS ∈ t ⟦ tr ⟧*▸ t' ] Σ[ frSs ∈ 1RFrags 1r frS ] SR s' t' × ObsEquiv s' t' × Conformant-1R 1r frP frPs frS frSs
  BC-1R 1r sr s=t frP (wᶜ {all₁ = all₁} {all₂ = all₂} fr₁ fr₂ fr₃@(fr₃' • r {rinv' = rinv'} _))
     with BC-all all₁ sr s=t fr₁
  ... | t₁ , frS₁ , sr-s₁-t₁ , s₁=t₁ , conf₁
     with BC-all (([] ∷ f) ++All mapAll r→rs all₂) sr-s₁-t₁ s₁=t₁ fr₂
  ... | t₂ , frS₂ , sr-s₂-t₂ , s₂=t₂ , conf₂ with runSimSR sr-s₂-t₂ fr₃
  ... | t' , frS' , ar ar-s'-t' =
          let oe' = AR⇒ObsEquiv (rinv' , ar-s'-t')
          in  t' , frS₁ ++RTC frS₂ ++RTC frS' , wᶜ frS₁ frS₂ frS' , ar ar-s'-t' , oe' , conf-all++ fr₁ frS₁ fr₂ frS₂ conf₁ conf₂ , oe'
  BC-1R 1r sr s=t frP (fᶜ {all₁ = all₁} {all₂ = all₂} fr₁ fr₂ fr₃@(fr₃' • r {rinv' = rinv'} _))
     with BC-all all₁ sr s=t fr₁
  ... | t₁ , frS₁ , sr-s₁-t₁ , s₁=t₁ , conf₁
     with BC-all (([] ∷ f) ++All mapAll r→rs all₂) sr-s₁-t₁ s₁=t₁ fr₂
  ... | t₂ , frS₂ , sr-s₂-t₂ , s₂=t₂ , conf₂ with runSimSR sr-s₂-t₂ fr₃
  ... | t' , frS' , ar ar-s'-t' =
          let oe' = AR⇒ObsEquiv (rinv' , ar-s'-t')
          in  t' , frS₁ ++RTC frS₂ ++RTC frS' , fᶜ frS₁ frS₂ frS' , ar ar-s'-t' , oe' , conf-all++ fr₁ frS₁ fr₂ frS₂ conf₁ conf₂ , oe'
  BC-1R 1r sr s=t frP (wᶜ-nof {all₂ = all₂} fr₂ fr₃@(fr₃' • r {rinv' = rinv'} _))
     with BC-all (mapAll r→rs all₂) sr s=t fr₂
  ... | _ , frS₂ , sr-s₂-t₂ , s₂=t₂ , conf₂ with runSimSR sr-s₂-t₂ fr₃
  ... | t' , frS' , ar ar-s'-t' =
          let oe' = AR⇒ObsEquiv (rinv' , ar-s'-t')
          in  t' , frS₂ ++RTC frS' , wᶜ-nof frS₂ frS' , ar ar-s'-t' , oe' , conf₂ , oe'
  BC-1R 1r sr s=t frP (fᶜ-nof {all₂ = all₂} fr₂ fr₃@(fr₃' • r {rinv' = rinv'} _))
     with BC-all (mapAll r→rs all₂) sr s=t fr₂
  ... | _ , frS₂ , sr-s₂-t₂ , s₂=t₂ , conf₂ with runSimSR sr-s₂-t₂ fr₃
  ... | t' , frS' , ar ar-s'-t' =
          let oe' = AR⇒ObsEquiv (rinv' , ar-s'-t')
          in  t' , frS₂ ++RTC frS' , fᶜ-nof frS₂ frS' , ar ar-s'-t' , oe' , conf₂ , oe'

  BC-ind : {tr : Trace} (mr : MultiRecovery tr) {s s' : Stateᴾ} → Initᴾ s → (frP : s ⟦ tr ⟧ᴾ*▸ s') (frPs : MRFrags mr frP)
         → Σ[ t ∈ State ] Init t × Σ[ t' ∈ State ] SR s' t' × ObsEquiv s' t' × Σ[ frS ∈ t ⟦ tr ⟧*▸ t' ] Σ[ frSs ∈ MRFrags mr frS ] Conformant mr frP frPs frS frSs
  BC-ind (init all) {s = s₀} (init rs₀) (frP • rP@(r {rinv' = rinv'} rs)) frPs with runSimSR (cr (initᴿ-CR (proj₁ s₀) rs₀ (proj₁ t-init) (proj₂ t-init))) frP
  ... | t'' , frS , sr' with simSR sr' rP
  ... | t' , rS , (ar ar-rs'-t') =
          let eq = AR⇒ObsEquiv (rinv' , ar-rs'-t')
          in  proj₁ t-init , proj₂ t-init , t' , ar ar-rs'-t' , eq , frS • rS , init (frS • rS) , eq
  BC-ind (one mr x) init-s _ (one {mr = mr₁} {fr₁ = frP₁} frPs₁ {1r = 1r} frP₂ frPs₂) with BC-ind mr init-s _ frPs₁
  ... | t , init-t , t'' , sr'' , oe'' , frS₁ , frSs₁ , conf₁ with BC-1R 1r sr'' oe'' frP₂ frPs₂
  ... | t' , frS₂ , frSs₂ , sr' , oe' , conf₂ = t , init-t , t' , sr' , oe' , frS₁ ++RTC frS₂ , one frSs₁ frS₂ frSs₂ , conf₁ , oe'' , conf₂

  BC-mr : {tr : Trace} (mr : MultiRecovery tr) {s s' : Stateᴾ} → Initᴾ s → (frP : s ⟦ tr ⟧ᴾ*▸ s') → (frPs : MRFrags mr frP)
        → Σ[ t ∈ State ] Init t × Σ[ t' ∈ State ] Σ[ frS ∈ t ⟦ tr ⟧*▸ t' ] Σ[ frSs ∈ MRFrags mr frS ] Conformant mr frP frPs frS frSs
  BC-mr mr init-s frP frPs =
    let (t , init-t , t' , _ , _ , frS , frSs , conf) = BC-ind mr init-s frP frPs
    in  (t , init-t , t' , frS ,  frSs , conf)

  BC : {tr : Trace} (mr : MultiRecovery tr) {s s' : Stateᴾ} → Initᴾ s → (frP : s ⟦ tr ⟧ᴾ*▸ s') (frPs : MRFrags mr frP)
     → {tr' : Trace} {s'' : Stateᴾ} → All Regular×Snapshot tr' → (frP' : s' ⟦ tr' ⟧ᴾ*▸ s'')
     → Σ[ t ∈ State ] Init t × Σ[ t' ∈ State ] Σ[ frS ∈ t ⟦ tr ⟧*▸ t' ] Σ[ frSs ∈ MRFrags mr frS ] Σ[ t'' ∈ State ] Σ[ frS' ∈ t' ⟦ tr' ⟧*▸ t'' ]
       Conformant mr frP frPs frS frSs × Conformant-all frP' frS'
  BC mr init-s frP frPs all frP' =
    let (t , init-t , t' , sr' , oe' , frS , frSs , conf) = BC-ind mr init-s frP frPs
        (t'' , frS' , _ , _ , conf') = BC-all all sr' oe' frP'
    in  (t , init-t , t' , frS , frSs , t'' , frS' , conf , conf')

  SC : {s₀ s s' : Stateᴾ} {tr₀ tr : Trace} → (mr : MultiRecovery tr₀) → (1r : OneRecovery tr)
     → Initᴾ s₀ → (fr₀ : s₀ ⟦ tr₀ ⟧ᴾ*▸ s) → MRFrags mr fr₀ → (frP : s ⟦ tr ⟧ᴾ*▸ s') → (frPs : 1RFrags 1r frP)
     → SnapshotConsistency (λ{(rs , _) (rs' , _) → read rs ≐ read rs'}) 1r frP frPs
  SC mr 1r init-s₀ frP₀ frPs₀ frP frPs with BC-mr (one mr 1r) init-s₀ (frP₀ ++RTC frP) (one frPs₀ frP frPs)
  SC mr ._ init-s₀ frP₀ frPs₀ ._ (wᶜ frP₁ frP₂ frP₃) |
     t₀ , init-t₀ , t' , ._ , one frSs ._ (wᶜ {all₁ = all₁} {all₂ = all₂} {all₃ = all₃} frS₁ frS₂ frS₃) , (_ , oe-s-t , conf , oe-s'-t')
       = Conformant-all-intermediate frP₁ frS₁ frP₂ frS₂ conf oe-s-t <≐> SpecSC-wᶜ ⦃ all₂ ⦄ ⦃ all₃ ⦄ frS₂ frS₃ <≐> sym-≐ oe-s'-t'
  SC mr ._ init-s₀ frP₀ frPs₀ ._ (fᶜ frP₁ frP₂ frP₃) |
     t₀ , init-t₀ , t' , ._ , one frSs ._ (fᶜ {all₁ = all₁} {all₂ = all₂} {all₃ = all₃} frS₁ frS₂ frS₃) , (_ , oe-s-t , conf , oe-s'-t')
       with SpecSC-fᶜ {{all₂}} {{all₃}} frS₂ frS₃
  ...  | inj₁ req = inj₁ $ Conformant-all-intermediate (frP₁ ++RTC frP₂) (frS₁ ++RTC frS₂) ∅ ∅ conf oe-s-t <≐> req <≐> sym-≐ oe-s'-t'
  ...  | inj₂ req = inj₂ $ Conformant-all-intermediate frP₁ frS₁ frP₂ frS₂ conf oe-s-t <≐> req <≐> sym-≐ oe-s'-t'
  SC mr ._ init-s₀ frP₀ frPs₀ ._ (wᶜ-nof frP₂ frP₃) |
     t₀ , init-t₀ , t' , ._ , one {fr₁ = frS₀} frSs ._ (wᶜ-nof {all₂ = all₂} {all₃ = all₃} frS₂ frS₃) , (_ , oe-s-t , conf , oe-s'-t')
       = oe-s-t <≐> SpecSC-wᶜ-nof ⦃ all₂ ⦄ ⦃ all₃ ⦄ (proj₂ (lastr mr frS₀ frSs)) frS₂ frS₃ <≐> sym-≐ oe-s'-t'
  SC mr ._ init-s₀ frP₀ frPs₀ ._ (fᶜ-nof frP₂ frP₃) |
     t₀ , init-t₀ , t' , ._ , one frSs ._ (fᶜ-nof {all₂ = all₂} {all₃ = all₃} frS₂ frS₃) , (_ , oe-s-t , conf , oe-s'-t')
       with SpecSC-fᶜ-nof {{all₂}} {{all₃}} (proj₂ (lastr mr _ frSs)) frS₂ frS₃
  ...  | inj₁ req = inj₁ $ Conformant-all-intermediate frP₂ frS₂ ∅ ∅ conf oe-s-t <≐> req <≐> sym-≐ oe-s'-t'
  ...  | inj₂ req = inj₂ $ oe-s-t <≐> req <≐> sym-≐ oe-s'-t'


-- {-# OPTIONS -v term:10 -v tc.pos:10 -v tc.decl:10 #-}

-- Andreas, 2018-02-26, issue #2975
-- Problem history:
--
-- The example below crashed with an internal error.
-- The problem is that the termination checker needs to know
-- whether force is the projection of a recursive coinductive
-- record.  However, the positivity checker has not run,
-- thus, this information is not available.

record R : Set where
  coinductive
  field force : R

  -- The following corecursive definition should pass the termination checker.
  r : R
  force r = r

-- Should succeed.


-- Andreas, 2020-02-10, issue 4429, reported by Nisse
--
-- Injectivity analysis can make type checker loop (or slow down)
-- since it reduces the rhs of definitions.
--
-- Try to be smarter and do not needlessly invoke the injectivity
-- analysis.  For instance, do not consider a projection pattern
-- a proper match for the sake of injectivity, since a metavariable
-- cannot occupy its position (unlike for constructor and literal patterns).

-- {-# OPTIONS -v tc.inj.check:45 #-}

record _⇔_ (A B : Set) : Set where
  field
    to   : A → B
    from : B → A

postulate
  A : Set

{-# TERMINATING #-}

to : A → A
to = to  -- An approximation of slow but terminating code.

{-# TERMINATING #-}

from : A → A
from = from  -- An approximation of slow but terminating code.

works : A ⇔ A
works = record
  { to   = to
  ; from = from
  }

test : A ⇔ A
test ._⇔_.to   = to
test ._⇔_.from = from

-- WAS: Definition by copatterns loops, because the injectivity
-- checker tries to reduce the rhs.

-- Should pass, since now injectivity checker does not consider
-- a projection pattern as proper match.
-- Thus, injectivity for this function would be pointless.


open import Level.NP
open import Type
open import Relation.Binary.Logical
open import Relation.Binary.PropositionalEquality

module Explore.Universe.Logical (X : ★) where

open import Explore.Universe.Type
open import Explore.Universe X
open import Explore.Core

module From⟦X⟧ (⟦X⟧ : ⟦★₀⟧ X X) where

  -- TODO _⟦≃⟧_ : (⟦Rel⟧ ⟦★₀⟧) ₀ _≃_ _≃_

  data ⟦U⟧ : ⟦★₁⟧ U U
  ⟦El⟧ : (⟦U⟧ ⟦→⟧ ⟦★₀⟧) El El

  data ⟦U⟧ where
    ⟦𝟘ᵁ⟧ : ⟦U⟧ 𝟘ᵁ 𝟘ᵁ
    ⟦𝟙ᵁ⟧ : ⟦U⟧ 𝟙ᵁ 𝟙ᵁ
    ⟦𝟚ᵁ⟧ : ⟦U⟧ 𝟚ᵁ 𝟚ᵁ
    _⟦×ᵁ⟧_ : ⟦Op₂⟧ {_} {_} {₁} ⟦U⟧ _×ᵁ_ _×ᵁ_
    _⟦⊎ᵁ⟧_ : ⟦Op₂⟧ {_} {_} {₁} ⟦U⟧ _⊎ᵁ_ _⊎ᵁ_
    ⟦Σᵁ⟧ : (⟨ u ∶ ⟦U⟧ ⟩⟦→⟧ (⟦El⟧ u ⟦→⟧ ⟦U⟧) ⟦→⟧ ⟦U⟧) Σᵁ Σᵁ
    ⟦Xᵁ⟧ : ⟦U⟧ Xᵁ Xᵁ
    -- ⟦≃ᵁ⟧ : (⟨ u ∶ ⟦U⟧ ⟩⟦→⟧ (⟨ A ∶ ⟦★₀⟧ ⟩⟦→⟧ ⟦El⟧ u ⟦≃⟧ A ⟦→⟧ ⟦U⟧)) ≃ᵁ ≃ᵁ

  ⟦El⟧ ⟦𝟘ᵁ⟧ = _≡_
  ⟦El⟧ ⟦𝟙ᵁ⟧ = _≡_
  ⟦El⟧ ⟦𝟚ᵁ⟧ = _≡_
  ⟦El⟧ (u₀ ⟦×ᵁ⟧ u₁) = ⟦El⟧ u₀ ⟦×⟧ ⟦El⟧ u₁
  ⟦El⟧ (u₀ ⟦⊎ᵁ⟧ u₁) = ⟦El⟧ u₀ ⟦⊎⟧ ⟦El⟧ u₁
  ⟦El⟧ (⟦Σᵁ⟧ u f) = ⟦Σ⟧ (⟦El⟧ u) λ x → ⟦El⟧ (f x)
  ⟦El⟧ ⟦Xᵁ⟧ = ⟦X⟧
  -- ⟦El⟧ (⟦≃ᵁ⟧ u A e) = A

  module From⟦Xᵉ⟧
           {⟦X⟧ : ⟦★₀⟧ X X}
           {ℓ₀ ℓ₁} ℓᵣ
           {Xᵉ : Explore X}
           (⟦Xᵉ⟧ : ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ ⟦X⟧ Xᵉ Xᵉ) where
    open From⟦X⟧ ⟦X⟧ public

    ⟦explore⟧ : ∀ {u₀ u₁} (u : ⟦U⟧ u₀ u₁) → ⟦Explore⟧ {ℓ₀} {ℓ₁} ℓᵣ (⟦El⟧ u) (explore u₀) (explore u₁)
    ⟦explore⟧ ⟦𝟘ᵁ⟧        = ⟦𝟘ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ}
    ⟦explore⟧ ⟦𝟙ᵁ⟧        = ⟦𝟙ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_} {refl}
    ⟦explore⟧ ⟦𝟚ᵁ⟧        = ⟦𝟚ᵉ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} {_≡_} {refl} {refl}
    ⟦explore⟧ (u₀ ⟦×ᵁ⟧ u₁) = ⟦explore×⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ u₀) (⟦explore⟧ u₁)
    ⟦explore⟧ (u₀ ⟦⊎ᵁ⟧ u₁) = ⟦explore⊎⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ u₀) (⟦explore⟧ u₁)
    ⟦explore⟧ (⟦Σᵁ⟧ u f)  = ⟦exploreΣ⟧ {ℓ₀} {ℓ₁} {ℓᵣ} (⟦explore⟧ u) (⟦explore⟧ ∘ f)
    ⟦explore⟧ ⟦Xᵁ⟧        = ⟦Xᵉ⟧
    -- ⟦explore⟧ (⟦≃ᵁ⟧ u A e) = {!⟦explore-iso⟧ e!}

{-
⟦U⟧-sound : ∀ {{_ : FunExt}} {x y} → ⟦U⟧ x y → x ≡ y
⟦U⟧-refl : ∀ x → ⟦U⟧ x x

{-
⟦El⟧-refl : ∀ x → {!⟦El⟧ x x!}
⟦El⟧-refl = {!!}
-}

⟦U⟧-sound ⟦𝟘ᵁ⟧ = refl
⟦U⟧-sound ⟦𝟙ᵁ⟧ = refl
⟦U⟧-sound ⟦𝟚ᵁ⟧ = refl
⟦U⟧-sound (u ⟦×ᵁ⟧ u₁) = ap₂ _×ᵁ_ (⟦U⟧-sound u) (⟦U⟧-sound u₁)
⟦U⟧-sound (u ⟦⊎ᵁ⟧ u₁) = ap₂ _⊎ᵁ_ (⟦U⟧-sound u) (⟦U⟧-sound u₁)
⟦U⟧-sound (⟦Σᵁ⟧ {u₀} {u₁} u {f₀} {f₁} fᵣ) = apd₂ Σᵁ (⟦U⟧-sound u) (tr-→ El (const U) (⟦U⟧-sound u) f₀ ∙ λ= (λ A → ap (λ z → z (f₀ (tr El (! ⟦U⟧-sound u) A))) (tr-const (⟦U⟧-sound u)) ∙ ⟦U⟧-sound (fᵣ {!!}))) -- (λ= (λ y → let foo = xᵣ {{!!}} {y} {!xᵣ!} in {!tr-→ El (const U) (⟦U⟧-sound u)!}))

⟦U⟧-refl 𝟘ᵁ = ⟦𝟘ᵁ⟧
⟦U⟧-refl 𝟙ᵁ = ⟦𝟙ᵁ⟧
⟦U⟧-refl 𝟚ᵁ = ⟦𝟚ᵁ⟧
⟦U⟧-refl (x ×ᵁ x₁) = ⟦U⟧-refl x ⟦×ᵁ⟧ ⟦U⟧-refl x₁
⟦U⟧-refl (x ⊎ᵁ x₁) = ⟦U⟧-refl x ⟦⊎ᵁ⟧ ⟦U⟧-refl x₁
⟦U⟧-refl (Σᵁ x f) = ⟦Σᵁ⟧ (⟦U⟧-refl x) (λ y → {!⟦U⟧-refl ?!})
-}


open import MLib.Algebra.PropertyCode
open import MLib.Algebra.PropertyCode.Structures

module MLib.Matrix.Tensor {c ℓ} (struct : Struct bimonoidCode c ℓ) where

open import MLib.Prelude
open import MLib.Matrix.Core
open import MLib.Matrix.Equality struct
open import MLib.Matrix.Mul struct
open import MLib.Algebra.Operations struct

open Table using (head; tail; rearrange; fromList; toList; _≗_; replicate)
open Nat using () renaming (_+_ to _+ℕ_; _*_ to _*ℕ_)

open FunctionProperties

open import MLib.Fin.Parts.Simple

-- Tensor product

_⊠_ : ∀ {m n p q} → Matrix S m n → Matrix S p q → Matrix S (m *ℕ p) (n *ℕ q)
(A ⊠ B) i j =
  let i₁ , i₂ = toParts i
      j₁ , j₂ = toParts j
  in A i₁ j₁ *′ B i₂ j₂

private
  ≡⇒≡×≡×≡ :
    ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
    {i i′ : A} {j j′ : B} {k k′ : C} →
    (i , j , k) ≡ (i′ , j′ , k′) →
    i ≡ i′ × j ≡ j′ × k ≡ k′
  ≡⇒≡×≡×≡ = Σ.map id Σ.≡⇒≡×≡ ∘ Σ.≡⇒≡×≡

open _≃_

module _ ⦃ props : Has (associative on * ∷ []) ⦄ {m n p q r s} where

  ⊠-associative :
    (A : Matrix S m n) (B : Matrix S p q) (C : Matrix S r s) →
    (A ⊠ B) ⊠ C ≃ A ⊠ (B ⊠ C)
  ⊠-associative A B C .m≡p = Nat.*-assoc m p r
  ⊠-associative A B C .n≡q = Nat.*-assoc n q s
  ⊠-associative A B C .equal {i} {i′} {j} {j′} i≅i′ j≅j′ =
    let i₁ , i₂ , i₃ = toParts³ m p r i
        j₁ , j₂ , j₃ = toParts³ n q s j

        i′₁ , i′₂ , i′₃ = toParts³′ m p r i′
        j′₁ , j′₂ , j′₃ = toParts³′ n q s j′

        i₁-eq , i₂-eq , i₃-eq = ≡⇒≡×≡×≡ (toParts-assoc m p r i≅i′)
        j₁-eq , j₂-eq , j₃-eq = ≡⇒≡×≡×≡ (toParts-assoc n q s j≅j′)

        open EqReasoning S.setoid
    in begin
      ((A ⊠ B) ⊠ C) i j                        ≡⟨⟩
      A i₁ j₁ *′ B i₂ j₂ *′ C i₃ j₃            ≈⟨ from props (associative on *) _ _ _ ⟩
      A i₁ j₁ *′ (B i₂ j₂ *′ C i₃ j₃)          ≡⟨ ≡.cong₂ _*′_ (≡.cong₂ A i₁-eq j₁-eq) (≡.cong₂ _*′_ (≡.cong₂ B i₂-eq j₂-eq) (≡.cong₂ C i₃-eq j₃-eq)) ⟩
      A i′₁ j′₁ *′ (B i′₂ j′₂ *′ C i′₃ j′₃)    ≡⟨⟩
      (A ⊠ (B ⊠ C)) i′ j′                      ∎

⊠-cong : ∀ {m n m′ n′} {p q p′ q′} {A : Matrix S m n} {A′ : Matrix S m′ n′} {B : Matrix S p q} {B′ : Matrix S p′ q′} → A ≃ A′ → B ≃ B′ → (A ⊠ B) ≃ (A′ ⊠ B′)
⊠-cong A≃A′ B≃B′ with A≃A′ .m≡p | B≃B′ .m≡p | A≃A′ .n≡q | B≃B′ .n≡q
⊠-cong {A = A} {A′} {B} {B′} A≃A′ B≃B′ | ≡.refl | ≡.refl | ≡.refl | ≡.refl = lem
  where
  lem : (A ⊠ B) ≃ (A′ ⊠ B′)
  lem .m≡p = ≡.refl
  lem .n≡q = ≡.refl
  lem .equal ≅.refl ≅.refl = cong * (A≃A′ .equal ≅.refl ≅.refl) (B≃B′ .equal ≅.refl ≅.refl)

⊠-identityˡ :
  ⦃ props : Has (1# is leftIdentity for * ∷ []) ⦄ →
  ∀ {m n} (A : Matrix S m n) → 1● {1} ⊠ A ≃ A
⊠-identityˡ A .m≡p = Nat.*-identityˡ _
⊠-identityˡ A .n≡q = Nat.*-identityˡ _
⊠-identityˡ ⦃ props ⦄ A .equal {i} {i′} {j} {j′} i≅i′ j≅j′ =
  let i₁ , i₂ = toParts {1} i
      j₁ , j₂ = toParts {1} j
      -- x  : i₁ ≡ zero
      -- x′ : i₂ ≡ i′
      -- y  : j₁ ≡ zero
      -- y′ : j₂ ≡ j′
      x , x′ = Σ.≡⇒≡×≡ (toParts-1ˡ i i′ i≅i′)
      y , y′ = Σ.≡⇒≡×≡ (toParts-1ˡ j j′ j≅j′)

      open EqReasoning S.setoid
  in begin
    (1● {1} ⊠ A) i j           ≡⟨⟩
    1● {1} i₁ j₁     *′ A i₂ j₂ ≡⟨ ≡.cong₂ _*′_ (≡.cong₂ (1● {1}) x y) (≡.cong₂ A x′ y′) ⟩
    1● {1} zero zero *′ A i′ j′ ≡⟨⟩
    1′               *′ A i′ j′ ≈⟨ from props (1# is leftIdentity for *) _ ⟩
    A i′ j′ ∎

⊠-identityʳ :
  ⦃ props : Has (1# is rightIdentity for * ∷ []) ⦄ →
  ∀ {m n} (A : Matrix S m n) → A ⊠ 1● {1} ≃ A
⊠-identityʳ A .m≡p = Nat.*-identityʳ _
⊠-identityʳ A .n≡q = Nat.*-identityʳ _
⊠-identityʳ A .equal {i} {i′} {j} {j′} i≅i′ j≅j′ with Σ.≡⇒≡×≡ (toParts-1ʳ i i′ i≅i′) | Σ.≡⇒≡×≡ (toParts-1ʳ j j′ j≅j′)
⊠-identityʳ ⦃ props ⦄ A .equal {i} {i′} {j} {j′} i≅i′ j≅j′ | x , x′ | y , y′
  rewrite x | x′ | y | y′ = from props (1# is rightIdentity for *) _