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

open import lib.Basics
open import lib.NConnected
open import lib.types.Bool
open import lib.types.FunctionSeq
open import lib.types.Pointed
open import lib.types.Suspension.Core
open import lib.types.TLevel

module lib.types.Suspension.Iterated where

Susp^ : ∀ {i} (n : ℕ) → Type i → Type i
Susp^ O X = X
Susp^ (S n) X = Susp (Susp^ n X)

Susp^-pt : ∀ {i} (n : ℕ) (A : Ptd i) → Susp^ n (de⊙ A)
Susp^-pt O A = pt A
Susp^-pt (S n) A = north

⊙Susp^ : ∀ {i} (n : ℕ) → Ptd i → Ptd i
⊙Susp^ n X = ptd (Susp^ n (de⊙ X)) (Susp^-pt n X)

abstract
  Susp^-conn : ∀ {i} (n : ℕ) {A : Type i} {m : ℕ₋₂}
    {{_ : is-connected m A}} → is-connected (⟨ n ⟩₋₂ +2+ m) (Susp^ n A)
  Susp^-conn O = ⟨⟩
  Susp^-conn (S n) = Susp-conn (Susp^-conn n)

  ⊙Susp^-conn' : ∀ {i} (n : ℕ) {A : Type i}
    {{_ : is-connected 0 A}} → is-connected ⟨ n ⟩ (Susp^ n A)
  ⊙Susp^-conn' O = ⟨⟩
  ⊙Susp^-conn' (S n) = Susp-conn (⊙Susp^-conn' n)

Susp^-fmap : ∀ {i j} (n : ℕ) {A : Type i} {B : Type j}
  → (A → B) → Susp^ n A → Susp^ n B
Susp^-fmap O f = f
Susp^-fmap (S n) f = Susp-fmap (Susp^-fmap n f)

⊙Susp^-fmap-pt : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  (f : X ⊙→ Y)
  → Susp^-fmap n (fst f) (pt (⊙Susp^ n X)) == pt (⊙Susp^ n Y)
⊙Susp^-fmap-pt O f = snd f
⊙Susp^-fmap-pt (S n) f = idp

⊙Susp^-fmap : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → X ⊙→ Y → ⊙Susp^ n X ⊙→ ⊙Susp^ n Y
⊙Susp^-fmap n f = Susp^-fmap n (fst f) , ⊙Susp^-fmap-pt n f

Susp^-fmap-idf : ∀ {i} (n : ℕ) (A : Type i)
  → Susp^-fmap n (idf A) == idf (Susp^ n A)
Susp^-fmap-idf O A = idp
Susp^-fmap-idf (S n) A = ↯ $
  Susp-fmap (Susp^-fmap n (idf A))
    =⟪ ap Susp-fmap (Susp^-fmap-idf n A) ⟫
  Susp-fmap (idf _)
    =⟪ λ= (Susp-fmap-idf _) ⟫
  idf (Susp^ (S n) A) ∎∎

transport-Susp^ : ∀ {i} {A B : Type i} (n : ℕ) (p : A == B)
  → transport (Susp^ n) p == Susp^-fmap n (coe p)
transport-Susp^ n idp = ! (Susp^-fmap-idf n _)

⊙Susp^-fmap-idf : ∀ {i} (n : ℕ) (X : Ptd i)
  → ⊙Susp^-fmap n (⊙idf X) ◃⊙idf =⊙∘ ⊙idf-seq
⊙Susp^-fmap-idf O X = =⊙∘-in idp
⊙Susp^-fmap-idf (S n) X =
  ⊙Susp^-fmap (S n) (⊙idf X) ◃⊙idf
    =⊙∘₁⟨ ap ⊙Susp-fmap (Susp^-fmap-idf n (de⊙ X)) ⟩
  ⊙Susp-fmap (idf _) ◃⊙idf
    =⊙∘⟨ ⊙Susp-fmap-idf (Susp^ n (de⊙ X)) ⟩
  ⊙idf-seq ∎⊙∘

⊙transport-⊙Susp^ : ∀ {i} {X Y : Ptd i} (n : ℕ) (p : X == Y)
  → ⊙transport (⊙Susp^ n) p == ⊙Susp^-fmap n (⊙coe p)
⊙transport-⊙Susp^ n p@idp = ! (=⊙∘-out (⊙Susp^-fmap-idf n _))

Susp^-fmap-cst : ∀ {i j} (n : ℕ) {A : Type i} {Y : Ptd j}
  → Susp^-fmap n {A = A} (λ _ → pt Y) == (λ _ → pt (⊙Susp^ n Y))
Susp^-fmap-cst O = idp
Susp^-fmap-cst (S n) {A} {Y} = ↯ $
  Susp-fmap (Susp^-fmap n {A = A} (λ _ → pt Y))
    =⟪ ap Susp-fmap (Susp^-fmap-cst n) ⟫
  Susp-fmap (λ _ → pt (⊙Susp^ n Y))
    =⟪ λ= (Susp-fmap-cst (pt (⊙Susp^ n Y))) ⟫
  (λ _ → north) ∎∎

⊙Susp^-fmap-cst : ∀ {i j} (n : ℕ) {X : Ptd i} {Y : Ptd j}
  → ⊙Susp^-fmap n (⊙cst {X = X} {Y = Y}) == ⊙cst
⊙Susp^-fmap-cst O = idp
⊙Susp^-fmap-cst (S n) = ap ⊙Susp-fmap (Susp^-fmap-cst n) ∙ ⊙Susp-fmap-cst

Susp^-fmap-∘ : ∀ {i j k} (n : ℕ) {A : Type i} {B : Type j} {C : Type k}
  (g : B → C) (f : A → B)
  → Susp^-fmap n (g ∘ f) == Susp^-fmap n g ∘ Susp^-fmap n f
Susp^-fmap-∘ O g f = idp
Susp^-fmap-∘ (S n) g f =
  Susp-fmap (Susp^-fmap n (g ∘ f))
    =⟨ ap Susp-fmap (Susp^-fmap-∘ n g f) ⟩
  Susp-fmap (Susp^-fmap n g ∘ Susp^-fmap n f)
    =⟨ λ= (Susp-fmap-∘ (Susp^-fmap n g) (Susp^-fmap n f)) ⟩
  Susp^-fmap (S n) g ∘ Susp^-fmap (S n) f =∎

⊙Susp^-fmap-∘ : ∀ {i j k} (n : ℕ) {X : Ptd i} {Y : Ptd j} {Z : Ptd k}
  (g : Y ⊙→ Z) (f : X ⊙→ Y)
  → ⊙Susp^-fmap n (g ⊙∘ f) == ⊙Susp^-fmap n g ⊙∘ ⊙Susp^-fmap n f
⊙Susp^-fmap-∘ O g f = idp
⊙Susp^-fmap-∘ (S n) g f =
  ap ⊙Susp-fmap (Susp^-fmap-∘ n (fst g) (fst f))
  ∙ ⊙Susp-fmap-∘ (Susp^-fmap n (fst g)) (Susp^-fmap n (fst f))

⊙Susp^-fmap-seq : ∀ {i} (n : ℕ) {X : Ptd i} {Y : Ptd i}
  → X ⊙–→ Y
  → ⊙Susp^ n X ⊙–→ ⊙Susp^ n Y
⊙Susp^-fmap-seq n ⊙idf-seq = ⊙idf-seq
⊙Susp^-fmap-seq n (f ◃⊙∘ fs) = ⊙Susp^-fmap n f ◃⊙∘ ⊙Susp^-fmap-seq n fs

⊙Susp^-fmap-seq-∘ : ∀ {i} (n : ℕ) {X : Ptd i} {Y : Ptd i} (fs : X ⊙–→ Y)
  → ⊙Susp^-fmap n (⊙compose fs) ◃⊙idf =⊙∘ ⊙Susp^-fmap-seq n fs
⊙Susp^-fmap-seq-∘ n ⊙idf-seq = ⊙Susp^-fmap-idf n _
⊙Susp^-fmap-seq-∘ n (f ◃⊙∘ fs) = =⊙∘-in $
  ⊙Susp^-fmap n (f ⊙∘ ⊙compose fs)
    =⟨ ⊙Susp^-fmap-∘ n f (⊙compose fs) ⟩
  ⊙Susp^-fmap n f ⊙∘ ⊙Susp^-fmap n (⊙compose fs)
    =⟨ ap (⊙Susp^-fmap n f ⊙∘_) (=⊙∘-out (⊙Susp^-fmap-seq-∘ n fs)) ⟩
  ⊙Susp^-fmap n f ⊙∘ ⊙compose (⊙Susp^-fmap-seq n fs) =∎

⊙Susp^-fmap-seq-=⊙∘ : ∀ {i} (n : ℕ) {X : Ptd i} {Y : Ptd i} {fs gs : X ⊙–→ Y}
  → fs =⊙∘ gs
  → ⊙Susp^-fmap-seq n fs =⊙∘ ⊙Susp^-fmap-seq n gs
⊙Susp^-fmap-seq-=⊙∘ n {fs = fs} {gs = gs} p =
  ⊙Susp^-fmap-seq n fs
    =⊙∘⟨ !⊙∘ $ ⊙Susp^-fmap-seq-∘ n fs ⟩
  ⊙Susp^-fmap n (⊙compose fs) ◃⊙idf
    =⊙∘₁⟨ ap (⊙Susp^-fmap n) (=⊙∘-out p) ⟩
  ⊙Susp^-fmap n (⊙compose gs) ◃⊙idf
    =⊙∘⟨ ⊙Susp^-fmap-seq-∘ n gs ⟩
  ⊙Susp^-fmap-seq n gs ∎⊙∘

⊙Sphere : (n : ℕ) → Ptd₀
⊙Sphere n = ⊙Susp^ n ⊙Bool

Sphere : (n : ℕ) → Type₀
Sphere n = de⊙ (⊙Sphere n)

abstract
  instance
    Sphere-conn : ∀ (n : ℕ) → is-connected ⟨ n ⟩₋₁ (Sphere n)
    Sphere-conn 0 = inhab-conn true
    Sphere-conn (S n) = Susp-conn (Sphere-conn n)

-- favonia: [S¹] has its own elim rules in Circle.agda.
⊙S⁰ = ⊙Sphere 0
⊙S¹ = ⊙Sphere 1
⊙S² = ⊙Sphere 2
⊙S³ = ⊙Sphere 3
S⁰ = Sphere 0
S¹ = Sphere 1
S² = Sphere 2
S³ = Sphere 3


module _ (A : Set) (Sing : A → Set) (F : (a : A) → Sing a → Set) where

test : {a : A} → Sing a → Set
test s = F {!!} s

-- WAS: C-c C-s inserts a, which produces a scope error
-- Instead, it should insert _


