------------------------------------------------------------------------------
-- Miscellaneous properties
------------------------------------------------------------------------------

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

module FOTC.Program.SortList.Properties.MiscellaneousI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.Bool
open import FOTC.Data.Bool.PropertiesI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.List.PropertiesI
open import FOTC.Data.Nat.List.Type
open import FOTC.Data.Nat.Type
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Program.SortList.Properties.Totality.BoolI
open import FOTC.Program.SortList.SortList

------------------------------------------------------------------------------
-- This is a weird result but recall that "the relation ≤ between
-- lists is only an ordering if nil is excluded" (Burstall 1969,
-- p. 46).
-- xs≤[] : ∀ {is} → ListN is → OrdList is → LE-Lists is []
-- xs≤[] lnnil                     _       = ≤-Lists-[] []
-- xs≤[] (lncons {i} {is} Ni LNis) LOconsL =
--   begin
--     ≤-Lists (i ∷ is) []
--       ≡⟨ ≤-Lists-∷ i is [] ⟩
--     ≤-ItemList i [] && ≤-Lists is []
--       ≡⟨ subst (λ t → ≤-ItemList i [] && ≤-Lists is [] ≡ t && ≤-Lists is [])
--                (≤-ItemList-[] i)
--                refl
--       ⟩
--     true && ≤-Lists is []
--       ≡⟨ subst (λ t → true && ≤-Lists is [] ≡ true && t)
--                (xs≤[] LNis (subList-OrdList Ni LNis LOconsL))
--                refl
--       ⟩
--     true && true
--       ≡⟨ &&-tt ⟩
--     true
--   ∎

x≤ys++zs→x≤zs : ∀ {i js ks} → N i → ListN js → ListN ks →
                ≤-ItemList i (js ++ ks) → ≤-ItemList i ks
x≤ys++zs→x≤zs {i} {ks = ks} Ni lnnil LNks  i≤[]++ks =
  subst (≤-ItemList i) (++-leftIdentity ks) i≤[]++ks
x≤ys++zs→x≤zs {i} {ks = ks} Ni (lncons {j} {js} Nj LNjs) LNks i≤j∷js++ks =
  x≤ys++zs→x≤zs Ni LNjs LNks lemma₂
  where
  lemma₁ : le i j && le-ItemList i (js ++ ks) ≡ true
  lemma₁ =
    le i j && le-ItemList i (js ++ ks)
      ≡⟨ sym (le-ItemList-∷ i j (js ++ ks)) ⟩
    le-ItemList i (j ∷ (js ++ ks))
      ≡⟨ subst (λ t → le-ItemList i (j ∷ (js ++ ks)) ≡ le-ItemList i t)
               (sym (++-∷ j js ks))
               refl
      ⟩
    le-ItemList i ((j ∷ js) ++ ks) ≡⟨ i≤j∷js++ks ⟩
    true ∎

  lemma₂ : ≤-ItemList i (js ++ ks)
  lemma₂ = &&-list₂-t₂ (le-Bool Ni Nj)
                       (le-ItemList-Bool Ni (++-ListN LNjs LNks))
                       lemma₁

xs++ys-OrdList→xs≤ys : ∀ {is js} → ListN is → ListN js →
                       OrdList (is ++ js) → ≤-Lists is js
xs++ys-OrdList→xs≤ys {js = js} lnnil LNjs OLis++js = le-Lists-[] js
xs++ys-OrdList→xs≤ys {js = js} (lncons {i} {is} Ni LNis) LNjs OLis++js =
  le-Lists (i ∷ is) js
    ≡⟨ le-Lists-∷ i is js ⟩
  le-ItemList i js && le-Lists is js
    ≡⟨ subst (λ t → le-ItemList i js && le-Lists is js ≡
                    t && le-Lists is js)
             (x≤ys++zs→x≤zs Ni LNis LNjs lemma₁)
             refl
    ⟩
  true && le-Lists is js
    ≡⟨ subst (λ t → true && le-Lists is js ≡ true && t)
             (xs++ys-OrdList→xs≤ys LNis LNjs lemma₂)  --IH.
             refl
    ⟩
  true && true
    ≡⟨ t&&x≡x true ⟩
  true ∎
  where
  lemma₀ : le-ItemList i (is ++ js) && ordList (is ++ js) ≡ true
  lemma₀ = trans (sym (ordList-∷ i (is ++ js)))
                 (trans (subst (λ t → ordList (i ∷ is ++ js) ≡ ordList t)
                               (sym (++-∷ i is js))
                               refl)
                 OLis++js)

  helper₁ : Bool (le-ItemList i (is ++ js))
  helper₁ = le-ItemList-Bool Ni (++-ListN LNis LNjs)

  helper₂ : Bool (ordList (is ++ js))
  helper₂ = ordList-Bool (++-ListN LNis LNjs)

  lemma₁ : le-ItemList i (is ++ js) ≡ true
  lemma₁ = &&-list₂-t₁ helper₁ helper₂ lemma₀

  lemma₂ : ordList (is ++ js) ≡ true
  lemma₂ = &&-list₂-t₂ helper₁ helper₂ lemma₀

x≤ys→x≤zs→x≤ys++zs : ∀ {i js ks} → N i → ListN js → ListN ks →
                     ≤-ItemList i js →
                     ≤-ItemList i ks →
                     ≤-ItemList i (js ++ ks)
x≤ys→x≤zs→x≤ys++zs {i} {ks = ks} Ni lnnil LNks _ i≤k =
  subst (≤-ItemList i) (sym (++-leftIdentity ks)) i≤k
x≤ys→x≤zs→x≤ys++zs {i} {ks = ks} Ni (lncons {j} {js} Nj LNjs) LNks i≤j∷js i≤k =
  le-ItemList i ((j ∷ js) ++ ks)
    ≡⟨ subst (λ t → le-ItemList i ((j ∷ js) ++ ks) ≡
                    le-ItemList i t)
             (++-∷ j js ks)
             refl
    ⟩
  le-ItemList i (j ∷ (js ++ ks))
    ≡⟨ le-ItemList-∷ i j (js ++ ks) ⟩
  le i j && le-ItemList i (js ++ ks)
    ≡⟨ subst₂ (λ t₁ t₂ → le i j && le-ItemList i (js ++ ks) ≡ t₁ && t₂)
              (&&-list₂-t₁ helper₁ helper₂ helper₃)
              (x≤ys→x≤zs→x≤ys++zs Ni LNjs LNks
                                  (&&-list₂-t₂ helper₁ helper₂ helper₃)
                                  i≤k)
              refl
    ⟩
  true && true
    ≡⟨ t&&x≡x true ⟩
  true ∎
  where
  helper₁ : Bool (le i j)
  helper₁ = le-Bool Ni Nj

  helper₂ : Bool (le-ItemList i js)
  helper₂ = le-ItemList-Bool Ni LNjs

  helper₃ : le i j && (le-ItemList i js) ≡ true
  helper₃ = trans (sym (le-ItemList-∷ i j js)) i≤j∷js

xs≤ys→xs≤zs→xs≤ys++zs : ∀ {is js ks} → ListN is → ListN js → ListN ks →
                        ≤-Lists is js →
                        ≤-Lists is ks →
                        ≤-Lists is (js ++ ks)
xs≤ys→xs≤zs→xs≤ys++zs lnnil LNjs LNks _ _ = le-Lists-[] _
xs≤ys→xs≤zs→xs≤ys++zs {js = js} {ks} (lncons {i} {is} Ni LNis)
                      LNjs LNks i∷is≤js i∷is≤ks =
  le-Lists (i ∷ is) (js ++ ks)
    ≡⟨ le-Lists-∷ i is (js ++ ks)  ⟩
  le-ItemList i (js ++ ks) && le-Lists is (js ++ ks)
    ≡⟨ subst (λ t → le-ItemList i (js ++ ks) && le-Lists is (js ++ ks) ≡
                    t                       && le-Lists is (js ++ ks))
             (x≤ys→x≤zs→x≤ys++zs Ni LNjs LNks
                                 (&&-list₂-t₁ helper₁ helper₂ helper₃)
                                 (&&-list₂-t₁ helper₄ helper₅ helper₆))
             refl
    ⟩
  true && le-Lists is (js ++ ks)
    ≡⟨ subst (λ t → true && le-Lists is (js ++ ks) ≡ true && t)
             (xs≤ys→xs≤zs→xs≤ys++zs LNis LNjs LNks
                                    (&&-list₂-t₂ helper₁ helper₂ helper₃)
                                    (&&-list₂-t₂ helper₄ helper₅ helper₆))
             refl
    ⟩
  true && true
    ≡⟨ t&&x≡x true ⟩
  true ∎
  where
  helper₁ = le-ItemList-Bool Ni LNjs
  helper₂ = le-Lists-Bool LNis LNjs
  helper₃ = trans (sym (le-Lists-∷ i is js)) i∷is≤js

  helper₄ = le-ItemList-Bool Ni LNks
  helper₅ = le-Lists-Bool LNis LNks
  helper₆ = trans (sym (le-Lists-∷ i is ks)) i∷is≤ks

xs≤zs→ys≤zs→xs++ys≤zs : ∀ {is js ks} → ListN is → ListN js → ListN ks →
                        ≤-Lists is ks →
                        ≤-Lists js ks →
                        ≤-Lists (is ++ js) ks
xs≤zs→ys≤zs→xs++ys≤zs {js = js} {ks} lnnil LNjs LNks is≤ks js≤ks =
  subst (λ t → ≤-Lists t ks)
        (sym (++-leftIdentity js))
        js≤ks
xs≤zs→ys≤zs→xs++ys≤zs {js = js} {ks}
                      (lncons {i} {is} Ni LNis) LNjs LNks i∷is≤ks js≤ks =
  le-Lists ((i ∷ is) ++ js) ks
    ≡⟨ subst (λ t → le-Lists ((i ∷ is) ++ js) ks ≡ le-Lists t ks)
             (++-∷ i is js)
             refl
    ⟩
    le-Lists (i ∷ (is ++ js)) ks
    ≡⟨ le-Lists-∷ i (is ++ js) ks ⟩
  le-ItemList i ks && le-Lists (is ++ js) ks
    ≡⟨ subst₂ (λ x y → le-ItemList i ks && le-Lists (is ++ js) ks ≡ x && y)
              ≤-ItemList-i-ks
              ≤-Lists-is++js-ks
              refl
    ⟩
  true && true
    ≡⟨ t&&x≡x true ⟩
  true ∎
  where
  helper₁ = le-ItemList-Bool Ni LNks
  helper₂ = le-Lists-Bool LNis LNks
  helper₃ = trans (sym (le-Lists-∷ i is ks)) i∷is≤ks

  ≤-ItemList-i-ks : ≤-ItemList i ks
  ≤-ItemList-i-ks = &&-list₂-t₁ helper₁ helper₂ helper₃

  ≤-Lists-is++js-ks : ≤-Lists (is ++ js) ks
  ≤-Lists-is++js-ks =
    xs≤zs→ys≤zs→xs++ys≤zs LNis LNjs LNks
                          (&&-list₂-t₂ helper₁ helper₂ helper₃)
                          js≤ks

------------------------------------------------------------------------------
-- References
--
-- Burstall, R. M. (1969). Proving properties of programs by
-- structural induction. The Computer Journal 12.1, pp. 41–48.


open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym)
open import Function.Equivalence using (_⇔_; equivalence; Equivalence)
open import Data.Bool using (Bool; true; false; if_then_else_)
open import Data.Product using (_×_; _,_; proj₁; proj₂)
open import Data.Sum using (_⊎_)

open import IMP
open import OperationalSemantics
open import Hoare

wp : ∀{l} → com → assn {l} → assn {l}
wp c Q s = ∀ t → ⦅ c , s ⦆⇒ t → Q t

fatto : ∀{P Q : assn} {c}
      → ⊨[ P ] c [ Q ]
      → (∀ s → P s → wp c Q s)
fatto = λ z s z₁ t → z z₁

fatto-converse : ∀{P Q : assn} {c}
      → (∀ s → P s → wp c Q s)
      → ⊨[ P ] c [ Q ]
fatto-converse = (λ z {s} {t} z₁ → z s z₁ t)

wp-hoare : ∀ c {l} {Q : assn {l}}
  → ⊢[ wp c Q ] c [ Q ]
wp-hoare SKIP = Conseq (λ s z → z s Skip) Skip (λ s z → z)
wp-hoare (x ::= a) = Conseq (λ s wpe → wpe (s [ x ::= aval a s ]) Loc) Loc (λ s r → r)
wp-hoare (c :: c₁) = Comp (Conseq (λ s z x x₁ x₂ x₃ → z x₂ (Comp x₁ x₃)) (wp-hoare c) (λ s z → z)) (wp-hoare c₁)
wp-hoare (IF x THEN c ELSE c₁) = If (Conseq (λ s z x x₁ → proj₁ z x (IfTrue (proj₂ z) x₁)) (wp-hoare c) (λ s z → z))
                                    (Conseq (λ s z x x₁ → proj₁ z x (IfFalse (proj₂ z) x₁)) (wp-hoare c₁) (λ s z → z))
wp-hoare (WHILE b DO c) =
  Conseq (λ s x → x)
         (While (Conseq (λ s z x x₁ x₂ x₃ → proj₁ z x₂ (WhileTrue (proj₂ z) x₁ x₃))
                        (wp-hoare c)
                        (λ s z → z)))
         (λ s z → proj₁ z s (WhileFalse (proj₂ z)))

completeness : ∀ c {P Q : assn}
  → ⊨[ P ] c [ Q ]
  → ⊢[ P ] c [ Q ]
completeness c cc = Conseq (fatto cc) (wp-hoare c) (λ r x → x)


-- Andreas, 2014-01-08, following Maxime Denes 2014-01-06

-- This file demonstrates that size-based termination does
-- not lead to incompatibility with HoTT.

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

open import Common.Size
open import Common.Equality

data Empty : Set where

data Box : Size → Set where
  wrap : ∀ i → (Empty → Box i) → Box (↑ i)

-- Box is inhabited at each stage > 0:

gift : ∀ {i} → Empty → Box i
gift ()

box : ∀ {i} → Box (↑ i)
box {i} = wrap i gift

-- wrap has an inverse:

unwrap : ∀ i → Box (↑ i) → (Empty → Box i)
unwrap .i (wrap i f) = f

-- There is an isomorphism between (Empty → Box ∞) and (Box ∞)
-- but none between (Empty → Box i) and (Box i).
-- We only get the following, but it is not sufficient to
-- produce the loop.

postulate iso : ∀ i → (Empty → Box i) ≡ Box (↑ i)

-- Since Agda's termination checker uses the structural order
-- in addition to sized types, we need to conceal the subterm.

conceal : {A : Set} → A → A
conceal x = x

mutual
  loop : ∀ i → Box i → Empty
  loop .(↑ i) (wrap i x) = loop' (↑ i) (Empty → Box i) (iso i) (conceal x)

  -- We would like to write  loop' i  instead of  loop' (↑ i)
  -- but this is ill-typed.  Thus, we cannot achieve something
  -- well-founded wrt. to sized types.

  loop' : ∀ i A → A ≡ Box i → A → Empty
  loop' i .(Box i) refl x = loop i x

-- The termination checker complains here, rightfully!

bug : Empty
bug = loop ∞ box


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Bags with negative multiplicities, for Nehemiah.
--
-- Instead of implementing bags (with negative multiplicities,
-- like in the paper) in Agda, we postulate that a group of such
-- bags exist. Note that integer bags with integer multiplicities
-- are actually the free group given a singleton operation
-- `Integer -> Bag`, so this should be easy to formalize in
-- principle.
------------------------------------------------------------------------
module Postulate.Bag-Nehemiah where

-- Postulates about bags of integers, version Nehemiah
--
-- This module postulates bags of integers with negative
-- multiplicities as a group under additive union.

open import Relation.Binary.PropositionalEquality
open import Algebra.Structures
open import Data.Integer

-- postulate Bag as an abelion group
postulate Bag : Set
-- singleton
postulate singletonBag : ℤ → Bag
-- union
postulate _++_ : Bag → Bag → Bag
infixr 5 _++_
-- negate = mapMultiplicities (λ z → - z)
postulate negateBag : Bag → Bag
postulate emptyBag : Bag
instance
  postulate abelian-bag : IsAbelianGroup _≡_ _++_ emptyBag negateBag

-- Naming convention follows Algebra.Morphism
-- Homomorphic₁ : morphism preserves negation
Homomorphic₁ :
  {A B : Set} (f : A → B) (negA : A → A) (negB : B → B) → Set
Homomorphic₁ {A} {B} f negA negB = ∀ {x} → f (negA x) ≡ negB (f x)

-- Homomorphic₂ : morphism preserves binary operation.
Homomorphic₂ :
  {A B : Set} (f : A → B) (_+_ : A → A → A) (_*_ : B → B → B) → Set
Homomorphic₂ {A} {B} f _+_ _*_ = ∀ {x y} → f (x + y) ≡ f x * f y

-- postulate map, flatmap and sum to be homomorphisms
postulate mapBag : (f : ℤ → ℤ) (b : Bag) → Bag
postulate flatmapBag : (f : ℤ → Bag) (b : Bag) → Bag
postulate sumBag : Bag → ℤ
postulate homo-map : ∀ {f} → Homomorphic₂ (mapBag f) _++_ _++_
postulate homo-flatmap : ∀ {f} → Homomorphic₂ (flatmapBag f) _++_ _++_
postulate homo-sum : Homomorphic₂ sumBag _++_ _+_
postulate neg-map : ∀ {f} → Homomorphic₁ (mapBag f) negateBag negateBag
postulate neg-flatmap : ∀ {f} → Homomorphic₁ (flatmapBag f) negateBag negateBag


------------------------------------------------------------------------
-- Some results related to an LTS from Section 6.2.5 of "Enhancements
-- of the bisimulation proof method" by Pous and Sangiorgi,
-- implemented using the coinductive definition of bisimilarity
------------------------------------------------------------------------

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

open import Prelude

module Bisimilarity.6-2-5 {Name : Type} where

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

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

import Bisimilarity.Equational-reasoning-instances
open import Equational-reasoning
open import Indexed-container using (⟦_⟧)
open import Labelled-transition-system.6-2-5 Name
open import Relation

open import Bisimilarity 6-2-5
open import Bisimilarity.Up-to 6-2-5

-- Some simple lemmas. The first two are stated by Pous and Sangiorgi,
-- and the third one is a generalisation of a result stated by Pous
-- and Sangiorgi.

op·∅ : ∀ {a} → op (a · ∅) ∼ ∅
op·∅ {a} = ⟨ lr , (λ ()) ⟩
  where
  lr : ∀ {P′ μ} →
       op (a · ∅) [ μ ]⟶ P′ →
       ∃ λ Q′ → ∅ [ μ ]⟶ Q′ × P′ ∼′ Q′
  lr (op action ())

op··∅ : ∀ {a} → op (a · a · ∅) ∼ a · ∅
op··∅ {a} = ⟨ lr , rl ⟩
  where
  lr : ∀ {P′ μ b} →
       op (a · b · ∅) [ μ ]⟶ P′ →
       ∃ λ Q′ → b · ∅ [ μ ]⟶ Q′ × P′ ∼′ Q′
  lr (op action action) = _ , action , reflexive

  rl : ∀ {Q′ μ} →
       a · ∅ [ μ ]⟶ Q′ →
       ∃ λ P′ → op (a · a · ∅) [ μ ]⟶ P′ × P′ ∼′ Q′
  rl action = _ , op action action , reflexive

a≁b·c : ∀ {a b c} → ¬ (a · ∅ ∼ b · c · ∅)
a≁b·c a∼b·c with right-to-left a∼b·c action
... | .∅ , action , ∅∼a with right-to-left (force ∅∼a) action
...   | _ , () , _

-- Pous and Sangiorgi note that every context preserves bisimilarity.
-- One can prove that a ·_ preserves bisimilarity in a size-preserving
-- way.

·-cong : ∀ {i a P Q} → [ i ] P ∼ Q → [ i ] a · P ∼ a · Q
·-cong {i} {a} P∼Q =
  ⟨ lr P∼Q
  , Σ-map id (Σ-map id symmetric) ∘ lr (symmetric P∼Q)
  ⟩
  where
  lr : ∀ {P P′ Q μ} →
       [ i ] P ∼ Q → a · P [ μ ]⟶ P′ →
       ∃ λ Q′ → a · Q [ μ ]⟶ Q′ × [ i ] P′ ∼′ Q′
  lr P∼Q action = _ , action , convert P∼Q

-- The operator op also preserves bisimilarity, but this lemma is not
-- claimed to be size-preserving.

op-cong : ∀ {i} {j : Size< i} {P Q} →
          [ i ] P ∼ Q → [ j ] op P ∼ op Q
op-cong {i} {j} P∼Q =
  ⟨ lr P∼Q
  , Σ-map id (Σ-map id symmetric) ∘ lr (symmetric P∼Q)
  ⟩
  where
  lr : ∀ {P P′ Q μ} →
       [ i ] P ∼ Q → op P [ μ ]⟶ P′ →
       ∃ λ Q′ → op Q [ μ ]⟶ Q′ × [ j ] P′ ∼′ Q′
  lr P∼Q (op P⟶P′ P′⟶P″) =
    let Q′ , Q⟶Q′  , P′∼Q′ = left-to-right        P∼Q    P⟶P′
        Q″ , Q′⟶Q″ , P″∼Q″ = left-to-right (force P′∼Q′) P′⟶P″
    in Q″ , op Q⟶Q′ Q′⟶Q″ , P″∼Q″

-- Let us assume that the Name type is inhabited. In that case op-cong
-- /cannot/ preserve the size of its argument.
--
-- The proof is based on an argument presented by Pous and Sangiorgi.

op-cong-cannot-preserve-size :
  Name →
  ¬ (∀ {i P Q} → [ i ] P ∼ Q → [ i ] op P ∼ op Q)
op-cong-cannot-preserve-size a op-cong = a≁b·c a∼a·a
  where
  op-cong′ : ∀ {i P Q} → [ i ] P ∼′ Q → [ i ] op P ∼′ op Q
  force (op-cong′ P∼′Q) = op-cong (force P∼′Q)

  a∼a·a : ∀ {i} → [ i ] a · ∅ ∼ a · a · ∅
  a∼a·a {i} = ⟨ lr , rl ⟩
    where
    a∼′a·a : ∀ {i} → [ i ] a · ∅ ∼′ a · a · ∅
    force a∼′a·a = a∼a·a

    lemma =
      ∅               ∼⟨ symmetric op·∅ ⟩
      op (a · ∅)      ∼⟨ op-cong′ (a∼′a·a {i = i}) ⟩
      op (a · a · ∅)  ∼⟨ op··∅ ⟩■
      a · ∅

    lr : ∀ {P′ μ} →
         a · ∅ [ μ ]⟶ P′ →
         ∃ λ Q′ → a · a · ∅ [ μ ]⟶ Q′ × [ i ] P′ ∼′ Q′
    lr action = a · ∅ , action , lemma

    rl : ∀ {Q′ μ} →
         a · a · ∅ [ μ ]⟶ Q′ →
         ∃ λ P′ → a · ∅ [ μ ]⟶ P′ × [ i ] P′ ∼′ Q′
    rl action = ∅ , action , lemma

-- Up to context (for monadic contexts).