-- 2012-09-25 Andreas, reported by Nicolas Pouillard
{-# OPTIONS --sized-types #-}
module Issue700 where

import Common.Level
open import Common.Size

postulate
  Size< : Size → Set
{-# BUILTIN SIZELT Size< #-}

postulate
  A : Set

data T (i : Size) : Set where
  c : (j : Size< i) → T j → T _

bug : ∀ i → T i → A
bug i (c j x) = bug j x

{- WAS: de Bruijn index out of scope

Issue700.bug is projection like in argument 1 for type Issue700.T
Translated clause:
  delta = (j : Size< @0) (x : T j)
  perm  = x0,x1 -> x0,x1
  ps    = [r(ConP Issue700.T.c Nothing [r(VarP "j"),r(VarP "x")])]
  body  = Bind (Abs "h1" Bind (Abs "h2" Body (Def Issue700.bug [r(Var 1 []),r(Var 0 [])])))
  body  = [h1 h2] bug h1 h2
-}


open import Common.Prelude
open import Common.Reflection
open import Common.Equality

postulate
  trustme : ∀ {a} {A : Set a} {x y : A} → x ≡ y

magic : List (Arg Type) → Term → Tactic
magic _ _ = give (def (quote trustme) [])

id : ∀ {a} {A : Set a} → A → A
id x = x

science : List (Arg Type) → Term → Tactic
science _ _ = give (def (quote id) [])

by-magic : ∀ n → n + 4 ≡ 3
by-magic n = tactic magic

by-science : ∀ n → 0 + n ≡ n
by-science n = tactic science | refl


module Sessions.Syntax.Values where

open import Prelude hiding (both)
open import Relation.Unary
open import Data.Maybe
open import Data.List.Properties using (++-isMonoid)
import Data.List as List

open import Sessions.Syntax.Types
open import Sessions.Syntax.Expr

open import Relation.Ternary.Separation.Morphisms

data Runtype : Set where
  endp : SType → Runtype
  chan : SType → SType → Runtype

flipped : Runtype → Runtype
flipped (endp x)   = endp x
flipped (chan α β) = chan β α

data Ends : Runtype → Runtype → Runtype → Set where
  lr : ∀ {a b} → Ends (endp a) (endp b) (chan a b)
  rl : ∀ {a b} → Ends (endp b) (endp a) (chan a b)

instance
  ≺-raw-sep : RawSep Runtype
  RawSep._⊎_≣_ ≺-raw-sep = Ends

  ≺-has-sep : IsSep ≺-raw-sep
  IsSep.⊎-comm ≺-has-sep lr = rl
  IsSep.⊎-comm ≺-has-sep rl = lr
  IsSep.⊎-assoc ≺-has-sep lr ()
  IsSep.⊎-assoc ≺-has-sep rl ()

RCtx = List Runtype
open import Relation.Ternary.Separation.Construct.ListOf Runtype public

End : SType → Runtype → Set
End α τ = [ endp α ] ≤ [ τ ]

ending : ∀ {ys} → Ends (endp γ) ys (chan α β) → End γ (chan α β)
ending lr = -, divide lr ⊎-idˡ
ending rl = -, divide rl ⊎-idˡ

mutual
  Env = Allstar Val

  data Closure : Type → Type → Pred RCtx 0ℓ where
    clos : ∀ {a} → Exp b (a ∷ Γ) → ∀[ Env Γ ⇒ Closure a b ]

  Endptr = Just ∘ endp

  data Val : Type → Pred RCtx 0ℓ where
    tt    : ε[ Val unit ]
    cref  : ∀[ Endptr α ⇒ Val (cref α)   ]
    pairs : ∀[ Val a ✴ Val b  ⇒ Val (prod a b) ]
    clos  : Exp b (a ∷ Γ) → ∀[ Env Γ ⇒ Val (a ⊸ b) ]


postulate
  A : Set

data D : Set → Set₁ where
  d : (A : Set) → D A

f : Set → (D A → Set) → Set
f A f = f (d A)

-- Expected error:
-- A != A of type Set
-- (because one is a variable and one a defined identifier)
-- when checking that the pattern d A has type D A


{-# OPTIONS --cubical #-}
module _ where

module _ where
  open import Agda.Primitive.Cubical public

  postulate
    Path' : ∀ {ℓ} {A :     Set ℓ} → A    → A    → Set ℓ
    PathP : ∀ {ℓ} (A : I → Set ℓ) → A i0 → A i1 → Set ℓ

  {-# BUILTIN PATH         Path'     #-}
  {-# BUILTIN PATHP        PathP     #-}

  infix 4 _≡_
  _≡_ : ∀ {ℓ} {A : Set ℓ} → A → A → Set ℓ
  _≡_ {A = A} = PathP (λ _ → A)

  Path = _≡_

  refl : ∀ {a} {A : Set a} {x : A} → x ≡ x
  refl {x = x} = \ _ → x

-- Here there's no solution for H, pattern unification will try
-- H := \ i -> b, but the equality constraints from
-- H : Path b a should rule out that assignment.
testPath : ∀ {A : Set} {b a : A} (let H : Path b a; H = _) → ∀ i → H i ≡ b
testPath i = refl


module PredicateName where

open import OscarPrelude

record PredicateName : Set
 where
  constructor ⟨_⟩
  field
    name : Nat

open PredicateName public

instance EqPredicateName : Eq PredicateName
Eq._==_ EqPredicateName _ = decEq₁ (cong name) ∘ (_≟_ on name $ _)


{- Formal verification of authenticated append-only skiplists in Agda, version 1.0.

   Copyright (c) 2020 Oracle and/or its affiliates.
   Licensed under the Universal Permissive License v 1.0 as shown at https://opensource.oracle.com/licenses/upl
-}
open import Data.Unit.NonEta
open import Data.Empty
open import Data.Fin using (Fin; fromℕ≤) renaming (zero to fz; suc to fs)
import      Data.Fin.Properties renaming (_≟_ to _≟Fin_)
open import Data.Sum
open import Data.Product
open import Data.Product.Properties
open import Data.Nat renaming (_≟_ to _≟ℕ_; _≤?_ to _≤?ℕ_)
open import Data.Nat.Properties
open import Data.List renaming (map to List-map)
open import Data.List.Properties using (∷-injective; length-++)
open import Data.List.Relation.Binary.Pointwise using (decidable-≡)
open import Data.List.Relation.Unary.All as List-All
open import Data.List.Relation.Unary.Any renaming (map to Any-map)
open import Data.List.Relation.Unary.Any.Properties renaming (gmap to Any-gmap)
open import Data.Bool hiding (_≤_ ; _<_)
open import Data.Maybe renaming (map to Maybe-map)

open import Function using (_∘_)

open import Relation.Binary.PropositionalEquality
open ≡-Reasoning
open import Relation.Binary.Core
open import Relation.Nullary

-- This module contains various useful lemmas

module AAOSL.Lemmas where

 -----------------------------
 -- Properties about functions

 postulate  -- valid assumption, functional extensionality
   fun-ext : ∀{a b}{A : Set a}{B : Set b}
           → {f g : A → B}
           → (∀ x → f x ≡ g x)
           → f ≡ g

 ------------------------------
 -- Properties about inequality

 ≢-pi : ∀{a}{A : Set a}{m n : A}(p q : m ≢ n) → p ≡ q
 ≢-pi p q = fun-ext {f = p} {q} (λ x → ⊥-elim (p x))

 suc-≢ : ∀ {m n} → (suc m ≢ suc n) → m ≢ n
 suc-≢ sm≢sn m≡n = sm≢sn (cong suc m≡n)

 *-cong-≢ : ∀ p {m n} → 0 < p → m ≢ n → p * m ≢ p * n
 *-cong-≢ (suc p) 0<p m≢n p*m≡p*n = m≢n (*-cancelˡ-≡ p p*m≡p*n)

 ⊥-1≡m*2 : ∀ m → 1 ≢ m * 2
 ⊥-1≡m*2 zero = λ x → <⇒≢ (s≤s z≤n) (sym x)
 ⊥-1≡m*2 (suc m) = λ x → <⇒≢ (s≤s z≤n) (suc-injective x)

 ∸-≢ : ∀{m} n → 1 ≤ n → n ≤ suc m → suc m ∸ n ≢ suc m
 ∸-≢ {m} (suc n) 1≤n (s≤s n≤sm)
   rewrite sym (+-identityʳ (suc m))
         | sym (n∸n≡0 n)
         | sym (+-∸-assoc m {n} {n} ≤-refl)
         | +-∸-comm {m} n {n} n≤sm = m≢1+m+n (m ∸ n)

 1≢a+b : ∀{a b} → 1 ≤ a → 1 ≤ b → 1 ≢ a + b
 1≢a+b (s≤s {n = a} 1≤a) (s≤s {n = b} 1≤b) abs
   rewrite +-comm a (suc b) = 1+n≢0 (sym (suc-injective abs))

 0≢a*b-magic : ∀{a b} → 0 < a → 0 < b → 0 ≢ a * b
 0≢a*b-magic {a} {b} 0<a 0<b hip
   with m*n≡0⇒m≡0∨n≡0 a (sym hip)
 ... | inj₁ x = <⇒≢ 0<a (sym x)
 ... | inj₂ y = <⇒≢ 0<b (sym y)

 -----------------------------------
 -- Injectivty of ℕ ranged functions

 *2-injective : ∀ n m → n * 2 ≡ m * 2 → m ≡ n
 *2-injective zero    zero    x = refl
 *2-injective (suc n) (suc m) x
    = cong suc (*2-injective n m (suc-injective (suc-injective x)))

 2^-injective : ∀ {n m : ℕ}
   → 2 ^ n ≡ 2 ^ m
   → n ≡ m
 2^-injective {n} {zero} 2^n≡2^0
     with (m^n≡1⇒n≡0∨m≡1 2 n 2^n≡2^0)
 ...| inj₁ m≡0 = m≡0
 2^-injective {zero} {suc m} 2^0≡2^sm
     with (m^n≡1⇒n≡0∨m≡1 2 (suc m) (sym 2^0≡2^sm))
 ...| inj₁ sm≡0 = sym sm≡0
 2^-injective {suc n} {suc m} 2^n≡2^m = cong suc (2^-injective (*-cancelˡ-≡ {2 ^ n} {2 ^ m} 1 2^n≡2^m))

 +-inj : ∀ {m n p : ℕ} → m + n ≡ m + p → n ≡ p
 +-inj {0}     {n} {p} prf = prf
 +-inj {suc m} {n} {p} prf =  +-inj (suc-injective prf)

 ∸-inj : ∀{m} o n → o ≤ m → n ≤ m → m ∸ o ≡ m ∸ n → o ≡ n
 ∸-inj {m} o n o≤m n≤m m∸o≡m∸n =
       begin
         o
       ≡⟨ sym (m∸[m∸n]≡n o≤m) ⟩
         m ∸ (m ∸ o)
       ≡⟨ cong (m ∸_) m∸o≡m∸n ⟩
         m ∸ (m ∸ n)
       ≡⟨ m∸[m∸n]≡n n≤m ⟩
         n
       ∎

 -------------------------------
 -- Properties about _≤_ and _<_

 <-≤-trans : ∀{m n o} → m < n → n ≤ o → m < o
 <-≤-trans p q = ≤-trans p q

 ≤-<-trans : ∀{m n o} → m ≤ n → n < o → m < o
 ≤-<-trans p q = ≤-trans (s≤s p) q

 ≤-unstep2 : ∀{m n} → suc m ≤ suc n → m ≤ n
 ≤-unstep2 (s≤s p) = p

 ≤-unstep : ∀{m n} → suc m ≤ n → m ≤ n
 ≤-unstep (s≤s p) = ≤-step p

 0<-suc : ∀{m} → 0 < m → ∃[ n ] (m ≡ suc n)
 0<-suc (s≤s p) = _ , refl

 1≤0-⊥ : 1 ≤ 0 → ⊥
 1≤0-⊥ ()

 -------------------------------
 -- Properties of Multiplication

 a*2-lemma : ∀ a → (a + (a + zero)) ≡ a * 2
 a*2-lemma a rewrite *-comm a 2 = refl

 *2< : ∀ (m n : ℕ)
   → m * 2 < n * 2
   → m < n
 *2< 0       0       ()
 *2< 0       (suc n) _             = s≤s z≤n
 *2< (suc m) (suc n) (s≤s (s≤s x)) = s≤s (*2< m n x)

 a*b*2-lemma : ∀ a b → a * b * 2 ≡ (a + (a + zero)) * b
 a*b*2-lemma a b rewrite *-comm (a * b) 2
                       | *-assoc 2 a b = refl

 +-*-suc' : ∀ m n → m * suc n ≡ m + n * m
 +-*-suc' m n with *-suc m n
 ...| xx rewrite *-comm n m = xx

 ----------------------------------
 -- Properties of divisibility by 2

 1+n=m*2⇒m<1+n : ∀ m n → 1 + n ≡ m * 2 → m < 1 + n
 1+n=m*2⇒m<1+n (suc zero) (suc n) eq = s≤s (s≤s z≤n)
 1+n=m*2⇒m<1+n (suc (suc m)) (suc (suc n)) eq = s≤s (<-trans ih (n<1+n (1 + n)))
   where
   eq' : 1 + n ≡ (1 + m) * 2
   eq' = +-cancelˡ-≡ 2 eq

   ih : (1 + m) < 1 + n
   ih = 1+n=m*2⇒m<1+n (1 + m) n eq'

 -------------------------------
 -- Properties of exponentiation

 1≤2^n : ∀ n → 1 ≤ (2 ^ n)
 1≤2^n 0       = s≤s z≤n
 1≤2^n (suc n) = ≤-trans (1≤2^n n) (m≤m+n (2 ^ n) ((2 ^ n) + zero))

 1<2^sucn : ∀ n → 1 < (2 ^ suc n)
 1<2^sucn n = ≤∧≢⇒< (1≤2^n (suc n))
                    (subst (λ P → 1 ≢ (2 ^ n) + P)
                      (+-comm 0 (2 ^ n))
                      (1≢a+b (1≤2^n n) (1≤2^n n)))

 pow*d>1 : ∀ k d → 0 < k → 0 < d → 1 < 2 ^ k * d
 pow*d>1 (suc k) d 0<k 0<d = *-mono-≤ (1<2^sucn k) 0<d

 2^ld-2l : ∀ l₀ l₁ d → l₁ ≤ l₀
              → (2 ^ l₀) * d ∸ 2 ^ l₁ ≡ 2 ^ l₁ * (2 ^ (l₀ ∸ l₁) * d ∸ 1)
 2^ld-2l l₀ l₁ d x rewrite *-distribˡ-∸ (2 ^ l₁) (2 ^ (l₀ ∸ l₁) * d) 1
                         | sym (*-assoc (2 ^ l₁) (2 ^ (l₀ ∸ l₁)) d)
                         | sym (^-distribˡ-+-* 2 l₁ (l₀ ∸ l₁))
                         | sym (+-∸-assoc l₁ {l₀} {l₁} x)
                         | m+n∸m≡n l₁ l₀
                         | *-identityʳ (2 ^ l₁) = refl

 -------------------------------------
 -- Monotonicity of ℕ ranged functions

 2^-mono : ∀{m n} → m < n → 2 ^ m < 2 ^ n
 2^-mono {zero} {suc zero}    x  = s≤s (s≤s z≤n)
 2^-mono {zero} {suc (suc n)} x  = +-mono-<-≤ (2^-mono {zero} {suc n} (s≤s z≤n))
                                              (m≤n+m zero (2 * 2 ^ n))
 2^-mono {suc m} {suc n} (s≤s x) = +-mono-<   (2^-mono x)
                                              (+-mono-<-≤ (2^-mono x) z≤n)

 log-mono : ∀ (l n : ℕ)
   → 2 ^ l < 2 ^ n
   → l < n
 log-mono l 0 x = ⊥-elim (<⇒≱ x (1≤2^n l))
 log-mono 0 (suc n) x = s≤s z≤n
 log-mono (suc l) (suc n) x
   rewrite a*2-lemma (2 ^ l) | a*2-lemma (2 ^ n)
   =  s≤s ((log-mono l n (*2< (2 ^ l) (2 ^ n) x)))

 ^-mono : ∀ (l n : ℕ) → l ≤ n → 2 ^ l ≤ 2 ^ n
 ^-mono zero    n    _  = 1≤2^n n
 ^-mono (suc l) zero ()
 ^-mono (suc l) (suc n) (s≤s xx)
   rewrite +-identityʳ (2 ^ l)
         | +-identityʳ (2 ^ n)
         = +-mono-≤ (^-mono l n xx)  (^-mono l n xx)

 2^kd-mono : ∀{m n d} → m ≤ n → 0 < d → 2 ^ m ≤ 2 ^ n * d
 2^kd-mono {m} {n} {d} m≤n 0<d = ≤-trans (^-mono m n m≤n) (m≤m*n (2 ^ n) 0<d)

 1≤m*n⇒0<n : ∀{m n} → 1 ≤ m * n → 0 < n
 1≤m*n⇒0<n {m} {n} 1≤m*n rewrite *-comm m n = 1≤n*m⇒0<n n m 1≤m*n
     where 1≤n*m⇒0<n : ∀ m n →  1 ≤ m * n → 0 < m
           1≤n*m⇒0<n (suc m) n 1≤m*n = s≤s z≤n

 n+p≡m+q∧n<m⇒q<p : ∀ {n p m q} → n < m → n + p ≡ m + q → q < p
 n+p≡m+q∧n<m⇒q<p {n} {p} {m} {q} n<m n+p≡m+q = +-cancelˡ-< n (subst ((n + q) <_) (sym n+p≡m+q) (+-monoˡ-< q n<m))

 -------------------
 -- Misc. Properties

 ss≰1 : ∀{n} → suc (suc n) ≰ 1
 ss≰1 (s≤s ())

 ∸-split : ∀{a b c} → c < b → b < a → a ∸ c ≡ (a ∸ b) + (b ∸ c)
 ∸-split {a} {b} {c} c<b b<a
   rewrite sym (+-∸-comm {a} (b ∸ c) {b} (<⇒≤ b<a))
         | sym (+-∸-assoc a {b} {c} (<⇒≤ c<b))
         | +-∸-comm {a} b {c} (<⇒≤ (<-trans c<b b<a))
         | m+n∸n≡m (a ∸ c) b = refl

 0<m-n : ∀{m n} → n < m → 0 < m ∸ n
 0<m-n {n = zero} (s≤s x) = s≤s x
 0<m-n {n = suc n} (s≤s x) = 0<m-n x

 2^k-is-suc : ∀ n → ∃ (λ r → 2 ^ n ≡ suc r)
 2^k-is-suc zero = 0 , refl
 2^k-is-suc (suc n) with 2^k-is-suc n
 ...| fst , snd rewrite snd
                      | +-identityʳ fst
                      | +-comm fst (suc fst) = (suc (fst + fst)) , refl

 -------------------------
 -- Properties about lists

 ∷≡[]-⊥ : ∀{a}{A : Set a}{x : A}{xs : List A}
        → _≡_ {a} {List A} (x ∷ xs) [] → ⊥
 ∷≡[]-⊥ ()

 All-pi : ∀{a}{A : Set a}{P : A → Set}
        → (∀ {x}(p₁ p₂ : P x) → p₁ ≡ p₂)
        → {xs : List A}
        → (a₁ a₂ : All P xs)
        → a₁ ≡ a₂
 All-pi P-pi [] [] = refl
 All-pi P-pi (a ∷ as) (b ∷ bs) = cong₂ _∷_ (P-pi a b) (All-pi P-pi as bs)

 _∈_ : {A : Set} → A → List A → Set
 x ∈ xs = Any (_≡_ x) xs

 witness : {A : Set}{P : A → Set}{x : A}{xs : List A}
         → x ∈ xs → All P xs → P x
 witness {x = x} {xs = []} ()
 witness {P = P } {x = x} {xh ∷ xt} (here px) all = subst P (sym px) (List-All.head all)
 witness {x = x} {xh ∷ xt} (there x∈xt) all = witness x∈xt (List-All.tail all)

 List-map-≡ : {A B : Set}
            → (f g : A → B)
            → (xs : List A)
            → (∀ x → x ∈ xs → f x ≡ g x)
            → List-map f xs ≡ List-map g xs
 List-map-≡ f g [] prf = refl
 List-map-≡ f g (x ∷ xs) prf
   = cong₂ _∷_ (prf x (here refl)) (List-map-≡ f g xs
                                     (λ x₁ prf' → prf x₁ (there prf')))

 List-map-≡-All : {A B : Set}
                → (f g : A → B)
                → (xs : List A)
                → All (λ x → f x ≡ g x) xs
                → List-map f xs ≡ List-map g xs
 List-map-≡-All f g xs hyp
   = List-map-≡ f g xs (λ x x∈xs → witness x∈xs hyp)

 nats : (n : ℕ) → List (Fin n)
 nats 0       = []
 nats (suc n) = fz ∷ List-map fs (nats n)

 nats-correct : ∀{m}(x : Fin m) → x ∈ nats m
 nats-correct {suc m} fz     = here refl
 nats-correct {suc m} (fs x) = there (Any-gmap (cong fs) (nats-correct x))

 nats-length : ∀{m} → 0 < m → 1 ≤ length (nats m)
 nats-length (s≤s prf) = s≤s z≤n

 ++-inj : ∀{a}{A : Set a}{m n o p : List A}
        → length m ≡ length n → m ++ o ≡ n ++ p
        → m ≡ n × o ≡ p
 ++-inj {m = []}     {x ∷ n} () hip
 ++-inj {m = x ∷ m}  {[]}    () hip
 ++-inj {m = []}     {[]}     lhip hip
   = refl , hip
 ++-inj {m = m ∷ ms} {n ∷ ns} lhip hip
   with ++-inj {m = ms} {ns} (suc-injective lhip) (proj₂ (∷-injective hip))
 ...| (mn , op) rewrite proj₁ (∷-injective hip)
    = cong (n ∷_) mn , op

 ++-abs : ∀{a}{A : Set a}{n : List A}(m : List A)
        → 1 ≤ length m → [] ≡ m ++ n → ⊥
 ++-abs [] ()
 ++-abs (x ∷ m) imp ()

 ++-injₕ : ∀{a}{A : Set a}{m o p : List A}
         → m ++ o ≡ m ++ p
         → o ≡ p
 ++-injₕ {m = m} {o} {p} r = proj₂ (++-inj {m = m} {m} {o} {p} refl r)


{-# OPTIONS --rewriting #-}

data FALSE : Set where

CONTRADICTION : ∀ {A : Set} → FALSE → A
CONTRADICTION ()

record TRUE : Set where
{-# BUILTIN UNIT TRUE #-}

data Bool : Set where
  false true : Bool
{-# BUILTIN BOOL  Bool  #-}
{-# BUILTIN TRUE  true  #-}
{-# BUILTIN FALSE false #-}

data Nat : Set where
  zero : Nat
  suc : Nat → Nat
{-# BUILTIN NATURAL Nat #-}

_+_ : Nat → Nat → Nat
zero  + m = m
suc n + m = suc (n + m)
{-# BUILTIN NATPLUS _+_ #-}

_-_ : Nat → Nat → Nat
n     - zero  = n
zero  - suc m = zero
suc n - suc m = n - m
{-# BUILTIN NATMINUS _-_ #-}

_*_ : Nat → Nat → Nat
zero  * m = zero
suc n * m = (n * m) + m
{-# BUILTIN NATTIMES _*_ #-}

_==_ : Nat → Nat → Bool
zero  == zero  = true
suc n == suc m = n == m
_     == _     = false
{-# BUILTIN NATEQUALS _==_ #-}

postulate String : Set
{-# BUILTIN STRING String #-}

primitive
  primStringAppend   : String → String → String
  primStringEquality : String → String → Bool

_+++_ = primStringAppend
_===_ = primStringEquality

data List(A : Set) : Set where
  nil : List(A)
  _::_ : A → List(A) → List(A)
{-# BUILTIN LIST List  #-}

data _≡_ {a} {A : Set a} (x : A) : A → Set a where
  refl : x ≡ x
{-# BUILTIN EQUALITY _≡_  #-}
{-# BUILTIN REWRITE _≡_ #-}

cong : ∀ {a} {X Y : Set a} {x y : X} (f : X → Y) → (x ≡ y) → (f x ≡ f y)
cong f refl = refl

_≢_ :  ∀ {a} {A : Set a} → A → A → Set a
(x ≢ y) = (x ≡ y) → FALSE

data Dec(A : Set) : Set where
  yes : A → Dec(A)
  no : (A → FALSE) → Dec(A)

primitive
  primEraseEquality : ∀ {a} {A : Set a} {x y : A} → x ≡ y → x ≡ y

primTrustMe : ∀ {a} {A : Set a} {x y : A} → x ≡ y
primTrustMe {x = x} {y} = primEraseEquality unsafePrimTrustMe where
   postulate unsafePrimTrustMe : x ≡ y

_≟String_ : (s t : String) → Dec(s ≡ t)
(s ≟String t) with primStringEquality s t
(s ≟String t) | true = yes primTrustMe
(s ≟String t) | false = no unsafeNo where
  postulate unsafeNo : s ≢ t

_≟Nat_ : (m n : Nat) → Dec(m ≡ n)
(m ≟Nat n) with m == n
(m ≟Nat n) | true = yes primTrustMe
(m ≟Nat n) | false = no unsafeNo where
  postulate unsafeNo : m ≢ n

data _≤_ : Nat → Nat → Set where
  zero : ∀ {x} → zero ≤ x
  suc : ∀ {x y} → (x ≤ y) → (suc x ≤ suc y)

_≤?_ : (x y : Nat) → Dec(x ≤ y)
zero ≤? y = yes zero
suc x ≤? zero = no (λ ())
suc x ≤? suc y with (x ≤? y)
... | yes p = yes (suc p)
... | no  p = no  (λ { (suc q) → p q })

_<_ : Nat → Nat → Set
m < n = (n ≤ m) → FALSE

asym : ∀ {m n} → (m ≤ n) → (n ≤ m) → (m ≡ n)
asym zero zero = refl
asym (suc p) (suc q) with asym p q
asym (suc p) (suc q) | refl = refl

if : ∀ {X Y : Set} → Dec(X) → Y → Y → Y
if (yes p) x y = x
if (no  p) x y = y

+zero : ∀ {m} → (m + zero) ≡ m
+zero {zero} = refl
+zero {suc m} = cong suc +zero

+suc : ∀ {m n} → (m + suc n) ≡ suc (m + n)
+suc {zero} = refl
+suc {suc m} = cong suc +suc

{-# REWRITE +zero +suc #-}


-- We define the localisation of a commutative ring
-- at a multiplicatively closed subset and show that it
-- has a commutative ring structure.

{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommRing.Localisation.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Powerset
open import Cubical.Foundations.Transport
open import Cubical.Functions.FunExtEquiv

import Cubical.Data.Empty as ⊥
open import Cubical.Data.Bool
open import Cubical.Data.Nat renaming ( _+_ to _+ℕ_ ; _·_ to _·ℕ_
                                      ; +-comm to +ℕ-comm ; +-assoc to +ℕ-assoc
                                      ; ·-assoc to ·ℕ-assoc ; ·-comm to ·ℕ-comm)
open import Cubical.Data.Vec
open import Cubical.Data.Sigma.Base
open import Cubical.Data.Sigma.Properties
open import Cubical.Data.FinData
open import Cubical.Relation.Nullary
open import Cubical.Relation.Binary

open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.RingSolver.ReflectionSolving

open import Cubical.HITs.SetQuotients as SQ
open import Cubical.HITs.PropositionalTruncation as PT

open Iso

private
  variable
    ℓ ℓ' : Level
    A : Type ℓ

-- A multiplicatively closed subset is assumed to contain 1
record isMultClosedSubset (R' : CommRing ℓ) (S' : ℙ (fst R')) : Type ℓ where
 constructor
   multclosedsubset
 field
   containsOne : (R' .snd .CommRingStr.1r) ∈ S'
   multClosed : ∀ {s t} → s ∈ S' → t ∈ S' → ((snd R') .CommRingStr._·_ s t) ∈ S'

module Loc (R' : CommRing ℓ) (S' : ℙ (fst R')) (SMultClosedSubset : isMultClosedSubset R' S') where
 open isMultClosedSubset
 private R = fst R'
 open CommRingStr (snd R')
 open RingTheory (CommRing→Ring R')
 open CommRingTheory R'

 S = Σ[ s ∈ R ] (s ∈ S')

 -- We define the localisation of R by S by quotienting by the following relation:
 _≈_ : R × S → R × S → Type ℓ
 (r₁ , s₁) ≈ (r₂ , s₂) = Σ[ s ∈ S ] (fst s · r₁ · fst s₂ ≡ fst s · r₂ · fst s₁)

 S⁻¹R = (R × S) / _≈_

 -- now define addition for S⁻¹R
 open BinaryRelation

 locRefl : isRefl _≈_
 locRefl _ = (1r , SMultClosedSubset .containsOne) , refl

 locSym : isSym _≈_
 locSym (r , s , s∈S') (r' , s' , s'∈S') (u , p) = u , sym p

 locTrans : isTrans _≈_
 locTrans (r , s , s∈S') (r' , s' , s'∈S') (r'' , s'' , s''∈S') ((u , u∈S') , p) ((v , v∈S') , q) =
   ((u · v · s') , SMultClosedSubset .multClosed (SMultClosedSubset .multClosed u∈S' v∈S') s'∈S')
   , path
  where
  eq1 : (r s r' s' r'' s'' u v : R) → u · v · s' · r · s'' ≡ u · r · s' · v · s''
  eq1 = solve R'

  eq2 : (r s r' s' r'' s'' u v : R) → u · r' · s · v · s'' ≡ u · s · (v · r' · s'')
  eq2 = solve R'

  eq3 : (r s r' s' r'' s'' u v : R) → u · s · (v · r'' · s') ≡ u · v · s' · r'' · s
  eq3 = solve R'

  path : u · v · s' · r · s'' ≡ u · v · s' · r'' · s
  path = u · v · s' · r · s''   ≡⟨ eq1 r s r' s' r'' s'' u v ⟩ -- not just ≡⟨ solve R' ⟩
         u · r · s' · v · s''   ≡⟨ cong (λ x → x · v · s'') p ⟩
         u · r' · s · v · s''   ≡⟨ eq2 r s r' s' r'' s'' u v ⟩
         u · s · (v · r' · s'') ≡⟨ cong (u · s ·_) q ⟩
         u · s · (v · r'' · s') ≡⟨ eq3 r s r' s' r'' s'' u v ⟩
         u · v · s' · r'' · s   ∎

 locIsEquivRel : isEquivRel _≈_
 isEquivRel.reflexive locIsEquivRel = locRefl
 isEquivRel.symmetric locIsEquivRel = locSym
 isEquivRel.transitive locIsEquivRel = locTrans

 _+ₗ_ : S⁻¹R → S⁻¹R → S⁻¹R
 _+ₗ_ = setQuotSymmBinOp locRefl locTrans _+ₚ_
         (λ a b → subst (λ x → (a +ₚ b) ≈ x) (+ₚ-symm a b) (locRefl (a +ₚ b))) θ
  where
  _+ₚ_ : R × S → R × S → R × S
  (r₁ , s₁ , s₁∈S) +ₚ (r₂ , s₂ , s₂∈S) =
                      (r₁ · s₂ + r₂ · s₁) , (s₁ · s₂) , SMultClosedSubset .multClosed s₁∈S s₂∈S

  +ₚ-symm : (a b : R × S) → (a +ₚ b) ≡ (b +ₚ a)
  +ₚ-symm (r₁ , s₁ , s₁∈S) (r₂ , s₂ , s₂∈S) =
          ΣPathP (+Comm _ _ , Σ≡Prop (λ x → S' x .snd) (·-comm _ _))

  θ : (a a' b : R × S) → a ≈ a' → (a +ₚ b) ≈ (a' +ₚ b)
  θ (r₁ , s₁ , s₁∈S) (r'₁ , s'₁ , s'₁∈S) (r₂ , s₂ , s₂∈S) ((s , s∈S) , p) = (s , s∈S) , path
    where
    eq1 : (r₁ s₁ r'₁ s'₁ s'₁ r₂ s₂ s : R)
        → s · (r₁ · s₂ + r₂ · s₁) · (s'₁ · s₂) ≡ s · r₁ · s'₁ · s₂ · s₂ + s · r₂ · s₁ · s'₁ · s₂
    eq1 = solve R'

    eq2 : (r₁ s₁ r'₁ s'₁ s'₁ r₂ s₂ s : R)
        → s · r'₁ · s₁ · s₂ · s₂ + s · r₂ · s₁ · s'₁ · s₂ ≡ s · (r'₁ · s₂ + r₂ · s'₁) · (s₁ · s₂)
    eq2 = solve R'

    path : s · (r₁ · s₂ + r₂ · s₁) · (s'₁ · s₂) ≡ s · (r'₁ · s₂ + r₂ · s'₁) · (s₁ · s₂)
    path = s · (r₁ · s₂ + r₂ · s₁) · (s'₁ · s₂)

         ≡⟨ eq1 r₁ s₁ r'₁ s'₁ s'₁ r₂ s₂ s ⟩

           s · r₁ · s'₁ · s₂ · s₂ + s · r₂ · s₁ · s'₁ · s₂

         ≡⟨ cong (λ x → x · s₂ · s₂ + s · r₂ · s₁ · s'₁ · s₂) p ⟩

           s · r'₁ · s₁ · s₂ · s₂ + s · r₂ · s₁ · s'₁ · s₂

         ≡⟨ eq2 r₁ s₁ r'₁ s'₁ s'₁ r₂ s₂ s ⟩

           s · (r'₁ · s₂ + r₂ · s'₁) · (s₁ · s₂) ∎

 -- check group-laws for addition
 +ₗ-assoc : (x y z : S⁻¹R) → x +ₗ (y +ₗ z) ≡ (x +ₗ y) +ₗ z
 +ₗ-assoc = SQ.elimProp3 (λ _ _ _ → squash/ _ _) +ₗ-assoc[]
  where
  +ₗ-assoc[] : (a b c : R × S) → [ a ] +ₗ ([ b ] +ₗ [ c ]) ≡ ([ a ] +ₗ [ b ]) +ₗ [ c ]
  +ₗ-assoc[] (r , s , s∈S) (r' , s' , s'∈S) (r'' , s'' , s''∈S) =
     cong [_] (ΣPathP ((path r s r' s' r'' s'') , Σ≡Prop (λ x → ∈-isProp S' x) (·Assoc _ _ _)))
     where
     path : (r s r' s' r'' s'' : R)
          → r · (s' · s'') + (r' · s'' + r'' · s') · s ≡ (r · s' + r' · s) · s'' + r'' · (s · s')
     path = solve R'

 0ₗ : S⁻¹R
 0ₗ = [ 0r , 1r , SMultClosedSubset .containsOne ]

 +ₗ-rid : (x : S⁻¹R) → x +ₗ 0ₗ ≡ x
 +ₗ-rid = SQ.elimProp (λ _ → squash/ _ _) +ₗ-rid[]
  where
  +ₗ-rid[] : (a : R × S) → [ a ] +ₗ 0ₗ ≡ [ a ]
  +ₗ-rid[] (r , s , s∈S) = path
   where
   eq1 : (r s : R) → r · 1r + 0r · s ≡ r
   eq1 = solve R'

   path : [ r · 1r + 0r · s , s · 1r , SMultClosedSubset .multClosed s∈S
                                      (SMultClosedSubset .containsOne) ]
        ≡ [ r , s , s∈S ]
   path = cong [_] (ΣPathP (eq1 r s , Σ≡Prop (λ x → ∈-isProp S' x) (·Rid _)))

 -ₗ_ : S⁻¹R → S⁻¹R
 -ₗ_ = SQ.rec squash/ -ₗ[] -ₗWellDef
  where
  -ₗ[] : R × S → S⁻¹R
  -ₗ[] (r , s) = [ - r , s ]

  -ₗWellDef : (a b : R × S) → a ≈ b → -ₗ[] a ≡ -ₗ[] b
  -ₗWellDef (r , s , _) (r' , s' , _) ((u , u∈S) , p) = eq/ _ _ ((u , u∈S) , path)
   where
   eq1 : (u r s' : R) → u · - r · s' ≡ - (u · r · s')
   eq1 = solve R'

   eq2 : (u r' s : R) → - (u · r' · s) ≡ u · - r' · s
   eq2 = solve R'

   path : u · - r · s' ≡ u · - r' · s
   path = eq1 u r s' ∙∙ cong -_ p ∙∙ eq2 u r' s

 +ₗ-rinv : (x : S⁻¹R) → x +ₗ (-ₗ x) ≡ 0ₗ
 +ₗ-rinv = SQ.elimProp (λ _ → squash/ _ _) +ₗ-rinv[]
  where
  +ₗ-rinv[] : (a : R × S) → ([ a ] +ₗ (-ₗ [ a ])) ≡ 0ₗ
  +ₗ-rinv[] (r , s , s∈S) = eq/ _ _ ((1r , SMultClosedSubset .containsOne) , path r s)
   where
   path : (r s : R) → 1r · (r · s + - r · s) · 1r ≡ 1r · 0r · (s · s)
   path = solve R'

 +ₗ-comm : (x y : S⁻¹R) → x +ₗ y ≡ y +ₗ x
 +ₗ-comm = SQ.elimProp2 (λ _ _ → squash/ _ _) +ₗ-comm[]
  where
  +ₗ-comm[] : (a b : R × S) → ([ a ] +ₗ [ b ]) ≡ ([ b ] +ₗ [ a ])
  +ₗ-comm[] (r , s , s∈S) (r' , s' , s'∈S) =
            cong [_] (ΣPathP ((+Comm _ _) , Σ≡Prop (λ x → ∈-isProp S' x) (·-comm _ _)))

 -- Now for multiplication
 _·ₗ_ : S⁻¹R → S⁻¹R → S⁻¹R
 _·ₗ_ = setQuotSymmBinOp locRefl locTrans _·ₚ_
         (λ a b → subst (λ x → (a ·ₚ b) ≈ x) (·ₚ-symm a b) (locRefl (a ·ₚ b))) θ
  where
  _·ₚ_ : R × S → R × S → R × S
  (r₁ , s₁ , s₁∈S) ·ₚ (r₂ , s₂ , s₂∈S) =
                      (r₁ · r₂) , ((s₁ · s₂) , SMultClosedSubset .multClosed s₁∈S s₂∈S)

  ·ₚ-symm : (a b : R × S) → (a ·ₚ b) ≡ (b ·ₚ a)
  ·ₚ-symm (r₁ , s₁ , s₁∈S) (r₂ , s₂ , s₂∈S) =
          ΣPathP (·-comm _ _ , Σ≡Prop (λ x → S' x .snd) (·-comm _ _))

  θ : (a a' b : R × S) → a ≈ a' → (a ·ₚ b) ≈ (a' ·ₚ b)
  θ (r₁ , s₁ , s₁∈S) (r'₁ , s'₁ , s'₁∈S) (r₂ , s₂ , s₂∈S) ((s , s∈S) , p) = (s , s∈S) , path
   where
   eq1 : (r₁ s₁ r'₁ s'₁ r₂ s₂ s : R)
       → s · (r₁ · r₂) · (s'₁ · s₂) ≡ s · r₁ · s'₁ · r₂ · s₂
   eq1 = solve R'

   eq2 : (r₁ s₁ r'₁ s'₁ r₂ s₂ s : R)
       → s · r'₁ · s₁ · r₂ · s₂ ≡ s · (r'₁ · r₂) · (s₁ · s₂)
   eq2 = solve R'

   path : s · (r₁ · r₂) · (s'₁ · s₂) ≡ s · (r'₁ · r₂) · (s₁ · s₂)
   path = eq1 r₁ s₁ r'₁ s'₁ r₂ s₂ s ∙∙ cong (λ x → x · r₂ · s₂) p ∙∙ eq2 r₁ s₁ r'₁ s'₁ r₂ s₂ s

 -- checking laws for multiplication
 1ₗ : S⁻¹R
 1ₗ = [ 1r , 1r , SMultClosedSubset .containsOne ]

 ·ₗ-assoc : (x y z : S⁻¹R) → x ·ₗ (y ·ₗ z) ≡ (x ·ₗ y) ·ₗ z
 ·ₗ-assoc = SQ.elimProp3 (λ _ _ _ → squash/ _ _) ·ₗ-assoc[]
   where
   ·ₗ-assoc[] : (a b c : R × S) → [ a ] ·ₗ ([ b ] ·ₗ [ c ]) ≡ ([ a ] ·ₗ [ b ]) ·ₗ [ c ]
   ·ₗ-assoc[] (r , s , s∈S) (r' , s' , s'∈S) (r'' , s'' , s''∈S) =
              cong [_] (ΣPathP ((·Assoc _ _ _) , Σ≡Prop (λ x → ∈-isProp S' x) (·Assoc _ _ _)))

 ·ₗ-rid : (x : S⁻¹R) → x ·ₗ 1ₗ ≡ x
 ·ₗ-rid = SQ.elimProp (λ _ → squash/ _ _) ·ₗ-rid[]
   where
   ·ₗ-rid[] : (a : R × S) → ([ a ] ·ₗ 1ₗ) ≡ [ a ]
   ·ₗ-rid[] (r , s , s∈S) = cong [_] (ΣPathP ((·Rid _) , Σ≡Prop (λ x → ∈-isProp S' x) (·Rid _)))

 ·ₗ-rdist-+ₗ : (x y z : S⁻¹R) → x ·ₗ (y +ₗ z) ≡ (x ·ₗ y) +ₗ (x ·ₗ z)
 ·ₗ-rdist-+ₗ = SQ.elimProp3 (λ _ _ _ → squash/ _ _) ·ₗ-rdist-+ₗ[]
   where
   ·ₗ-rdist-+ₗ[] : (a b c : R × S) → [ a ] ·ₗ ([ b ] +ₗ [ c ]) ≡ ([ a ] ·ₗ [ b ]) +ₗ ([ a ] ·ₗ [ c ])
   ·ₗ-rdist-+ₗ[] (r , s , s∈S) (r' , s' , s'∈S) (r'' , s'' , s''∈S) =
      eq/ _ _ ((1r , (SMultClosedSubset .containsOne)) , path r s r' s' r'' s'')
      where
      -- could be shortened even further
      path : (r s r' s' r'' s'' : R)
           → 1r · (r · (r' · s'' + r'' · s')) · (s · s' · (s · s''))
           ≡ 1r · (r · r' · (s · s'') + r · r'' · (s · s')) · (s · (s' · s''))
      path = solve R'

 ·ₗ-comm : (x y : S⁻¹R) → x ·ₗ y ≡ y ·ₗ x
 ·ₗ-comm = SQ.elimProp2 (λ _ _ → squash/ _ _) ·ₗ-comm[]
   where
   ·ₗ-comm[] : (a b : R × S) → [ a ] ·ₗ [ b ] ≡ [ b ] ·ₗ [ a ]
   ·ₗ-comm[] (r , s , s∈S) (r' , s' , s'∈S) =
             cong [_] (ΣPathP ((·-comm _ _) , Σ≡Prop (λ x → ∈-isProp S' x) (·-comm _ _)))

 -- Commutative ring structure on S⁻¹R
 S⁻¹RAsCommRing : CommRing ℓ
 S⁻¹RAsCommRing = S⁻¹R , S⁻¹RCommRingStr
  where
  open CommRingStr
  S⁻¹RCommRingStr : CommRingStr S⁻¹R
  0r S⁻¹RCommRingStr = 0ₗ
  1r S⁻¹RCommRingStr = 1ₗ
  _+_ S⁻¹RCommRingStr = _+ₗ_
  _·_ S⁻¹RCommRingStr = _·ₗ_
  - S⁻¹RCommRingStr = -ₗ_
  isCommRing S⁻¹RCommRingStr = makeIsCommRing squash/ +ₗ-assoc +ₗ-rid +ₗ-rinv +ₗ-comm
                                                      ·ₗ-assoc ·ₗ-rid ·ₗ-rdist-+ₗ ·ₗ-comm


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

open import lib.Basics
open import lib.NType2
open import lib.types.Group
open import lib.types.EilenbergMacLane1.Core
open import lib.groups.Homomorphism
open import lib.groups.LoopSpace
open import lib.two-semi-categories.FundamentalCategory
open import lib.two-semi-categories.Functor
open import lib.two-semi-categories.GroupToCategory

module lib.types.EilenbergMacLane1.Recursion {i} {G : Group i} where

private
  module G = Group G

module EM₁Rec' {j} {C : Type j}
  {{C-level : has-level 2 C}}
  (embase* : C)
  (emloop* : (g : G.El) → embase* == embase*)
  (emloop-comp* : (g₁ g₂ : G.El) → emloop* (G.comp g₁ g₂) == emloop* g₁ ∙ emloop* g₂)
  (emloop-coh* : (g₁ g₂ g₃ : G.El) →
    emloop-comp* (G.comp g₁ g₂) g₃ ◃∙
    ap (λ l → l ∙ emloop* g₃) (emloop-comp* g₁ g₂) ◃∙
    ∙-assoc (emloop* g₁) (emloop* g₂) (emloop* g₃) ◃∎
    =ₛ
    ap emloop* (G.assoc g₁ g₂ g₃) ◃∙
    emloop-comp* g₁ (G.comp g₂ g₃) ◃∙
    ap (λ l → emloop* g₁ ∙ l) (emloop-comp* g₂ g₃) ◃∎) where

  private
    P : EM₁ G → Type j
    P _ = C

    Q : embase' G == embase → Type j
    Q p = embase* == embase* [ P ↓ p ]

    emloop** : ∀ g → Q (emloop g)
    emloop** g = ↓-cst-in (emloop* g)

    emloop-comp** : ∀ g₁ g₂ →
      emloop** (G.comp g₁ g₂) == emloop** g₁ ∙ᵈ emloop** g₂
        [ Q ↓ emloop-comp g₁ g₂ ]
    emloop-comp** g₁ g₂ =
      ↓-cst-in2 (emloop-comp* g₁ g₂) ▹
      ↓-cst-in-∙ (emloop g₁) (emloop g₂) (emloop* g₁) (emloop* g₂)

    module _ (g₁ g₂ g₃ : G.El) where

      s₀ : embase' G == embase
      s₀ = emloop (G.comp (G.comp g₁ g₂) g₃)

      s₁ : embase' G == embase
      s₁ = emloop (G.comp g₁ g₂) ∙ emloop g₃

      s₂ : embase' G == embase
      s₂ = (emloop g₁ ∙ emloop g₂) ∙ emloop g₃

      s₃ : embase' G == embase
      s₃ = emloop g₁ ∙ (emloop g₂ ∙ emloop g₃)

      s₄ : embase' G == embase
      s₄ = emloop (G.comp g₁ (G.comp g₂ g₃))

      s₅ : embase' G == embase
      s₅ = emloop g₁ ∙ emloop (G.comp g₂ g₃)

      e₀₁ : s₀ == s₁
      e₀₁ = emloop-comp (G.comp g₁ g₂) g₃

      e₁₂ : s₁ == s₂
      e₁₂ = ap (_∙ emloop g₃) (emloop-comp g₁ g₂)

      e₂₃ : s₂ == s₃
      e₂₃ = ∙-assoc (emloop g₁) (emloop g₂) (emloop g₃)

      e₀₄ : s₀ == s₄
      e₀₄ = ap emloop (G.assoc g₁ g₂ g₃)

      e₄₅ : s₄ == s₅
      e₄₅ = emloop-comp g₁ (G.comp g₂ g₃)

      e₅₃ : s₅ == s₃
      e₅₃ = ap (emloop g₁ ∙_) (emloop-comp g₂ g₃)

      φ : s₀ == s₃
      φ = ↯ (e₀₁ ◃∙ e₁₂ ◃∙ e₂₃ ◃∎)

      ψ : s₀ == s₃
      ψ = ↯ (e₀₄ ◃∙ e₄₅ ◃∙ e₅₃ ◃∎)

      φ=ψ : φ == ψ
      φ=ψ = =ₛ-out (emloop-coh g₁ g₂ g₃)

      s₀* : embase* == embase*
      s₀* = emloop* (G.comp (G.comp g₁ g₂) g₃)

      s₁* : embase* == embase*
      s₁* = emloop* (G.comp g₁ g₂) ∙ emloop* g₃

      s₂* : embase* == embase*
      s₂* = (emloop* g₁ ∙ emloop* g₂) ∙ emloop* g₃

      s₃* : embase* == embase*
      s₃* = emloop* g₁ ∙ (emloop* g₂ ∙ emloop* g₃)

      s₄* : embase* == embase*
      s₄* = emloop* (G.comp g₁ (G.comp g₂ g₃))

      s₅* : embase* == embase*
      s₅* = emloop* g₁ ∙ emloop* (G.comp g₂ g₃)

      e₀₁* : s₀* == s₁*
      e₀₁* = emloop-comp* (G.comp g₁ g₂) g₃

      e₁₂* : s₁* == s₂*
      e₁₂* = ap (_∙ emloop* g₃) (emloop-comp* g₁ g₂)

      e₂₃* : s₂* == s₃*
      e₂₃* = ∙-assoc (emloop* g₁) (emloop* g₂) (emloop* g₃)

      e₀₄* : s₀* == s₄*
      e₀₄* = ap emloop* (G.assoc g₁ g₂ g₃)

      e₄₅* : s₄* == s₅*
      e₄₅* = emloop-comp* g₁ (G.comp g₂ g₃)

      e₅₃* : s₅* == s₃*
      e₅₃* = ap (emloop* g₁ ∙_) (emloop-comp* g₂ g₃)

      φ* : s₀* == s₃*
      φ* = ↯ (e₀₁* ◃∙ e₁₂* ◃∙ e₂₃* ◃∎)

      ψ* : s₀* == s₃*
      ψ* = ↯ (e₀₄* ◃∙ e₄₅* ◃∙ e₅₃* ◃∎)

      φ*=ψ* : φ* == ψ*
      φ*=ψ* = =ₛ-out (emloop-coh* g₁ g₂ g₃)

      s₀** : Q s₀
      s₀** = emloop** (G.comp (G.comp g₁ g₂) g₃)

      s₁** : Q s₁
      s₁** = emloop** (G.comp g₁ g₂) ∙ᵈ emloop** g₃

      s₂** : Q s₂
      s₂** = (emloop** g₁ ∙ᵈ emloop** g₂) ∙ᵈ emloop** g₃

      s₃** : Q s₃
      s₃** = emloop** g₁ ∙ᵈ (emloop** g₂ ∙ᵈ emloop** g₃)

      s₄** : Q s₄
      s₄** = emloop** (G.comp g₁ (G.comp g₂ g₃))

      s₅** : Q s₅
      s₅** = emloop** g₁ ∙ᵈ emloop** (G.comp g₂ g₃)

      e₀₁** : s₀** == s₁** [ Q ↓ e₀₁ ]
      e₀₁** = emloop-comp** (G.comp g₁ g₂) g₃

      e₁₂** : s₁** == s₂** [ Q ↓ e₁₂ ]
      e₁₂** = emloop-comp** g₁ g₂ ∙ᵈᵣ emloop** g₃

      e₂₃** : s₂** == s₃** [ Q ↓ e₂₃ ]
      e₂₃** = ∙ᵈ-assoc (emloop** g₁) (emloop** g₂) (emloop** g₃)

      e₀₄** : s₀** == s₄** [ Q ↓ e₀₄ ]
      e₀₄** = ↓-ap-in Q emloop (apd emloop** (G.assoc g₁ g₂ g₃))

      e₄₅** : s₄** == s₅** [ Q ↓ e₄₅ ]
      e₄₅** = emloop-comp** g₁ (G.comp g₂ g₃)

      e₅₃** : s₅** == s₃** [ Q ↓ e₅₃ ]
      e₅₃** = emloop** g₁ ∙ᵈₗ emloop-comp** g₂ g₃

      φ** : s₀** == s₃** [ Q ↓ φ ]
      φ** = e₀₁** ∙ᵈ e₁₂** ∙ᵈ e₂₃**

      ψ** : s₀** == s₃** [ Q ↓ ψ ]
      ψ** = e₀₄** ∙ᵈ e₄₅** ∙ᵈ e₅₃**

      s₃-path₁ : ↓-cst-in {p = s₃} s₃* ==
                 emloop** g₁ ∙ᵈ ↓-cst-in (emloop* g₂ ∙ emloop* g₃)
      s₃-path₁ = ↓-cst-in-∙ (emloop g₁) (emloop g₂ ∙ emloop g₃)
                            (emloop* g₁) (emloop* g₂ ∙ emloop* g₃)

      s₃-path₂' : ↓-cst-in (emloop* g₂ ∙ emloop* g₃) ==
                  emloop** g₂ ∙ᵈ emloop** g₃
      s₃-path₂' = ↓-cst-in-∙ (emloop g₂) (emloop g₃)
                             (emloop* g₂) (emloop* g₃)

      s₃-path₂ : emloop** g₁ ∙ᵈ ↓-cst-in (emloop* g₂ ∙ emloop* g₃) == s₃**
      s₃-path₂ = emloop** g₁ ∙ᵈₗ s₃-path₂'

      s₃-path : ↓-cst-in s₃* == s₃**
      s₃-path = s₃-path₁ ∙ s₃-path₂

      *-to-**-path : (r : s₀ == s₃) → s₀* == s₃* → s₀** == s₃** [ Q ↓ r ]
      *-to-**-path r q = ↓-cst-in2 {q = r} q ▹ s₃-path

      φ-step : *-to-**-path φ φ* == φ**
      φ-step =
        ↓-cst-in2 {q = φ} φ* ▹ s₃-path
          =⟨ (↓-cst-in2-∙ {p₀₁ = e₀₁} {p₁₂ = e₁₂ ∙ e₂₃}
                          e₀₁* (e₁₂* ∙ e₂₃*)) ∙'ᵈᵣ s₃-path ⟩
        (e₀₁*' ∙ᵈ ↓-cst-in2 {q = e₁₂ ∙ e₂₃} (e₁₂* ∙ e₂₃*)) ▹ s₃-path
          =⟨ ap (λ y → (e₀₁*' ∙ᵈ y) ▹ s₃-path) $
             ↓-cst-in2-∙ {p₀₁ = e₁₂} {p₁₂ = e₂₃} e₁₂* e₂₃* ⟩
        (e₀₁*' ∙ᵈ e₁₂*' ∙ᵈ e₂₃*') ▹ s₃-path
          =⟨ ∙ᵈ-∙'ᵈ-assoc' e₀₁*' (e₁₂*' ∙ᵈ e₂₃*') s₃-path ⟩
        e₀₁*' ∙ᵈ (e₁₂*' ∙ᵈ e₂₃*') ▹ s₃-path
          =⟨ ap (e₀₁*' ∙ᵈ_) (∙ᵈ-∙'ᵈ-assoc' e₁₂*' e₂₃*' s₃-path) ⟩
        e₀₁*' ∙ᵈ e₁₂*' ∙ᵈ e₂₃*' ▹ s₃-path
          =⟨ ap (λ y → e₀₁*' ∙ᵈ e₁₂*' ∙ᵈ y) $
             ↓-cst-in-assoc {p₀ = emloop g₁} {p₁ = emloop g₂} {p₂ = emloop g₃}
                            (emloop* g₁) (emloop* g₂) (emloop* g₃) ⟩
        e₀₁*' ∙ᵈ e₁₂*' ∙ᵈ f₂ ◃ f₃ ◃ e₂₃**
          =⟨ ! (ap (e₀₁*' ∙ᵈ_) (▹∙ᵈ-∙ᵈ◃-assoc e₁₂*' f₂ (f₃ ◃ e₂₃**))) ⟩
        e₀₁*' ∙ᵈ (e₁₂*' ▹ f₂) ∙ᵈ f₃ ◃ e₂₃**
          =⟨ ap (λ y → e₀₁*' ∙ᵈ y ∙ᵈ f₃ ◃ e₂₃**) $
             ↓-cst-in2-whisker-right {p' = emloop g₃} {q' = emloop* g₃}
                                     {p₀₁ = emloop-comp g₁ g₂}
                                     (emloop-comp* g₁ g₂) ⟩
        e₀₁*' ∙ᵈ (f₀ ◃ f₁) ∙ᵈ f₃ ◃ e₂₃**
          =⟨ ap (e₀₁*' ∙ᵈ_) (∙ᵈ-assoc f₀ f₁ (f₃ ◃ e₂₃**)) ⟩
        e₀₁*' ∙ᵈ f₀ ◃ f₁ ∙ᵈ f₃ ◃ e₂₃**
          =⟨ ! (▹∙ᵈ-∙ᵈ◃-assoc e₀₁*' f₀ (f₁ ∙ᵈ f₃ ◃ e₂₃**)) ⟩
        e₀₁** ∙ᵈ f₁ ∙ᵈ f₃ ◃ e₂₃**
          =⟨ ! (ap (e₀₁** ∙ᵈ_) (▹∙ᵈ-∙ᵈ◃-assoc f₁ f₃ e₂₃**)) ⟩
        e₀₁** ∙ᵈ (f₁ ▹ f₃) ∙ᵈ e₂₃**
          =⟨ ! (ap (λ y → e₀₁** ∙ᵈ y ∙ᵈ e₂₃**) (∙ᵈᵣ-∙'ᵈ f₁' f₃' (emloop** g₃))) ⟩
        φ** =∎
        where
        e₀₁*' : ↓-cst-in s₀* == ↓-cst-in s₁* [ Q ↓ e₀₁ ]
        e₀₁*' = ↓-cst-in2 {q = e₀₁} e₀₁*
        e₁₂*' : ↓-cst-in s₁* == ↓-cst-in s₂* [ Q ↓ e₁₂ ]
        e₁₂*' = ↓-cst-in2 {q = e₁₂} e₁₂*
        e₂₃*' : ↓-cst-in s₂* == ↓-cst-in s₃* [ Q ↓ e₂₃ ]
        e₂₃*' = ↓-cst-in2 {q = e₂₃} e₂₃*
        f₀ : ↓-cst-in (emloop* (G.comp g₁ g₂) ∙ emloop* g₃) ==
             emloop** (G.comp g₁ g₂) ∙ᵈ emloop** g₃
        f₀ = ↓-cst-in-∙ (emloop (G.comp g₁ g₂)) (emloop g₃)
                        (emloop* (G.comp g₁ g₂)) (emloop* g₃)
        f₁' : emloop** (G.comp g₁ g₂) ==
              ↓-cst-in {p = emloop g₁ ∙ emloop g₂} (emloop* g₁ ∙ emloop* g₂)
                [ Q ↓ emloop-comp' G g₁ g₂ ]
        f₁' = ↓-cst-in2 {q = emloop-comp g₁ g₂} (emloop-comp* g₁ g₂)
        f₁ : emloop** (G.comp g₁ g₂) ∙ᵈ emloop** g₃ ==
             ↓-cst-in {p = emloop g₁ ∙ emloop g₂} (emloop* g₁ ∙ emloop* g₂) ∙ᵈ emloop** g₃
               [ Q ↓ ap (_∙ emloop' G g₃) (emloop-comp' G g₁ g₂) ]
        f₁ = f₁' ∙ᵈᵣ emloop** g₃
        f₂ : ↓-cst-in ((emloop* g₁ ∙ emloop* g₂) ∙ emloop* g₃) ==
             ↓-cst-in {p = emloop g₁ ∙ emloop g₂} (emloop* g₁ ∙ emloop* g₂) ∙ᵈ emloop** g₃
        f₂ = ↓-cst-in-∙ (emloop g₁ ∙ emloop g₂) (emloop g₃)
                        (emloop* g₁ ∙ emloop* g₂) (emloop* g₃)
        f₃' : ↓-cst-in {p = emloop g₁ ∙ emloop g₂} (emloop* g₁ ∙ emloop* g₂) ==
              emloop** g₁ ∙ᵈ emloop** g₂
        f₃' = ↓-cst-in-∙ (emloop g₁) (emloop g₂) (emloop* g₁) (emloop* g₂)
        f₃ : ↓-cst-in {p = emloop g₁ ∙ emloop g₂} (emloop* g₁ ∙ emloop* g₂) ∙ᵈ emloop** g₃ ==
             (emloop** g₁ ∙ᵈ emloop** g₂) ∙ᵈ emloop** g₃
        f₃ = f₃' ∙ᵈᵣ emloop** g₃

      ψ-step : *-to-**-path ψ ψ* == ψ**
      ψ-step =
        ↓-cst-in2 {q = ψ} ψ* ▹ s₃-path
          =⟨ ap (_▹ s₃-path) $
             ↓-cst-in2-∙ {p₀₁ = e₀₄} {p₁₂ = e₄₅ ∙ e₅₃}
                         e₀₄* (e₄₅* ∙ e₅₃*) ⟩
        (e₀₄*' ∙ᵈ ↓-cst-in2 {q = e₄₅ ∙ e₅₃} (e₄₅* ∙ e₅₃*)) ▹ s₃-path
          =⟨ ap (λ y → (e₀₄*' ∙ᵈ y) ▹ s₃-path) $
             ↓-cst-in2-∙ {p₀₁ = e₄₅} {p₁₂ = e₅₃} e₄₅* e₅₃* ⟩
        (e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ e₅₃*') ▹ s₃-path
          =⟨ ∙ᵈ-∙'ᵈ-assoc' e₀₄*' (e₄₅*' ∙ᵈ e₅₃*') s₃-path ⟩
        e₀₄*' ∙ᵈ (e₄₅*' ∙ᵈ e₅₃*') ▹ s₃-path
          =⟨ ap (e₀₄*' ∙ᵈ_) (∙ᵈ-∙'ᵈ-assoc' e₄₅*' e₅₃*' s₃-path) ⟩
        e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ e₅₃*' ▹ s₃-path
          =⟨ ap (λ y → e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ e₅₃*' ▹ y) (∙=∙' s₃-path₁ s₃-path₂) ⟩
        e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ e₅₃*' ▹ (s₃-path₁ ∙' s₃-path₂)
          =⟨ ! $ ap (λ y → e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ y) $
             ∙'ᵈ-assoc e₅₃*' s₃-path₁ s₃-path₂ ⟩
        e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ (e₅₃*' ▹ s₃-path₁) ▹ s₃-path₂
          =⟨ ap (λ y → e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ y ▹ s₃-path₂) $
             ↓-cst-in2-whisker-left {p = emloop g₁} {q = emloop* g₁}
                                    {p₀₁' = emloop-comp g₂ g₃}
                                    (emloop-comp* g₂ g₃) ⟩
        e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ (f₀ ◃ f₁) ▹ s₃-path₂
          =⟨ ap (λ y → e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ y) $
             ∙ᵈ-∙'ᵈ-assoc f₀ f₁ s₃-path₂ ⟩
        e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ f₀ ◃ (f₁ ▹ s₃-path₂)
          =⟨ ! $ ap (λ y → e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ f₀ ◃ y) $
             ∙ᵈₗ-∙'ᵈ f₁' s₃-path₂' (emloop** g₁) ⟩
        e₀₄*' ∙ᵈ e₄₅*' ∙ᵈ f₀ ◃ e₅₃**
          =⟨ ! (ap (e₀₄*' ∙ᵈ_) (▹∙ᵈ-∙ᵈ◃-assoc e₄₅*' f₀ e₅₃**)) ⟩
        e₀₄*' ∙ᵈ e₄₅** ∙ᵈ e₅₃**
          =⟨ ap (_∙ᵈ e₄₅** ∙ᵈ e₅₃**) $
             ↓-cst-in2-ap emloop emloop* (G.assoc g₁ g₂ g₃) ⟩
        ψ** =∎
        where
        e₀₄*' : ↓-cst-in s₀* == ↓-cst-in s₄* [ Q ↓ e₀₄ ]
        e₀₄*' = ↓-cst-in2 {q = e₀₄} e₀₄*
        e₄₅*' : ↓-cst-in s₄* == ↓-cst-in s₅* [ Q ↓ e₄₅ ]
        e₄₅*' = ↓-cst-in2 {q = e₄₅} e₄₅*
        e₅₃*' : ↓-cst-in s₅* == ↓-cst-in s₃* [ Q ↓ e₅₃ ]
        e₅₃*' = ↓-cst-in2 {q = e₅₃} e₅₃*
        f₀ : ↓-cst-in (emloop* g₁ ∙ emloop* (G.comp g₂ g₃)) ==
             emloop** g₁ ∙ᵈ ↓-cst-in (emloop* (G.comp g₂ g₃))
        f₀ = ↓-cst-in-∙ (emloop g₁) (emloop' G (G.comp g₂ g₃))
                        (emloop* g₁) (emloop* (G.comp g₂ g₃))
        f₁' : emloop** (G.comp g₂ g₃) == ↓-cst-in (emloop* g₂ ∙ emloop* g₃)
                [ Q ↓ emloop-comp g₂ g₃ ]
        f₁' = ↓-cst-in2 {q = emloop-comp g₂ g₃} (emloop-comp* g₂ g₃)
        f₁ : emloop** g₁ ∙ᵈ emloop** (G.comp g₂ g₃) ==
             emloop** g₁ ∙ᵈ ↓-cst-in (emloop* g₂ ∙ emloop* g₃)
               [ Q ↓ ap (emloop g₁ ∙_) (emloop-comp g₂ g₃) ]
        f₁ = emloop** g₁ ∙ᵈₗ f₁'

      abstract
        emloop-coh** : φ** == ψ** [ (λ q → s₀** == s₃** [ Q ↓ q ]) ↓ φ=ψ ]
        emloop-coh** =
          ! φ-step ◃
          ap (λ p* → *-to-**-path φ p*) φ*=ψ* ◃
          apd (λ p → *-to-**-path p ψ*) φ=ψ ▹
          ψ-step

    module M = EM₁Elim {P = λ _ → C} {{λ _ → C-level}}
                       embase* emloop** emloop-comp** emloop-coh**

  abstract
    f : EM₁ G → C
    f = M.f

    embase-β : f embase ↦ embase*
    embase-β = M.embase-β
    {-# REWRITE embase-β #-}

    emloop-β : (g : G.El) → ap f (emloop g) == emloop* g
    emloop-β g = apd=cst-in (M.emloop-β g)

    private
      middle-fun : ∀ {i j} {A : Type i} {B : Type j}
        {f : A → B} {a₀ a₁ a₂ : A}
        (p₀₁ : a₀ == a₁) (p₁₂ : a₁ == a₂) (p₀₂ : a₀ == a₂)
        (q₀₁ : f a₀ == f a₁) (q₁₂ : f a₁ == f a₂) (q₀₂ : f a₀ == f a₂)
        (p-comp : p₀₂ == p₀₁ ∙ p₁₂)
        → apd f p₀₂ == ↓-cst-in {p = p₀₁} q₀₁ ∙ᵈ ↓-cst-in {p = p₁₂} q₁₂
            [ (λ w → f a₀ == f a₂ [ (λ _ → B) ↓ w ]) ↓ p-comp ]
        → ap f p₀₂ == q₀₁ ∙ q₁₂
      middle-fun {f = f} p₀₁ p₁₂ p₀₂ q₀₁ q₁₂ q₀₂ p-comp inner =
        ap=↓-cst-out-apd f p₀₂ ∙
        ↓-cst-out2 inner ∙
        ↓-cst-out2 (! (↓-cst-in-∙ p₀₁ p₁₂ q₀₁ q₁₂)) ∙
        ↓-cst-β (p₀₁ ∙ p₁₂) (q₀₁ ∙ q₁₂)

      emloop-comp-path-rewrite₁ : ∀ {i j} {A : Type i} {B : Type j}
        {f : A → B} {a₀ a₁ a₂ : A}
        (p₀₁ : a₀ == a₁) (p₁₂ : a₁ == a₂) (p₀₂ : a₀ == a₂)
        (q₀₁ : f a₀ == f a₁) (q₁₂ : f a₁ == f a₂) (q₀₂ : f a₀ == f a₂)
        (p-comp : p₀₂ == p₀₁ ∙ p₁₂)
        (r₀₁ : apd f p₀₁ == ↓-cst-in q₀₁)
        (r₁₂ : apd f p₁₂ == ↓-cst-in q₁₂)
        → ap (ap f) p-comp ∙
          ap-∙ f p₀₁ p₁₂ ∙
          ap2 _∙_ (apd=cst-in r₀₁) (apd=cst-in r₁₂)
          ==
          middle-fun p₀₁ p₁₂ p₀₂ q₀₁ q₁₂ q₀₂ p-comp
            (apd (apd f) p-comp ▹
              apd-∙ f p₀₁ p₁₂ ∙
              ap2 _∙ᵈ_ r₀₁ r₁₂)
      emloop-comp-path-rewrite₁ idp idp .idp q₀₁ q₁₂ q₀₂ idp r₀₁ r₁₂ =
        ! (∙-unit-r (idp ∙' ap2 _∙_ r₀₁ r₁₂) ∙ ∙'-unit-l (ap2 _∙_ r₀₁ r₁₂))

      emloop-comp-path-rewrite₂ : ∀ {i j} {A : Type i} {B : Type j}
        {f : A → B} {a₀ a₁ a₂ : A}
        (p₀₁ : a₀ == a₁) (p₁₂ : a₁ == a₂) (p₀₂ : a₀ == a₂)
        (q₀₁ : f a₀ == f a₁) (q₁₂ : f a₁ == f a₂) (q₀₂ : f a₀ == f a₂)
        (p-comp : p₀₂ == p₀₁ ∙ p₁₂) (q-comp : q₀₂ == q₀₁ ∙ q₁₂)
        (r₀₁ : apd f p₀₁ == ↓-cst-in q₀₁)
        (r₁₂ : apd f p₁₂ == ↓-cst-in q₁₂)
        (r₀₂ : apd f p₀₂ == ↓-cst-in q₀₂)
        → middle-fun p₀₁ p₁₂ p₀₂ q₀₁ q₁₂ q₀₂ p-comp
            (r₀₂ ◃
              ↓-cst-in2 {q = p-comp} q-comp ▹
              ↓-cst-in-∙ p₀₁ p₁₂ q₀₁ q₁₂)
          ==
          apd=cst-in r₀₂ ∙
          q-comp
      emloop-comp-path-rewrite₂ idp idp .idp q₀₁ q₁₂ q₀₂ idp q-comp r₀₁ r₁₂ r₀₂ =
        ∙-unit-r (r₀₂ ∙ q-comp)

    emloop-comp-path : (g₁ g₂ : G.El)
      → ap (ap f) (emloop-comp g₁ g₂) ◃∙
        ap-∙ f (emloop g₁) (emloop g₂) ◃∙
        ap2 _∙_ (emloop-β g₁) (emloop-β g₂) ◃∎
        =ₛ
        emloop-β (G.comp g₁ g₂) ◃∙
        emloop-comp* g₁ g₂ ◃∎
    emloop-comp-path g₁ g₂ = =ₛ-in $
      ap (ap f) (emloop-comp g₁ g₂) ∙
      ap-∙ f (emloop g₁) (emloop g₂) ∙
      ap2 _∙_ (emloop-β g₁) (emloop-β g₂)
        =⟨ emloop-comp-path-rewrite₁ p₀₁ p₁₂ p₀₂ q₀₁ q₁₂ q₀₂ p-comp r₀₁ r₁₂ ⟩
      fun (apd (apd f) (emloop-comp g₁ g₂) ▹
            apd-∙ f (emloop g₁) (emloop g₂) ∙
            ap2 _∙ᵈ_ (M.emloop-β g₁) (M.emloop-β g₂))
        =⟨ ap fun (M.emloop-comp-path g₁ g₂) ⟩
      fun (M.emloop-β (G.comp g₁ g₂) ◃ emloop-comp** g₁ g₂)
        =⟨ emloop-comp-path-rewrite₂ p₀₁ p₁₂ p₀₂ q₀₁ q₁₂ q₀₂ p-comp q-comp r₀₁ r₁₂ r₀₂ ⟩
      emloop-β (G.comp g₁ g₂) ∙ emloop-comp* g₁ g₂ =∎
      where
        p₀₁ = emloop g₁
        p₁₂ = emloop g₂
        p₀₂ = emloop (G.comp g₁ g₂)
        q₀₁ = emloop* g₁
        q₁₂ = emloop* g₂
        q₀₂ = emloop* (G.comp g₁ g₂)
        r₀₁ = M.emloop-β g₁
        r₁₂ = M.emloop-β g₂
        r₀₂ = M.emloop-β (G.comp g₁ g₂)
        p-comp = emloop-comp g₁ g₂
        q-comp = emloop-comp* g₁ g₂
        fun = middle-fun p₀₁ p₁₂ p₀₂ q₀₁ q₁₂ q₀₂ p-comp

module EM₁Rec {j} {C : Type j}
  {{C-level : has-level 2 C}}
  (F : TwoSemiFunctor (group-to-cat G) (2-type-fundamental-cat C {{C-level}})) where

  private
    module F = TwoSemiFunctor F
    module M =
      EM₁Rec' {C = C} {{C-level}}
              (F.F₀ unit)
              F.F₁
              F.pres-comp
              F.pres-comp-coh

  abstract
    f : EM₁ G → C
    f = M.f

    embase-β : f embase ↦ F.F₀ unit
    embase-β = M.embase-β
    {-# REWRITE embase-β #-}

    emloop-β : (g : G.El) → ap f (emloop g) == F.F₁ g
    emloop-β = M.emloop-β

    emloop-comp-path : (g₁ g₂ : G.El)
      → ap (ap f) (emloop-comp g₁ g₂) ◃∙
        ap-∙ f (emloop g₁) (emloop g₂) ◃∙
        ap2 _∙_ (emloop-β g₁) (emloop-β g₂) ◃∎
        =ₛ
        emloop-β (G.comp g₁ g₂) ◃∙
        F.pres-comp g₁ g₂ ◃∎
    emloop-comp-path = M.emloop-comp-path

open EM₁Rec public using () renaming (f to EM₁-rec)

module EM₁Level₁Rec {j} {C : Type j}
  {{C-level : has-level 1 C}}
  (embase* : C)
  (hom* : G →ᴳ (Ω^S-group 0 ⊙[ C , embase* ])) where

  module M =
    EM₁Rec' {{raise-level 1 C-level}}
            embase* (GroupHom.f hom*) (GroupHom.pres-comp hom*)
            (λ g₁ g₂ g₃ → =ₛ-in (prop-has-all-paths _ _))

  abstract
    f : EM₁ G → C
    f = M.f

    embase-β : f embase ↦ embase*
    embase-β = M.embase-β
    {-# REWRITE embase-β #-}

    emloop-β : (g : G.El) → ap f (emloop g) == GroupHom.f hom* g
    emloop-β = M.emloop-β

open EM₁Level₁Rec public using () renaming (f to EM₁-level₁-rec)


{-# OPTIONS --cubical --no-import-sorts #-}

module Summary where

import Cubical.Data.Nat using (ℕ)
open import Cubical.Foundations.Prelude using (Lift; refl)
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.Unit.Base using (Unit)
open import Cubical.Data.Sigma.Base

infix 1 _≅_
_≅_ = Iso

open import Number.Postulates
open import Number.Base
open import Number.Prettyprint

open ℕⁿ
open ℤᶻ
open ℚᶠ
open ℝʳ
open ℂᶜ

number-≅-Σ : ∀{p} → Number p ≅ NumberInterpretation p
number-≅-Σ = λ where
  .Iso.fun               → pop
  .Iso.inv      (x ,  p) → x ,, p
  .Iso.leftInv  (x ,, p) → refl
  .Iso.rightInv (x ,  p) → refl

iso00 : [ℕ]   ≅ Σ[ x ∈ Cubical.Data.Nat.ℕ ] Unit
iso01 : [ℕ⁺⁻] ≅ Σ[ x ∈ Cubical.Data.Nat.ℕ ] x  #ⁿ 0ⁿ
iso02 : [ℕ₀⁺] ≅ Σ[ x ∈ Cubical.Data.Nat.ℕ ] 0ⁿ ≤ⁿ x
iso03 : [ℕ⁺]  ≅ Σ[ x ∈ Cubical.Data.Nat.ℕ ] 0ⁿ <ⁿ x
iso04 : [ℕ₀⁻] ≅ Σ[ x ∈ Cubical.Data.Nat.ℕ ] x  ≤ⁿ 0ⁿ
iso05 : [ℤ]   ≅ Σ[ x ∈ ℤ.Carrier          ] Lift {j = ℤℓ'} Unit
iso06 : [ℤ⁺⁻] ≅ Σ[ x ∈ ℤ.Carrier          ] x  #ᶻ 0ᶻ
iso07 : [ℤ₀⁺] ≅ Σ[ x ∈ ℤ.Carrier          ] 0ᶻ ≤ᶻ x
iso08 : [ℤ⁺]  ≅ Σ[ x ∈ ℤ.Carrier          ] 0ᶻ <ᶻ x
iso09 : [ℤ⁻]  ≅ Σ[ x ∈ ℤ.Carrier          ] x  <ᶻ 0ᶻ
iso10 : [ℤ₀⁻] ≅ Σ[ x ∈ ℤ.Carrier          ] x  ≤ᶻ 0ᶻ
iso11 : [ℚ]   ≅ Σ[ x ∈ ℚ.Carrier          ] Lift {j = ℚℓ'} Unit
iso12 : [ℚ⁺⁻] ≅ Σ[ x ∈ ℚ.Carrier          ] x  #ᶠ 0ᶠ
iso13 : [ℚ₀⁺] ≅ Σ[ x ∈ ℚ.Carrier          ] 0ᶠ ≤ᶠ x
iso14 : [ℚ⁺]  ≅ Σ[ x ∈ ℚ.Carrier          ] 0ᶠ <ᶠ x
iso15 : [ℚ⁻]  ≅ Σ[ x ∈ ℚ.Carrier          ] x  <ᶠ 0ᶠ
iso16 : [ℚ₀⁻] ≅ Σ[ x ∈ ℚ.Carrier          ] x  ≤ᶠ 0ᶠ
iso17 : [ℝ]   ≅ Σ[ x ∈ ℝ.Carrier          ] Lift {j = ℝℓ'} Unit
iso18 : [ℝ⁺⁻] ≅ Σ[ x ∈ ℝ.Carrier          ] x  #ʳ 0ʳ
iso19 : [ℝ₀⁺] ≅ Σ[ x ∈ ℝ.Carrier          ] 0ʳ ≤ʳ x
iso20 : [ℝ⁺]  ≅ Σ[ x ∈ ℝ.Carrier          ] 0ʳ <ʳ x
iso21 : [ℝ⁻]  ≅ Σ[ x ∈ ℝ.Carrier          ] x  <ʳ 0ʳ
iso22 : [ℝ₀⁻] ≅ Σ[ x ∈ ℝ.Carrier          ] x  ≤ʳ 0ʳ
iso23 : [ℂ]   ≅ Σ[ x ∈ ℂ.Carrier          ] Lift {j = ℂℓ'} Unit
iso24 : [ℂ⁺⁻] ≅ Σ[ x ∈ ℂ.Carrier          ] x  #ᶜ 0ᶜ

iso00 = number-≅-Σ
iso01 = number-≅-Σ
iso02 = number-≅-Σ
iso03 = number-≅-Σ
iso04 = number-≅-Σ
iso05 = number-≅-Σ
iso06 = number-≅-Σ
iso07 = number-≅-Σ
iso08 = number-≅-Σ
iso09 = number-≅-Σ
iso10 = number-≅-Σ
iso11 = number-≅-Σ
iso12 = number-≅-Σ
iso13 = number-≅-Σ
iso14 = number-≅-Σ
iso15 = number-≅-Σ
iso16 = number-≅-Σ
iso17 = number-≅-Σ
iso18 = number-≅-Σ
iso19 = number-≅-Σ
iso20 = number-≅-Σ
iso21 = number-≅-Σ
iso22 = number-≅-Σ
iso23 = number-≅-Σ
iso24 = number-≅-Σ


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

open import Algebra.Structures.Bundles.Field
open import Algebra.Linear.Structures.Bundles

module Algebra.Linear.Space.Hom
  {k ℓ} (K : Field k ℓ)
  {a₁ ℓ₁} (V₁-space : VectorSpace K a₁ ℓ₁)
  {a₂ ℓ₂} (V₂-space : VectorSpace K a₂ ℓ₂)
  where

open import Relation.Binary
open import Level using (_⊔_; suc)
open import Data.Nat using (ℕ) renaming (_+_ to _+ℕ_)
open import Algebra.Linear.Morphism.Bundles K
open import Algebra.Linear.Morphism.Properties K
open import Algebra.Linear.Structures.VectorSpace

open import Data.Product

open VectorSpaceField K

open VectorSpace V₁-space
  using ()
  renaming
  ( Carrier       to V₁
  ; _≈_           to _≈₁_
  ; isEquivalence to ≈₁-isEquiv
  ; refl          to ≈₁-refl
  ; sym           to ≈₁-sym
  ; trans         to ≈₁-trans
  ; setoid        to setoid₁
  ; _+_           to _+₁_
  ; _∙_           to _∙₁_
  ; -_            to -₁_
  ; 0#            to 0₁
  ; +-identityˡ    to +₁-identityˡ
  ; +-identityʳ    to +₁-identityʳ
  ; +-identity    to +₁-identity
  ; +-cong        to +₁-cong
  ; +-assoc       to +₁-assoc
  ; +-comm        to +₁-comm
  ; *ᵏ-∙-compat   to *ᵏ-∙₁-compat
  ; ∙-+-distrib   to ∙₁-+₁-distrib
  ; ∙-+ᵏ-distrib  to ∙₁-+ᵏ-distrib
  ; ∙-cong        to ∙₁-cong
  ; ∙-identity    to ∙₁-identity
  ; ∙-absorbˡ      to ∙₁-absorbˡ
  ; ∙-absorbʳ      to ∙₁-absorbʳ
  ; -‿cong        to -₁‿cong
  ; -‿inverseˡ    to -₁‿inverseˡ
  ; -‿inverseʳ    to -₁‿inverseʳ
  )

open VectorSpace V₂-space
  using ()
  renaming
  ( Carrier       to V₂
  ; _≈_           to _≈₂_
  ; isEquivalence to ≈₂-isEquiv
  ; refl          to ≈₂-refl
  ; sym           to ≈₂-sym
  ; trans         to ≈₂-trans
  ; setoid        to setoid₂
  ; _+_           to _+₂_
  ; _∙_           to _∙₂_
  ; -_            to -₂_
  ; 0#            to 0₂
  ; +-identityˡ    to +₂-identityˡ
  ; +-identityʳ    to +₂-identityʳ
  ; +-identity    to +₂-identity
  ; +-cong        to +₂-cong
  ; +-assoc       to +₂-assoc
  ; +-comm        to +₂-comm
  ; *ᵏ-∙-compat   to *ᵏ-∙₂-compat
  ; ∙-+-distrib   to ∙₂-+₂-distrib
  ; ∙-+ᵏ-distrib  to ∙₂-+ᵏ-distrib
  ; ∙-cong        to ∙₂-cong
  ; ∙-identity    to ∙₂-identity
  ; ∙-absorbˡ      to ∙₂-absorbˡ
  ; ∙-absorbʳ      to ∙₂-absorbʳ
  ; ∙-∙-comm      to ∙₂-∙₂-comm
  ; -‿cong        to -₂‿cong
  ; -‿inverseˡ    to -₂‿inverseˡ
  ; -‿inverseʳ    to -₂‿inverseʳ
  ; -‿+-comm     to -₂‿+₂-comm
  ; -1∙u≈-u       to -1∙u≈₂-u
  )

import Function

private
  V : Set (suc (k ⊔ a₁ ⊔ a₂ ⊔ ℓ₁ ⊔ ℓ₂))
  V = LinearMap V₁-space V₂-space

open LinearMap using (_⟪$⟫_; ⟦⟧-cong; distrib-linear)

setoid : Setoid (suc (k ⊔ a₁ ⊔ a₂ ⊔ ℓ₁ ⊔ ℓ₂)) _
setoid = linearMap-setoid V₁-space V₂-space

open Setoid setoid public
  renaming (isEquivalence to ≈-isEquiv)

open import Algebra.FunctionProperties _≈_
open import Algebra.Structures _≈_
open import Function.Equality hiding (setoid; _∘_)

open import Relation.Binary.EqReasoning setoid₂

0# : V
0# = record
  { ⟦_⟧ = λ x → 0₂
  ; isLinearMap = linear V₁-space V₂-space π
    λ a b u v →
      begin
        0₂
      ≈⟨ ≈₂-trans (≈₂-sym (∙₂-absorbʳ b)) (≈₂-sym (+₂-identityˡ (b ∙₂ 0₂))) ⟩
        0₂ +₂ b ∙₂ 0₂
      ≈⟨ +₂-cong (≈₂-sym (∙₂-absorbʳ a)) ≈₂-refl ⟩
        a ∙₂ 0₂ +₂ b ∙₂ 0₂
      ∎
  }
  where π : setoid₁ ⟶ setoid₂
        π = record
          { _⟨$⟩_ = λ x → 0₂
          ; cong  = λ r → ≈₂-refl }

-_ : Op₁ V
- f = record
  { ⟦_⟧ = λ x → -₂ f ⟪$⟫ x
  ; isLinearMap = linear V₁-space V₂-space π
    let -[a∙u]≈₂a∙[-u] : ∀ (a : K') (u : V₂) -> (-₂ (a ∙₂ u)) ≈₂ a ∙₂ (-₂ u)
        -[a∙u]≈₂a∙[-u] a u =
          begin
            (-₂ (a ∙₂ u))
          ≈⟨ ≈₂-sym (-1∙u≈₂-u (a ∙₂ u)) ⟩
            (-ᵏ 1ᵏ) ∙₂ (a ∙₂ u)
          ≈⟨ ≈₂-sym (*ᵏ-∙₂-compat (-ᵏ 1ᵏ) a u) ⟩
            ((-ᵏ 1ᵏ) *ᵏ a) ∙₂ u
          ≈⟨ ∙₂-cong (≈ᵏ-trans (≈ᵏ-sym (-ᵏ‿distribˡ-*ᵏ 1ᵏ a)) (-ᵏ‿cong (*ᵏ-identityˡ a))) ≈₂-refl ⟩
            (-ᵏ a) ∙₂ u
          ≈⟨ ∙₂-cong (≈ᵏ-trans (-ᵏ‿cong (≈ᵏ-sym (*ᵏ-identityʳ a))) (-ᵏ‿distribʳ-*ᵏ a 1ᵏ)) ≈₂-refl ⟩
            (a *ᵏ (-ᵏ 1ᵏ)) ∙₂ u
          ≈⟨ ≈₂-trans (*ᵏ-∙₂-compat a (-ᵏ 1ᵏ) u) (∙₂-cong ≈ᵏ-refl (-1∙u≈₂-u u)) ⟩
             a ∙₂ (-₂ u)
          ∎
    in λ a b u v →
      begin
        π ⟨$⟩ a ∙₁ u +₁ b ∙₁ v
      ≈⟨ -₂‿cong (distrib-linear f a b u v) ⟩
        -₂ (a ∙₂ (f ⟪$⟫ u) +₂ b ∙₂ (f ⟪$⟫ v))
      ≈⟨ ≈₂-sym (-₂‿+₂-comm (a ∙₂ (f ⟪$⟫ u)) ( b ∙₂ (f ⟪$⟫ v))) ⟩
        ((-₂ (a ∙₂ (f ⟪$⟫ u))) +₂ (-₂ (b ∙₂ (f ⟪$⟫ v))))
      ≈⟨ +₂-cong (-[a∙u]≈₂a∙[-u] a (f ⟪$⟫ u)) (-[a∙u]≈₂a∙[-u] b (f ⟪$⟫ v)) ⟩
        a ∙₂ (π ⟨$⟩ u) +₂ b ∙₂ (π ⟨$⟩ v)
      ∎
  } where π : setoid₁ ⟶ setoid₂
          π = record
            { _⟨$⟩_ = λ x → -₂ f ⟪$⟫ x
            ; cong  = λ r → -₂‿cong (⟦⟧-cong f r)
            }

infixr 25 _+_
_+_ : Op₂ V
f + g = record
  { ⟦_⟧ = λ x -> (f ⟪$⟫ x) +₂ (g ⟪$⟫ x)
  ; isLinearMap = linear V₁-space V₂-space π
    let reassoc : ∀ (u v u' v' : V₂) -> (u +₂ v) +₂ (u' +₂ v') ≈₂ (u +₂ u') +₂ (v +₂ v')
        reassoc u v u' v' =
          begin
            (u +₂ v) +₂ (u' +₂ v')
          ≈⟨ +₂-assoc u v (u' +₂ v') ⟩
            u +₂ (v +₂ (u' +₂ v'))
          ≈⟨ +₂-cong ≈₂-refl (≈₂-trans (≈₂-sym (+₂-assoc v u' v')) (+₂-cong (+₂-comm v u') ≈₂-refl)) ⟩
            u +₂ ((u' +₂ v) +₂ v')
          ≈⟨ ≈₂-trans (+₂-cong ≈₂-refl (+₂-assoc u' v v')) (≈₂-sym (+₂-assoc u u' (v +₂ v'))) ⟩
            (u +₂ u') +₂ (v +₂ v')
          ∎
        distrib-f-g k w = ≈₂-sym (∙₂-+₂-distrib k (f ⟪$⟫ w) (g ⟪$⟫ w))
    in λ a b u v →
      begin
        π ⟨$⟩ a ∙₁ u +₁ b ∙₁ v
      ≡⟨⟩
        (f ⟪$⟫ (a ∙₁ u +₁ b ∙₁ v)) +₂ (g ⟪$⟫ (a ∙₁ u +₁ b ∙₁ v))
      ≈⟨ +₂-cong (distrib-linear f a b u v) (distrib-linear g a b u v) ⟩
        (a ∙₂ (f ⟪$⟫ u) +₂ b ∙₂ (f ⟪$⟫ v)) +₂ ((a ∙₂ (g ⟪$⟫ u) +₂ b ∙₂ (g ⟪$⟫ v)))
      ≈⟨ reassoc (a ∙₂ (f ⟪$⟫ u)) (b ∙₂ (f ⟪$⟫ v)) (a ∙₂ (g ⟪$⟫ u)) (b ∙₂ (g ⟪$⟫ v)) ⟩
        (a ∙₂ (f ⟪$⟫ u) +₂ a ∙₂ (g ⟪$⟫ u)) +₂ ((b ∙₂ (f ⟪$⟫ v)) +₂ b ∙₂ (g ⟪$⟫ v))
      ≈⟨ +₂-cong (distrib-f-g a u) (distrib-f-g b v) ⟩
        a ∙₂ (π ⟨$⟩ u) +₂ b ∙₂ (π ⟨$⟩ v)
      ∎
  } where π : setoid₁ ⟶ setoid₂
          π = record
            { _⟨$⟩_ = λ x → (f ⟪$⟫ x) +₂ (g ⟪$⟫ x)
            ; cong  = λ r → +₂-cong (⟦⟧-cong f r) (⟦⟧-cong g r)
            }

infixr 30 _∙_
_∙_ : K' -> V -> V
c ∙ f = record
  { ⟦_⟧ = λ x → c ∙₂ (f ⟪$⟫ x)
  ; isLinearMap = linear V₁-space V₂-space π
    λ a b u v →
      begin
        π ⟨$⟩ a ∙₁ u +₁ b ∙₁ v
      ≈⟨ ∙₂-cong ≈ᵏ-refl (distrib-linear f a b u v) ⟩
        c ∙₂ (a ∙₂ (f ⟪$⟫ u) +₂ b ∙₂ (f ⟪$⟫ v))
      ≈⟨ ∙₂-+₂-distrib c (a ∙₂ (f ⟪$⟫ u)) ( b ∙₂ (f ⟪$⟫ v)) ⟩
        (c ∙₂ (a ∙₂ (f ⟪$⟫ u))) +₂ (c ∙₂ (b ∙₂ (f ⟪$⟫ v)))
      ≈⟨ +₂-cong (∙₂-∙₂-comm c a (f ⟪$⟫ u)) (∙₂-∙₂-comm c b (f ⟪$⟫ v)) ⟩
        a ∙₂ (π ⟨$⟩ u) +₂ b ∙₂ (π ⟨$⟩ v)
      ∎
  } where π : setoid₁ ⟶ setoid₂
          π = record
            { _⟨$⟩_ = λ x → c ∙₂ (f ⟪$⟫ x)
            ; cong  = λ r → ∙₂-cong ≈ᵏ-refl (⟦⟧-cong f r)
            }

+-cong : Congruent₂ _+_
+-cong r₁ r₂ = λ rₓ -> +₂-cong (r₁ rₓ) (r₂ rₓ)

+-assoc : Associative _+_
+-assoc f g h {y = y} rₓ = ≈₂-trans
  (+₂-cong (+₂-cong (⟦⟧-cong f rₓ) (⟦⟧-cong g rₓ)) (⟦⟧-cong h rₓ))
  (+₂-assoc (f ⟪$⟫ y) (g ⟪$⟫ y) (h ⟪$⟫ y))

+-identityˡ : LeftIdentity 0# _+_
+-identityˡ  f {x} rₓ = ≈₂-trans
  (+₂-identityˡ (f ⟪$⟫ x))
  (⟦⟧-cong f rₓ)

+-identityʳ : RightIdentity 0# _+_
+-identityʳ f {x} rₓ = ≈₂-trans
  (+₂-identityʳ (f ⟪$⟫ x))
  (⟦⟧-cong f rₓ)

+-identity : Identity 0# _+_
+-identity = +-identityˡ , +-identityʳ

+-comm : Commutative _+_
+-comm f g {x} rₓ = ≈₂-trans
  (+₂-comm (f ⟪$⟫ x) (g ⟪$⟫ x))
  (+₂-cong (⟦⟧-cong g rₓ) (⟦⟧-cong f rₓ))

*ᵏ-∙-compat : ∀ (a b : K') (f : V) -> ((a *ᵏ b) ∙ f) ≈ (a ∙ (b ∙ f))
*ᵏ-∙-compat a b f {x} rₓ = ≈₂-trans
  (*ᵏ-∙₂-compat a b (f ⟪$⟫ x))
  (∙₂-cong ≈ᵏ-refl (∙₂-cong ≈ᵏ-refl (⟦⟧-cong f rₓ)))

∙-+-distrib : ∀ (a : K') (f g : V) -> (a ∙ (f + g)) ≈ ((a ∙ f) + (a ∙ g))
∙-+-distrib a f g {x} rₓ = ≈₂-trans
  (∙₂-+₂-distrib a (f ⟪$⟫ x) (g ⟪$⟫ x))
  (+₂-cong (∙₂-cong ≈ᵏ-refl (⟦⟧-cong f rₓ)) (∙₂-cong ≈ᵏ-refl (⟦⟧-cong g rₓ)))

∙-+ᵏ-distrib : ∀ (a b : K') (f : V) -> ((a +ᵏ b) ∙ f) ≈ ((a ∙ f) + (b ∙ f))
∙-+ᵏ-distrib a b f {x} rₓ = ≈₂-trans
  (∙₂-+ᵏ-distrib a b (f ⟪$⟫ x))
  (+₂-cong cf cf)
  where cf : ∀ {c : K'} -> _
        cf {c} = ∙₂-cong (≈ᵏ-refl {c}) (⟦⟧-cong f rₓ)

∙-cong : ∀ {a b : K'} {f g : V} -> a ≈ᵏ b -> f ≈ g -> (a ∙ f) ≈ (b ∙ g)
∙-cong {f = f} {g = g} rk rf rₓ = ≈₂-trans
  (∙₂-cong rk (rf rₓ))
  (∙₂-cong ≈ᵏ-refl (⟦⟧-cong g ≈₁-refl))

∙-identity : ∀ (f : V) → (1ᵏ ∙ f) ≈ f
∙-identity f {x} rₓ = ≈₂-trans (∙₂-identity (f ⟪$⟫ x)) (⟦⟧-cong f rₓ)

∙-absorbˡ : ∀ (x : V) → (0ᵏ ∙ x) ≈ 0#
∙-absorbˡ f {x} _ = ≈₂-trans (∙₂-absorbˡ (f ⟪$⟫ x)) ≈₂-refl

-‿inverseˡ : LeftInverse 0# -_ _+_
-‿inverseˡ f {x} _ = ≈₂-trans (-₂‿inverseˡ (f ⟪$⟫ x)) ≈₂-refl

-‿inverseʳ : RightInverse 0# -_ _+_
-‿inverseʳ f {x} _ = -₂‿inverseʳ (f ⟪$⟫ x)

-‿inverse : Inverse 0# -_ _+_
-‿inverse = -‿inverseˡ , -‿inverseʳ

-‿cong : Congruent₁ -_
-‿cong r rₓ = -₂‿cong (r rₓ)

isMagma : IsMagma _+_
isMagma = record
  { isEquivalence = ≈-isEquiv
  -- I don't know how to solve this: I'd like to write simply ∙-cong = +-cong
  ; ∙-cong        = λ {f} {g} {u} {v} -> +-cong {f} {g} {u} {v}
  }

isSemigroup : IsSemigroup _+_
isSemigroup = record
  { isMagma = isMagma
  ; assoc   = +-assoc
  }

isMonoid : IsMonoid _+_ 0#
isMonoid = record
  { isSemigroup = isSemigroup
  ; identity    = +-identity
  }

isGroup : IsGroup _+_ 0# -_
isGroup = record
  { isMonoid = isMonoid
  ; inverse  = -‿inverse
  ; ⁻¹-cong   = λ {f} {g} -> -‿cong {f} {g}
  }

isAbelianGroup : IsAbelianGroup _+_ 0# -_
isAbelianGroup = record
  { isGroup = isGroup
  ; comm    = +-comm
  }

isVectorSpace : IsVectorSpace K _≈_ _+_ _∙_ -_ 0#
isVectorSpace = record
  { isAbelianGroup = isAbelianGroup
  ; *ᵏ-∙-compat      = *ᵏ-∙-compat
  ; ∙-+-distrib      = ∙-+-distrib
  ; ∙-+ᵏ-distrib     = ∙-+ᵏ-distrib
  ; ∙-cong           = λ {a} {b} {f} {g} -> ∙-cong {a} {b} {f} {g}
  ; ∙-identity       = ∙-identity
  ; ∙-absorbˡ         = ∙-absorbˡ
  }

vectorSpace : VectorSpace K (suc (k ⊔ a₁ ⊔ a₂ ⊔ ℓ₁ ⊔ ℓ₂)) (a₁ ⊔ ℓ₁ ⊔ ℓ₂)
vectorSpace = record { isVectorSpace = isVectorSpace }


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of operations on the Delay type
------------------------------------------------------------------------

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

module Codata.Delay.Properties where

open import Size
import Data.Sum as Sum
open import Codata.Thunk using (Thunk; force)
open import Codata.Conat
open import Codata.Conat.Bisimilarity as Coℕ using (zero ; suc)
open import Codata.Delay
open import Codata.Delay.Bisimilarity
open import Function
open import Relation.Binary.PropositionalEquality as Eq using (_≡_)

module _ {a} {A : Set a} where

 length-never : ∀ {i} → i Coℕ.⊢ length (never {A = A}) ≈ infinity
 length-never = suc λ where .force → length-never

module _ {a b} {A : Set a} {B : Set b} where

 length-map : ∀ (f : A → B) da {i} → i Coℕ.⊢ length (map f da) ≈ length da
 length-map f (now a)    = zero
 length-map f (later da) = suc λ where .force → length-map f (da .force)

module _ {a b c} {A : Set a} {B : Set b} {C : Set c} where

 length-zipWith : ∀ (f : A → B → C) da db {i} →
   i Coℕ.⊢ length (zipWith f da db) ≈ length da ⊔ length db
 length-zipWith f (now a)      db         = length-map (f a) db
 length-zipWith f da@(later _) (now b)    = length-map (λ a → f a b) da
 length-zipWith f (later da)   (later db) =
   suc λ where .force →  length-zipWith f (da .force) (db .force)

 map-map-fusion : ∀ (f : A → B) (g : B → C) da {i}  →
   i ⊢ map g (map f da) ≈ map (g ∘′ f) da
 map-map-fusion f g (now a)    = now Eq.refl
 map-map-fusion f g (later da) = later λ where .force → map-map-fusion f g (da .force)

 map-unfold-fusion : ∀ (f : B → C) n (s : A) {i} →
   i ⊢ map f (unfold n s) ≈ unfold (Sum.map id f ∘′ n) s
 map-unfold-fusion f n s with n s
 ... | Sum.inj₁ s′ = later λ where .force → map-unfold-fusion f n s′
 ... | Sum.inj₂ b  = now Eq.refl


module Avionics.SafetyEnvelopes where

open import Data.Bool using (Bool; true; false; _∧_; _∨_)
open import Data.List using (List; []; _∷_; any; map; foldl; length)
open import Data.List.Relation.Unary.Any as Any using (Any)
open import Data.List.Relation.Unary.All as All using (All)
open import Data.Maybe using (Maybe; just; nothing; is-just; _>>=_)
open import Data.Nat using (ℕ; zero; suc)
open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩)
open import Function using (_∘_)
open import Relation.Binary.PropositionalEquality
    using (_≡_; _≢_; refl; cong; subst; sym)
open import Relation.Unary using (_∈_)
open import Relation.Nullary using (yes; no; ¬_)
open import Relation.Nullary.Decidable using (fromWitnessFalse)

open import Avionics.Real
    using (ℝ; _+_; _-_; _*_; _÷_; _^_; _<ᵇ_; _≤ᵇ_; _≤_; _<_; _<?_; _≤?_; _≟_;
           1/_;
           0ℝ; 1ℝ; 2ℝ; 1/2; _^2; √_; fromℕ)
--open import Avionics.Product using (_×_; ⟨_,_⟩; proj₁; proj₂)
open import Avionics.Probability using (Dist; NormalDist; ND; BiNormalDist)

sum : List ℝ → ℝ
sum = foldl _+_ 0ℝ

inside : NormalDist → ℝ → ℝ → Bool
inside nd z x = ((μ - z * σ) <ᵇ x) ∧ (x <ᵇ (μ + z * σ))
  where open NormalDist nd using (μ; σ)

mahalanobis1 : ℝ → ℝ → ℝ → ℝ
mahalanobis1 u v IV = √((u - v) * IV * (u - v))

inside' : NormalDist → ℝ → ℝ → Bool
inside' nd z x = mahalanobis1 μ x σ²-¹ <ᵇ z
  where open NormalDist nd using (μ; σ)
        σ²-¹ = 1/ (σ * σ)

mahalanobis2 : (ℝ × ℝ) → (ℝ × ℝ) → (ℝ × ℝ × ℝ × ℝ) → ℝ
--mahalanobis2 u v VI = ...
mahalanobis2 ⟨ u₁ , u₂ ⟩ ⟨ v₁ , v₂ ⟩
            ⟨ iv₁₁ , ⟨ iv₁₂ , ⟨ iv₂₁ , iv₂₂ ⟩ ⟩ ⟩ = √ ⟨u-v⟩IV⟨u-v⟩'
  where x₁ = u₁ - v₁
        x₂ = u₂ - v₂
        ⟨u-v⟩IV⟨u-v⟩' = (x₁ * x₁ * iv₁₁ + x₁ * x₂ * iv₁₂
                        + x₁ * x₂ * iv₂₁ + x₂ * x₂ * iv₂₂)

insideBiv : BiNormalDist → ℝ → (ℝ × ℝ) → Bool
insideBiv bnd z x = mahalanobis2 μ x Σ-¹ <ᵇ z
  where open BiNormalDist bnd using (μ; Σ-¹)

FlightState = (ℝ × ℝ)

record Model : Set where
  field
    -- Flight states
    SM : List FlightState
    -- Map from flight states to Normal Distributions
    fM : List (FlightState × (NormalDist × ℝ))
    -- Every flight state must be represented in the map fM
    .fMisMap₁ : All (λ θ → Any (λ θ,ND → proj₁ θ,ND ≡ θ) fM ) SM
    .fMisMap₂ : All (λ θ,ND → Any (λ θ → proj₁ θ,ND ≡ θ) SM ) fM
    .lenSM>0 : length SM ≢ 0
    --.lenfM>0 : length fM ≢ 0 -- this is the result of the bijection above and .lenSM>0

z-predictable' : List NormalDist → ℝ → ℝ → ℝ × Bool
z-predictable' nds z x = ⟨ x , any (λ nd → inside nd z x) nds ⟩

z-predictable : Model → ℝ → ℝ → ℝ × Bool
z-predictable M z x = z-predictable' (map (proj₁ ∘ proj₂) (Model.fM M)) z x

--

sample-z-predictable : List NormalDist → ℝ → ℝ → List ℝ → Maybe (ℝ × ℝ × Bool)
sample-z-predictable nds zμ zσ [] = nothing
sample-z-predictable nds zμ zσ (_ ∷ []) = nothing
sample-z-predictable nds zμ zσ xs@(_ ∷ _ ∷ _) = just ⟨ mean , ⟨ var_est , any inside'' nds ⟩ ⟩
  where
    n = fromℕ (length xs)

    mean = (sum xs ÷ n)
    var_est = (sum (map (λ{x →(x - mean)^2}) xs) ÷ (n - 1ℝ))

    inside'' : NormalDist → Bool
    inside'' nd = ((μ - zμ * σ) <ᵇ mean) ∧ (mean <ᵇ (μ + zμ * σ))
                ∧ (σ^2 - zσ * std[σ^2] <ᵇ var) ∧ (var <ᵇ σ^2 + zσ * std[σ^2])
      where open NormalDist nd using (μ; σ)
            σ^2 = σ ^2
            --Var[σ^2] = 2 * (σ^2)^2 / n
            std[σ^2] = (√ 2ℝ) * (σ^2 ÷ (√ n))

            -- Notice that the estimated variance here is computed assuming `μ`
            -- it's the mean of the distribution. This is so that Cramer-Rao
            -- lower bound can be applied to it
            var = (sum (map (λ{x →(x - μ)^2}) xs) ÷ n)

nonneg-cf : ℝ → ℝ × Bool
nonneg-cf x = ⟨ x , 0ℝ ≤ᵇ x ⟩

data StallClasses : Set where
  Stall NoStall Uncertain : StallClasses

P[stall]f⟨_|stall⟩_ : ℝ → List (ℝ × ℝ × Dist ℝ) → ℝ
P[stall]f⟨ x |stall⟩ pbs = sum (map unpack pbs)
  where
    unpack : ℝ × ℝ × Dist ℝ → ℝ
    unpack ⟨ P[θ] , ⟨ P[stall|θ] , dist ⟩ ⟩ = pdf x * P[θ] * P[stall|θ]
      where open Dist dist using (pdf)

f⟨_⟩_ : ℝ → List (ℝ × ℝ × Dist ℝ) → ℝ
f⟨ x ⟩ pbs = sum (map unpack pbs)
  where
    unpack : ℝ × ℝ × Dist ℝ → ℝ
    unpack ⟨ P[θ] , ⟨ _ , dist ⟩ ⟩ = pdf x * P[θ]
      where open Dist dist using (pdf)

-- There should be a proof showing that the resulting value will always be in the interval [0,1]
P[_|X=_]_ : StallClasses → ℝ → List (ℝ × ℝ × Dist ℝ) → Maybe ℝ
P[ Stall |X= x ] pbs with f⟨ x ⟩ pbs ≟ 0ℝ
... | yes _ = nothing
... | no _  = just (((P[stall]f⟨ x |stall⟩ pbs) ÷ (f⟨ x ⟩ pbs)))
P[ NoStall |X= x ] pbs with f⟨ x ⟩ pbs ≟ 0ℝ
... | yes _ = nothing
... | no _  = just (1ℝ - ((P[stall]f⟨ x |stall⟩ pbs) ÷ (f⟨ x ⟩ pbs)))
P[ Uncertain |X= _ ] _ = nothing

postulate
  -- TODO: Find out how to prove this!
  -- It probably requires to prove that P[Stall|X=x] + P[NoStall|X=x] ≡ 1
  Stall≡1-NoStall : ∀ {x pbs p}
                  → P[ Stall |X= x ] pbs ≡ just p
                  → P[ NoStall |X= x ] pbs ≡ just (1ℝ - p)
  NoStall≡1-Stall : ∀ {x pbs p}
                  → P[ NoStall |X= x ] pbs ≡ just p
                  → P[ Stall |X= x ] pbs ≡ just (1ℝ - p)

  -- Main assumptions
  --   * 0.5 < τ ≤ 1
  --   * 0 ≤ p ≤ 1
  -- Of course, these assumptions are never explicit in the code. But note
  -- that, only the first assumption can be broken by an user bad input. The
  -- second assumption stems for probability theory, yet not proven but
  -- should be true
  ≤p→¬≤1-p : ∀ {τ p}
           -- This first line are the assumptions. From them, the rest should follow
           → 1/2 < τ → τ ≤ 1ℝ   -- 0.5 < τ ≤ 1
           → 0ℝ ≤ p → p ≤ 1ℝ  -- 0 ≤ p ≤ 1
           → τ ≤ p
           → ¬ τ ≤ (1ℝ - p)
  ≤1-p→¬≤p : ∀ {τ p}
           → 1/2 < τ → τ ≤ 1ℝ  -- 0.5 < τ ≤ 1
           → 0ℝ ≤ p → p ≤ 1ℝ   -- 0 ≤ p ≤ 1
           → τ ≤ (1ℝ - p)
           → ¬ τ ≤ p

classify'' : List (ℝ × ℝ × Dist ℝ) → ℝ → ℝ → StallClasses
classify'' pbs τ x with P[ Stall |X= x ] pbs
...   | nothing = Uncertain
...   | just p with τ ≤? p | τ ≤? (1ℝ - p)
...            | yes _ | no  _ = Stall
...            | no _  | yes _ = NoStall
...            | _     | _     = Uncertain -- the only missing case is `no _ | no _`, `yes _ | yes _` is not possible

M→pbs : Model → List (ℝ × ℝ × Dist ℝ)
M→pbs M = map convert (Model.fM M)
  where
    n = fromℕ (length (Model.fM M))

    convert : (ℝ × ℝ) × (NormalDist × ℝ) → ℝ × ℝ × Dist ℝ
    convert ⟨ _ , ⟨ nd , P[stall|c] ⟩ ⟩ = ⟨ 1/ n , ⟨ P[stall|c] , dist ⟩ ⟩
      where open NormalDist nd using (dist)

classify : Model → ℝ → ℝ → StallClasses
classify M = classify'' (M→pbs M)

no-uncertain : StallClasses → Bool
no-uncertain Uncertain = false
no-uncertain _ = true

τ-confident : Model → ℝ → ℝ → Bool
τ-confident M τ = no-uncertain ∘ classify M τ

safety-envelope : Model → ℝ → ℝ → ℝ → Bool
safety-envelope M z τ x = proj₂ (z-predictable M z x)
                          ∧ τ-confident M τ x


-- Properties of (pre)additive categories
{-# OPTIONS --safe #-}

module Cubical.Categories.Additive.Properties where

open import Cubical.Algebra.AbGroup.Base
open import Cubical.Algebra.Group.Properties
open import Cubical.Categories.Additive.Base
open import Cubical.Foundations.Prelude

private
  variable
    ℓ ℓ' : Level

-- Some useful lemmas about preadditive categories
module PreaddCategoryTheory (C : PreaddCategory ℓ ℓ') where
  open PreaddCategory C

  -- Pure group theory lemmas
  +idl = λ {x y} → AbGroupStr.+IdL (homAbStr x y)
  +idr = λ {x y} → AbGroupStr.+IdR (homAbStr x y)
  +invl = λ {x y} → AbGroupStr.+InvL (homAbStr x y)
  +invr = λ {x y} → AbGroupStr.+InvR (homAbStr x y)
  +assoc = λ {x y} → AbGroupStr.+Assoc (homAbStr x y)
  +comm = λ {x y} → AbGroupStr.+Comm (homAbStr x y)

  -dist+ : {x y : ob} (f g : Hom[ x , y ]) →
      - (f + g) ≡ (- f) + (- g)
  -dist+ {x} {y} f g =
    let open GroupTheory (AbGroup→Group (Hom[ x , y ] , homAbStr x y)) in
      (invDistr _ _) ∙ (+comm _ _)

  +4assoc : {x y : ob} (a b c d : Hom[ x , y ]) →
      (a + b) + (c + d)  ≡  a + (b + c) + d
  +4assoc a b c d = sym (+assoc _ _ _) ∙ cong (a +_) (+assoc _ _ _)

  +4comm : {x y : ob} (a b c d : Hom[ x , y ]) →
      (a + b) + (c + d)  ≡  (a + c) + (b + d)
  +4comm a b c d = +4assoc _ _ _ _ ∙
      cong (λ u → a + (u + d)) (+comm _ _) ∙ sym (+4assoc _ _ _ _)

  -- Interaction of categorical & group structure
  ⋆0hl : ∀ {w x y} (f : Hom[ x , y ]) → 0h ⋆ f ≡ 0h {w}
  ⋆0hl f =
      0h ⋆ f                              ≡⟨ sym (+idr _) ⟩
      0h ⋆ f  +  0h                       ≡⟨ cong (0h ⋆ f +_) (sym (+invr _)) ⟩
      0h ⋆ f  +  (0h ⋆ f  -  0h ⋆ f)      ≡⟨ +assoc _ _ _ ⟩
      (0h ⋆ f  +  0h ⋆ f)  -  0h ⋆ f      ≡⟨ cong (_- 0h ⋆ f) (sym (⋆distr+ _ _ _)) ⟩
      (0h + 0h) ⋆ f  -  0h ⋆ f            ≡⟨ cong (λ a → a ⋆ f - 0h ⋆ f) (+idr _) ⟩
      0h ⋆ f  -  0h ⋆ f                   ≡⟨ +invr _ ⟩
      0h                                  ∎

  ⋆0hr : ∀ {x y z} (f : Hom[ x , y ]) → f ⋆ 0h ≡ 0h {x} {z}
  ⋆0hr f =
      f ⋆ 0h                              ≡⟨ sym (+idr _) ⟩
      f ⋆ 0h  +  0h                       ≡⟨ cong (f ⋆ 0h +_) (sym (+invr _)) ⟩
      f ⋆ 0h  +  (f ⋆ 0h  -  f ⋆ 0h)      ≡⟨ +assoc _ _ _ ⟩
      (f ⋆ 0h  +  f ⋆ 0h)  -  f ⋆ 0h      ≡⟨ cong (_- f ⋆ 0h) (sym (⋆distl+ _ _ _)) ⟩
      f ⋆ (0h + 0h)  -  f ⋆ 0h            ≡⟨ cong (λ a → f ⋆ a - f ⋆ 0h) (+idr _) ⟩
      f ⋆ 0h  -  f ⋆ 0h                   ≡⟨ +invr _ ⟩
      0h                                  ∎

  -distl⋆ : ∀ {x y z} (f : Hom[ x , y ]) (g : Hom[ y , z ])
    → (- f) ⋆ g ≡ - (f ⋆ g)
  -distl⋆ {x} {y} {z} f g =
    let open GroupTheory (AbGroup→Group (Hom[ x , z ] , homAbStr x z)) in
    invUniqueR (
      f ⋆ g + (- f) ⋆ g     ≡⟨ sym (⋆distr+ _ _ _) ⟩
      (f - f) ⋆ g           ≡⟨ cong (_⋆ g) (+invr _) ⟩
      0h ⋆ g                ≡⟨ ⋆0hl _ ⟩
      0h                    ∎
    )

  -distr⋆ : ∀ {x y z} (f : Hom[ x , y ]) (g : Hom[ y , z ])
    → f ⋆ (- g) ≡ - (f ⋆ g)
  -distr⋆ {x} {y} {z} f g =
    let open GroupTheory (AbGroup→Group (Hom[ x , z ] , homAbStr x z)) in
    invUniqueR (
      f ⋆ g + f ⋆ (- g)     ≡⟨ sym (⋆distl+ _ _ _) ⟩
      f ⋆ (g - g)           ≡⟨ cong (f ⋆_) (+invr _) ⟩
      f ⋆ 0h                ≡⟨ ⋆0hr _ ⟩
      0h                    ∎
    )

-- Matrix notation for morphisms  (x₁ ⊕ ⋯ ⊕ xₙ) → (y₁ ⊕ ⋯ ⊕ yₘ)
-- in an additive category
module MatrixNotation (A : AdditiveCategory ℓ ℓ') where
    open AdditiveCategory A
    open PreaddCategoryTheory preaddcat

    -- Polymorphic biproduct morphisms
    i₁ = λ {x y} → Biproduct.i₁ (biprod x y)
    i₂ = λ {x y} → Biproduct.i₂ (biprod x y)
    π₁ = λ {x y} → Biproduct.π₁ (biprod x y)
    π₂ = λ {x y} → Biproduct.π₂ (biprod x y)
    -- and axioms
    i₁⋆π₁ = λ {x y} → Biproduct.i₁⋆π₁ (biprod x y)
    i₁⋆π₂ = λ {x y} → Biproduct.i₁⋆π₂ (biprod x y)
    i₂⋆π₁ = λ {x y} → Biproduct.i₂⋆π₁ (biprod x y)
    i₂⋆π₂ = λ {x y} → Biproduct.i₂⋆π₂ (biprod x y)
    ∑π⋆i  = λ {x y} → Biproduct.∑π⋆i  (biprod x y)

    _∣_ : ∀ {x y y'} → Hom[ x , y ] → Hom[ x , y' ] → Hom[ x , y ⊕ y' ]
    f ∣ f' = (f ⋆ i₁) + (f' ⋆ i₂)
    infixr 5 _∣_

    _`_ : ∀ {y y' z} → Hom[ y , z ] → Hom[ y' , z ] → Hom[ y ⊕ y' , z ]
    g ` g' = (π₁ ⋆ g) + (π₂ ⋆ g')
    infixr 6 _`_

    -- Use the matrix notation like this:
    private module _ (x y : ob) (f : Hom[ x , y ]) where

      h : Hom[ x ⊕ x ⊕ x , y ⊕ y ⊕ y ⊕ y ]

      h =  f  ` - f `  0h   ∣
           0h `  0h `  f    ∣
           f  ` - f `  0h   ∣
           0h `  f  ` f + f

    -- Exchange law
    exchange : ∀ {x x' y y'} (a : Hom[ x , y ]) (b : Hom[ x' , y ])
            (c : Hom[ x , y' ]) (d : Hom[ x' , y' ]) →
        (a ` b ∣ c ` d)  ≡  (a ∣ c) ` (b ∣ d)

    exchange a b c d =
        (π₁ ⋆ a  +  π₂ ⋆ b) ⋆ i₁  +  (π₁ ⋆ c  +  π₂ ⋆ d) ⋆ i₂
                ≡⟨ cong₂ _+_ (⋆distr+ _ _ _) (⋆distr+ _ _ _) ⟩
        ((π₁ ⋆ a) ⋆ i₁  +  (π₂ ⋆ b) ⋆ i₁)  +  ((π₁ ⋆ c) ⋆ i₂  +  (π₂ ⋆ d) ⋆ i₂)
                ≡⟨ +4comm _ _ _ _ ⟩
        ((π₁ ⋆ a) ⋆ i₁  +  (π₁ ⋆ c) ⋆ i₂)  +  ((π₂ ⋆ b) ⋆ i₁  +  (π₂ ⋆ d) ⋆ i₂)
                ≡⟨ cong₂ _+_ (cong₂ _+_ (⋆Assoc _ _ _) (⋆Assoc _ _ _))
                            (cong₂ _+_ (⋆Assoc _ _ _) (⋆Assoc _ _ _)) ⟩
        (π₁ ⋆ (a ⋆ i₁)  +  π₁ ⋆ (c ⋆ i₂))  +  (π₂ ⋆ (b ⋆ i₁)  +  π₂ ⋆ (d ⋆ i₂))
                ≡⟨ sym (cong₂ _+_ (⋆distl+ _ _ _) (⋆distl+ _ _ _)) ⟩
        π₁ ⋆ (a ⋆ i₁  +  c ⋆ i₂)  +  π₂ ⋆ (b ⋆ i₁  +  d ⋆ i₂)
                ∎

    -- iₖ times a row
    module _ {x x' y : ob} (a : Hom[ x , y ]) (b : Hom[ x' , y ]) where

      i₁⋆row :  i₁ ⋆ (a ` b)  ≡  a
      i₁⋆row =
          i₁ ⋆ (π₁ ⋆ a  +  π₂ ⋆ b)
                  ≡⟨ ⋆distl+ _ _ _ ⟩
          i₁ ⋆ (π₁ ⋆ a)  +  i₁ ⋆ (π₂ ⋆ b)
                  ≡⟨ cong₂ _+_ (sym (⋆Assoc _ _ _)) (sym (⋆Assoc _ _ _)) ⟩
          (i₁ ⋆ π₁) ⋆ a  +  (i₁ ⋆ π₂) ⋆ b
                  ≡⟨ cong₂ (λ u v → u ⋆ a + v ⋆ b) i₁⋆π₁ i₁⋆π₂ ⟩
          id ⋆ a  +  0h ⋆ b
                  ≡⟨ cong₂ _+_ (⋆IdL _) (⋆0hl _) ⟩
          a  +  0h
                  ≡⟨ +idr _ ⟩
          a       ∎

      i₂⋆row :  i₂ ⋆ (a ` b)  ≡  b
      i₂⋆row =
          i₂ ⋆ (π₁ ⋆ a  +  π₂ ⋆ b)
                  ≡⟨ ⋆distl+ _ _ _ ⟩
          i₂ ⋆ (π₁ ⋆ a)  +  i₂ ⋆ (π₂ ⋆ b)
                  ≡⟨ cong₂ _+_ (sym (⋆Assoc _ _ _)) (sym (⋆Assoc _ _ _)) ⟩
          (i₂ ⋆ π₁) ⋆ a  +  (i₂ ⋆ π₂) ⋆ b
                  ≡⟨ cong₂ (λ u v → u ⋆ a + v ⋆ b) i₂⋆π₁ i₂⋆π₂ ⟩
          0h ⋆ a  +  id ⋆ b
                  ≡⟨ cong₂ _+_ (⋆0hl _) (⋆IdL _) ⟩
          0h  +  b
                  ≡⟨ +idl _ ⟩
          b       ∎

    -- A column times πₖ
    module _ {x y y' : ob} (a : Hom[ x , y ]) (b : Hom[ x , y' ]) where

      col⋆π₁ :  (a ∣ b) ⋆ π₁  ≡  a
      col⋆π₁ =
          (a ⋆ i₁  +  b ⋆ i₂) ⋆ π₁
                  ≡⟨ ⋆distr+ _ _ _ ⟩
          (a ⋆ i₁) ⋆ π₁  +  (b ⋆ i₂) ⋆ π₁
                  ≡⟨ cong₂ _+_ (⋆Assoc _ _ _) (⋆Assoc _ _ _) ⟩
          a ⋆ (i₁ ⋆ π₁)  +  b ⋆ (i₂ ⋆ π₁)
                  ≡⟨ cong₂ (λ u v → a ⋆ u + b ⋆ v) i₁⋆π₁ i₂⋆π₁ ⟩
          a ⋆ id  +  b ⋆ 0h
                  ≡⟨ cong₂ _+_ (⋆IdR _) (⋆0hr _) ⟩
          a  +  0h
                  ≡⟨ +idr _ ⟩
          a       ∎

      col⋆π₂ :  (a ∣ b) ⋆ π₂  ≡  b
      col⋆π₂ =
          (a ⋆ i₁  +  b ⋆ i₂) ⋆ π₂
                  ≡⟨ ⋆distr+ _ _ _ ⟩
          (a ⋆ i₁) ⋆ π₂  +  (b ⋆ i₂) ⋆ π₂
                  ≡⟨ cong₂ _+_ (⋆Assoc _ _ _) (⋆Assoc _ _ _) ⟩
          a ⋆ (i₁ ⋆ π₂)  +  b ⋆ (i₂ ⋆ π₂)
                  ≡⟨ cong₂ (λ u v → a ⋆ u + b ⋆ v) i₁⋆π₂ i₂⋆π₂ ⟩
          a ⋆ 0h  +  b ⋆ id
                  ≡⟨ cong₂ _+_ (⋆0hr _) (⋆IdR _) ⟩
          0h  +  b
                  ≡⟨ +idl _ ⟩
          b       ∎

    -- iₖ / πₖ times a diagonal matrix
    module _ {x x' y y'} (a : Hom[ x , y ]) (b : Hom[ x' , y' ]) where

      i₁⋆diag :  i₁ ⋆ (a ` 0h ∣ 0h ` b)  ≡  a ⋆ i₁
      i₁⋆diag =
          i₁ ⋆ (a ` 0h ∣ 0h ` b)          ≡⟨ cong (i₁ ⋆_) (exchange _ _ _ _) ⟩
          i₁ ⋆ ((a ∣ 0h) ` (0h ∣ b))      ≡⟨ i₁⋆row _ _ ⟩
          (a ∣ 0h)                        ≡⟨ cong (a ⋆ i₁ +_) (⋆0hl _) ⟩
          a ⋆ i₁  +  0h                   ≡⟨ +idr _ ⟩
          a ⋆ i₁                          ∎

      i₂⋆diag :  i₂ ⋆ (a ` 0h ∣ 0h ` b)  ≡  b ⋆ i₂
      i₂⋆diag =
          i₂ ⋆ (a ` 0h ∣ 0h ` b)          ≡⟨ cong (i₂ ⋆_) (exchange _ _ _ _) ⟩
          i₂ ⋆ ((a ∣ 0h) ` (0h ∣ b))      ≡⟨ i₂⋆row _ _ ⟩
          (0h ∣ b)                        ≡⟨ cong (_+ b ⋆ i₂) (⋆0hl _) ⟩
          0h  +  b ⋆ i₂                   ≡⟨ +idl _ ⟩
          b ⋆ i₂                          ∎

      diag⋆π₁ :  (a ` 0h ∣ 0h ` b) ⋆ π₁  ≡  π₁ ⋆ a
      diag⋆π₁ =
          (a ` 0h ∣ 0h ` b) ⋆ π₁      ≡⟨ col⋆π₁ _ _ ⟩
          a ` 0h                      ≡⟨ cong (π₁ ⋆ a +_) (⋆0hr _) ⟩
          π₁ ⋆ a  +  0h               ≡⟨ +idr _ ⟩
          π₁ ⋆ a                      ∎

      diag⋆π₂ :  (a ` 0h ∣ 0h ` b) ⋆ π₂  ≡  π₂ ⋆ b
      diag⋆π₂ =
          (a ` 0h ∣ 0h ` b) ⋆ π₂      ≡⟨ col⋆π₂ _ _ ⟩
          0h ` b                      ≡⟨ cong (_+ π₂ ⋆ b) (⋆0hr _) ⟩
          0h  +  π₂ ⋆ b               ≡⟨ +idl _ ⟩
          π₂ ⋆ b                      ∎

    -- Matrix addition
    addRow : ∀ {x y z}
        (f f' : Hom[ x , z ]) (g g' : Hom[ y , z ]) →
        (f ` g) + (f' ` g') ≡ (f + f') ` (g + g')

    addRow f f' g g' =
        (π₁ ⋆ f + π₂ ⋆ g) + (π₁ ⋆ f' + π₂ ⋆ g')
                ≡⟨ +4comm _ _ _ _ ⟩
        (π₁ ⋆ f + π₁ ⋆ f') + (π₂ ⋆ g + π₂ ⋆ g')
                ≡⟨ sym (cong₂ _+_ (⋆distl+ _ _ _) (⋆distl+ _ _ _)) ⟩
        π₁ ⋆ (f + f') + π₂ ⋆ (g + g')
                ∎

    addCol : ∀ {x y z}
        (f f' : Hom[ x , y ]) (g g' : Hom[ x , z ]) →
        (f ∣ g) + (f' ∣ g') ≡ (f + f') ∣ (g + g')

    addCol f f' g g' =
        (f ⋆ i₁ + g ⋆ i₂) + (f' ⋆ i₁ + g' ⋆ i₂)
                ≡⟨ +4comm _ _ _ _ ⟩
        (f ⋆ i₁ + f' ⋆ i₁) + (g ⋆ i₂ + g' ⋆ i₂)
                ≡⟨ sym (cong₂ _+_ (⋆distr+ _ _ _) (⋆distr+ _ _ _)) ⟩
        (f + f') ⋆ i₁ + (g + g') ⋆ i₂
                ∎

    private
      ⋆4assoc : ∀ {x y z w v} (a : Hom[ x , y ]) (b : Hom[ y , z ])
              (c : Hom[ z , w ]) (d : Hom[ w , v ]) →
          (a ⋆ b) ⋆ (c ⋆ d) ≡ a ⋆ (b ⋆ c) ⋆ d
      ⋆4assoc a b c d = (⋆Assoc _ _ _) ∙ cong (a ⋆_) (sym (⋆Assoc _ _ _))

      ⋆4assoc' : ∀ {x y z w v} (a : Hom[ x , y ]) (b : Hom[ y , z ])
              (c : Hom[ z , w ]) (d : Hom[ w , v ]) →
          (a ⋆ b) ⋆ (c ⋆ d) ≡ (a ⋆ (b ⋆ c)) ⋆ d
      ⋆4assoc' a b c d = sym (⋆Assoc _ _ _) ∙ cong (_⋆ d) (⋆Assoc _ _ _)

    -- Matrix multiplication
    innerProd : ∀ {x y₁ y₂ z} (f₁ : Hom[ x , y₁ ]) (g₁ : Hom[ y₁ , z ])
                              (f₂ : Hom[ x , y₂ ]) (g₂ : Hom[ y₂ , z ]) →
        (f₁ ∣ f₂) ⋆ (g₁ ` g₂) ≡ (f₁ ⋆ g₁) + (f₂ ⋆ g₂)

    innerProd f₁ g₁ f₂ g₂ =
        (f₁ ⋆ i₁ + f₂ ⋆ i₂) ⋆ (π₁ ⋆ g₁ + π₂ ⋆ g₂)
                ≡⟨ ⋆distr+ _ _ _ ⟩
        (f₁ ⋆ i₁) ⋆ (π₁ ⋆ g₁ + π₂ ⋆ g₂)  +  (f₂ ⋆ i₂) ⋆ (π₁ ⋆ g₁ + π₂ ⋆ g₂)
                ≡⟨ cong₂ _+_ (⋆distl+ _ _ _) (⋆distl+ _ _ _) ⟩
        ((f₁ ⋆ i₁) ⋆ (π₁ ⋆ g₁)  +  (f₁ ⋆ i₁) ⋆ (π₂ ⋆ g₂))
            +  (f₂ ⋆ i₂) ⋆ (π₁ ⋆ g₁)  +  (f₂ ⋆ i₂) ⋆ (π₂ ⋆ g₂)
                ≡⟨ cong₂ _+_ (cong₂ _+_ eq₁₁ eq₁₂) (cong₂ _+_ eq₂₁ eq₂₂) ⟩
        (f₁ ⋆ g₁  +  0h)  +  0h  +  f₂ ⋆ g₂
                ≡⟨ cong₂ _+_ (+idr _) (+idl _) ⟩
        (f₁ ⋆ g₁) + (f₂ ⋆ g₂)
                ∎
     where
      eq₁₁ = (f₁ ⋆ i₁) ⋆ (π₁ ⋆ g₁)      ≡⟨ ⋆4assoc _ _ _ _ ⟩
             f₁ ⋆ (i₁ ⋆ π₁) ⋆ g₁        ≡⟨ cong (λ u → _ ⋆ u ⋆ _) i₁⋆π₁ ⟩
             f₁ ⋆ id ⋆ g₁               ≡⟨ cong (f₁ ⋆_) (⋆IdL _) ⟩
             f₁ ⋆ g₁                    ∎

      eq₁₂ = (f₁ ⋆ i₁) ⋆ (π₂ ⋆ g₂)      ≡⟨ ⋆4assoc _ _ _ _ ⟩
             f₁ ⋆ (i₁ ⋆ π₂) ⋆ g₂        ≡⟨ cong (λ u → _ ⋆ u ⋆ _) i₁⋆π₂ ⟩
             f₁ ⋆ 0h ⋆ g₂               ≡⟨ cong (f₁ ⋆_) (⋆0hl _) ⟩
             f₁ ⋆ 0h                    ≡⟨ ⋆0hr _ ⟩
             0h                         ∎

      eq₂₁ = (f₂ ⋆ i₂) ⋆ (π₁ ⋆ g₁)      ≡⟨ ⋆4assoc _ _ _ _ ⟩
             f₂ ⋆ (i₂ ⋆ π₁) ⋆ g₁        ≡⟨ cong (λ u → _ ⋆ u ⋆ _) i₂⋆π₁ ⟩
             f₂ ⋆ 0h ⋆ g₁               ≡⟨ cong (f₂ ⋆_) (⋆0hl _) ⟩
             f₂ ⋆ 0h                    ≡⟨ ⋆0hr _ ⟩
             0h                         ∎

      eq₂₂ = (f₂ ⋆ i₂) ⋆ (π₂ ⋆ g₂)      ≡⟨ ⋆4assoc _ _ _ _ ⟩
             f₂ ⋆ (i₂ ⋆ π₂) ⋆ g₂        ≡⟨ cong (λ u → _ ⋆ u ⋆ _) i₂⋆π₂ ⟩
             f₂ ⋆ id ⋆ g₂               ≡⟨ cong (f₂ ⋆_) (⋆IdL _) ⟩
             f₂ ⋆ g₂                    ∎

    outerProd : ∀ {x₁ x₂ y z₁ z₂} (f₁ : Hom[ x₁ , y ]) (g₁ : Hom[ y , z₁ ])
                                  (f₂ : Hom[ x₂ , y ]) (g₂ : Hom[ y , z₂ ]) →

        (f₁ ` f₂) ⋆ (g₁ ∣ g₂)  ≡  f₁ ⋆ g₁ ` f₂ ⋆ g₁ ∣
                                  f₁ ⋆ g₂ ` f₂ ⋆ g₂

    outerProd {y = y} f₁ g₁ f₂ g₂ =
        (π₁ ⋆ f₁  +  π₂ ⋆ f₂) ⋆ (g₁ ⋆ i₁  +  g₂ ⋆ i₂)
                ≡⟨ ⋆distl+ _ _ _ ⟩
        (π₁ ⋆ f₁  +  π₂ ⋆ f₂) ⋆ (g₁ ⋆ i₁)  +  (π₁ ⋆ f₁  +  π₂ ⋆ f₂) ⋆ (g₂ ⋆ i₂)
                ≡⟨ cong₂ _+_ (eq g₁ i₁) (eq g₂ i₂) ⟩
           (π₁ ⋆ (f₁ ⋆ g₁)  +  π₂ ⋆ (f₂ ⋆ g₁)) ⋆ i₁
        +  (π₁ ⋆ (f₁ ⋆ g₂)  +  π₂ ⋆ (f₂ ⋆ g₂)) ⋆ i₂
                ∎
     where
      eq = λ {z w} (g : Hom[ y , z ]) (i : Hom[ z , w ]) →
        (π₁ ⋆ f₁  +  π₂ ⋆ f₂) ⋆ (g ⋆ i)
                ≡⟨ ⋆distr+ _ _ _ ⟩
        (π₁ ⋆ f₁) ⋆ (g ⋆ i)  +  (π₂ ⋆ f₂) ⋆ (g ⋆ i)
                ≡⟨ cong₂ _+_ (⋆4assoc' _ _ _ _) (⋆4assoc' _ _ _ _) ⟩
        (π₁ ⋆ (f₁ ⋆ g)) ⋆ i  +  (π₂ ⋆ (f₂ ⋆ g)) ⋆ i
                ≡⟨ sym (⋆distr+ _ _ _) ⟩
        (π₁ ⋆ (f₁ ⋆ g)  +  π₂ ⋆ (f₂ ⋆ g)) ⋆ i
                    ∎


{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Join where

open import Cubical.HITs.Join.Base public

-- open import Cubical.HITs.Join.Properties public


-- Andreas, 2016-01-21, issue 1791
-- With-clause stripping for copatterns with "polymorphic" field.

-- {-# OPTIONS --show-implicit #-}
-- {-# OPTIONS -v tc.with.strip:60 #-}

postulate anything : ∀{A : Set} → A

record Wrap (A : Set) : Set where
  field unwrap : A

module VisibleWorks where

  -- monomorphic field

  record Pointed (M : Set → Set) : Set₁ where
    field point : ∀ A → M A

  test : Pointed Wrap
  Wrap.unwrap (Pointed.point test A) with Set₂
  ... | _ = anything

-- polymorphic field

record Pointed (M : Set → Set) : Set₁ where
  field point : ∀{A} → M A

module ExplicitWorks where

  test : Pointed Wrap
  Wrap.unwrap (Pointed.point test {A}) with Set₂
  ... | _ = anything

-- WAS: hidden fails

test : Pointed Wrap
Wrap.unwrap (Pointed.point test) with Set₂
... | _ = anything

-- should succeed


------------------------------------------------------------------------------
-- Theory T from the paper
------------------------------------------------------------------------------

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

module T where

infixl 9 _·_  -- The symbol is '\cdot'.
infix  7 _≡_

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

postulate
  T        : Set
  zero K S : T
  succ     : T → T
  _·_      : T → T → T

-- The identity type on the universe of discourse.
data _≡_ (x : T) : T → Set where
  refl : x ≡ x

-- Conversion rules
postulate
  cK : ∀ x y → K · x · y         ≡ x
  cS : ∀ x y z → S · x ·  y ·  z ≡ x ·  z ·  (y ·  z)


{-# OPTIONS --safe #-}

module Definition.Typed.EqRelInstance where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties
open import Definition.Typed.Weakening
open import Definition.Typed.Properties
open import Definition.Typed.Reduction
open import Definition.Typed.EqualityRelation

open import Tools.Function

Urefl   : ∀ {r l Γ} → ⊢ Γ → Γ ⊢ (Univ r l) ≡ (Univ r l) ^ [ ! , next l ]
Urefl {l = ⁰} ⊢Γ = refl (univ (univ 0<1 ⊢Γ))
Urefl {l = ¹} ⊢Γ = refl (Uⱼ ⊢Γ)

instance eqRelInstance : EqRelSet
eqRelInstance = eqRel _⊢_≡_^_ _⊢_≡_∷_^_ _⊢_≡_∷_^_
                      idᶠ idᶠ idᶠ univ un-univ≡
                      sym genSym genSym trans genTrans genTrans
                      conv conv wkEq wkEqTerm wkEqTerm
                      reduction reductionₜ
                      Urefl (refl ∘ᶠ univ 0<1) (refl ∘ᶠ ℕⱼ) (refl ∘ᶠ Emptyⱼ)
                      Π-cong ∃-cong (refl ∘ᶠ zeroⱼ) suc-cong
                      (λ lF lG x x₁ x₂ x₃ x₄ x₅ → η-eq lF lG x x₁ x₂ x₅)
                      genVar app-cong natrec-cong Emptyrec-cong
                      Id-cong
                      (λ ⊢Γ → Id-cong (refl (ℕⱼ ⊢Γ)))
                      (λ ⊢Γ → Id-cong (refl (ℕⱼ ⊢Γ)) (refl (zeroⱼ ⊢Γ)))
                      (λ ⊢Γ t → Id-cong (refl (ℕⱼ ⊢Γ)) (suc-cong t))
                      (λ ⊢Γ → Id-cong (refl (univ 0<1 ⊢Γ)))
                      (λ ⊢Γ → Id-cong (refl (univ 0<1 ⊢Γ)) (refl (ℕⱼ ⊢Γ)))
                      (λ ⊢A B → Id-cong (refl (univ 0<1 (wfEq (univ ⊢A)))) ⊢A B)
                      cast-cong
                      (λ ⊢Γ → cast-cong (refl (ℕⱼ ⊢Γ)))
                      (λ ⊢Γ → cast-cong (refl (ℕⱼ ⊢Γ)) (refl (ℕⱼ ⊢Γ)))
                      cast-cong
                      (λ ⊢A ⊢P P → cast-cong (refl (ℕⱼ (wf (univ ⊢A)))) P)
                      (λ ⊢A ⊢P P → cast-cong P (refl (ℕⱼ (wf (univ ⊢A)))))
                      (λ ⊢A ⊢P P ⊢A' ⊢P' P' → cast-cong P P')
                      (λ ⊢A ⊢P P ⊢A' ⊢P' P' → cast-cong P P')
                      proof-irrelevance