Up-to-context : Trans₂ (# 0) Proc
Up-to-context R (P , Q) =
  ∃ λ (C : Context 1) →
  ∃ λ P′ →
  ∃ λ Q′ →
  P ≡ C [ (λ _ → P′) ]
    ×
  Q ≡ C [ (λ _ → Q′) ]
    ×
  R (P′ , Q′)

-- Up to context is monotone.

up-to-context-monotone : Monotone Up-to-context
up-to-context-monotone R⊆S =
  Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id $ Σ-map id R⊆S

-- Up to bisimilarity and context.

Up-to-bisimilarity-and-context : Trans₂ (# 0) Proc
Up-to-bisimilarity-and-context =
  Up-to-bisimilarity ∘ Up-to-context

-- Up to bisimilarity and context is monotone.

up-to-bisimilarity-and-context-monotone :
  Monotone Up-to-bisimilarity-and-context
up-to-bisimilarity-and-context-monotone =
  up-to-bisimilarity-monotone ∘ up-to-context-monotone

-- Up to bisimilarity and context is not sound (assuming that Name is
-- inhabited).
--
-- This result is due to Pous and Sangiorgi.

¬-up-to-bisimilarity-and-context :
  Name →
  ¬ Up-to-technique Up-to-bisimilarity-and-context
¬-up-to-bisimilarity-and-context a =
  Up-to-technique Up-to-bisimilarity-and-context  ↝⟨ _$ R⊆ ⟩
  R ⊆ Bisimilarity ∞                              ↝⟨ R⊈∼ ⟩□
  ⊥                                               □
  where
  data R : Rel₂ (# 0) Proc where
    base : R (a · ∅ , a · a · ∅)

  lemma : Up-to-bisimilarity-and-context R (∅ , a · ∅)
  lemma =
    op (a · ∅) ,
    symmetric op·∅ ,
    op (a · a · ∅) ,
    (op (hole fzero) , a · ∅ , a · a · ∅ , refl , refl , base) ,
    op··∅

  R⊆ : R ⊆ ⟦ StepC ⟧ (Up-to-bisimilarity-and-context R)
  R⊆ base =
    ⟨ (λ { action → a · ∅ , action , lemma })
    , (λ { action → ∅     , action , lemma })
    ⟩

  R⊈∼ : ¬ R ⊆ Bisimilarity ∞
  R⊈∼ =
    R ⊆ Bisimilarity ∞  ↝⟨ (λ R⊆∼ → R⊆∼ base) ⟩
    a · ∅ ∼ a · a · ∅   ↝⟨ a≁b·c ⟩□
    ⊥                   □

-- The last result above can be used to give another proof showing
-- that op-cong cannot preserve the size of its argument (assuming
-- that Name is inhabited).

op-cong-cannot-preserve-size′ :
  Name →
  ¬ (∀ {i P Q} → [ i ] P ∼ Q → [ i ] op P ∼ op Q)
op-cong-cannot-preserve-size′ a =
  (∀ {i P Q} → [ i ] P ∼ Q → [ i ] op P ∼ op Q)               ↝⟨ (λ op-cong C P∼Q → []-cong op-cong C (λ _ → P∼Q)) ⟩

  (∀ {i P Q} (C : Context 1) → [ i ] P ∼ Q →
   [ i ] C [ (λ _ → P) ] ∼ C [ (λ _ → Q) ])                   ↝⟨ (λ []-cong → λ where
                                                                    {x = P , Q} (_ , P∼C[R₁] , _ ,
                                                                                (C , R₁ , R₂ , refl , refl , R₁∼R₂) , C[R₂]∼Q) →

                                                                      P                 ∼⟨ P∼C[R₁] ⟩
                                                                      C [ (λ _ → R₁) ]  ∼⟨ []-cong C R₁∼R₂ ⟩
                                                                      C [ (λ _ → R₂) ]  ∼⟨ C[R₂]∼Q ⟩■
                                                                      Q) ⟩
  (∀ {i} → Up-to-bisimilarity-and-context (Bisimilarity i) ⊆
           Bisimilarity i)                                    ↝⟨ _⇔_.from (monotone→⇔ up-to-bisimilarity-and-context-monotone) ⟩

  Size-preserving Up-to-bisimilarity-and-context              ↝⟨ size-preserving→up-to ⟩

  Up-to-technique Up-to-bisimilarity-and-context              ↝⟨ ¬-up-to-bisimilarity-and-context a ⟩□

  ⊥                                                           □
  where
  []-cong :
    (∀ {i P Q} → [ i ] P ∼ Q → [ i ] op P ∼ op Q) →
    ∀ {i n Ps Qs}
    (C : Context n) → (∀ x → [ i ] Ps x ∼ Qs x) →
    [ i ] C [ Ps ] ∼ C [ Qs ]
  []-cong op-cong (hole x) Ps∼Qs = Ps∼Qs x
  []-cong op-cong (op C)   Ps∼Qs = op-cong ([]-cong op-cong C Ps∼Qs)
  []-cong op-cong (a · C)  Ps∼Qs = ·-cong ([]-cong op-cong C Ps∼Qs)
  []-cong op-cong ∅        Ps∼Qs = reflexive


------------------------------------------------------------------------
-- Isomorphisms and equalities relating an arbitrary "equality with J"
-- to path equality, along with a proof of extensionality for the
-- "equality with J"
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --safe #-}

import Equality.Path as P

module Equality.Path.Isomorphisms
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq

open import Prelude

import Bijection
import Embedding
import Equivalence
import Equivalence.Contractible-preimages
import Equivalence.Half-adjoint
import Function-universe
import H-level
import Surjection
import Univalence-axiom

private
  module B  = Bijection equality-with-J
  module CP = Equivalence.Contractible-preimages equality-with-J
  module HA = Equivalence.Half-adjoint equality-with-J
  module Eq = Equivalence equality-with-J
  module F  = Function-universe equality-with-J

  module PB  = Bijection P.equality-with-J
  module PM  = Embedding P.equality-with-J
  module PE  = Equivalence P.equality-with-J
  module PCP = Equivalence.Contractible-preimages P.equality-with-J
  module PHA = Equivalence.Half-adjoint P.equality-with-J
  module PF  = Function-universe P.equality-with-J
  module PH  = H-level P.equality-with-J
  module PS  = Surjection P.equality-with-J
  module PU  = Univalence-axiom P.equality-with-J

open B using (_↔_)
open Embedding equality-with-J hiding (id; _∘_)
open Eq using (_≃_; Is-equivalence)
open F hiding (id; _∘_)
open H-level equality-with-J
open Surjection equality-with-J using (_↠_)
open Univalence-axiom equality-with-J

private
  variable
    a b c p q ℓ : Level
    A           : Type a
    B           : A → Type b
    u v x y z   : A
    f g h       : (x : A) → B x
    n           : ℕ

------------------------------------------------------------------------
-- Extensionality

-- The proof bad-ext is perhaps not less "good" than ext (I don't
-- know), it is called this simply because it is not defined using
-- good-ext.

bad-ext : Extensionality a b
apply-ext bad-ext {f = f} {g = g} =
  (∀ x → f x ≡ g x)    ↝⟨ (λ p x → _↔_.to ≡↔≡ (p x)) ⟩
  (∀ x → f x P.≡ g x)  ↝⟨ P.apply-ext P.ext ⟩
  f P.≡ g              ↔⟨ inverse ≡↔≡ ⟩□
  f ≡ g                □

-- Extensionality.

ext : Extensionality a b
ext = Eq.good-ext bad-ext

⟨ext⟩ : Extensionality′ A B
⟨ext⟩ = apply-ext ext

abstract

  -- The function ⟨ext⟩ is an equivalence.

  ext-is-equivalence : Is-equivalence {A = ∀ x → f x ≡ g x} ⟨ext⟩
  ext-is-equivalence = Eq.good-ext-is-equivalence bad-ext

  -- Equality rearrangement lemmas for ⟨ext⟩.

  ext-refl : ⟨ext⟩ (λ x → refl (f x)) ≡ refl f
  ext-refl = Eq.good-ext-refl bad-ext _

  ext-const :
    (x≡y : x ≡ y) →
    ⟨ext⟩ (const {B = A} x≡y) ≡ cong const x≡y
  ext-const = Eq.good-ext-const bad-ext

  cong-ext :
    ∀ (f≡g : ∀ x → f x ≡ g x) {x} →
    cong (_$ x) (⟨ext⟩ f≡g) ≡ f≡g x
  cong-ext = Eq.cong-good-ext bad-ext

  ext-cong :
    {B : Type b} {C : B → Type c}
    {f : A → (x : B) → C x} {x≡y : x ≡ y} →
    ⟨ext⟩ (λ z → cong (flip f z) x≡y) ≡ cong f x≡y
  ext-cong = Eq.good-ext-cong bad-ext

  subst-ext :
    ∀ {f g : (x : A) → B x}
    (P : B x → Type p) {p} (f≡g : ∀ x → f x ≡ g x) →
    subst (λ f → P (f x)) (⟨ext⟩ f≡g) p ≡ subst P (f≡g x) p
  subst-ext = Eq.subst-good-ext bad-ext

  elim-ext :
    (P : B x → B x → Type p)
    (p : (y : B x) → P y y)
    {f g : (x : A) → B x}
    (f≡g : ∀ x → f x ≡ g x) →
    elim (λ {f g} _ → P (f x) (g x)) (p ∘ (_$ x)) (⟨ext⟩ f≡g) ≡
    elim (λ {x y} _ → P x y) p (f≡g x)
  elim-ext = Eq.elim-good-ext bad-ext

  -- I based the statements of the following three lemmas on code in
  -- the Lean Homotopy Type Theory Library with Jakob von Raumer and
  -- Floris van Doorn listed as authors. The file was claimed to have
  -- been ported from the Coq HoTT library. (The third lemma has later
  -- been generalised.)

  ext-sym :
    (f≡g : ∀ x → f x ≡ g x) →
    ⟨ext⟩ (sym ∘ f≡g) ≡ sym (⟨ext⟩ f≡g)
  ext-sym = Eq.good-ext-sym bad-ext

  ext-trans :
    (f≡g : ∀ x → f x ≡ g x) (g≡h : ∀ x → g x ≡ h x) →
    ⟨ext⟩ (λ x → trans (f≡g x) (g≡h x)) ≡ trans (⟨ext⟩ f≡g) (⟨ext⟩ g≡h)
  ext-trans = Eq.good-ext-trans bad-ext

  cong-post-∘-ext :
    (f≡g : ∀ x → f x ≡ g x) →
    cong (h ∘_) (⟨ext⟩ f≡g) ≡ ⟨ext⟩ (cong h ∘ f≡g)
  cong-post-∘-ext = Eq.cong-post-∘-good-ext bad-ext bad-ext

  cong-pre-∘-ext :
    (f≡g : ∀ x → f x ≡ g x) →
    cong (_∘ h) (⟨ext⟩ f≡g) ≡ ⟨ext⟩ (f≡g ∘ h)
  cong-pre-∘-ext = Eq.cong-pre-∘-good-ext bad-ext bad-ext

  cong-∘-ext :
    {A : Type a} {B : Type b} {C : Type c} {f g : B → C}
    (f≡g : ∀ x → f x ≡ g x) →
    cong {B = (A → B) → (A → C)}
         (λ f → f ∘_) (⟨ext⟩ f≡g) ≡
    ⟨ext⟩ λ h → ⟨ext⟩ λ x → f≡g (h x)
  cong-∘-ext = Eq.cong-∘-good-ext bad-ext bad-ext bad-ext

------------------------------------------------------------------------
-- More isomorphisms and related properties

-- Split surjections expressed using equality are equivalent to split
-- surjections expressed using paths.

↠≃↠ :
  {A : Type a} {B : Type b} →
  (A ↠ B) ≃ (A PS.↠ B)
↠≃↠ = Eq.↔→≃
  (λ A↠B → record
     { logical-equivalence = _↠_.logical-equivalence A↠B
     ; right-inverse-of    = _↔_.to ≡↔≡ ∘ _↠_.right-inverse-of A↠B
     })
  (λ A↠B → record
     { logical-equivalence = PS._↠_.logical-equivalence A↠B
     ; right-inverse-of    = _↔_.from ≡↔≡ ∘ PS._↠_.right-inverse-of A↠B
     })
  (λ A↠B →
     cong (λ r → record
             { logical-equivalence = PS._↠_.logical-equivalence A↠B
             ; right-inverse-of    = r
             }) $
     ⟨ext⟩ λ _ → _↔_.right-inverse-of ≡↔≡ _)
  (λ A↠B →
     cong (λ r → record
             { logical-equivalence = _↠_.logical-equivalence A↠B
             ; right-inverse-of    = r
             }) $
     ⟨ext⟩ λ _ → _↔_.left-inverse-of ≡↔≡ _)

private

  -- Bijections expressed using paths can be converted into bijections
  -- expressed using equality.

  ↔→↔ : {A B : Type ℓ} → A PB.↔ B → A ↔ B
  ↔→↔ A↔B = record
    { surjection      = _≃_.from ↠≃↠ $ PB._↔_.surjection      A↔B
    ; left-inverse-of = _↔_.from ≡↔≡ ∘ PB._↔_.left-inverse-of A↔B
    }

-- Bijections expressed using equality are equivalent to bijections
-- expressed using paths.

↔≃↔ :
  {A : Type a} {B : Type b} →
  (A ↔ B) ≃ (A PB.↔ B)
↔≃↔ {A = A} {B = B} =
  A ↔ B                                                 ↔⟨ B.↔-as-Σ ⟩

  (∃ λ (f : A → B) → ∃ λ (f⁻¹ : B → A) →
    (∀ x → f (f⁻¹ x) ≡ x) × (∀ x → f⁻¹ (f x) ≡ x))      ↔⟨ (∃-cong λ _ → ∃-cong λ _ →
                                                            (∀-cong ext λ _ → ≡↔≡)
                                                              ×-cong
                                                            (∀-cong ext λ _ → ≡↔≡)) ⟩
  (∃ λ (f : A → B) → ∃ λ (f⁻¹ : B → A) →
    (∀ x → f (f⁻¹ x) P.≡ x) × (∀ x → f⁻¹ (f x) P.≡ x))  ↔⟨ inverse $ ↔→↔ $ PB.↔-as-Σ ⟩□

  A PB.↔ B                                              □

-- H-level expressed using equality is isomorphic to H-level expressed
-- using paths.

H-level↔H-level : ∀ n → H-level n A ↔ PH.H-level n A
H-level↔H-level {A = A} zero =
  H-level 0 A                    ↔⟨⟩
  (∃ λ (x : A) → ∀ y → x ≡ y)    ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → ≡↔≡) ⟩
  (∃ λ (x : A) → ∀ y → x P.≡ y)  ↔⟨⟩
  PH.H-level 0 A                 □

H-level↔H-level {A = A} (suc n) =
  H-level (suc n) A                 ↝⟨ inverse $ ≡↔+ _ ext ⟩
  (∀ x y → H-level n (x ≡ y))       ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → H-level-cong ext _ ≡↔≡) ⟩
  (∀ x y → H-level n (x P.≡ y))     ↝⟨ (∀-cong ext λ _ → ∀-cong ext λ _ → H-level↔H-level n) ⟩
  (∀ x y → PH.H-level n (x P.≡ y))  ↝⟨ ↔→↔ $ PF.≡↔+ _ P.ext ⟩
  PH.H-level (suc n) A              □

-- CP.Is-equivalence is isomorphic to PCP.Is-equivalence.

Is-equivalence-CP↔Is-equivalence-CP :
  CP.Is-equivalence f ↔ PCP.Is-equivalence f
Is-equivalence-CP↔Is-equivalence-CP {f = f} =
  CP.Is-equivalence f                         ↔⟨⟩
  (∀ y →   Contractible (∃ λ x → f x   ≡ y))  ↝⟨ (∀-cong ext λ _ → H-level-cong ext _ $ ∃-cong λ _ → ≡↔≡) ⟩
  (∀ y →   Contractible (∃ λ x → f x P.≡ y))  ↝⟨ (∀-cong ext λ _ → H-level↔H-level _) ⟩
  (∀ y → P.Contractible (∃ λ x → f x P.≡ y))  ↔⟨⟩
  PCP.Is-equivalence f                        □

-- Is-equivalence expressed using equality is isomorphic to
-- Is-equivalence expressed using paths.

Is-equivalence↔Is-equivalence :
  Is-equivalence f ↔ PE.Is-equivalence f
Is-equivalence↔Is-equivalence {f = f} =
  Is-equivalence f      ↝⟨ HA.Is-equivalence↔Is-equivalence-CP ext ⟩
  CP.Is-equivalence f   ↝⟨ Is-equivalence-CP↔Is-equivalence-CP ⟩
  PCP.Is-equivalence f  ↝⟨ inverse $ ↔→↔ $ PHA.Is-equivalence↔Is-equivalence-CP P.ext ⟩□
  PE.Is-equivalence f   □

-- The type of equivalences, expressed using equality, is isomorphic
-- to the type of equivalences, expressed using paths.

≃↔≃ :
  {A : Type a} {B : Type b} →
  A ≃ B ↔ A PE.≃ B
≃↔≃ {A = A} {B = B} =
  A ≃ B                ↝⟨ Eq.≃-as-Σ ⟩
  ∃ Is-equivalence     ↝⟨ (∃-cong λ _ → Is-equivalence↔Is-equivalence) ⟩
  ∃ PE.Is-equivalence  ↝⟨ inverse $ ↔→↔ PE.≃-as-Σ ⟩□
  A PE.≃ B             □

private

  -- ≃↔≃ computes in the "right" way.

  to-≃↔≃ :
    {A : Type a} {B : Type b} {A≃B : A ≃ B} →
    PE._≃_.logical-equivalence (_↔_.to ≃↔≃ A≃B) ≡
    _≃_.logical-equivalence A≃B
  to-≃↔≃ = refl _

  from-≃↔≃ :
    {A : Type a} {B : Type b} {A≃B : A PE.≃ B} →
    _≃_.logical-equivalence (_↔_.from ≃↔≃ A≃B) ≡
    PE._≃_.logical-equivalence A≃B
  from-≃↔≃ = refl _

-- The type of equivalences, expressed using "contractible preimages"
-- and equality, is isomorphic to the type of equivalences, expressed
-- using contractible preimages and paths.

≃-CP↔≃-CP :
  {A : Type a} {B : Type b} →
  A CP.≃ B ↔ A PCP.≃ B
≃-CP↔≃-CP {A = A} {B = B} =
  ∃ CP.Is-equivalence   ↝⟨ (∃-cong λ _ → Is-equivalence-CP↔Is-equivalence-CP) ⟩□
  ∃ PCP.Is-equivalence  □

-- The cong function for paths can be expressed in terms of the cong
-- function for equality.

cong≡cong :
  {A : Type a} {B : Type b} {f : A → B} {x y : A} {x≡y : x P.≡ y} →
  cong f (_↔_.from ≡↔≡ x≡y) ≡ _↔_.from ≡↔≡ (P.cong f x≡y)
cong≡cong {f = f} {x≡y = x≡y} = P.elim
  (λ x≡y → cong f (_↔_.from ≡↔≡ x≡y) ≡ _↔_.from ≡↔≡ (P.cong f x≡y))
  (λ x →
     cong f (_↔_.from ≡↔≡ P.refl)    ≡⟨ cong (cong f) from-≡↔≡-refl ⟩
     cong f (refl x)                 ≡⟨ cong-refl _ ⟩
     refl (f x)                      ≡⟨ sym $ from-≡↔≡-refl ⟩
     _↔_.from ≡↔≡ P.refl             ≡⟨ cong (_↔_.from ≡↔≡) $ sym $ _↔_.from ≡↔≡ $ P.cong-refl f ⟩∎
     _↔_.from ≡↔≡ (P.cong f P.refl)  ∎)
  x≡y

-- The sym function for paths can be expressed in terms of the sym
-- function for equality.

sym≡sym :
  {x≡y : x P.≡ y} →
  sym (_↔_.from ≡↔≡ x≡y) ≡ _↔_.from ≡↔≡ (P.sym x≡y)
sym≡sym {x≡y = x≡y} = P.elim₁
  (λ x≡y → sym (_↔_.from ≡↔≡ x≡y) ≡ _↔_.from ≡↔≡ (P.sym x≡y))
  (sym (_↔_.from ≡↔≡ P.refl)    ≡⟨ cong sym from-≡↔≡-refl ⟩
   sym (refl _)                 ≡⟨ sym-refl ⟩
   refl _                       ≡⟨ sym from-≡↔≡-refl ⟩
   _↔_.from ≡↔≡ P.refl          ≡⟨ cong (_↔_.from ≡↔≡) $ sym $ _↔_.from ≡↔≡ P.sym-refl ⟩∎
   _↔_.from ≡↔≡ (P.sym P.refl)  ∎)
  x≡y

-- The trans function for paths can be expressed in terms of the trans
-- function for equality.

trans≡trans :
  {x≡y : x P.≡ y} {y≡z : y P.≡ z} →
  trans (_↔_.from ≡↔≡ x≡y) (_↔_.from ≡↔≡ y≡z) ≡
  _↔_.from ≡↔≡ (P.trans x≡y y≡z)
trans≡trans {x≡y = x≡y} {y≡z = y≡z} = P.elim₁
  (λ x≡y → trans (_↔_.from ≡↔≡ x≡y) (_↔_.from ≡↔≡ y≡z) ≡
           _↔_.from ≡↔≡ (P.trans x≡y y≡z))
  (trans (_↔_.from ≡↔≡ P.refl) (_↔_.from ≡↔≡ y≡z)  ≡⟨ cong (flip trans _) from-≡↔≡-refl ⟩
   trans (refl _) (_↔_.from ≡↔≡ y≡z)               ≡⟨ trans-reflˡ _ ⟩
   _↔_.from ≡↔≡ y≡z                                ≡⟨ cong (_↔_.from ≡↔≡) $ sym $ _↔_.from ≡↔≡ $ P.trans-reflˡ _ ⟩∎
   _↔_.from ≡↔≡ (P.trans P.refl y≡z)               ∎)
  x≡y

-- The type of embeddings, expressed using equality, is isomorphic to
-- the type of embeddings, expressed using paths.

Embedding↔Embedding :
  {A : Type a} {B : Type b} →
  Embedding A B ↔ PM.Embedding A B
Embedding↔Embedding {A = A} {B = B} =
  Embedding A B                                   ↝⟨ Embedding-as-Σ ⟩
  (∃ λ f → ∀ x y → Is-equivalence (cong f))       ↔⟨ (∃-cong λ f → ∀-cong ext λ x → ∀-cong ext λ y →
                                                      Eq.⇔→≃ (Eq.propositional ext _) (Eq.propositional ext _)
                                                        (λ is → _≃_.is-equivalence $
                                                           Eq.with-other-function
                                                             (
      x P.≡ y                                                  ↔⟨ inverse ≡↔≡ ⟩
      x ≡ y                                                    ↝⟨ Eq.⟨ _ , is ⟩ ⟩
      f x ≡ f y                                                ↔⟨ ≡↔≡ ⟩□
      f x P.≡ f y                                              □)
                                                             (P.cong f)
                                                             (λ eq →
      _↔_.to ≡↔≡ (cong f (_↔_.from ≡↔≡ eq))                     ≡⟨ cong (_↔_.to ≡↔≡) cong≡cong ⟩
      _↔_.to ≡↔≡ (_↔_.from ≡↔≡ (P.cong f eq))                   ≡⟨ _↔_.right-inverse-of ≡↔≡ _ ⟩∎
      P.cong f eq                                               ∎))
                                                        (λ is → _≃_.is-equivalence $
                                                           Eq.with-other-function
                                                             (
      x ≡ y                                                    ↔⟨ ≡↔≡ ⟩
      x P.≡ y                                                  ↝⟨ Eq.⟨ _ , is ⟩ ⟩
      f x P.≡ f y                                              ↔⟨ inverse ≡↔≡ ⟩□
      f x ≡ f y                                                □)
                                                             (cong f)
                                                             (λ eq →
      _↔_.from ≡↔≡ (P.cong f (_↔_.to ≡↔≡ eq))                   ≡⟨ sym cong≡cong ⟩
      cong f (_↔_.from ≡↔≡ (_↔_.to ≡↔≡ eq))                     ≡⟨ cong (cong f) $ _↔_.left-inverse-of ≡↔≡ _ ⟩∎
      cong f eq                                                 ∎))) ⟩
  (∃ λ f → ∀ x y → Is-equivalence (P.cong f))     ↝⟨ (∃-cong λ _ → ∀-cong ext λ _ → ∀-cong ext λ _ → Is-equivalence↔Is-equivalence) ⟩
  (∃ λ f → ∀ x y → PE.Is-equivalence (P.cong f))  ↝⟨ inverse $ ↔→↔ PM.Embedding-as-Σ ⟩□
  PM.Embedding A B                                □

-- The subst function for paths can be expressed in terms of the subst
-- function for equality.

subst≡subst :
  ∀ {P : A → Type p} {x≡y : x P.≡ y} {p} →
  subst P (_↔_.from ≡↔≡ x≡y) p ≡ P.subst P x≡y p
subst≡subst {P = P} {x≡y} = P.elim
  (λ x≡y → ∀ {p} → subst P (_↔_.from ≡↔≡ x≡y) p ≡ P.subst P x≡y p)
  (λ x {p} →
     subst P (_↔_.from ≡↔≡ P.refl) p  ≡⟨ cong (λ eq → subst P eq p) from-≡↔≡-refl ⟩
     subst P (refl x) p               ≡⟨ subst-refl _ _ ⟩
     p                                ≡⟨ sym $ _↔_.from ≡↔≡ $ P.subst-refl P _ ⟩∎
     P.subst P P.refl p               ∎)
  x≡y

-- A "computation" rule for subst≡subst.

subst≡subst-refl :
  ∀ {P : A → Type p} {p : P x} →
  subst≡subst {x≡y = P.refl} ≡
  trans (cong (λ eq → subst P eq p) from-≡↔≡-refl)
    (trans (subst-refl _ _) (sym $ _↔_.from ≡↔≡ $ P.subst-refl P _))
subst≡subst-refl {P = P} = cong (λ f → f {p = _}) $ _↔_.from ≡↔≡ $
  P.elim-refl
    (λ x≡y → ∀ {p} → subst P (_↔_.from ≡↔≡ x≡y) p ≡ P.subst P x≡y p)
    (λ _ → trans (cong (λ eq → subst P eq _) from-≡↔≡-refl)
             (trans (subst-refl _ _)
                (sym $ _↔_.from ≡↔≡ $ P.subst-refl P _)))

-- Some corollaries.

subst≡↔subst≡ :
  ∀ {eq : x P.≡ y} →
  subst B (_↔_.from ≡↔≡ eq) u ≡ v ↔
  P.subst B eq u P.≡ v
subst≡↔subst≡ {B = B} {u = u} {v = v} {eq = eq} =
  subst B (_↔_.from ≡↔≡ eq) u ≡ v  ↝⟨ ≡⇒↝ _ $ cong (_≡ _) subst≡subst ⟩
  P.subst B eq u ≡ v               ↝⟨ ≡↔≡ ⟩□
  P.subst B eq u P.≡ v             □

subst≡↔[]≡ :
  {eq : x P.≡ y} →
  subst B (_↔_.from ≡↔≡ eq) u ≡ v ↔
  P.[ (λ i → B (eq i)) ] u ≡ v
subst≡↔[]≡ {B = B} {u = u} {v = v} {eq = eq} =
  subst B (_↔_.from ≡↔≡ eq) u ≡ v  ↝⟨ subst≡↔subst≡ ⟩
  P.subst B eq u P.≡ v             ↝⟨ ↔→↔ $ PB.inverse $ P.heterogeneous↔homogeneous _ ⟩□
  P.[ (λ i → B (eq i)) ] u ≡ v     □

-- The dcong function for paths can be expressed using dcong for
-- equality (up to pointwise equality).

dcong≡dcong :
  {f : (x : A) → B x} {x≡y : x P.≡ y} →
  _↔_.to subst≡↔subst≡ (dcong f (_↔_.from ≡↔≡ x≡y)) ≡
  P.dcong f x≡y
dcong≡dcong {B = B} {f = f} {x≡y} = P.elim
  (λ x≡y → _↔_.to subst≡↔subst≡ (dcong f (_↔_.from ≡↔≡ x≡y)) ≡
           P.dcong f x≡y)
  (λ x →
     _↔_.to subst≡↔subst≡ (dcong f (_↔_.from ≡↔≡ P.refl))    ≡⟨⟩

     _↔_.to ≡↔≡ (_↔_.to (≡⇒↝ _ $ cong (_≡ _) subst≡subst) $
       dcong f (_↔_.from ≡↔≡ P.refl))                        ≡⟨ cong (_↔_.to ≡↔≡) $ lemma x ⟩

     _↔_.to ≡↔≡ (_↔_.from ≡↔≡ $ P.subst-refl B (f x))        ≡⟨ _↔_.right-inverse-of ≡↔≡ _ ⟩

     P.subst-refl B (f x)                                    ≡⟨ sym $ _↔_.from ≡↔≡ $ P.dcong-refl f ⟩∎

     P.dcong f P.refl                                        ∎)
  x≡y
  where
  lemma : ∀ _ → _
  lemma _ =
     _↔_.to (≡⇒↝ _ $ cong (_≡ _) subst≡subst)
       (dcong f (_↔_.from ≡↔≡ P.refl))                         ≡⟨ sym $ subst-in-terms-of-≡⇒↝ bijection _ _ _ ⟩

     subst (_≡ _) subst≡subst (dcong f (_↔_.from ≡↔≡ P.refl))  ≡⟨ cong (λ p → subst (_≡ _) p $ dcong f _) $ sym $ sym-sym _ ⟩

     subst (_≡ _) (sym $ sym subst≡subst)
       (dcong f (_↔_.from ≡↔≡ P.refl))                         ≡⟨ subst-trans _ ⟩

     trans (sym (subst≡subst {x≡y = P.refl}))
       (dcong f (_↔_.from ≡↔≡ P.refl))                         ≡⟨ cong (λ p → trans (sym p) (dcong f (_↔_.from ≡↔≡ P.refl)))
                                                                  subst≡subst-refl ⟩
     trans
       (sym $ trans (cong (λ eq → subst B eq _) from-≡↔≡-refl)
                (trans (subst-refl _ _)
                   (sym $ _↔_.from ≡↔≡ $ P.subst-refl B _)))
       (dcong f (_↔_.from ≡↔≡ P.refl))                         ≡⟨ elim₁ (λ {x} p →
                                                                           trans (sym $ trans (cong (λ eq → subst B eq _) p)
                                                                                (trans (subst-refl _ _)
                                                                                (sym $ _↔_.from ≡↔≡ $ P.subst-refl B _)))
                                                                             (dcong f x) ≡
                                                                           trans (sym $ trans (cong (λ eq → subst B eq _) (refl _))
                                                                                (trans (subst-refl _ _)
                                                                                (sym $ _↔_.from ≡↔≡ $ P.subst-refl B _)))
                                                                             (dcong f (refl _)))
                                                                        (refl _)
                                                                        from-≡↔≡-refl ⟩
     trans
       (sym $ trans (cong (λ eq → subst B eq _) (refl _))
                (trans (subst-refl _ _)
                   (sym $ _↔_.from ≡↔≡ $ P.subst-refl B _)))
       (dcong f (refl _))                                      ≡⟨ cong₂ (λ p → trans $ sym $ trans p $ trans (subst-refl _ _) $ sym $
                                                                                _↔_.from ≡↔≡ $ P.subst-refl B _)
                                                                    (cong-refl _)
                                                                    (dcong-refl _) ⟩
     trans
       (sym $ trans (refl _)
                (trans (subst-refl _ _)
                   (sym $ _↔_.from ≡↔≡ $ P.subst-refl B _)))
       (subst-refl B _)                                        ≡⟨ cong (λ p → trans (sym p) (subst-refl _ _)) $ trans-reflˡ _ ⟩

     trans
       (sym $ trans (subst-refl _ _)
                (sym $ _↔_.from ≡↔≡ $ P.subst-refl B _))
       (subst-refl B _)                                        ≡⟨ cong (λ p → trans p (subst-refl _ _)) $ sym-trans _ _ ⟩

     trans
       (trans (sym $ sym $ _↔_.from ≡↔≡ $ P.subst-refl B _)
              (sym $ subst-refl _ _))
       (subst-refl B _)                                        ≡⟨ trans-[trans-sym]- _ _ ⟩

     sym $ sym $ _↔_.from ≡↔≡ $ P.subst-refl B _               ≡⟨ sym-sym _ ⟩∎

     _↔_.from ≡↔≡ $ P.subst-refl B _                           ∎

-- A lemma relating dcong and hcong (for paths).

dcong≡hcong :
  {x≡y : x P.≡ y} (f : (x : A) → B x) →
  dcong f (_↔_.from ≡↔≡ x≡y) ≡ _↔_.from subst≡↔[]≡ (P.hcong f x≡y)
dcong≡hcong {x≡y = x≡y} f =
  dcong f (_↔_.from ≡↔≡ x≡y)                                     ≡⟨ sym $ _↔_.from-to (inverse subst≡↔subst≡) dcong≡dcong ⟩

  _↔_.from subst≡↔subst≡ (P.dcong f x≡y)                         ≡⟨ cong (_↔_.from subst≡↔subst≡) $ _↔_.from ≡↔≡ $ P.dcong≡hcong f ⟩

  _↔_.from subst≡↔subst≡
    (PB._↔_.to (P.heterogeneous↔homogeneous _) (P.hcong f x≡y))  ≡⟨⟩

  _↔_.from subst≡↔[]≡ (P.hcong f x≡y)                            ∎

-- Three corollaries, intended to be used in the implementation of
-- eliminators for HITs. For some examples, see Interval and
-- Quotient.HIT.

subst≡→[]≡ :
  {eq : x P.≡ y} →
  subst B (_↔_.from ≡↔≡ eq) u ≡ v →
  P.[ (λ i → B (eq i)) ] u ≡ v
subst≡→[]≡ = _↔_.to subst≡↔[]≡

dcong-subst≡→[]≡ :
  {eq₁ : x P.≡ y} {eq₂ : subst B (_↔_.from ≡↔≡ eq₁) (f x) ≡ f y} →
  P.hcong f eq₁ ≡ subst≡→[]≡ eq₂ →
  dcong f (_↔_.from ≡↔≡ eq₁) ≡ eq₂
dcong-subst≡→[]≡ {B = B} {f = f} {eq₁} {eq₂} hyp =
  dcong f (_↔_.from ≡↔≡ eq₁)                   ≡⟨ dcong≡hcong f ⟩
  _↔_.from subst≡↔[]≡ (P.hcong f eq₁)          ≡⟨ cong (_↔_.from subst≡↔[]≡) hyp ⟩
  _↔_.from subst≡↔[]≡ (_↔_.to subst≡↔[]≡ eq₂)  ≡⟨ _↔_.left-inverse-of subst≡↔[]≡ _ ⟩∎
  eq₂                                          ∎

cong-≡↔≡ :
  {eq₁ : x P.≡ y} {eq₂ : f x ≡ f y} →
  P.cong f eq₁ ≡ _↔_.to ≡↔≡ eq₂ →
  cong f (_↔_.from ≡↔≡ eq₁) ≡ eq₂
cong-≡↔≡ {f = f} {eq₁ = eq₁} {eq₂} hyp =
  cong f (_↔_.from ≡↔≡ eq₁)      ≡⟨ cong≡cong ⟩
  _↔_.from ≡↔≡ $ P.cong f eq₁    ≡⟨ cong (_↔_.from ≡↔≡) hyp ⟩
  _↔_.from ≡↔≡ $ _↔_.to ≡↔≡ eq₂  ≡⟨ _↔_.left-inverse-of ≡↔≡ _ ⟩∎
  eq₂                            ∎

------------------------------------------------------------------------
-- Univalence

-- CP.Univalence′ is pointwise equivalent to PCP.Univalence′.

Univalence′-CP≃Univalence′-CP :
  {A B : Type ℓ} →
  CP.Univalence′ A B ≃ PCP.Univalence′ A B
Univalence′-CP≃Univalence′-CP {A = A} {B = B} =
  ((A≃B : A CP.≃ B) →
   ∃ λ (x : ∃ λ A≡B → CP.≡⇒≃ A≡B ≡ A≃B) → ∀ y → x ≡ y)       ↔⟨⟩

  ((A≃B : ∃ λ (f : A → B) → CP.Is-equivalence f) →
   ∃ λ (x : ∃ λ A≡B → CP.≡⇒≃ A≡B ≡ A≃B) →
   ∀ y → x ≡ y)                                              ↝⟨ (Π-cong ext (∃-cong λ _ → Is-equivalence-CP↔Is-equivalence-CP) λ A≃B →
                                                                 Σ-cong (lemma₁ A≃B) λ _ →
                                                                 Π-cong ext (lemma₁ A≃B) λ _ →
                                                                 inverse $ Eq.≃-≡ (lemma₁ A≃B)) ⟩
  ((A≃B : ∃ λ (f : A → B) → PCP.Is-equivalence f) →
   ∃ λ (x : ∃ λ A≡B → PCP.≡⇒≃ A≡B ≡ A≃B) →
   ∀ y → x ≡ y)                                              ↔⟨⟩

  ((A≃B : A PCP.≃ B) →
   ∃ λ (x : ∃ λ A≡B → PCP.≡⇒≃ A≡B ≡ A≃B) → ∀ y → x ≡ y)      ↔⟨ Is-equivalence-CP↔Is-equivalence-CP ⟩□

  ((A≃B : A PCP.≃ B) →
   ∃ λ (x : ∃ λ A≡B → PCP.≡⇒≃ A≡B P.≡ A≃B) → ∀ y → x P.≡ y)  □
  where
  lemma₃ :
    (A≡B : A ≡ B) →
    _↔_.to ≃-CP↔≃-CP (CP.≡⇒≃ A≡B) ≡ PCP.≡⇒≃ (_↔_.to ≡↔≡ A≡B)
  lemma₃ = elim¹
    (λ A≡B → _↔_.to ≃-CP↔≃-CP (CP.≡⇒≃ A≡B) ≡ PCP.≡⇒≃ (_↔_.to ≡↔≡ A≡B))
    (_↔_.to ≃-CP↔≃-CP (CP.≡⇒≃ (refl _))  ≡⟨ cong (_↔_.to ≃-CP↔≃-CP) CP.≡⇒≃-refl ⟩
     _↔_.to ≃-CP↔≃-CP CP.id              ≡⟨ _↔_.from ≡↔≡ $ P.Σ-≡,≡→≡ P.refl (PCP.propositional P.ext _ _ _) ⟩
     PCP.id                              ≡⟨ sym $ _↔_.from ≡↔≡ PCP.≡⇒≃-refl ⟩
     PCP.≡⇒≃ P.refl                      ≡⟨ sym $ cong PCP.≡⇒≃ to-≡↔≡-refl ⟩∎
     PCP.≡⇒≃ (_↔_.to ≡↔≡ (refl _))       ∎)

  lemma₂ : ∀ _ _ → _ ≃ _
  lemma₂ A≡B (f , f-eq) =
    CP.≡⇒≃ A≡B ≡ (f , f-eq)                                ↝⟨ inverse $ Eq.≃-≡ (Eq.↔⇒≃ ≃-CP↔≃-CP) ⟩

    _↔_.to ≃-CP↔≃-CP (CP.≡⇒≃ A≡B) ≡
    (f , _↔_.to Is-equivalence-CP↔Is-equivalence-CP f-eq)  ↝⟨ ≡⇒≃ $ cong (_≡ (f , _↔_.to Is-equivalence-CP↔Is-equivalence-CP f-eq)) $
                                                              lemma₃ A≡B ⟩□
    PCP.≡⇒≃ (_↔_.to ≡↔≡ A≡B) ≡
    (f , _↔_.to Is-equivalence-CP↔Is-equivalence-CP f-eq)  □

  lemma₁ :
    ∀ A≃B →
    (∃ λ A≡B → CP.≡⇒≃ A≡B ≡ A≃B) ≃
    (∃ λ A≡B →
         PCP.≡⇒≃ A≡B ≡
         ( proj₁ A≃B
         , _↔_.to Is-equivalence-CP↔Is-equivalence-CP (proj₂ A≃B)
         ))
  lemma₁ A≃B = Σ-cong ≡↔≡ λ A≡B → lemma₂ A≡B A≃B

-- Univalence′ expressed using equality is equivalent to Univalence′
-- expressed using paths.

Univalence′≃Univalence′ :
  {A B : Type ℓ} →
  Univalence′ A B ≃ PU.Univalence′ A B
Univalence′≃Univalence′ {A = A} {B = B} =
  Univalence′ A B      ↝⟨ Univalence′≃Univalence′-CP ext ⟩
  CP.Univalence′ A B   ↝⟨ Univalence′-CP≃Univalence′-CP ⟩
  PCP.Univalence′ A B  ↝⟨ inverse $ _↔_.from ≃↔≃ $ PU.Univalence′≃Univalence′-CP P.ext ⟩□
  PU.Univalence′ A B   □

-- Univalence expressed using equality is equivalent to univalence
-- expressed using paths.

Univalence≃Univalence : Univalence ℓ ≃ PU.Univalence ℓ
Univalence≃Univalence {ℓ = ℓ} =
  ({A B : Type ℓ} → Univalence′ A B)     ↝⟨ implicit-∀-cong ext $ implicit-∀-cong ext Univalence′≃Univalence′ ⟩□
  ({A B : Type ℓ} → PU.Univalence′ A B)  □


module Prelude where

infixr 90 _∘_
infixr 0 _$_

id : {A : Set} -> A -> A
id x = x

_∘_ : {A B C : Set} -> (B -> C) -> (A -> B) -> A -> C
(f ∘ g) x = f (g x)

_$_ : {A B : Set} -> (A -> B) -> A -> B
f $ x = f x

flip : {A B C : Set} -> (A -> B -> C) -> B -> A -> C
flip f x y = f y x

const : {A B : Set} -> A -> B -> A
const x _ = x

typeOf : {A : Set} -> A -> Set
typeOf {A} _ = A

typeOf1 : {A : Set1} -> A -> Set1
typeOf1 {A} _ = A


------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Standard evaluation for MTerm
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term
import Parametric.Denotation.Value as Value

import Parametric.Syntax.MType as MType
import Parametric.Syntax.MTerm as MTerm
import Parametric.Denotation.MValue as MValue

module Parametric.Denotation.MEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (ValConst : MTerm.ValConstStructure Const)
    (CompConst : MTerm.CompConstStructure Const)
    (cbnToCompConst : MTerm.CbnToCompConstStructure Const CompConst)
    (cbvToCompConst : MTerm.CbvToCompConstStructure Const CompConst)
  where

open Type.Structure Base

open MType.Structure Base
open MTerm.Structure Const ValConst CompConst cbnToCompConst cbvToCompConst
open MValue.Structure Base ⟦_⟧Base

open import Base.Data.DependentList
open import Base.Denotation.Notation

-- Extension Point: Evaluation of constants.
ValStructure : Set
ValStructure = ∀ {τ} → ValConst τ → ⟦ τ ⟧

CompStructure : Set
CompStructure = ∀ {τ} → CompConst τ → ⟦ τ ⟧

module Structure
       (⟦_⟧ValBase  : ValStructure)
       (⟦_⟧CompBase : CompStructure)
    where

  -- We provide: Evaluation of arbitrary value/computation terms.
  ⟦_⟧Comp : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValContext → ⟦ τ ⟧CompType
  ⟦_⟧Val : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValContext → ⟦ τ ⟧ValType

  ⟦ vVar x     ⟧Val ρ  = ⟦ x ⟧ValVar ρ
  ⟦ vThunk x   ⟧Val ρ  = ⟦ x ⟧Comp ρ
  ⟦ vConst c   ⟧Val ρ  = ⟦ c ⟧ValBase

  ⟦ cConst c   ⟧Comp ρ = ⟦ c ⟧CompBase
  ⟦ cForce x   ⟧Comp ρ = ⟦ x ⟧Val ρ
  ⟦ cReturn v  ⟧Comp ρ = ⟦ v ⟧Val ρ
  ⟦ cAbs c     ⟧Comp ρ = λ x → ⟦ c ⟧Comp (x • ρ)
  ⟦ cApp s t   ⟧Comp ρ = ⟦ s ⟧Comp ρ (⟦ t ⟧Val ρ)
  ⟦ c₁ into c₂ ⟧Comp ρ = ⟦ c₂ ⟧Comp (⟦ c₁ ⟧Comp ρ • ρ)

  meaningOfVal : ∀ {Γ τ} → Meaning (Val Γ τ)
  meaningOfVal = meaning ⟦_⟧Val

  -- Evaluation.agda also proves weaken-sound.


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

open import M-types.Base.Core

module M-types.Base.Prod where
    ∏ : (X : Ty ℓ₀) → (Y : X → Ty ℓ₁) → Ty (ℓ-max ℓ₀ ℓ₁)
    ∏ X Y = (x : X) → Y x

    ∏-syntax : (X : Ty ℓ₀) → (Y : X → Ty ℓ₁) → Ty (ℓ-max ℓ₀ ℓ₁)
    ∏-syntax = ∏
    infix 2 ∏-syntax
    syntax ∏-syntax X (λ x → Y) = ∏[ x ∈ X ] Y

    id : {X : Ty ℓ} →
        (X → X)
    id = λ x → x

    infixr 9 _∘_
    _∘_ : {X : Ty ℓ₀} {Y : X → Ty ℓ₁} {Z : {x : X} → Y x → Ty ℓ₂} →
        ∏[ g ∈ ({x : X} → ∏[ y ∈ Y x ] Z y) ]
        ∏[ f ∈ (∏[ x ∈ X ] Y x) ]
        ∏[ x ∈ X ] Z (f x)
    f ∘ g = λ x → f (g x)


{-# OPTIONS --safe #-}

module Cubical.HITs.FreeComMonoids.Properties where

open import Cubical.Foundations.Everything hiding (assoc; ⟨_⟩)

open import Cubical.Data.Nat hiding (_·_ ; _^_)

open import Cubical.HITs.FreeComMonoids.Base as FCM
open import Cubical.HITs.AssocList as AL

private variable
  ℓ : Level
  A : Type ℓ

multi-· : A → ℕ → FreeComMonoid A → FreeComMonoid A
multi-· x zero xs = xs
multi-· x (suc n) xs = ⟦ x ⟧ · multi-· x n xs

_^_ : A → ℕ → FreeComMonoid A
x ^ n = multi-· x n ε

^+≡ : ∀ (p : A) m n → ((p ^ m) · (p ^ n)) ≡ (p ^ (m + n))
^+≡ p zero n = identityₗ _
^+≡ p (suc m) n = sym (assoc _ _ _) ∙ cong (_ ·_) (^+≡ _ _ _)

AL→FCM : AssocList A → FreeComMonoid A
AL→FCM = AL.Rec.f trunc ε (λ a n p → (a ^ n) · p)
  per* agg* (const identityₗ)
  where
  per* : ∀ x y (mon : FreeComMonoid A) →
    ((⟦ x ⟧ · ε) · ((⟦ y ⟧ · ε) · mon)) ≡
    ((⟦ y ⟧ · ε) · ((⟦ x ⟧ · ε) · mon))
  per* x y mon =
    (⟦ x ⟧ · ε) · ((⟦ y ⟧ · ε) · mon)
    ≡⟨ assoc _ _ _ ⟩
    ((⟦ x ⟧ · ε) · (⟦ y ⟧ · ε)) · mon
    ≡⟨ cong (_· mon) (comm _ _) ⟩
    (((⟦ y ⟧ · ε) · (⟦ x ⟧ · ε)) · mon)
    ≡⟨ sym (assoc _ _ _) ⟩
    ((⟦ y ⟧ · ε) · ((⟦ x ⟧ · ε) · mon)) ∎

  agg* : ∀ a m n mon →
      ((a ^ m) · ((a ^ n) · mon)) ≡ ((a ^ (m + n)) · mon)
  agg* a m n mon =
    ((a ^ m) · ((a ^ n) · mon))
    ≡⟨ assoc _ _ _ ⟩
    (((a ^ m) · (a ^ n)) · mon)
    ≡⟨ cong (_· _) (^+≡ _ _ _) ⟩
    ((a ^ (m + n)) · mon) ∎

FCM→AL : FreeComMonoid A → AssocList A
FCM→AL = FCM.Rec.f trunc ⟨_⟩ ⟨⟩ _++_ comm-++ unitr-++ (λ _ → refl) assoc-++

^-id : (x : A) (m : ℕ) (u : FreeComMonoid A)
  → FCM→AL ((x ^ m) · u) ≡ ⟨ x , m ⟩∷ FCM→AL u
^-id x zero u = cong FCM→AL (identityₗ u) ∙ sym (del _ _)
^-id x (suc m) u =
  FCM→AL ((⟦ x ⟧ · (x ^ m)) · u)
  ≡⟨ cong ⟨ x , 1 ⟩∷_ (^-id x m u) ⟩
  ⟨ x , 1 ⟩∷ ⟨ x , m ⟩∷ FCM→AL u
  ≡⟨ agg _ _ _ _ ⟩
  ⟨ x , suc m ⟩∷ FCM→AL u ∎

++-· : (x y : AssocList A)
  → AL→FCM (x ++ y) ≡ AL→FCM x · AL→FCM y
++-· = AL.ElimProp.f
  (isPropΠ (λ _ → trunc _ _))
  (λ _ → sym (identityₗ _))
  λ x n {xs} p ys →
  AL→FCM (((⟨ x , n ⟩∷ ⟨⟩) ++ xs) ++ ys)
  ≡⟨ cong AL→FCM (cong (_++ ys) (comm-++ (⟨ x , n ⟩∷ ⟨⟩) xs) ∙ sym (assoc-++ xs _ ys)) ⟩
  AL→FCM (xs ++ (⟨ x , n ⟩∷ ys))
  ≡⟨ p _ ⟩
  (AL→FCM xs · ((x ^ n) · AL→FCM ys))
  ≡⟨ assoc (AL→FCM xs) _ _ ⟩
  ((AL→FCM xs · (x ^ n)) · AL→FCM ys)
  ≡⟨ cong (_· AL→FCM ys) (comm _ _) ⟩
  ((x ^ n) · AL→FCM xs) · AL→FCM ys ∎

AL→FCM∘FCM→AL≡id : section {A = AssocList A} AL→FCM FCM→AL
AL→FCM∘FCM→AL≡id = FCM.ElimProp.f (trunc _ _) (λ x → identityᵣ _ ∙ identityᵣ _) refl
  λ {x y} p q → ++-· (FCM→AL x) (FCM→AL y) ∙ cong₂ _·_ p q

FCM→AL∘AL→FCM≡id : retract {A = AssocList A} AL→FCM FCM→AL
FCM→AL∘AL→FCM≡id = AL.ElimProp.f (trunc _ _) refl
  λ x n {xs} p → ^-id x n (AL→FCM xs) ∙ cong (⟨ _ , _ ⟩∷_) p

AssocList≃FreeComMonoid : AssocList A ≃ FreeComMonoid A
AssocList≃FreeComMonoid = isoToEquiv (iso AL→FCM FCM→AL AL→FCM∘FCM→AL≡id FCM→AL∘AL→FCM≡id)

AssocList≡FreeComMonoid : AssocList A ≡ FreeComMonoid A
AssocList≡FreeComMonoid = ua AssocList≃FreeComMonoid


------------------------------------------------------------------------------
-- A partial function: iter₀
------------------------------------------------------------------------------

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

module FOTC.Program.Iter0.Iter0 where

open import FOTC.Base
open import FOTC.Base.List

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

postulate
  iter₀    : D → D → D
  iter₀-eq : ∀ f n → iter₀ f n ≡
             (if (iszero₁ n) then [] else (n ∷ iter₀ f (f · n)))
{-# ATP axiom iter₀-eq #-}


open import Prelude

module Implicits.Semantics.Type where

open import Data.Vec
open import Implicits.Syntax
open import SystemF.Everything as F using ()

⟦_⟧tp→ : ∀ {ν} → Type ν → F.Type ν
⟦ simpl (tc n) ⟧tp→ = F.tc n
⟦ simpl (tvar n) ⟧tp→ = F.tvar n
⟦ simpl (a →' b) ⟧tp→ = ⟦ a ⟧tp→ F.→' ⟦ b ⟧tp→
⟦ a ⇒ b ⟧tp→ = ⟦ a ⟧tp→ F.→' ⟦ b ⟧tp→
⟦ ∀' x ⟧tp→ = F.∀' ⟦ x ⟧tp→

⟦_⟧tps→ : ∀ {ν n} → Vec (Type ν) n → Vec (F.Type ν) n
⟦ v ⟧tps→ = map (⟦_⟧tp→) v


------------------------------------------------------------------------
-- Inductive axiomatisation of subtyping
------------------------------------------------------------------------

module RecursiveTypes.Subtyping.Axiomatic.Inductive where

open import Codata.Musical.Notation
open import Data.Nat using (ℕ; zero; suc)
open import Data.List using (List; []; _∷_; _++_)
open import Data.List.Relation.Unary.Any as Any using (Any)
open import Data.List.Relation.Unary.Any.Properties
open import Data.List.Relation.Unary.All as All using (All; []; _∷_)
open import Data.List.Membership.Propositional using (_∈_)
open import Data.Product
open import Data.Sum as Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Function.Base
open import Function.Equality using (_⟨$⟩_)
open import Function.Inverse using (module Inverse)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Relation.Binary.PropositionalEquality as PropEq
  using (_≡_; refl)

open import RecursiveTypes.Syntax
open import RecursiveTypes.Syntax.UnfoldedOrFixpoint
open import RecursiveTypes.Substitution using (unfold[μ_⟶_])
import RecursiveTypes.Subterm as ST
import RecursiveTypes.Subterm.RestrictedHypothesis as Restricted
open import RecursiveTypes.Subtyping.Semantic.Coinductive as Sem
  using (_≤Coind_)
open import RecursiveTypes.Subtyping.Axiomatic.Coinductive as Ax
  using (_≤_; ⊥; ⊤; _⟶_; unfold; fold; _∎; _≤⟨_⟩_)

------------------------------------------------------------------------
-- Definition

infixr 10 _⟶_
infix  4  _⊢_≤_
infix  3  _∎
infixr 2  _≤⟨_⟩_

-- This inductive subtyping relation is parameterised on a list of
-- hypotheses. Note Brandt and Henglein's unusual definition of _⟶_.

data _⊢_≤_ {n} (A : List (Hyp n)) : Ty n → Ty n → Set where
  -- Structural rules.
  ⊥   : ∀ {τ} → A ⊢ ⊥ ≤ τ
  ⊤   : ∀ {σ} → A ⊢ σ ≤ ⊤
  _⟶_ : ∀ {σ₁ σ₂ τ₁ τ₂} →
        let H = σ₁ ⟶ σ₂ ≲ τ₁ ⟶ τ₂ in
        (τ₁≤σ₁ : H ∷ A ⊢ τ₁ ≤ σ₁) (σ₂≤τ₂ : H ∷ A ⊢ σ₂ ≤ τ₂) →
        A ⊢ σ₁ ⟶ σ₂ ≤ τ₁ ⟶ τ₂

  -- Rules for folding and unfolding μ.
  unfold : ∀ {τ₁ τ₂} → A ⊢ μ τ₁ ⟶ τ₂ ≤ unfold[μ τ₁ ⟶ τ₂ ]
  fold   : ∀ {τ₁ τ₂} → A ⊢ unfold[μ τ₁ ⟶ τ₂ ] ≤ μ τ₁ ⟶ τ₂

  -- Reflexivity.
  _∎ : ∀ τ → A ⊢ τ ≤ τ

  -- Transitivity.
  _≤⟨_⟩_ : ∀ τ₁ {τ₂ τ₃}
           (τ₁≤τ₂ : A ⊢ τ₁ ≤ τ₂) (τ₂≤τ₃ : A ⊢ τ₂ ≤ τ₃) → A ⊢ τ₁ ≤ τ₃

  -- Hypothesis.
  hyp : ∀ {σ τ} (σ≤τ : (σ ≲ τ) ∈ A) → A ⊢ σ ≤ τ

------------------------------------------------------------------------
-- Soundness

-- A hypothesis is valid if there is a corresponding proof.

Valid : ∀ {n} → (Ty n → Ty n → Set) → Hyp n → Set
Valid _≤_ (σ₁ ≲ σ₂) = σ₁ ≤ σ₂

module Soundness where

  -- The soundness proof uses my trick to show that the code is
  -- productive.

  infixr 10 _⟶_
  infix   4 _≤P_ _≤W_
  infixr  2 _≤⟨_⟩_

  mutual

    -- Soundness proof programs.

    data _≤P_ {n} : Ty n → Ty n → Set where
      sound : ∀ {A σ τ} →
              (valid : All (Valid _≤W_) A) (σ≤τ : A ⊢ σ ≤ τ) → σ ≤P τ

    -- Weak head normal forms of soundness proof programs. Note that
    -- _⟶_ takes (suspended) /programs/ as arguments, while _≤⟨_⟩_
    -- takes /WHNFs/.

    data _≤W_ {n} : Ty n → Ty n → Set where
      done   : ∀ {σ τ} (σ≤τ : σ ≤ τ) → σ ≤W τ
      _⟶_    : ∀ {σ₁ σ₂ τ₁ τ₂}
               (τ₁≤σ₁ : ∞ (τ₁ ≤P σ₁)) (σ₂≤τ₂ : ∞ (σ₂ ≤P τ₂)) →
               σ₁ ⟶ σ₂ ≤W τ₁ ⟶ τ₂
      _≤⟨_⟩_ : ∀ τ₁ {τ₂ τ₃}
               (τ₁≤τ₂ : τ₁ ≤W τ₂) (τ₂≤τ₃ : τ₂ ≤W τ₃) → τ₁ ≤W τ₃

  -- The following two functions compute the WHNF of a soundness
  -- program. Note the circular, but productive, definition of proof
  -- below.

  soundW : ∀ {n} {σ τ : Ty n} {A} →
           All (Valid _≤W_) A → A ⊢ σ ≤ τ → σ ≤W τ
  soundW valid ⊥                     = done ⊥
  soundW valid ⊤                     = done ⊤
  soundW valid unfold                = done unfold
  soundW valid fold                  = done fold
  soundW valid (τ ∎)                 = done (τ ∎)
  soundW valid (τ₁ ≤⟨ τ₁≤τ₂ ⟩ τ₂≤τ₃) = τ₁ ≤⟨ soundW valid τ₁≤τ₂ ⟩
                                             soundW valid τ₂≤τ₃
  soundW valid (hyp σ≤τ)             = All.lookup valid σ≤τ
  soundW valid (τ₁≤σ₁ ⟶ σ₂≤τ₂)       = proof
    where
    proof : _ ≤W _
    proof = ♯ sound (proof ∷ valid) τ₁≤σ₁ ⟶
            ♯ sound (proof ∷ valid) σ₂≤τ₂

  whnf : ∀ {n} {σ τ : Ty n} →
         σ ≤P τ → σ ≤W τ
  whnf (sound valid σ≤τ) = soundW valid σ≤τ

  -- Computes actual proofs.

  mutual

    ⟦_⟧W : ∀ {n} {σ τ : Ty n} → σ ≤W τ → σ ≤ τ
    ⟦ done σ≤τ            ⟧W = σ≤τ
    ⟦ τ₁≤σ₁ ⟶ σ₂≤τ₂       ⟧W = ♯ ⟦ ♭ τ₁≤σ₁ ⟧P ⟶ ♯ ⟦ ♭ σ₂≤τ₂ ⟧P
    ⟦ τ₁ ≤⟨ τ₁≤τ₂ ⟩ τ₂≤τ₃ ⟧W = τ₁ ≤⟨ ⟦ τ₁≤τ₂ ⟧W ⟩ ⟦ τ₂≤τ₃ ⟧W

    ⟦_⟧P : ∀ {n} {σ τ : Ty n} → σ ≤P τ → σ ≤ τ
    ⟦ σ≤τ ⟧P = ⟦ whnf σ≤τ ⟧W

-- The subtyping relation defined above is sound with respect to the
-- others.

sound : ∀ {n A} {σ τ : Ty n} →
        All (Valid _≤_) A → A ⊢ σ ≤ τ → σ ≤ τ
sound {n} valid σ≤τ =
  ⟦ S.sound (All.map (λ {h} → done′ h) valid) σ≤τ ⟧P
  where
  open module S = Soundness

  done′ : (σ₁≲σ₂ : Hyp n) → Valid _≤_ σ₁≲σ₂ → Valid _≤W_ σ₁≲σ₂
  done′ (_ ≲ _) = done

------------------------------------------------------------------------
-- The subtyping relation is decidable

module Decidable {n} (χ₁ χ₂ : Ty n) where

  open Restricted χ₁ χ₂

  -- The proof below is not optimised for speed. (See Gapeyev, Levin
  -- and Pierce's "Recursive Subtyping Revealed" from ICFP '00 for
  -- more information about the complexity of subtyping algorithms.)

  mutual

    -- A wrapper which applies the U∨Μ view.

    _⊢_,_≤?_,_ : ∀ {A ℓ} → A ⊕ ℓ →
                 ∀ σ → Subterm σ → ∀ τ → Subterm τ →
                 ⟨ A ⟩⋆ ⊢ σ ≤ τ ⊎ (¬ σ ≤Coind τ)
    T ⊢ σ , σ⊑ ≤? τ , τ⊑ = T ⊩ u∨μ σ , σ⊑ ≤? u∨μ τ , τ⊑

    -- _⊩_,_≤?_,_ unfolds fixpoints. Note that at least one U∨Μ
    -- argument becomes smaller in each recursive call, while ℓ, an
    -- upper bound on the number of pairs of types yet to be
    -- inspected, is preserved.

    _⊩_,_≤?_,_ : ∀ {A ℓ} → A ⊕ ℓ →
                 ∀ {σ τ} → U∨Μ σ → Subterm σ → U∨Μ τ → Subterm τ →
                 ⟨ A ⟩⋆ ⊢ σ ≤ τ ⊎ (¬ σ ≤Coind τ)

    T ⊩ fixpoint {σ₁} {σ₂} u , σ⊑ ≤? τ , τ⊑ =
      Sum.map (λ ≤τ → μ σ₁ ⟶ σ₂           ≤⟨ unfold ⟩
                      unfold[μ σ₁ ⟶ σ₂ ]  ≤⟨ ≤τ ⟩
                      u∨μ⁻¹ τ             ∎)
              (λ ≰τ ≤τ → ≰τ (Sem.trans Sem.fold ≤τ))
              (T ⊩ u , anti-mono ST.unfold′ σ⊑ ≤? τ , τ⊑)
    T ⊩ σ , σ⊑ ≤? fixpoint {τ₁} {τ₂} u , τ⊑ =
      Sum.map (λ σ≤ → u∨μ⁻¹ σ             ≤⟨ σ≤ ⟩
                      unfold[μ τ₁ ⟶ τ₂ ]  ≤⟨ fold ⟩
                      μ τ₁ ⟶ τ₂           ∎)
              (λ σ≰ σ≤ → σ≰ (Sem.trans σ≤ Sem.unfold))
              (T ⊩ σ , σ⊑ ≤? u , anti-mono ST.unfold′ τ⊑)

    T ⊩ unfolded σ , σ⊑ ≤? unfolded τ , τ⊑ = T ⊪ σ , σ⊑ ≤? τ , τ⊑

    -- _⊪_,_≤?_,_ handles the structural cases. Note that ℓ becomes
    -- smaller in each recursive call.

    _⊪_,_≤?_,_ : ∀ {A ℓ} → A ⊕ ℓ →
                 ∀ {σ} → Unfolded σ → Subterm σ →
                 ∀ {τ} → Unfolded τ → Subterm τ →
                 ⟨ A ⟩⋆ ⊢ σ ≤ τ ⊎ (¬ σ ≤Coind τ)
    T ⊪ ⊥ , _ ≤? τ , _ = inj₁ ⊥
    T ⊪ σ , _ ≤? ⊤ , _ = inj₁ ⊤

    T ⊪ var x , _ ≤? var y , _ = helper (var x ≡? var y)
      where
      helper : ∀ {A x y} → Dec ((Ty n ∋ var x) ≡ var y) →
               ⟨ A ⟩⋆ ⊢ var x ≤ var y ⊎ ¬ var x ≤Coind var y
      helper (yes refl) = inj₁ (var _ ∎)
      helper (no  x≠y)  = inj₂ (x≠y ∘ Sem.var:≤∞⟶≡)

    _⊪_,_≤?_,_ {A} T (σ₁ ⟶ σ₂) σ⊑ (τ₁ ⟶ τ₂) τ⊑ =
      helper (lookupOrInsert T H)
      where
      H = (-, σ⊑) ≲ (-, τ⊑)

      helper₂ :
        ⟨ H ∷ A ⟩⋆ ⊢ τ₁      ≤ σ₁      ⊎ ¬ τ₁      ≤Coind σ₁      →
        ⟨ H ∷ A ⟩⋆ ⊢      σ₂ ≤      τ₂ ⊎ ¬      σ₂ ≤Coind      τ₂ →
        ⟨     A ⟩⋆ ⊢ σ₁ ⟶ σ₂ ≤ τ₁ ⟶ τ₂ ⊎ ¬ σ₁ ⟶ σ₂ ≤Coind τ₁ ⟶ τ₂
      helper₂ (inj₁ ≤₁) (inj₁ ≤₂) = inj₁ (≤₁ ⟶ ≤₂)
      helper₂ (inj₂ ≰ ) (_      ) = inj₂ (≰ ∘  Sem.left-proj)
      helper₂ (_      ) (inj₂ ≰ ) = inj₂ (≰ ∘ Sem.right-proj)

      helper : ∀ {ℓ} → Any (_≈_ H) A ⊎ (∃ λ n → ℓ ≡ suc n × H ∷ A ⊕ n) →
               ⟨ A ⟩⋆ ⊢ σ₁ ⟶ σ₂ ≤ τ₁ ⟶ τ₂ ⊎ ¬ σ₁ ⟶ σ₂ ≤Coind τ₁ ⟶ τ₂
      helper (inj₁ σ≲τ)             = inj₁ $ hyp $ Inverse.to map↔ ⟨$⟩ σ≲τ
      helper (inj₂ (_ , refl , T′)) = helper₂
        (T′ ⊢ τ₁ , anti-mono ST.⟶ˡ′ τ⊑ ≤? σ₁ , anti-mono ST.⟶ˡ′ σ⊑)
        (T′ ⊢ σ₂ , anti-mono ST.⟶ʳ′ σ⊑ ≤? τ₂ , anti-mono ST.⟶ʳ′ τ⊑)

    T ⊪ ⊤       , _ ≤? ⊥       , _ = inj₂ (λ ())
    T ⊪ ⊤       , _ ≤? var x   , _ = inj₂ (λ ())
    T ⊪ ⊤       , _ ≤? τ₁ ⟶ τ₂ , _ = inj₂ (λ ())
    T ⊪ var x   , _ ≤? ⊥       , _ = inj₂ (λ ())
    T ⊪ var x   , _ ≤? τ₁ ⟶ τ₂ , _ = inj₂ (λ ())
    T ⊪ σ₁ ⟶ σ₂ , _ ≤? ⊥       , _ = inj₂ (λ ())
    T ⊪ σ₁ ⟶ σ₂ , _ ≤? var x   , _ = inj₂ (λ ())

  -- Finally we have to prove that an upper bound ℓ actually exists.

  dec : [] ⊢ χ₁ ≤ χ₂ ⊎ (¬ χ₁ ≤ χ₂)
  dec = Sum.map id (λ σ≰τ → σ≰τ ∘ Ax.sound)
          (empty ⊢ χ₁ , inj₁ ST.refl ≤? χ₂ , inj₂ ST.refl)

infix 4 []⊢_≤?_ _≤?_

-- The subtyping relation defined above is decidable (when the set of
-- assumptions is empty).

[]⊢_≤?_ : ∀ {n} (σ τ : Ty n) → Dec ([] ⊢ σ ≤ τ)
[]⊢ σ ≤? τ with Decidable.dec σ τ
... | inj₁ σ≤τ = yes σ≤τ
... | inj₂ σ≰τ = no (σ≰τ ∘ sound [])

-- The other subtyping relations can also be decided.

_≤?_ : ∀ {n} (σ τ : Ty n) → Dec (σ ≤ τ)
σ ≤? τ with Decidable.dec σ τ
... | inj₁ σ≤τ = yes (sound [] σ≤τ)
... | inj₂ σ≰τ = no σ≰τ

------------------------------------------------------------------------
-- Completeness

-- Weakening (at the end of the list of assumptions).

weaken : ∀ {n A A′} {σ τ : Ty n} →
         A ⊢ σ ≤ τ → A ++ A′ ⊢ σ ≤ τ
weaken ⊥                     = ⊥
weaken ⊤                     = ⊤
weaken unfold                = unfold
weaken fold                  = fold
weaken (τ ∎)                 = τ ∎
weaken (τ₁ ≤⟨ τ₁≤τ₂ ⟩ τ₂≤τ₃) = τ₁ ≤⟨ weaken τ₁≤τ₂ ⟩ weaken τ₂≤τ₃
weaken (hyp h)               = hyp (Inverse.to ++↔ ⟨$⟩ inj₁ h)
weaken (τ₁≤σ₁ ⟶ σ₂≤τ₂)       = weaken τ₁≤σ₁ ⟶ weaken σ₂≤τ₂

-- The subtyping relation defined above is complete with respect to
-- the others.

complete : ∀ {n A} {σ τ : Ty n} →
           σ ≤ τ → A ⊢ σ ≤ τ
complete {σ = σ} {τ} σ≤τ with Decidable.dec σ τ
... | inj₁ []⊢σ≤τ = weaken []⊢σ≤τ
... | inj₂ σ≰τ    with σ≰τ σ≤τ
...   | ()


module SystemF.Syntax.Term.Constructors where

open import Prelude hiding (⊥-elim)
open import SystemF.WellTyped
open import SystemF.Substitutions.Lemmas
open import SystemF.Substitutions
open import SystemF.Syntax.Type.Constructors

-- polymorphic function application
-- applies a polymorphic function to an argument with the type of the domain
poly-· : ∀ {ν n} {a : Type ν} {K : Ctx ν n} {f arg} →
         (fa : IsFunction a) → K ⊢ f ∈ a → K ⊢ arg ∈ domain fa → ∃ λ t → K ⊢ t ∈ codomain fa
poly-· (lambda a b) ⊢f ⊢arg = , ⊢f · ⊢arg
poly-· {K = K} {f = f} {arg = arg} (∀'-lambda {a} fa) ⊢f ⊢arg = , Λ (proj₂ (poly-· fa f' arg'))
  where
    f' : ctx-weaken K ⊢ _ ∈ a
    f' = subst
      (λ τ → ctx-weaken K ⊢ _ ∈ τ)
     (TypeLemmas.a-/Var-varwk↑-/-sub0≡a a)
      ((⊢tp-weaken ⊢f) [ tvar zero ])
    arg' : ctx-weaken K ⊢ (tm-weaken arg) [ tvar zero ] ∈ domain fa
    arg' = subst
      (λ τ → ctx-weaken K ⊢ _ ∈ τ)
      (TypeLemmas.a-/Var-varwk↑-/-sub0≡a (domain fa))
      ((⊢tp-weaken ⊢arg) [ tvar zero ])

-- Polymorphic identity function
id' : {ν n : ℕ} → Term ν n
id' = Λ (λ' (tvar zero) (var zero))

-- Bottom elimination/univeral property of the initial type
⊥-elim : ∀ {m n} → Type n → Term n m
⊥-elim a = λ' ⊥' ((var zero) [ a ])

-- Unit value
tt = id'

-- n-ary term abstraction
λⁿ : ∀ {ν m k} → Vec (Type ν) k → Term ν (k N+ m) → Term ν m
λⁿ []       t = t
λⁿ (a ∷ as) t = λⁿ as (λ' a t)

infixl 9 _·ⁿ_

-- n-ary term application
_·ⁿ_ : ∀ {m n k} → Term m n → Vec (Term m n) k → Term m n
s ·ⁿ []       = s
s ·ⁿ (t ∷ ts) = (s ·ⁿ ts) · t

-- Record/tuple constructor
newrec : ∀ {ν n k} → Vec (Term ν n) k → {as : Vec (Type ν) k} → Term ν n
newrec []                = tt
newrec (t ∷ ts) {a ∷ as} =
  Λ (λ' (map tp-weaken (a ∷ as) →ⁿ tvar zero)
    (var zero ·ⁿ map tmtm-weaken (map tm-weaken (t ∷ ts))))

-- Field access/projection
π : ∀ {ν n k} → Fin k → Term ν n → {as : Vec (Type ν) k} → Term ν n
π     () t {[]}
π {n = n} x  t {as} =
  (t [ lookup x as ]) · (λⁿ as (var (inject+ n x)))


{-# OPTIONS --two-level #-}

open import Agda.Primitive

data Unit : Set where tt : Unit
data Unitω : Setω where tt : Unitω
data SUnit : SSet where tt : SUnit
data SUnitω : SSetω where tt : SUnitω

-- Cannot eliminate fibrant type Unit
-- unless target type is also fibrant
-- f1 : Unit → SUnit
-- f1 tt = tt

-- Cannot eliminate fibrant type Unit
-- unless target type is also fibrant
-- f2 : Unit → SUnitω
-- f2 tt = tt

--f3 : Unitω → SUnit
--f3 tt = tt

f4 : Unitω → SUnitω
f4 tt = tt


open import Signature
import Program

module Rewrite (Σ : Sig) (V : Set) (P : Program.Program Σ V) where

open import Terms Σ
open import Program Σ V
open import Data.Empty renaming (⊥ to ∅)
open import Data.Unit
open import Data.Product as Prod renaming (Σ to ⨿)
open import Data.Sum as Sum
open import Data.Fin
open import Relation.Nullary
open import Relation.Unary
open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst)

data _⟿_ (t : T V) : T V → Set where
  rew-step : (cl : dom P) (i : dom (getb P cl)) {σ : Subst V V} →
             matches (geth P cl) t σ → -- (mgm t (geth P cl) σ) →
             t ⟿ app σ (get (getb P cl) i)

Val : Pred (T V) _
Val t = (cl : dom P) (i : dom (getb P cl)) {σ : Subst V V} →
        ¬ (matches (geth P cl) t σ)

no-rewrite-on-vals : (t : T V) → Val t → (s : T V) → ¬ (t ⟿ s)
no-rewrite-on-vals t p ._ (rew-step cl i q) = p cl i q

data _↓_ (t : T V) : T V → Set where
  val : Val t → t ↓ t
  step : (r s : T V) → r ↓ s → t ⟿ r → t ↓ s

{- Strongly normalising terms wrt to P are either in normal form, i.e. values,
or for every clause that matches, every rewrite step must be SN.
This is an adaption of the usual (constructive) definition.
-}
data SN (t : T V) : Set where
  val-sn   : Val t → SN t
  steps-sn : (cl : dom P) (i : dom (getb P cl)) {σ : Subst V V} →
             (matches t (geth P cl) σ) →
             SN (app σ (get (getb P cl) i)) →
             SN t

-- | Determines whether a term t is derivable from an axiom, i.e., whether
-- there is a clause " ⇒ p" such that p matches t.
Axiom : Pred (T V) _
Axiom t = ∃₂ λ cl σ → (mgm t (geth P cl) σ) × (domEmpty (getb P cl))

-- | An inductively valid term is derivable in finitely many steps from
-- axioms.
data Valid (t : T V) : Set where
  val-sn   : Axiom t → Valid t
  steps-sn : (cl : dom P) (i : dom (getb P cl)) {σ : Subst V V} →
             (matches t (geth P cl) σ) →
             Valid (app σ (get (getb P cl) i)) →
             Valid t

{-

⊥ : {X : Set} → X ⊎ ⊤
⊥ = inj₂ tt

record Rew-Branch (F : T V → Set) (t : T V) : Set where
  constructor prf-branch
  field
    clause : dom P
    matcher : Subst V V
    isMgm : mgm t (geth P clause) matcher
    next : (i : dom (getb P clause)) →
           F (app matcher (get (getb P clause) i))

-- | Set of rewrite trees starting in t that use the rules given in P.
-- If the tree is ⊥, then t cannot be rewritten by any of the rules of P.
data Rew (t : T V) : Set where
  in-prf : Rew-Branch Rew t ⊎ ⊤ → Rew t

-- | Just as Rew, only that we also allow infinite rewriting sequences.
record Rew∞ (t : T V) : Set where
  coinductive
  field out-prf : Rew-Branch Rew∞ t ⊎ ⊤
open Rew∞

out-prf⁻¹ : ∀{t} → Rew-Branch Rew∞ t ⊎ ⊤ → Rew∞ t
out-prf (out-prf⁻¹ b) = b

-- | Finite rewriting trees are included in the set of the possibly infinite
-- ones.
χ-prf : ∀{t} → Rew t → Rew∞ t
χ-prf (in-prf (inj₁ (prf-branch c m isMgm next))) =
  out-prf⁻¹ (inj₁ (prf-branch c m isMgm (λ i → χ-prf (next i))))
χ-prf (in-prf (inj₂ tt)) = out-prf⁻¹ ⊥

Rew-Step : (F : {s : T V} → Rew∞ s → Set) → {t : T V} (R : Rew∞ t) → Set
Rew-Step F R with out-prf R
Rew-Step F R | inj₁ (prf-branch clause matcher isMgm next) = {!!}
Rew-Step F R | inj₂ tt = ∅

data Path {t : T V} (R : Rew∞ t) : Set where
  root : Path R
  step : {!!} → Path R
-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Argument relevance used in the reflection machinery
------------------------------------------------------------------------

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

module Reflection.Argument.Relevance where

open import Relation.Nullary
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

------------------------------------------------------------------------
-- Re-exporting the builtins publically

open import Agda.Builtin.Reflection public using (Relevance)
open Relevance public

------------------------------------------------------------------------
-- Decidable equality

_≟_ : DecidableEquality Relevance
relevant   ≟ relevant   = yes refl
irrelevant ≟ irrelevant = yes refl
relevant   ≟ irrelevant = no λ()
irrelevant ≟ relevant   = no λ()


{-# OPTIONS --omega-in-omega --no-termination-check --overlapping-instances #-}

module Light.Variable.Levels where

open import Light.Level using (Level)

variable ℓ aℓ bℓ cℓ dℓ eℓ fℓ gℓ hℓ : Level


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

open import lib.Basics
open import lib.types.Group
open import lib.types.List
open import lib.types.Pi
open import lib.types.Sigma
open import lib.types.Word
open import lib.groups.Homomorphism
open import lib.groups.GeneratedGroup
open import lib.groups.GeneratedAbelianGroup
open import lib.groups.Isomorphism

module lib.groups.TensorProduct where

module TensorProduct₀ {i} {j} (G : AbGroup i) (H : AbGroup j) where

  private
    module G = AbGroup G
    module H = AbGroup H

  ⊗-pair : Type (lmax i j)
  ⊗-pair = G.El × H.El

  data ⊗-rel : Word ⊗-pair → Word ⊗-pair → Type (lmax i j) where
    linear-l : (g₁ g₂ : G.El) (h : H.El) →
      ⊗-rel (inl (G.comp g₁ g₂ , h) :: nil) (inl (g₁ , h) :: inl (g₂ , h) :: nil)
    linear-r : (g : G.El) (h₁ h₂ : H.El) →
      ⊗-rel (inl (g , H.comp h₁ h₂) :: nil) (inl (g , h₁) :: inl (g , h₂) :: nil)

  private
    module Gen = GeneratedAbelianGroup ⊗-pair ⊗-rel
  open Gen hiding (GenGroup; GenAbGroup; El) public

  abstract
    abgroup : AbGroup (lmax i j)
    abgroup = Gen.GenAbGroup

  open AbGroup abgroup public

  abstract
    infixr 80 _⊗_
    _⊗_ : G.El → H.El → El
    _⊗_ g h = insert (g , h)

    ⊗-lin-l : ∀ g₁ g₂ h → G.comp g₁ g₂ ⊗ h == comp (g₁ ⊗ h) (g₂ ⊗ h)
    ⊗-lin-l g₁ g₂ h = rel-holds (linear-l g₁ g₂ h)

    ⊗-lin-r : ∀ g h₁ h₂ → g ⊗ H.comp h₁ h₂ == comp (g ⊗ h₁) (g ⊗ h₂)
    ⊗-lin-r g h₁ h₂ = rel-holds (linear-r g h₁ h₂)

    ⊗-unit-l : ∀ h → G.ident ⊗ h == ident
    ⊗-unit-l h = cancel-l (G.ident ⊗ h) $
      comp (G.ident ⊗ h) (G.ident ⊗ h)
        =⟨ ! (⊗-lin-l G.ident G.ident h) ⟩
      G.comp G.ident G.ident ⊗ h
        =⟨ ap (_⊗ h) (G.unit-l G.ident) ⟩
      G.ident ⊗ h
        =⟨ ! (unit-r (G.ident ⊗ h)) ⟩
      comp (G.ident ⊗ h) ident =∎

    ⊗-unit-r : ∀ g → g ⊗ H.ident == ident
    ⊗-unit-r g = cancel-r (g ⊗ H.ident) $
      comp (g ⊗ H.ident) (g ⊗ H.ident)
        =⟨ ! (⊗-lin-r g H.ident H.ident) ⟩
      g ⊗ H.comp H.ident H.ident
        =⟨ ap (g ⊗_) (H.unit-l H.ident) ⟩
      g ⊗ H.ident
        =⟨ ! (unit-r (g ⊗ H.ident)) ⟩
      comp (g ⊗ H.ident) ident =∎

  ins-l-hom : H.El → G.grp →ᴳ grp
  ins-l-hom h = group-hom (_⊗ h) (λ g₁ g₂ → ⊗-lin-l g₁ g₂ h)

  ins-r-hom : G.El → H.grp →ᴳ grp
  ins-r-hom g = group-hom (g ⊗_) (⊗-lin-r g)

  module BilinearMaps {k} (L : AbGroup k) where

    private
      module L = AbGroup L
      module HE = Gen.HomomorphismEquiv L

    is-linear-l : (G.El → H.El → L.El) → Type (lmax i (lmax j k))
    is-linear-l b = ∀ g₁ g₂ h → b (G.comp g₁ g₂) h == L.comp (b g₁ h) (b g₂ h)

    is-linear-l-is-prop : (b : G.El → H.El → L.El) → is-prop (is-linear-l b)
    is-linear-l-is-prop b =
      Π-level $ λ g₁ →
      Π-level $ λ g₂ →
      Π-level $ λ h →
      has-level-apply L.El-level _ _

    is-linear-r : (G.El → H.El → L.El) → Type (lmax i (lmax j k))
    is-linear-r b = ∀ g h₁ h₂ → b g (H.comp h₁ h₂) == L.comp (b g h₁) (b g h₂)

    is-linear-r-is-prop : (b : G.El → H.El → L.El) → is-prop (is-linear-r b)
    is-linear-r-is-prop b =
      Π-level $ λ g →
      Π-level $ λ h₁ →
      Π-level $ λ h₂ →
      has-level-apply L.El-level _ _

    record BilinearMap : Type (lmax i (lmax j k)) where
      field
        bmap : G.El → H.El → L.El
        linearity-l : is-linear-l bmap
        linearity-r : is-linear-r bmap

    BilinearMap= : {b b' : BilinearMap}
      → BilinearMap.bmap b == BilinearMap.bmap b'
      → b == b'
    BilinearMap= {b} {b'} idp =
      ap2 mk-bilinear-map
        (prop-path (is-linear-l-is-prop b.bmap) b.linearity-l b'.linearity-l)
        (prop-path (is-linear-r-is-prop b.bmap) b.linearity-r b'.linearity-r)
      where
      module b  = BilinearMap b
      module b' = BilinearMap b'
      mk-bilinear-map : is-linear-l b.bmap → is-linear-r b.bmap → BilinearMap
      mk-bilinear-map lin-l lin-r =
        record { bmap = b.bmap; linearity-l = lin-l; linearity-r = lin-r }

    bilinear-to-legal-equiv : BilinearMap ≃ HE.RelationRespectingFunction
    bilinear-to-legal-equiv =
      equiv to from
            (λ lf → HE.RelationRespectingFunction= idp)
            (λ b  → BilinearMap= idp)
      where
      to : BilinearMap → HE.RelationRespectingFunction
      to b = HE.rel-res-fun f f-respects
        where
        module b = BilinearMap b
        f : ⊗-pair → L.El
        f (g , h) = b.bmap g h
        f-respects : HE.respects-rel f
        f-respects (linear-l g₁ g₂ h) = b.linearity-l g₁ g₂ h
        f-respects (linear-r g h₁ h₂) = b.linearity-r g h₁ h₂
      from : HE.RelationRespectingFunction → BilinearMap
      from (HE.rel-res-fun f f-respects) =
        record { bmap = bmap; linearity-l = linearity-l; linearity-r = linearity-r }
        where
        bmap : G.El → H.El → L.El
        bmap g h = f (g , h)
        linearity-l : is-linear-l bmap
        linearity-l g₁ g₂ h = f-respects (linear-l g₁ g₂ h)
        linearity-r : is-linear-r bmap
        linearity-r g h₁ h₂ = f-respects (linear-r g h₁ h₂)

  module UniversalProperty {k} (L : AbGroup k) where

    open BilinearMaps L public
    private
      module HE = Gen.HomomorphismEquiv L

    abstract
      extend-equiv : BilinearMap ≃ (grp →ᴳ AbGroup.grp L)
      extend-equiv =
        HE.extend-equiv ∘e bilinear-to-legal-equiv

      extend : BilinearMap → (grp →ᴳ AbGroup.grp L)
      extend = –> extend-equiv

      restrict : (grp →ᴳ AbGroup.grp L) → BilinearMap
      restrict = <– extend-equiv

      extend-β : ∀ b g h → GroupHom.f (extend b) (g ⊗ h) == BilinearMap.bmap b g h
      extend-β b g h = idp

      hom= : ∀ {ϕ ψ : grp →ᴳ AbGroup.grp L}
        → (∀ g h → GroupHom.f ϕ (g ⊗ h) == GroupHom.f ψ (g ⊗ h))
        → ϕ == ψ
      hom= {ϕ} {ψ} e =
        ϕ
          =⟨ ! (<–-inv-r extend-equiv ϕ) ⟩
        extend (restrict ϕ)
          =⟨ ap extend (BilinearMap= (λ= (λ g → λ= (λ h → e g h)))) ⟩
        extend (restrict ψ)
          =⟨ <–-inv-r extend-equiv ψ ⟩
        ψ =∎

module TensorProduct₁ {i} {j} (G : AbGroup i) (H : AbGroup j) where

  private
    module G⊗H = TensorProduct₀ G H
    module H⊗G = TensorProduct₀ H G
    module F = G⊗H.UniversalProperty H⊗G.abgroup

    b : F.BilinearMap
    b =
      record
      { bmap = λ g h → h H⊗G.⊗ g
      ; linearity-l = λ g₁ g₂ h → H⊗G.⊗-lin-r h g₁ g₂
      ; linearity-r = λ g h₁ h₂ → H⊗G.⊗-lin-l h₁ h₂ g
      }

  swap : (G⊗H.grp →ᴳ H⊗G.grp)
  swap = F.extend b

  swap-β : ∀ g h →
    GroupHom.f swap (g G⊗H.⊗ h) == h H⊗G.⊗ g
  swap-β g h = F.extend-β b g h

  open G⊗H public

module TensorProduct₂ {i} {j} (G : AbGroup i) (H : AbGroup j) where

  private
    module G⊗H = TensorProduct₁ G H
    module H⊗G = TensorProduct₁ H G

  swap-swap : ∀ s → GroupHom.f (H⊗G.swap ∘ᴳ G⊗H.swap) s == s
  swap-swap s =
    ap (λ ϕ → GroupHom.f ϕ s) $
    G⊗H.UniversalProperty.hom= G⊗H.abgroup {ϕ = H⊗G.swap ∘ᴳ G⊗H.swap} {ψ = idhom _} $
    λ g h → ap (GroupHom.f H⊗G.swap) (G⊗H.swap-β g h) ∙ H⊗G.swap-β h g

  swap-swap-idhom : H⊗G.swap ∘ᴳ G⊗H.swap == idhom G⊗H.grp
  swap-swap-idhom = group-hom= (λ= swap-swap)

  open G⊗H public

module TensorProduct {i} {j} (G : AbGroup i) (H : AbGroup j) where

  private
    module G⊗H = TensorProduct₂ G H
    module H⊗G = TensorProduct₂ H G

  swap-is-equiv : is-equiv (GroupHom.f G⊗H.swap)
  swap-is-equiv = is-eq _ (GroupHom.f H⊗G.swap) H⊗G.swap-swap G⊗H.swap-swap

  commutative : G⊗H.grp ≃ᴳ H⊗G.grp
  commutative = G⊗H.swap , swap-is-equiv

  open G⊗H public


import Common.Level
open import Common.Equality

record Sigma (A : Set)(B : A -> Set) : Set where
  constructor _,_
  field
    fst : A
    snd : B fst
open Sigma

-- projected bound var
fail : (A : Set) (B : A -> Set) ->
  let X : A -> Sigma A B
      X = _
  in  (z : Sigma A B) -> X (fst z) ≡ z
fail A B z = refl


open import Relation.Unary
open import Relation.Ternary.Separation

module Relation.Ternary.Separation.Monad.Error {ℓ} {A : Set ℓ}
  {{r : RawSep A}}
  {u} {{_ : IsUnitalSep r u}}
  where

open import Level
open import Function
open import Data.Unit
open import Data.Sum
open import Relation.Unary renaming (U to True)
open import Relation.Unary.PredicateTransformer using (PT; Pt)
open import Relation.Ternary.Separation.Morphisms
open import Relation.Ternary.Separation.Monad
open import Relation.Binary.PropositionalEquality

module _ where
  record ExceptT (M : Pt A ℓ) (E : Set ℓ) (P : Pred A ℓ) (Φ : A) : Set ℓ where
    constructor partial
    field
      runErr : M ((λ _ → E) ∪ P) Φ

  open ExceptT public

  open import Relation.Ternary.Separation.Monad.Identity

  Except : ∀ E → Pt A ℓ
  Except E = ExceptT Identity.Id E

  pattern error e = partial (inj₁ e)
  pattern ✓ x     = partial (inj₂ x)

  data Err : Set ℓ where
    err : Err

  ErrorT : (M : Pt A ℓ) {{monad : Monads.Monad ⊤ ℓ (λ _ _ → M) }} → Pt A ℓ
  ErrorT M = ExceptT M Err

  open import Relation.Ternary.Separation.Monad.Identity

  Error : Pt A ℓ
  Error = ErrorT Identity.Id

module ExceptTrans
  (M : Pt A ℓ)
  {{monad : Monads.Monad ⊤ ℓ (λ _ _ → M) }}
  (Exc : Set ℓ) where

  open Monads

  instance
    except-monad : Monad ⊤ ℓ (λ _ _ → ExceptT M Exc)
    runErr (Monad.return except-monad px) =
      return (inj₂ px)
    runErr (app (Monad.bind except-monad f) (partial mpx) σ) = do
      inj₂ px ×⟨ σ₂ ⟩ f ← mpx &⟨ _ ─✴ _ ∥ ⊎-comm σ ⟩ f
        where
          (inj₁ e ×⟨ σ₂ ⟩ f) → return (inj₁ e)
      case app f px (⊎-comm σ₂) of λ where
        (partial z) → z

  mapExc : ∀ {E₁ E₂ P} → (E₁ → E₂) → ∀[ ExceptT M E₁ P ⇒ ExceptT M E₂ P ]
  mapExc f (partial mc) = partial (mapM mc λ where (inj₁ e) → inj₁ (f e); (inj₂ px) → inj₂ px)

module ExceptMonad (Exc : Set ℓ) where
  open import Relation.Ternary.Separation.Monad.Identity
  open ExceptTrans Identity.Id {{ Identity.id-monad }} Exc public

module ErrorTrans (M : Pt A ℓ) {{monad : Monads.Monad ⊤ ℓ (λ _ _ → M) }} where
  open import Relation.Ternary.Separation.Monad.Identity
  open ExceptTrans M {{ monad }} Err public
    renaming (except-monad to error-monad)

module ErrorMonad where
  open import Relation.Ternary.Separation.Monad.Identity
  open ExceptTrans Identity.Id {{ Identity.id-monad }} Err public
    renaming (except-monad to error-monad)


------------------------------------------------------------------------
-- A formalization of the polymorphic lambda calculus extended with
-- iso-recursive types
------------------------------------------------------------------------

-- Author: Sandro Stucki
-- Copyright (c) 2015 EPFL

-- The code in this directory contains an Agda formalization of the
-- Girard-Reynolds polymorphic lambda calculus (System F) extended
-- with iso-recursive types.
--
-- The code makes heavy use of the Agda standard library, which is
-- freely available from
--
--   https://github.com/agda/agda-stdlib/
--
-- The code has been tested using Agda 2.6.0.1 and version 1.0.1 of the
-- Agda standard library.

module README where

------------------------------------------------------------------------
-- Module overview

-- The formalization is organized in the following modules.

-- Syntax for terms and types along with support for term/type
-- substitutions.  These modules also contain church/CPS encodings for
-- some other forms, such as existential types or tuples.
open import SystemF.Term
open import SystemF.Type

-- Typing derivations along with substitution/weakening lemmas.
open import SystemF.WtTerm

-- A (functional) call-by-value small-step semantics.  This module
-- also contains a type soundness proof with respect to to said
-- semantics as well as a proof of its equivalence (strong
-- bisimilarity) to the big-step semantics mentioned below.  The type
-- soundness proof uses the common progress & preservation
-- (i.e. subject reduction) structure.
open import SystemF.Reduction

-- Two equivalent versions of a (functional) call-by-value big-step
-- semantics along with corresponding type soundness proofs.  The
-- second version is formulated without the use of productivity
-- checker workarounds.  The latter module also contains an
-- equivalence proof of the two semantics.
open import SystemF.Eval
open import SystemF.Eval.NoWorkarounds

-- Decision procedures for type checking and a uniqueness proof for
-- typing derivations.
open import SystemF.TypeCheck

-- Danielsson's partiality-and-failure monad.  This monad provides the
-- domain in which functional operational semantics are formulated.
open import PartialityAndFailure


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

open import HoTT
open import cohomology.CofiberSequence
open import cohomology.FunctionOver

module cohomology.MayerVietoris {i} where

{- Mayer-Vietoris Sequence: Given a span X ←f– Z –g→ Y, the cofiber space
   of the natural map [reglue : X ∨ Y → X ⊔_Z Y] (defined below) is equivalent
   to the suspension of Z. -}

{- Relevant functions -}
module MayerVietorisFunctions (ps : ⊙Span {i} {i} {i}) where

  open ⊙Span ps

  module Reglue = WedgeRec
    {X = ⊙Span.X ps} {Y = ⊙Span.Y ps} {C = fst (⊙Pushout ps)}
    left right (! (ap left (snd f)) ∙ glue (snd Z) ∙' ap right (snd g))

  reglue : X ∨ Y → fst (⊙Pushout ps)
  reglue = Reglue.f

  ⊙reglue : fst (X ⊙∨ Y ⊙→ ⊙Pushout ps)
  ⊙reglue = (reglue , idp)

  module MVDiff = SuspensionRec (fst Z) {C = Suspension (X ∨ Y)}
    (north _)
    (north _)
    (λ z → merid _ (winl (fst f z)) ∙ ! (merid _ (winr (fst g z))))

  mv-diff : Suspension (fst Z) → Suspension (X ∨ Y)
  mv-diff = MVDiff.f

  ⊙mv-diff : fst (⊙Susp Z ⊙→ ⊙Susp (X ⊙∨ Y))
  ⊙mv-diff = (mv-diff , idp)

{- We use path induction (via [⊙pushout-J]) to assume that the
   basepoint preservation paths of the span maps are [idp]. The module
   [Base] contains the proof of the theorem for this case. -}
module MayerVietorisBase
  {A B : Type i} (Z : Ptd i) (f : fst Z → A) (g : fst Z → B) where

  X = ⊙[ A , f (snd Z) ]
  Y = ⊙[ B , g (snd Z) ]
  ps = ⊙span X Y Z (f , idp) (g , idp)
  F : fst (Z ⊙→ X)
  F = (f , idp)
  G : fst (Z ⊙→ Y)
  G = (g , idp)

  open MayerVietorisFunctions ps

  {- Definition of the maps
       into : Cofiber reglue → ΣZ
       out  : ΣZ → Cofiber reglue
   -}

  private
    into-glue-square :
      Square idp idp (ap (ext-glue ∘ reglue) wglue) (merid _ (snd Z))
    into-glue-square =
      connection ⊡v∙
      ! (ap-∘ ext-glue reglue wglue ∙ ap (ap ext-glue) Reglue.glue-β
         ∙ ExtGlue.glue-β (snd Z))

    module IntoGlue = WedgeElim {P = λ xy → north _ == ext-glue (reglue xy)}
      (λ _ → idp)
      (λ _ → merid _ (snd Z))
      (↓-cst=app-from-square into-glue-square)

    into-glue = IntoGlue.f

  module Into = CofiberRec reglue (north _) ext-glue into-glue

  private
    out-glue-and-square : (z : fst Z)
      → Σ (cfbase reglue == cfbase reglue)
          (λ p → Square (cfglue _ (winl (f z))) p
                   (ap (cfcod _) (glue z)) (cfglue _ (winr (g z))))
    out-glue-and-square z = fill-square-top _ _ _

    out-glue = fst ∘ out-glue-and-square
    out-square = snd ∘ out-glue-and-square

  module Out = SuspensionRec (fst Z) {C = Cofiber reglue}
    (cfbase _)
    (cfbase _)
    out-glue

  into = Into.f
  out = Out.f

  {- [out] is a right inverse for [into] -}

  private
    into-out-sq : (z : fst Z) →
      Square idp (ap into (ap out (merid _ z))) (merid _ z) (merid _ (snd Z))
    into-out-sq z =
      (ap (ap into) (Out.glue-β z) ∙v⊡
        (! (Into.glue-β (winl (f z)))) ∙h⊡
          ap-square into (out-square z)
        ⊡h∙ (Into.glue-β (winr (g z))))
      ⊡v∙ (∘-ap into (cfcod _) (glue z) ∙ ExtGlue.glue-β z)

  into-out : ∀ σ → into (out σ) == σ
  into-out = Suspension-elim (fst Z)
    idp
    (merid _ (snd Z))
    (λ z → ↓-∘=idf-from-square into out (into-out-sq z))

  {- [out] is a left inverse for [into] -}

  {- [out] is left inverse on codomain part of cofiber space,
   - i.e. [out (into (cfcod _ γ)) == cfcod _ γ] -}

  private
    out-into-cod-square : (z : fst Z) →
      Square (cfglue reglue (winl (f z)))
             (ap (out ∘ ext-glue {s = ⊙span-out ps}) (glue z))
             (ap (cfcod _) (glue z)) (cfglue _ (winr (g z)))
    out-into-cod-square z =
      (ap-∘ out ext-glue (glue z)
        ∙ ap (ap out) (ExtGlue.glue-β z) ∙ Out.glue-β z)
      ∙v⊡ out-square z

    module OutIntoCod = PushoutElim
      {d = ⊙span-out ps} {P = λ γ → out (into (cfcod _ γ)) == cfcod _ γ}
      (λ x → cfglue _ (winl x))
      (λ y → cfglue _ (winr y))
      (λ z → ↓-='-from-square (out-into-cod-square z))

    out-into-cod = OutIntoCod.f

  {- Cube move lemma for the left inverse coherence. This is used to
     build up a right square (in this case starting from a cube filler)  -}
  private
    square-push-rb : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A} {b : A}
      {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : a₁₀ == b}
      (q : b == a₁₁) (sq : Square p₀₋ p₋₀ p₋₁ (p₁₋ ∙ q))
      → Square p₀₋ p₋₀ (p₋₁ ∙' ! q) p₁₋
    square-push-rb {p₁₋ = idp} idp sq = sq

    right-from-bot-lemma : ∀ {i} {A : Type i}
      {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ b₀ b₁ : A}
      {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
      {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
      {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

      {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
      {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
      (sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) -- right

      {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == b₀}
      {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == b₁}
      {q₀₋ : a₀₁₁ == b₀} {q₋₁ : b₀ == b₁} {q₁₋ : a₁₁₁ == b₁}
      {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ (p₀₋₁ ∙ q₀₋)} -- back
      {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
      {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ q₋₁} -- bottom
      {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ (p₁₋₁ ∙ q₁₋)} -- front
      (sq' : Square q₀₋ p₋₁₁ q₋₁ q₁₋)
      (cu : Cube sq₋₋₀ sq₋₋₁ (square-push-rb q₀₋ sq₀₋₋)
                 sq₋₀₋ (sq₋₁₋ ⊡h' !□h (square-symmetry sq'))
                 (square-push-rb q₁₋ sq₁₋₋))
      → Cube sq₋₋₀ (sq₋₋₁ ⊡v sq') sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
    right-from-bot-lemma sq₋₋₁ ids cu = right-from-bot-lemma' sq₋₋₁ cu
      where
      right-from-bot-lemma' : ∀ {i} {A : Type i}
        {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
        {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
        {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
        {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

        {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
        {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
        (sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) -- right

        {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
        {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
        {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ (p₀₋₁ ∙ idp)} -- back
        {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
        {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
        {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ (p₁₋₁ ∙ idp)} -- front
        (cu : Cube sq₋₋₀ sq₋₋₁ (square-push-rb idp sq₀₋₋) sq₋₀₋
                   (sq₋₁₋ ⊡h' !□h (square-symmetry vid-square))
                   (square-push-rb idp sq₁₋₋))
        → Cube sq₋₋₀ (sq₋₋₁ ⊡v vid-square) sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
      right-from-bot-lemma' ids cu = cu

  {- Proving the coherence term for the left inverse. This means proving
     [(w : X ∨ Y) → Square idp (ap out (ap into (glue w)))
                               (cfglue _ w) (out-into-cod (reglue w))]
  -}

  private
    out-into-sql : (x : fst X) → Square idp (ap out (into-glue (winl x)))
                                        (cfglue _ (winl x)) (cfglue _ (winl x))
    out-into-sql x = connection

    out-into-fill : Σ (Square idp (ap out (glue (snd Z))) idp idp) (λ sq →
      Cube (out-into-sql (snd X)) sq
           (natural-square (λ _ → idp) wglue)
           (natural-square (ap out ∘ into-glue) wglue)
           (natural-square (cfglue _) wglue
             ⊡h' !□h (square-symmetry connection))
           (square-push-rb (cfglue _ (winr (snd Y)))
             (natural-square (out-into-cod ∘ reglue) wglue)))
    out-into-fill = fill-cube-right _ _ _ _ _

    {- [fst out-into-fill] is chosen so that we can prove
       [out-into-sql == out-into-sqr [ ⋯ ↓ ⋯ ]];
       this is proven by massaging [out-into-fill-cube] into the right shape.
       The trick is that the type of [out-into-fill-square] is independent of
       [y], so we can pick it to give the right result at the basepoint.
    -}
    out-into-sqr : (y : fst Y)
      → Square idp (ap out (into-glue (winr y)))
               (cfglue _ (winr y)) (cfglue _ (winr y))
    out-into-sqr y = fst out-into-fill ⊡v connection

  out-into : ∀ κ → out (into κ) == κ
  out-into = Cofiber-elim reglue
    idp out-into-cod
    (λ w → ↓-∘=idf-from-square out into $
       ap (ap out) (Into.glue-β w) ∙v⊡
         Wedge-elim
           {P = λ w → Square idp (ap out (into-glue w))
                             (cfglue _ w) (out-into-cod (reglue w))}
           out-into-sql
           out-into-sqr
           (cube-to-↓-square $
             right-from-bot-lemma (fst out-into-fill) connection $
               (snd out-into-fill))
           w)

  {- equivalence and paths -}

  eq : Cofiber reglue ≃ Suspension (fst Z)
  eq = equiv into out into-out out-into

  path : Cofiber reglue == Suspension (fst Z)
  path = ua eq

  ⊙path : ⊙Cof ⊙reglue == ⊙Susp Z
  ⊙path = ⊙ua eq idp

  {- Transporting [cfcod reglue] over the equivalence -}

  cfcod-over : ⊙cfcod ⊙reglue == ⊙ext-glue
              [ (λ W → fst (⊙Pushout ps ⊙→ W)) ↓ ⊙path ]
  cfcod-over =
    codomain-over-⊙equiv (⊙cfcod ⊙reglue) eq idp ▹ lemma
    where
    lemma : (into , idp) ⊙∘ ⊙cfcod ⊙reglue == ⊙ext-glue
    lemma = pair= idp $
      ap into (! (cfglue reglue (winl (snd X)))) ∙ idp
        =⟨ ap-! into (cfglue reglue (winl (snd X))) |in-ctx (λ w → w ∙ idp) ⟩
      ! (ap into (cfglue reglue (winl (snd X)))) ∙ idp
        =⟨ Into.glue-β (winl (snd X)) |in-ctx (λ w → ! w ∙ idp) ⟩
      idp ∎

  {- Transporting [ext-glue] over the equivalence. Uses the same sort of
   - cube technique as in the proof of [⊙path]. -}

  private
    square-push-rt : ∀ {i} {A : Type i} {a₀₀ a₀₁ a₁₀ a₁₁ : A} {b : A}
      {p₀₋ : a₀₀ == a₀₁} {p₋₀ : a₀₀ == a₁₀} {p₋₁ : a₀₁ == a₁₁} {p₁₋ : b == a₁₁}
      (q : a₁₀ == b) (sq : Square p₀₋ p₋₀ p₋₁ (q ∙' p₁₋))
      → Square p₀₋ (p₋₀ ∙' q) p₋₁ p₁₋
    square-push-rt {p₁₋ = idp} idp sq = sq

    right-from-top-lemma : ∀ {i} {A : Type i}
      {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ b₀ b₁ : A}
      {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
      {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
      {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

      {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
      {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
      (sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) -- right

      {p₀₀₋ : a₀₀₀ == b₀ {-a₀₀₁-}} {p₀₁₋ : a₀₁₀ == a₀₁₁}
      {p₁₀₋ : a₁₀₀ == b₁ {-a₁₀₁-}} {p₁₁₋ : a₁₁₀ == a₁₁₁}
      {q₀₋ : b₀ == a₀₀₁} {q₋₀ : b₀ == b₁} {q₁₋ : b₁ == a₁₀₁}
      {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ (q₀₋ ∙' p₀₋₁)} -- back
      {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ q₋₀} -- top
      {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
      {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ (q₁₋ ∙' p₁₋₁)} -- front
      (sq' : Square q₀₋ q₋₀ p₋₀₁ q₁₋)
      (cu : Cube sq₋₋₀ sq₋₋₁ (square-push-rt q₀₋ sq₀₋₋)
                 (sq₋₀₋ ⊡h' square-symmetry sq') sq₋₁₋
                 (square-push-rt q₁₋ sq₁₋₋))
      → Cube sq₋₋₀ (sq' ⊡v' sq₋₋₁) sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
    right-from-top-lemma sq₋₋₁ ids cu = right-from-top-lemma' sq₋₋₁ cu
      where
      right-from-top-lemma' : ∀ {i} {A : Type i}
        {a₀₀₀ a₀₁₀ a₁₀₀ a₁₁₀ a₀₀₁ a₀₁₁ a₁₀₁ a₁₁₁ : A}
        {p₀₋₀ : a₀₀₀ == a₀₁₀} {p₋₀₀ : a₀₀₀ == a₁₀₀}
        {p₋₁₀ : a₀₁₀ == a₁₁₀} {p₁₋₀ : a₁₀₀ == a₁₁₀}
        {sq₋₋₀ : Square p₀₋₀ p₋₀₀ p₋₁₀ p₁₋₀} -- left

        {p₀₋₁ : a₀₀₁ == a₀₁₁} {p₋₀₁ : a₀₀₁ == a₁₀₁}
        {p₋₁₁ : a₀₁₁ == a₁₁₁} {p₁₋₁ : a₁₀₁ == a₁₁₁}
        (sq₋₋₁ : Square p₀₋₁ p₋₀₁ p₋₁₁ p₁₋₁) -- right

        {p₀₀₋ : a₀₀₀ == a₀₀₁} {p₀₁₋ : a₀₁₀ == a₀₁₁}
        {p₁₀₋ : a₁₀₀ == a₁₀₁} {p₁₁₋ : a₁₁₀ == a₁₁₁}
        {sq₀₋₋ : Square p₀₋₀ p₀₀₋ p₀₁₋ (idp ∙' p₀₋₁)} -- back
        {sq₋₀₋ : Square p₋₀₀ p₀₀₋ p₁₀₋ p₋₀₁} -- top
        {sq₋₁₋ : Square p₋₁₀ p₀₁₋ p₁₁₋ p₋₁₁} -- bottom
        {sq₁₋₋ : Square p₁₋₀ p₁₀₋ p₁₁₋ (idp ∙' p₁₋₁)} -- front
        (cu : Cube sq₋₋₀ sq₋₋₁ (square-push-rt idp sq₀₋₋)
                   (sq₋₀₋ ⊡h' square-symmetry vid-square) sq₋₁₋
                   (square-push-rt idp sq₁₋₋))
        → Cube sq₋₋₀ (vid-square ⊡v' sq₋₋₁) sq₀₋₋ sq₋₀₋ sq₋₁₋ sq₁₋₋
      right-from-top-lemma' ids cu = cu

  ext-over : ⊙ext-glue == ⊙mv-diff
             [ (λ W → fst (W ⊙→ ⊙Susp (X ⊙∨ Y))) ↓ ⊙path ]
  ext-over = ⊙λ= fn-lemma idp ◃ domain-over-⊙equiv ⊙mv-diff _ _
    where
    fn-lemma : ∀ κ → ext-glue κ == mv-diff (into κ)
    fn-lemma = Cofiber-elim reglue
      idp fn-cod
      (λ w → ↓-='-from-square $
        ExtGlue.glue-β w ∙v⊡
          fn-coh w
        ⊡v∙ ! (ap-∘ mv-diff into (glue w) ∙ ap (ap mv-diff) (Into.glue-β w)))
      where
      fn-cod : (γ : fst (⊙Pushout ps))
        → ext-glue (cfcod reglue γ) == mv-diff (ext-glue γ)
      fn-cod = Pushout-elim
        (λ x → ! (merid _ (winl x)))
        (λ y → ! (merid _ (winr y)))
        (λ z → ↓-='-from-square $
          ap-cst (south _) (glue z) ∙v⊡
            (bl-square (merid _ (winl (f z))) ⊡h connection)
          ⊡v∙ ! (ap-∘ mv-diff ext-glue (glue z)
                 ∙ ap (ap mv-diff) (ExtGlue.glue-β z)
                 ∙ MVDiff.glue-β z))

      fn-fill : Σ (Square idp idp (ap mv-diff (merid _ (snd Z))) idp)
        (λ sq → Cube (tr-square (merid _ (winl (snd X)))) sq
                     (natural-square (λ _ → idp) wglue)
                     (natural-square (merid _) wglue
                       ⊡h' square-symmetry (tr-square (merid _ (winr (snd Y)))))
                     (natural-square (ap mv-diff ∘ into-glue) wglue)
                     (square-push-rt (! (merid _ (winr (snd Y))))
                       (natural-square (fn-cod ∘ reglue) wglue)))
      fn-fill = fill-cube-right _ _ _ _ _

      fn-coh : (w : X ∨ Y)
        → Square idp (merid _ w) (ap mv-diff (into-glue w)) (fn-cod (reglue w))
      fn-coh = Wedge-elim
        (λ x → tr-square (merid _ (winl x)))
          (λ y → tr-square (merid _ (winr y)) ⊡v' (fst fn-fill))
        (cube-to-↓-square $ right-from-top-lemma
          (fst fn-fill)
          (tr-square (merid _ (winr (snd Y))))
          (snd fn-fill))

{- Main results -}
module MayerVietoris (ps : ⊙Span {i} {i} {i}) where

  private
    record Results (ps : ⊙Span {i} {i} {i}) : Type (lsucc i) where
      open ⊙Span ps
      open MayerVietorisFunctions ps public
      field
        eq : Cofiber reglue ≃ Suspension (fst Z)
        path : Cofiber reglue == Suspension (fst Z)
        ⊙path : ⊙Cof ⊙reglue == ⊙Susp Z
        cfcod-over : ⊙cfcod ⊙reglue == ⊙ext-glue
                     [ (λ W → fst (⊙Pushout ps ⊙→ W)) ↓ ⊙path ]
        ext-over : ⊙ext-glue == ⊙mv-diff
                   [ (λ W → fst (W ⊙→ ⊙Susp (X ⊙∨ Y))) ↓ ⊙path ]

    results : Results ps
    results = ⊙pushout-J Results base-results ps
      where
      base-results : ∀ {A} {B} Z (f : fst Z → A) (g : fst Z → B) →
        Results (⊙span _ _ Z (f , idp) (g , idp))
      base-results Z f g = record {
        eq = eq;
        path = path;
        ⊙path = ⊙path;
        cfcod-over = cfcod-over;
        ext-over = ext-over}
        where open MayerVietorisBase Z f g

    open Results results public


{-# OPTIONS --without-K --exact-split #-}

module group-completion where

import 15-groups
open 15-groups public