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

open import Algebra

module Quasigroup.Properties
  {a ℓ} (Q : Quasigroup a ℓ) where

open Quasigroup Q


module Data.Collection.Core.Properties where

-- open import Data.List public using (List; []; _∷_)
-- open import Data.String public using (String; _≟_)
-- open import Level using (zero)
--
-- open import Function using (flip)
-- open import Relation.Nullary
-- open import Relation.Nullary.Negation
-- open import Relation.Nullary.Decidable renaming (map to mapDec; map′ to mapDec′)
-- open import Relation.Unary
-- open import Relation.Binary
-- open import Relation.Binary.PropositionalEquality


open import Agda.Builtin.Equality

test : (A : Set) (x y : A) → x ≡ y → Set
test A .y y refl with A
test A .y y refl | X = ?

-- Jesper, 2018-12-03, issue #2892:
-- Error message is:
--    Ill-typed pattern after with abstraction:  y
--    (perhaps you can replace it by `_`?)
--    when checking that the clause ;Issue2892.with-14 A X y = ? has type
--    (A w : Set) (x : w) → Set
-- Implementing the suggestion makes the code typecheck, so this
-- behaviour is at least not obviously wrong.


-- Author: David Darais
--
-- This is a dependent de Bruijn encoding of STLC with proofs for
-- progress and preservation. This file has zero dependencies and is
-- 100% self-contained.
--
-- Because there is only a notion of well-typed terms (non-well-typed
-- terms do not exist), preservation is merely by observation that
-- substitution (i.e., cut) can be defined.
--
-- A small-step evaluation semantics is defined after the definition of cut.
--
-- Progress is proved w.r.t. the evaluation semantics.
--
-- Some ideas for extensions or homeworks are given at the end.
--
-- A few helper definitions are required.
-- * Basic Agda constructions (like booleans, products, dependent sums,
--   and lists) are defined first in a Prelude module which is
--   immediately opened.
-- * Binders (x : τ ∈ Γ) are proofs that the element τ is contained in
--   the list of types Γ. Helper functions for weakening and
--   introducing variables into contexts which are reusable are
--   defined in the Prelude. Helpers for weakening terms are defined
--   below. Some of the non-general helpers (like cut[∈]) could be
--   defined in a generic way to be reusable, but I decided against
--   this to keep things simple.

module Darais where

open import Agda.Primitive using (_⊔_)

module Prelude where

  infixr 3 ∃𝑠𝑡
  infixl 5 _∨_
  infix 10 _∈_
  infixl 15 _⧺_
  infixl 15 _⊟_
  infixl 15 _∾_
  infixr 20 _∷_

  data 𝔹 : Set where
    T : 𝔹
    F : 𝔹

  data _∨_ {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
    Inl : A → A ∨ B
    Inr : B → A ∨ B

  syntax ∃𝑠𝑡 A (λ x → B) = ∃ x ⦂ A 𝑠𝑡 B
  data ∃𝑠𝑡 {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : A → Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
    ⟨∃_,_⟩ : ∀ (x : A) → B x → ∃ x ⦂ A 𝑠𝑡 B x

  data ⟬_⟭ {ℓ} (A : Set ℓ) : Set ℓ where
    [] : ⟬ A ⟭
    _∷_ : A → ⟬ A ⟭ → ⟬ A ⟭

  _⧺_ : ∀ {ℓ} {A : Set ℓ} → ⟬ A ⟭ → ⟬ A ⟭ → ⟬ A ⟭
  [] ⧺ ys = ys
  x ∷ xs ⧺ ys = x ∷ (xs ⧺ ys)

  _∾_ : ∀ {ℓ} {A : Set ℓ} → ⟬ A ⟭ → ⟬ A ⟭ → ⟬ A ⟭
  [] ∾ ys = ys
  (x ∷ xs) ∾ ys = xs ∾ x ∷ ys

  data _∈_ {ℓ} {A : Set ℓ} (x : A) : ∀ (xs : ⟬ A ⟭) → Set ℓ where
    Z : ∀ {xs} → x ∈ x ∷ xs
    S : ∀ {x′ xs} → x ∈ xs → x ∈ x′ ∷ xs

  _⊟_ : ∀ {ℓ} {A : Set ℓ} (xs : ⟬ A ⟭) {x} → x ∈ xs → ⟬ A ⟭
  x ∷ xs ⊟ Z = xs
  x ∷ xs ⊟ S ε = x ∷ (xs ⊟ ε)

  wk[∈] : ∀ {ℓ} {A : Set ℓ} {xs : ⟬ A ⟭} {x : A} xs′ → x ∈ xs → x ∈ xs′ ∾ xs
  wk[∈] [] x = x
  wk[∈] (x′ ∷ xs) x = wk[∈] xs (S x)

  i[∈][_] : ∀ {ℓ} {A : Set ℓ} {xs : ⟬ A ⟭} {x x′ : A} (ε′ : x′ ∈ xs) → x ∈ xs ⊟ ε′ → x ∈ xs
  i[∈][ Z ] x = S x
  i[∈][ S ε′ ] Z = Z
  i[∈][ S ε′ ] (S x) = S (i[∈][ ε′ ] x)

open Prelude

-- ============================ --
-- Simply Typed Lambda Calculus --
-- ============================ --

-- A dependent de Bruijn encoding
-- Or, the dynamic semantics of natural deduction as seen through Curry-Howard

-- types --

data type : Set where
  ⟨𝔹⟩ : type
  _⟨→⟩_ : type → type → type

-- terms --

infix 10 _⊢_
data _⊢_ : ∀ (Γ : ⟬ type ⟭) (τ : type) → Set where
  ⟨𝔹⟩ : ∀ {Γ}
    (b : 𝔹)
    → Γ ⊢ ⟨𝔹⟩
  ⟨if⟩_❴_❵❴_❵ : ∀ {Γ τ}
    (e₁ : Γ ⊢ ⟨𝔹⟩)
    (e₂ : Γ ⊢ τ)
    (e₃ : Γ ⊢ τ)
    → Γ ⊢ τ
  Var : ∀ {Γ τ}
    (x : τ ∈ Γ)
    → Γ ⊢ τ
  ⟨λ⟩ : ∀ {Γ τ₁ τ₂}
    (e : τ₁ ∷ Γ ⊢ τ₂)
    → Γ ⊢ τ₁ ⟨→⟩ τ₂
  _⟨⋅⟩_ : ∀ {Γ τ₁ τ₂}
    (e₁ : Γ ⊢ τ₁ ⟨→⟩ τ₂)
    (e₂ : Γ ⊢ τ₁)
    → Γ ⊢ τ₂

-- introducing a new variable to the context --

i[⊢][_] : ∀ {Γ τ τ′} (x′ : τ′ ∈ Γ) → Γ ⊟ x′ ⊢ τ → Γ ⊢ τ
i[⊢][ x′ ] (⟨𝔹⟩ b) = ⟨𝔹⟩ b
i[⊢][ x′ ] ⟨if⟩ e₁ ❴ e₂ ❵❴ e₃ ❵ = ⟨if⟩ i[⊢][ x′ ] e₁ ❴ i[⊢][ x′ ] e₂ ❵❴ i[⊢][ x′ ] e₃ ❵
i[⊢][ x′ ] (Var x) = Var (i[∈][ x′ ] x)
i[⊢][ x′ ] (⟨λ⟩ e) = ⟨λ⟩ (i[⊢][ S x′ ] e)
i[⊢][ x′ ] (e₁ ⟨⋅⟩ e₂) = i[⊢][ x′ ] e₁ ⟨⋅⟩ i[⊢][ x′ ] e₂

i[⊢] : ∀ {Γ τ τ′} → Γ ⊢ τ → τ′ ∷ Γ ⊢ τ
i[⊢] = i[⊢][ Z ]

-- substitution for variables --

cut[∈]<_>[_] : ∀ {Γ τ₁ τ₂} (x : τ₁ ∈ Γ) Γ′ → Γ′ ∾ (Γ ⊟ x) ⊢ τ₁ → τ₂ ∈ Γ → Γ′ ∾ (Γ ⊟ x) ⊢ τ₂
cut[∈]< Z >[ Γ′ ] e Z = e
cut[∈]< Z >[ Γ′ ] e (S y) = Var (wk[∈] Γ′ y)
cut[∈]< S x′ >[ Γ′ ] e Z = Var (wk[∈] Γ′ Z)
cut[∈]< S x′ >[ Γ′ ] e (S x) = cut[∈]< x′ >[ _ ∷ Γ′ ] e x

cut[∈]<_> : ∀ {Γ τ₁ τ₂} (x : τ₁ ∈ Γ) → Γ ⊟ x ⊢ τ₁ → τ₂ ∈ Γ → Γ ⊟ x ⊢ τ₂
cut[∈]< x′ > = cut[∈]< x′ >[ [] ]

-- substitution for terms --

cut[⊢][_] : ∀ {Γ τ₁ τ₂} (x : τ₁ ∈ Γ) → Γ ⊟ x ⊢ τ₁ → Γ ⊢ τ₂ → Γ ⊟ x ⊢ τ₂
cut[⊢][ x′ ] e′ (⟨𝔹⟩ b) = ⟨𝔹⟩ b
cut[⊢][ x′ ] e′ ⟨if⟩ e₁ ❴ e₂ ❵❴ e₃ ❵ = ⟨if⟩ cut[⊢][ x′ ] e′ e₁ ❴ cut[⊢][ x′ ] e′ e₂ ❵❴ cut[⊢][ x′ ] e′ e₃ ❵
cut[⊢][ x′ ] e′ (Var x) = cut[∈]< x′ > e′ x
cut[⊢][ x′ ] e′ (⟨λ⟩ e) = ⟨λ⟩ (cut[⊢][ S x′ ] (i[⊢] e′) e)
cut[⊢][ x′ ] e′ (e₁ ⟨⋅⟩ e₂) = cut[⊢][ x′ ] e′ e₁ ⟨⋅⟩ cut[⊢][ x′ ] e′ e₂

cut[⊢] : ∀ {Γ τ₁ τ₂} → Γ ⊢ τ₁ → τ₁ ∷ Γ ⊢ τ₂ → Γ ⊢ τ₂
cut[⊢] = cut[⊢][ Z ]

-- values --

data value {Γ} : ∀ {τ} → Γ ⊢ τ → Set where
  ⟨𝔹⟩ : ∀ b → value (⟨𝔹⟩ b)
  ⟨λ⟩ : ∀ {τ τ′} (e : τ′ ∷ Γ ⊢ τ) → value (⟨λ⟩ e)

-- CBV evaluation for terms --
-- (borrowing some notation and style from Wadler: https://wenkokke.github.io/sf/Stlc)

infix 10 _↝_
data _↝_ {Γ τ} : Γ ⊢ τ → Γ ⊢ τ → Set where
  ξ⋅₁ : ∀ {τ′} {e₁ e₁′ : Γ ⊢ τ′ ⟨→⟩ τ} {e₂ : Γ ⊢ τ′}
    → e₁ ↝ e₁′
    → e₁ ⟨⋅⟩ e₂ ↝ e₁′ ⟨⋅⟩ e₂
  ξ⋅₂ : ∀ {τ′} {e₁ : Γ ⊢ τ′ ⟨→⟩ τ} {e₂ e₂′ : Γ ⊢ τ′}
    → value e₁
    → e₂ ↝ e₂′
    → e₁ ⟨⋅⟩ e₂ ↝ e₁ ⟨⋅⟩ e₂′
  βλ : ∀ {τ′} {e₁ : τ′ ∷ Γ ⊢ τ} {e₂ : Γ ⊢ τ′}
    → value e₂
    → ⟨λ⟩ e₁ ⟨⋅⟩ e₂ ↝ cut[⊢] e₂ e₁
  ξif : ∀ {e₁ e₁′ : Γ ⊢ ⟨𝔹⟩} {e₂ e₃ : Γ ⊢ τ}
    → e₁ ↝ e₁′
    → ⟨if⟩ e₁ ❴ e₂ ❵❴ e₃ ❵ ↝ ⟨if⟩ e₁′ ❴ e₂ ❵❴ e₃ ❵
  ξif-T : ∀ {e₂ e₃ : Γ ⊢ τ}
    → ⟨if⟩ ⟨𝔹⟩ T ❴ e₂ ❵❴ e₃ ❵ ↝ e₂
  ξif-F : ∀ {e₂ e₃ : Γ ⊢ τ}
    → ⟨if⟩ ⟨𝔹⟩ F ❴ e₂ ❵❴ e₃ ❵ ↝ e₃

-- progress --

progress : ∀ {τ} (e : [] ⊢ τ) → value e ∨ (∃ e′ ⦂ [] ⊢ τ 𝑠𝑡 e ↝ e′)
progress (⟨𝔹⟩ b) = Inl (⟨𝔹⟩ b)
progress ⟨if⟩ e ❴ e₁ ❵❴ e₂ ❵ with progress e
… | Inl (⟨𝔹⟩ T) = Inr ⟨∃ e₁ , ξif-T ⟩
… | Inl (⟨𝔹⟩ F) = Inr ⟨∃ e₂ , ξif-F ⟩
… | Inr ⟨∃ e′ , ε ⟩ = Inr ⟨∃ ⟨if⟩ e′ ❴ e₁ ❵❴ e₂ ❵ , ξif ε ⟩
progress (Var ())
progress (⟨λ⟩ e) = Inl (⟨λ⟩ e)
progress (e₁ ⟨⋅⟩ e₂) with progress e₁
… | Inr ⟨∃ e₁′ , ε ⟩ = Inr ⟨∃ e₁′ ⟨⋅⟩ e₂ , ξ⋅₁ ε ⟩
… | Inl (⟨λ⟩ e) with progress e₂
… | Inl x = Inr ⟨∃ cut[⊢] e₂ e , βλ x ⟩
… | Inr ⟨∃ e₂′ , ε ⟩ = Inr ⟨∃ e₁ ⟨⋅⟩ e₂′ , ξ⋅₂ (⟨λ⟩ e) ε ⟩

-- Some ideas for possible extensions or homework assignments
-- 1. A. Write a conversion from the dependent de Bruijn encoding (e : Γ ⊢ τ)
--       to the untyped lambda calculus (e : term).
--    B. Prove that the image of this conversion is well typed.
--    C. Write a conversion from well-typed untyped lambda calculus
--       terms ([e : term] and [ε : (Γ ⊢ e ⦂ τ)] into the dependent de
--       Bruijn encoding (e : Γ ⊢ τ)
-- 2. A. Write a predicate analogous to 'value' for strongly reduced
--       terms (reduction under lambda)
--    B. Prove "strong" progress: A term is either fully beta-reduced
--       (including under lambda) or it can take a step
-- 3. Relate this semantics to a big-step semantics.
-- 4. Prove strong normalization.
-- 5. Relate this semantics to a definitional interpreter into Agda's Set.


{-# OPTIONS --cubical --no-import-sorts --postfix-projections --safe #-}

module Cubical.Categories.TypesOfCategories.TypeCategory where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Data.Sigma
import Cubical.Functions.Fibration as Fibration

open import Cubical.Categories.Category
open import Cubical.Categories.Functor
open import Cubical.Categories.Presheaf
open import Cubical.Categories.Limits.Pullback
open import Cubical.Categories.NaturalTransformation
open import Cubical.Categories.Instances.Sets

open Fibration.ForSets

record isTypeCategory {ℓ ℓ' ℓ''} (C : Precategory ℓ ℓ')
       : Type (ℓ-max ℓ (ℓ-max ℓ' (ℓ-suc ℓ''))) where
  open Precategory C
  open Cospan
  open PullbackLegs
  open isPullback
  field
    -- a Type of types over a context
    Ty[_] : ob → Type ℓ''
    -- extend a context with a type
    cext : ∀ (Γ : _) → (A : Ty[ Γ ]) → Σ[ ΓA ∈ ob ] (C [ ΓA , Γ ])

  -- the new object from a context extension
  _⍮_ : (Γ : _) → (A : Ty[ Γ ]) → ob
  Γ ⍮ A = fst (cext Γ A)

  -- the projection from the extended context to the original
  π : (Γ : _) → (A : Ty[ Γ ]) → C [ Γ ⍮ A , Γ ]
  π Γ A = snd (cext Γ A)

  field
    -- pullback over context extentions
    reindex : ∀ {Γ' Γ}
            → C [ Γ' , Γ ]
            → (Ty[ Γ ] → Ty[ Γ' ])

    q⟨_,_⟩ : ∀ {Γ' Γ}
           → (f : C [ Γ' , Γ ])
           → (A : Ty[ Γ ])
           → C [ Γ' ⍮ (reindex f A) , Γ ⍮ A ]

    isPB : ∀ {Γ' Γ : ob} (f : C [ Γ' , Γ ]) (A : Ty[ Γ ])
         → isPullback {C = C} (cospan Γ' Γ (Γ ⍮ A) f (π Γ A))
                      (pblegs (π Γ' (reindex f A)) q⟨ f , A ⟩)

-- presheaves are type contexts
module _ {ℓ ℓ' ℓ'' : Level} (C : Precategory ℓ ℓ') where
  open isTypeCategory
  open Precategory
  open Functor
  open NatTrans
  open isPullback

  private
    -- types over Γ are types with a "projection" (aka surjection) to Γ
    PSTy[_] : PreShv C ℓ'' .ob → Type _
    PSTy[ Γ ] = Σ[ ΓA ∈ PreShv C ℓ'' .ob ]
                   Σ[ π ∈ ΓA ⇒ Γ ]
                     (∀ (c : C .ob)
                     → isSurjSET {A = ΓA ⟅ c ⟆} {Γ ⟅ c ⟆} (π ⟦ c ⟧))

    -- just directly use types from above as context extensions
    PSCext : (Γ : _) → PSTy[ Γ ] → Σ[ ΓA ∈ PreShv C ℓ'' .ob ] ΓA ⇒ Γ
    PSCext Γ (ΓA , π , _) = ΓA , π

    -- the pullback or reindexed set is the disjoint union of the fibers
    -- from the projection
    module _ {Δ Γ : PreShv C ℓ'' .ob} (γ : Δ ⇒ Γ)
             (A'@(ΓA , π , isSurjπ) : PSTy[ Γ ]) where
      ΔA : PreShv C ℓ'' .ob
      ΔA .F-ob c =  ΔATy , isSetΔA
        where
          ΔATy = (Σ[ x ∈ fst (Δ ⟅ c ⟆) ] fiber (π ⟦ c ⟧) ((γ ⟦ c ⟧) x))

          isSetΔA : isSet ΔATy
          isSetΔA = isOfHLevelΣ 2 (snd (Δ ⟅ c ⟆)) λ Γc → isOfHLevelΣ 2 (snd (ΓA ⟅ c ⟆)) λ ΓAc → isProp→isSet (snd (Γ ⟅ c ⟆) _ _)
      -- for morphisms, we apply Δ ⟪ f ⟫ to the first component
      -- and ΓA ⟪ f ⟫ to the second
      -- the fiber rule
      ΔA .F-hom {c} {d} f (δax , γax , eq)
        = ((Δ ⟪ f ⟫) δax)
        , (((ΓA ⟪ f ⟫) γax)
        , ((π ⟦ d ⟧) ((ΓA ⟪ f ⟫) γax)
        ≡[ i ]⟨ π .N-hom f i γax ⟩
          (Γ ⟪ f ⟫) ((π ⟦ c ⟧) γax)
        ≡[ i ]⟨ (Γ ⟪ f ⟫) (eq i) ⟩
          (Γ ⟪ f ⟫) ((γ ⟦ c ⟧) δax)
        ≡[ i ]⟨ γ .N-hom f (~ i) δax ⟩
          (γ ⟦ d ⟧) ((Δ ⟪ f ⟫) δax)
        ∎))
      ΔA .F-id {x = c}
        = funExt λ (δax , γax , eq)
                → ΣPathP ((λ i → Δ .F-id i δax)
                          , fibersEqIfRepsEq {isSetB = snd (Γ ⟅ c ⟆)} _
                                            (λ i → ΓA .F-id i γax))
      ΔA .F-seq {a} {b} {c} f g
        = funExt λ (δax , γax , eq)
                → ΣPathP ((λ i → Δ .F-seq f g i δax)
                  , fibersEqIfRepsEq {isSetB = snd (Γ ⟅ c ⟆)} _
                                      λ i → ΓA .F-seq f g i γax)
      π' : ΔA ⇒ Δ
      π' .N-ob c (x , snd) = x
      π' .N-hom f = refl
      PSReindex : PSTy[ Δ ]
      PSReindex = ΔA , (π' , isSurj)
        where

          isSurj : ∀ (c : C .ob) → isSurjSET {A = ΔA ⟅ c ⟆} {B = Δ ⟅ c ⟆} (π' ⟦ c ⟧)
          isSurj c δx = (δx , isSurjπ c ((γ ⟦ c ⟧) δx)) , refl

      PSq : ΔA ⇒ ΓA
      PSq .N-ob c (δax , γax , eq) = γax
      PSq .N-hom {c} {d} f = funExt λ (δax , γax , eq) → refl

      PSIsPB : isPullback {C = PreShv C ℓ''}
                 (cospan Δ Γ (fst (PSCext Γ A')) γ (snd (PSCext Γ A')))
                 (pblegs (snd (PSCext Δ PSReindex)) (PSq))
      PSIsPB .sq = makeNatTransPath (funExt sqExt)
        where
          sqExt : ∀ (c : C .ob) → _
          sqExt c = funExt λ (δax , γax , eq) → sym eq

      PSIsPB .up {Θ} (cone (pblegs p₁ p₂) sq)
        = ((α , eq)
          , unique)
        where
          α : Θ ⇒ ΔA
          α .N-ob c t = ((p₁ ⟦ c ⟧) t)
                      , (((p₂ ⟦ c ⟧) t)
                      , (λ i → (sq (~ i) ⟦ c ⟧) t))
          α .N-hom {d} {c} f = funExt αHomExt
            where
              αHomExt : ∀ (t : fst (Θ ⟅ d ⟆))
                      → ((p₁ ⟦ c ⟧) ((Θ ⟪ f ⟫) t) , (p₂ ⟦ c ⟧) ((Θ ⟪ f ⟫) t), _)
                      ≡ ((Δ ⟪ f ⟫) ((p₁ ⟦ d ⟧) t) , (ΓA ⟪ f ⟫) ((p₂ ⟦ d ⟧) t) , _)
              αHomExt t = ΣPathP ((λ i → p₁ .N-hom f i t)
                                 , fibersEqIfRepsEq {isSetB = snd (Γ ⟅ c ⟆)} _
                                                    (λ i → p₂ .N-hom f i t))

          eq : _
          eq = makeNatTransPath (funExt (λ _ → funExt λ _ → refl))
             , makeNatTransPath (funExt (λ _ → funExt λ _ → refl))

          unique : ∀ (βeq : Σ[ β ∈ Θ ⇒ ΔA ] _)
                 → (α , eq) ≡ βeq
          unique (β , eqβ) = ΣPathP (α≡β , eq≡eqβ)
            where
              α≡β : α ≡ β
              α≡β = makeNatTransPath (funExt λ c → funExt λ t → eqExt c t)
                where
                  eqβ1 = eqβ .fst
                  eqβ2 = eqβ .snd
                  eqExt : ∀ (c : C .ob)
                        → (t : fst (Θ ⟅ c ⟆))
                        → (α ⟦ c ⟧) t ≡ (β ⟦ c ⟧) t
                  eqExt c t = ΣPathP ((λ i → (eqβ1 i ⟦ c ⟧) t)
                            , fibersEqIfRepsEq {isSetB = snd (Γ ⟅ c ⟆)} _
                                               (λ i → (eqβ2 i ⟦ c ⟧) t))
              eq≡eqβ : PathP (λ i
                             → (p₁ ≡ (α≡β i) ●ᵛ π')
                             × (p₂ ≡ (α≡β i) ●ᵛ PSq)) eq eqβ
              eq≡eqβ = ΣPathP ( isPropNatP1 (eq .fst) (eqβ .fst) α≡β
                              , isPropNatP2 (eq .snd) (eqβ .snd) α≡β)
                where
                  isPropNatP1 : isOfHLevelDep 1 (λ γ → p₁ ≡ γ ●ᵛ π')
                  isPropNatP1 = isOfHLevel→isOfHLevelDep 1 (λ _ → isSetNat _ _)

                  isPropNatP2 : isOfHLevelDep 1 (λ γ → p₂ ≡ γ ●ᵛ PSq)
                  isPropNatP2 = isOfHLevel→isOfHLevelDep 1 (λ _ → isSetNat _ _)

  -- putting everything together
  isTypeCategoryPresheaf : isTypeCategory (PreShv C ℓ'')
  isTypeCategoryPresheaf .Ty[_] Γ = PSTy[ Γ ]
  isTypeCategoryPresheaf .cext = PSCext
  isTypeCategoryPresheaf .reindex = PSReindex
  isTypeCategoryPresheaf .q⟨_,_⟩ = PSq
  isTypeCategoryPresheaf .isPB = PSIsPB


------------------------------------------------------------------------
-- The Agda standard library
--
-- The free monad construction on containers
------------------------------------------------------------------------

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

module Data.Container.FreeMonad where

open import Level
open import Data.Sum using (inj₁; inj₂ ; [_,_]′)
open import Data.Product
open import Data.Container
open import Data.Container.Combinator using (const; _⊎_)
open import Data.W
open import Category.Monad

infixl 1 _⋆C_
infix  1 _⋆_

------------------------------------------------------------------------
-- The free monad construction over a container and a set is, in
-- universal algebra terminology, also known as the term algebra over a
-- signature (a container) and a set (of variable symbols). The return
-- of the free monad corresponds to variables and the bind operator
-- corresponds to (parallel) substitution.

-- A useful intuition is to think of containers describing single
-- operations and the free monad construction over a container and a set
-- describing a tree of operations as nodes and elements of the set as
-- leafs. If one starts at the root, then any path will pass finitely
-- many nodes (operations described by the container) and eventually end
-- up in a leaf (element of the set) -- hence the Kleene star notation
-- (the type can be read as a regular expression).

_⋆C_ : ∀ {x s p} → Container s p → Set x → Container (s ⊔ x) p
C ⋆C X = const X ⊎ C

_⋆_ : ∀ {x s p} → Container s p → Set x → Set (x ⊔ s ⊔ p)
C ⋆ X = μ (C ⋆C X)

module _ {s p} {C : Container s p} where

  inn : ∀ {x} {X : Set x} → ⟦ C ⟧ (C ⋆ X) → C ⋆ X
  inn (s , f) = sup (inj₂ s , f)

  rawMonad : ∀ {x} → RawMonad {s ⊔ p ⊔ x} (C ⋆_)
  rawMonad = record { return = return; _>>=_ = _>>=_ }
    where
    return : ∀ {X} → X → C ⋆ X
    return x = sup (inj₁ x , λ ())

    _>>=_ : ∀ {X Y} → C ⋆ X → (X → C ⋆ Y) → C ⋆ Y
    sup (inj₁ x , _) >>= k = k x
    sup (inj₂ s , f) >>= k = inn (s , λ p → f p >>= k)


{-# OPTIONS --cubical --guarded -W ignore #-}
module combinations-of-lift-and-multiset where

open import Clocked.Primitives
open import Cubical.Foundations.Everything
open import Cubical.Data.List as List
open import Cubical.Data.List.Properties
open import Cubical.Data.Sum using (_⊎_; inl; inr)
open import combinations-of-lift-and-list

--**************************************************************************--
--**************************************************************************--
-- Combining the monads Lift and Multiset freely and via a distributive law --
--**************************************************************************--
--**************************************************************************--

-- In this document I want to define a monad, called MultiLift, that is the free combination of the Lift monad and the Multiset monad.
-- In order to do so, I will first define the the Multiset monad, and check that it is indeed a monad (Step 1).
-- Then I define the LiftMulti monad, check that it is a monad (Step 2), and finally check that it is the free monad on the algebra
-- structures of a delay algebra and a monoid (Step 3).
-- The Lift monad has aleady been defined in my earlier work, combinations-of-lift-and-list.
-- In the same file I check that lift is indeed a monad, and define various usefull functions, such as a map function for Lift.

-- In addition to the free combination of the Multiset and the Lift monads, I also compose the two monads to form the monad
-- LcM : A → Lift(Multiset A). This composition uses a distributive law, which I prove does indeed satisfy all the axioms for a
-- distributive law.

--****************************--
-- Step 1: The Multiset monad --
--****************************--

--This code is based on the finite powerset example from:
--https://github.com/niccoloveltri/final-pfin/blob/main/Pfin/AsFreeJoinSemilattice.agda

--We define the multiset monad as the free commutative monoid monad on A.
--This is a HIT.

data Multiset {ℓ} (A : Type ℓ) : Type ℓ where
  m∅        : Multiset A
  unitM     : A → Multiset A
  _∪ₘ_      : Multiset A → Multiset A → Multiset A
  ass       : ∀ x y z → x ∪ₘ (y ∪ₘ z) ≡ (x ∪ₘ y) ∪ₘ z
  com       : ∀ x y → x ∪ₘ y ≡ y ∪ₘ x
  unitr     : ∀ x → x ∪ₘ m∅ ≡ x
  trunc     : isSet (Multiset A)

-- map function for Multiset
mapM : {A B : Set} → (A → B) → Multiset A → Multiset B
mapM f m∅ = m∅
mapM f (unitM x) = unitM (f x)
mapM f (M ∪ₘ N) = (mapM f M) ∪ₘ (mapM f N)
mapM f (ass M M₁ M₂ i) = ass (mapM f M) (mapM f M₁) (mapM f M₂) i
mapM f (com M N i) = com (mapM f M) (mapM f N) i
mapM f (unitr M i) = unitr (mapM f M) i
mapM f (trunc M N x y i i₁) = trunc (mapM f M) (mapM f N) (λ j → mapM f (x j)) (λ j → mapM f (y j)) i i₁

-- Bind and multiplication functions for Multiset
Multiset-bind : {A B : Set} → (A → Multiset B) → Multiset A → Multiset B
Multiset-bind f m∅ = m∅
Multiset-bind f (unitM a) = f a
Multiset-bind f (x ∪ₘ y) = (Multiset-bind f x) ∪ₘ (Multiset-bind f y)
Multiset-bind f (ass x y z i) = ass (Multiset-bind f x) (Multiset-bind f y) (Multiset-bind f z) i
Multiset-bind f (com x y i) = com (Multiset-bind f x) (Multiset-bind f y) i
Multiset-bind f (unitr x i) = unitr (Multiset-bind f x) i
Multiset-bind f (trunc s₁ s₂ x y i i₁) = trunc (Multiset-bind f s₁) (Multiset-bind f s₂) (\ j → Multiset-bind f (x j)) (\ j → Multiset-bind f (y j)) i i₁

Multiset-mult : {A : Set} → Multiset (Multiset A) → Multiset A
Multiset-mult m∅ = m∅
Multiset-mult (unitM x) = x
Multiset-mult (x ∪ₘ y) = (Multiset-mult x) ∪ₘ (Multiset-mult y)
Multiset-mult (ass x y z i) = ass (Multiset-mult x) (Multiset-mult y) (Multiset-mult z) i
Multiset-mult (com x y i) = com (Multiset-mult x) (Multiset-mult y) i
Multiset-mult (unitr x i) = unitr (Multiset-mult x) i
Multiset-mult (trunc s₁ s₂ x y i i₁) = trunc (Multiset-mult s₁) (Multiset-mult s₂) (\ j → Multiset-mult (x j)) (\ j → Multiset-mult (y j)) i i₁

-- Elimination principle for Multiset

-- module to make the inputs more readable
-- no name for the module to make the use of it more readable
module _ {ℓ}{A : Type ℓ}
         (P : Multiset A → hProp ℓ)
         (P∅ : fst (P m∅))
         (Pη : ∀ m → fst (P (unitM m)))
         (P∪ : ∀ {m n} → fst(P m) → fst(P n) → fst(P (m ∪ₘ n)))
         where

  elimM : ∀ M → fst(P M)
  elimM m∅ = P∅
  elimM (unitM x) = Pη x
  elimM (M ∪ₘ N) = P∪ (elimM M) (elimM N)
  elimM (ass M N O i) = isProp→PathP (λ j → snd (P (ass M N O j)))
                               ((P∪ (elimM M) (P∪ (elimM N) (elimM O))))
                               ((P∪ (P∪ (elimM M) (elimM N)) (elimM O) ))
                               i
  elimM (com M N i) = isProp→PathP (λ j → snd (P (com M N j))) (P∪ (elimM M) (elimM N)) (P∪ (elimM N) (elimM M)) i
  elimM (unitr M i) = isProp→PathP (λ j → snd (P (unitr M j))) (P∪ (elimM M) (P∅)) (elimM M) i
  elimM (trunc M N x y i j) = isOfHLevel→isOfHLevelDep 2 (λ k → isProp→isSet (snd (P k))) (elimM M) (elimM N) (cong elimM x) (cong elimM y)
                                      (trunc M N x y) i j

-- Proving that the Multiset forms a monad

-- Multiset-mult (unitM M) = M
Multiset-unitlaw1 : {A : Set} → ∀(M : Multiset A) → Multiset-mult (unitM M) ≡ M
Multiset-unitlaw1 M = refl

-- Multiset-mult (map unitM M) = M
Multiset-unitlaw2 : {A : Set} → ∀(M : Multiset A) → Multiset-mult (mapM unitM M) ≡ M
Multiset-unitlaw2 m∅ = refl
Multiset-unitlaw2 (unitM x) = refl
Multiset-unitlaw2 (M ∪ₘ N) = cong₂ (_∪ₘ_) (Multiset-unitlaw2 M) (Multiset-unitlaw2 N)
Multiset-unitlaw2 (ass M N P i) = λ j → ass (Multiset-unitlaw2 M j) (Multiset-unitlaw2 N j) (Multiset-unitlaw2 P j) i
Multiset-unitlaw2 (com M N i) = λ j → com (Multiset-unitlaw2 M j) (Multiset-unitlaw2 N j) i
Multiset-unitlaw2 (unitr M i) = λ j → unitr (Multiset-unitlaw2 M j) i
Multiset-unitlaw2 (trunc M N x y i i₁) = λ k → trunc (Multiset-unitlaw2 M k) (Multiset-unitlaw2 N k) (λ j → (Multiset-unitlaw2 (x j)) k) ((λ j → (Multiset-unitlaw2 (y j)) k)) i i₁

--proving the same with elimM:
Multiset-unitlaw2' : {A : Set} → ∀(M : Multiset A) → Multiset-mult (mapM unitM M) ≡ M
Multiset-unitlaw2' M = elimM
                        (λ N → (Multiset-mult (mapM unitM N) ≡ N) , trunc (Multiset-mult (mapM unitM N)) N)
                        refl
                        (λ N → refl)
                        (λ eq1 → λ eq2 → cong₂ _∪ₘ_ eq1 eq2 )
                        M

-- Multiset-mult (Multiset-mult M) = Multiset-mult (map Multiset-mult M)
Multiset-multlaw : {A : Set} → ∀(M : Multiset (Multiset (Multiset A))) →  Multiset-mult (Multiset-mult M) ≡ Multiset-mult (mapM Multiset-mult M)
Multiset-multlaw m∅ = refl
Multiset-multlaw (unitM M) = refl
Multiset-multlaw (M ∪ₘ N) = cong₂ (_∪ₘ_) (Multiset-multlaw M) (Multiset-multlaw N)
Multiset-multlaw (ass M N P i) = λ j → ass (Multiset-multlaw M j) (Multiset-multlaw N j) (Multiset-multlaw P j) i
Multiset-multlaw (com M N i) = λ j → com (Multiset-multlaw M j) (Multiset-multlaw N j) i
Multiset-multlaw (unitr M i) = λ j → unitr (Multiset-multlaw M j) i
Multiset-multlaw (trunc M N x y i i₁) = λ k → trunc (Multiset-multlaw M k) (Multiset-multlaw N k) (λ j → (Multiset-multlaw (x j)) k) ((λ j → (Multiset-multlaw (y j)) k)) i i₁

--proving the same with Elim:
Multiset-multlaw' :  {A : Set} → ∀(M : Multiset (Multiset (Multiset A))) →  Multiset-mult (Multiset-mult M) ≡ Multiset-mult (mapM Multiset-mult M)
Multiset-multlaw' M = elimM
                        (λ N → (Multiset-mult (Multiset-mult N) ≡ Multiset-mult (mapM Multiset-mult N))
                              , trunc (Multiset-mult (Multiset-mult N)) (Multiset-mult (mapM Multiset-mult N)))
                        refl
                        (λ N → refl)
                        (λ eq1 → λ eq2 → cong₂ (_∪ₘ_) eq1 eq2)
                        M

-- the unit is a natural transformation:
nattrans-Multunit : {A B : Set} → ∀(f : A → B) → ∀(x : A) → mapM f (unitM x) ≡ unitM (f x)
nattrans-Multunit f x = refl

-- the multiplication is a natural transformation:
nattrans-MultisetMult : {A B : Set} → ∀(f : A → B) → ∀(MM : Multiset (Multiset A)) → mapM f (Multiset-mult MM) ≡ Multiset-mult (mapM (mapM f) MM)
nattrans-MultisetMult f MM = elimM
                               ((λ NN →  (mapM f (Multiset-mult NN) ≡ Multiset-mult (mapM (mapM f) NN))
                                      , trunc (mapM f (Multiset-mult NN)) (Multiset-mult (mapM (mapM f) NN))))
                               refl
                               (λ M → refl)
                               (λ eq1 → λ eq2 → cong₂ (_∪ₘ_) eq1 eq2)
                               MM

--*****************************--
-- Step 2: The MultiLift monad --
--*****************************--

--Now that we have a multiset monad and a lift monad, I want to show that the following combination of the two is again a monad:
--MultiLift : (A : Set) → (κ : Cl) → Set
--MultiLift A κ = Multiset (A ⊎ (▹ κ (MultiLift A κ)))

data MultiLift (A : Set) (κ : Cl) : Set where
  conML : Multiset (A ⊎ (▹ κ (MultiLift A κ))) -> MultiLift A κ

-- Elimination principle for MultiLift

-- module to make the inputs more readable
-- no name for the module to make the use of it more readable
module _ {ℓ}{A : Set}{κ : Cl}
         (P : MultiLift A κ → hProp ℓ)
         (P∅ : fst (P (conML m∅)))
         (Pη1 : ∀ x → fst (P (conML (unitM (inl x)))))
         (Pη2 : ∀ {x} → (∀ α → fst (P (x α))) → fst (P (conML (unitM (inr x)))))
         (P∪ : ∀ {m n} → fst(P (conML m)) → fst(P (conML n)) → fst(P (conML (m ∪ₘ n))))
         where

  elimML : ∀ M → fst(P M)
  elimML (conML m∅) = P∅
  elimML (conML (unitM (inl x))) = Pη1 x
  elimML (conML (unitM (inr x))) = Pη2 λ α → elimML (x α)
  elimML (conML (x ∪ₘ y)) = P∪ (elimML (conML x)) (elimML (conML y))
  elimML (conML (ass M N O i)) = isProp→PathP (λ j → snd (P (conML (ass M N O j))))
                               ((P∪ (elimML (conML M)) (P∪ (elimML (conML N)) (elimML (conML O)))))
                               ((P∪ (P∪ (elimML (conML M)) (elimML (conML N))) (elimML (conML O)) ))
                               i
  elimML (conML (com M N i)) = isProp→PathP (λ j → snd (P (conML (com M N j)))) (P∪ (elimML (conML M)) (elimML (conML N))) (P∪ (elimML (conML N)) (elimML (conML M))) i
  elimML (conML (unitr M i)) = isProp→PathP (λ j → snd (P (conML (unitr M j)))) (P∪ (elimML (conML M)) (P∅)) (elimML (conML M)) i
  elimML (conML (trunc M N x y i j)) = isOfHLevel→isOfHLevelDep 2 (λ z → isProp→isSet (snd (P (conML z)))) (elimML (conML M)) (elimML (conML N))
                                        (cong elimML (cong conML x)) (cong elimML (cong conML y)) (trunc M N x y ) i j

--***proof that MultiLift is a set***--
-- strategy: build isomorphism, then make equivalence, then use univalence to turn equivalence into equality, then transport.

isoML :  {A : Set}{κ : Cl} → Iso (Multiset (A ⊎ (▹ κ (MultiLift A κ)))) (MultiLift A κ)
Iso.fun isoML = conML
Iso.inv isoML (conML x) = x
Iso.rightInv isoML (conML x) = refl
Iso.leftInv isoML a = refl

equivML :  {A : Set}{κ : Cl} → (Multiset (A ⊎ (▹ κ (MultiLift A κ)))) ≃ (MultiLift A κ)
equivML = isoToEquiv isoML

equalML : {A : Set}{κ : Cl} → (Multiset (A ⊎ (▹ κ (MultiLift A κ)))) ≡ (MultiLift A κ)
equalML = ua equivML

truncML : {A : Set} {κ : Cl} → isSet (MultiLift A κ)
truncML = subst⁻ isSet (sym equalML) trunc

--IsotoPath as shortcut for this bit of code

--***algebraic structure for MultiLift***--

--nowML and stepML turn MultiLift into a delay algebra structure:
nowML : {A : Set} (κ : Cl) → A → (MultiLift A κ)
nowML κ a = conML (unitM (inl a))

stepML : {A : Set} (κ : Cl) → ▹ κ (MultiLift A κ) → (MultiLift A κ)
stepML κ a = conML (unitM (inr a))

--the union is derived from the multiset union, and turns MultiLift into a monoid:
_∪ₘₗ_ : {A : Set} {κ : Cl} → (MultiLift A κ) → (MultiLift A κ) → (MultiLift A κ)
_∪ₘₗ_ {A} {κ} (conML m) (conML n) = conML (m ∪ₘ n)

--proof that this union does indeed provide a commutative monoid structure:
assoc∪ₘₗ : {A : Set} {κ : Cl} → ∀(ml nl ol : (MultiLift A κ)) → (ml ∪ₘₗ nl) ∪ₘₗ ol ≡ ml ∪ₘₗ (nl ∪ₘₗ ol)
assoc∪ₘₗ {A} {κ} (conML m) (conML n) (conML o) = cong conML (sym (ass m n o))

comm∪ₘₗ : {A : Set} {κ : Cl} → ∀(ml nl : (MultiLift A κ)) → ml ∪ₘₗ nl ≡ nl ∪ₘₗ ml
comm∪ₘₗ {A} {κ} (conML m) (conML n) = cong conML (com m n)

unitr∪ₘₗ : {A : Set} {κ : Cl} → ∀ (ml : (MultiLift A κ)) → ml ∪ₘₗ conML m∅ ≡ ml
unitr∪ₘₗ {A} {κ} (conML m) = cong conML (unitr m )

--***monadic structure for MultiLift***--

--a map function to turn MultiLift into a functor
mapML : {A B : Set} (κ : Cl) → (f : A → B) → (MultiLift A κ) → (MultiLift B κ)
mapML κ f (conML m∅) = conML m∅
mapML κ f (conML (unitM (inl x))) = conML (unitM (inl (f x)))
mapML κ f (conML (unitM (inr x))) = stepML κ (λ α → mapML κ f (x α))
mapML κ f (conML (x ∪ₘ y)) = (mapML κ f (conML x)) ∪ₘₗ (mapML κ f (conML y))
mapML κ f (conML (ass x y z i)) = sym (assoc∪ₘₗ (mapML κ f (conML x)) (mapML κ f (conML y)) (mapML κ f (conML z))) i
mapML κ f (conML (com x y i)) = comm∪ₘₗ (mapML κ f (conML x)) (mapML κ f (conML y)) i
mapML κ f (conML (unitr x i)) = unitr∪ₘₗ (mapML κ f (conML x)) i
mapML κ f (conML (trunc x y z w i i₁)) = truncML (mapML κ f (conML x)) (mapML κ f (conML y)) (\ j → mapML κ f (conML (z j))) (\ j → mapML κ f (conML (w j))) i i₁

--a bind operator to make MultiLift into a monad
bindML : {A B : Set} (κ : Cl) → (A → (MultiLift B κ)) → MultiLift A κ → MultiLift B κ
bindML κ f (conML m∅) = conML m∅
bindML κ f (conML (unitM (inl x))) = f x
bindML κ f (conML (unitM (inr x))) = stepML κ (\ α → bindML κ f (x α))
bindML κ f (conML (x ∪ₘ y)) = (bindML κ f (conML x)) ∪ₘₗ (bindML κ f (conML y))
bindML κ f (conML (ass x y z i)) = sym (assoc∪ₘₗ (bindML κ f (conML x)) (bindML κ f (conML y)) (bindML κ f (conML z))) i
bindML κ f (conML (com x y i)) = comm∪ₘₗ (bindML κ f (conML x)) (bindML κ f (conML y)) i
bindML κ f (conML (unitr x i)) = unitr∪ₘₗ (bindML κ f (conML x)) i
bindML κ f (conML (trunc x y z w i i₁)) = truncML (bindML κ f (conML x)) (bindML κ f (conML y)) (\ j → bindML κ f (conML (z j))) (\ j → bindML κ f (conML (w j))) i i₁

--bindML commutes with ∪ₘₗ
bindML-∪ₘₗ : {A B : Set} (κ : Cl) → ∀(f : A → (MultiLift B κ)) → ∀(ml nl : (MultiLift A κ)) → bindML κ f (ml ∪ₘₗ nl) ≡ (bindML κ f ml) ∪ₘₗ (bindML κ f nl)
bindML-∪ₘₗ κ f (conML x) (conML y) = refl

--***proof that MultiLift is a monad***--

--bindML and nowML need to be natural transformations
nattrans-nowML : {A B : Set} (κ : Cl) → ∀(f : A → B) → ∀(x : A) → mapML κ f (nowML κ x) ≡ nowML κ (f x)
nattrans-nowML {A}{B} κ f x = refl

-- TODO: bindML

-- bindML and nowML also need to satisfy three monad laws:
-- unit is a left-identity for bind
unitlawML1 : {A B : Set} (κ : Cl) → ∀ (f : A → (MultiLift B κ)) → ∀ (x : A) → (bindML {A} κ f (nowML κ x)) ≡ f x
unitlawML1 κ f x = refl

-- unit is a right-identity for bind
unitlawML2 : {A : Set}(κ : Cl) → ∀(x : (MultiLift A κ)) → (bindML κ (nowML κ) x) ≡ x
unitlawML2 κ x = elimML ((λ y → ((bindML κ (nowML κ) y) ≡ y)
                           , truncML (bindML κ (nowML κ) y) y))
                         refl
                         (λ y → refl)
                         (λ p → cong conML (cong unitM (cong inr (later-ext (λ β → p β)))))
                         (λ eq1 → λ eq2 → cong₂ _∪ₘₗ_ eq1 eq2)
                         x
-- bind is associative
assoclawML : {A B C : Set}(κ : Cl) → ∀(f : A → (MultiLift B κ)) → ∀ (g : B → (MultiLift C κ)) → ∀ (x : (MultiLift A κ))
                     → (bindML κ (\ y → (bindML κ g (f y))) x) ≡ (bindML κ g (bindML κ f x))
assoclawML {A} {B} {C} κ f g x = elimML ((λ z → ((bindML κ (\ y → (bindML κ g (f y))) z) ≡ (bindML κ g (bindML κ f z)))
                                           , truncML ((bindML κ (\ y → (bindML κ g (f y))) z)) (bindML κ g (bindML κ f z))))
                                        refl
                                        (λ y → refl)
                                        (λ p → cong conML (cong unitM (cong inr (later-ext (λ α → p α)))))
                                        (λ {m n} → λ eq1 → λ eq2 → (bindML κ (λ y → bindML κ g (f y)) (conML m) ∪ₘₗ
                                                           bindML κ (λ y → bindML κ g (f y)) (conML n))
                                                           ≡⟨ cong₂ (_∪ₘₗ_) eq1 eq2 ⟩
                                                           (bindML κ g (bindML κ f (conML m)) ∪ₘₗ bindML κ g (bindML κ f (conML n)))
                                                           ≡⟨ sym (bindML-∪ₘₗ κ g (bindML κ f (conML m)) (bindML κ f (conML n))) ⟩
                                                            bindML κ g (bindML κ f (conML m) ∪ₘₗ bindML κ f (conML n)) ∎)
                                        x

--*************************************************************************************--
-- Step 3: The MultiLift monad as the free delay-algebra and commutiative monoid monad --
--*************************************************************************************--

-- We already know that (MultiLift, stepML) forms a delay algebra structure,
-- and (Multilift, conML m∅ ,  ∪ₘₗ) forms a commutative monoid.
-- What we need to show is that MultiLift is the free monad with these properties.
-- That is, for a set A, and any other structure (B, δ, ε, _·_) where (B, δ) is a delay algebra and (B, ε, _·_) a commutative monoid
-- given a function f : A → B, there is a unique function MultiLift A → B extending f that preserves the algebra structures.

record IsComMonoid {A : Set} (ε : A) (_·_ : A → A → A) : Set where
  constructor iscommonoid

  field
    asso : (x y z : A) → (x · y) · z ≡ x · (y · z)
    comm : (x y : A) → (x · y) ≡ (y · x)
    uniteq : (x : A) → x · ε ≡ x

record IsDelayComMonoid {A : Set}(κ : Cl) (dm : DelayMonoidData A κ) : Set where
  constructor isdelaycommonoid

  open DelayMonoidData dm
  field
    isComMonoid : IsComMonoid (ε) (_·_)
    isDelayalg : IsDelayalg κ (nextA)

  open IsComMonoid isComMonoid public
  open IsDelayalg isDelayalg public

record IsExtendingML {A B : Set}{κ : Cl} (f : A → B) (h : (MultiLift A κ) → B) : Set where
  constructor isextendingML

  field
    extends : (x : A) → h (nowML κ x) ≡ (f x)

--foldML defines the function we are after
foldML : {A B : Set}{κ : Cl} → isSet A → isSet B → ∀ dm → IsDelayComMonoid {B} κ dm → (A → B) → (MultiLift A κ) → B
foldML setA setB (dmdata nextB ε _·_) isDMB f (conML m∅) = ε
foldML setA setB (dmdata nextB ε _·_) isDMB f (conML (unitM (inl x))) = f x
foldML setA setB dm@(dmdata nextB ε _·_) isDMB f (conML (unitM (inr x))) = nextB (λ α → foldML setA setB dm isDMB f (x α))
foldML setA setB dm@(dmdata nextB ε _·_) isDMB f (conML (x ∪ₘ y)) = (foldML setA setB dm isDMB f (conML x)) · (foldML setA setB dm isDMB f (conML y))
foldML setA setB dm@(dmdata nextB ε _·_) isDMB f (conML (ass x y z i)) = sym (IsDelayComMonoid.asso isDMB (foldML setA setB dm isDMB f (conML x))
                                                                                (foldML setA setB dm isDMB f (conML y))
                                                                                (foldML setA setB dm isDMB f (conML z))) i
foldML setA setB dm@(dmdata nextB ε _·_) isDMB f (conML (com x y i)) = IsDelayComMonoid.comm isDMB (foldML setA setB dm isDMB f (conML x)) (foldML setA setB dm isDMB f (conML y)) i
foldML setA setB dm@(dmdata nextB ε _·_) isDMB f (conML (unitr x i)) = IsDelayComMonoid.uniteq isDMB (foldML setA setB dm isDMB f (conML x)) i
foldML setA setB dm@(dmdata nextB ε _·_) isDMB f (conML (trunc x y x₁ y₁ i i₁)) = setB (foldML setA setB dm isDMB f (conML x))
                                                                                (foldML setA setB dm isDMB f (conML y))
                                                                                (λ j → (foldML setA setB dm isDMB f (conML (x₁ j))))
                                                                                (λ j → (foldML setA setB dm isDMB f (conML (y₁ j))))
                                                                                i i₁

--foldML extends the function f : A → B
foldML-extends : {A B : Set}{κ : Cl} → ∀(setA : isSet A) → ∀(setB : isSet B) → ∀ dm → ∀(isDMB : IsDelayComMonoid {B} κ dm) →
                   ∀ (f : A → B) → IsExtendingML f (foldML setA setB dm isDMB f)
IsExtendingML.extends (foldML-extends setA setB dm isDMB f) x = refl

-- or a more direct proof of the same fact:
foldML-extends-f : {A B : Set}{κ : Cl} → ∀(setA : isSet A) → ∀(setB : isSet B) → ∀ dm → ∀(isDMB : IsDelayComMonoid {B} κ dm) →
                   ∀ (f : A → B) → ∀ (x : A) → foldML setA setB dm isDMB f (nowML κ x) ≡ f x
foldML-extends-f setA setB dm isDMB f x = refl

--foldML preseves the DelayMonoid structure

module _ {A B : Set}{κ : Cl} (setA : isSet A) (setB : isSet B) (dm : _) (isDMB : IsDelayComMonoid {B} κ dm)
         (f : A → B)
 where
  open IsPreservingDM
  open DelayMonoidData dm renaming (nextA to nextB)

  foldML-preserves : IsPreservingDM {MultiLift A κ}{B} κ (dmdata (stepML κ) (conML m∅) _∪ₘₗ_) dm (foldML setA setB dm isDMB f)
  unit-preserve foldML-preserves = refl
  next-preserve foldML-preserves x = cong nextB (later-ext (λ α → refl))
  union-preserve foldML-preserves (conML x) (conML y) = refl

--and foldML is unique in doing so.
--That is, for any function h that both preserves the algebra structure
--and extends the function f : A → B,
-- h is equivalent to fold.

module _ {A B : Set} {κ : Cl} (h : MultiLift A κ → B)
                       (setA : isSet A) (setB : isSet B) (dm : _) (isDMB : IsDelayComMonoid {B} κ dm)
                       (f : A → B) (isPDM : IsPreservingDM {MultiLift A κ}{B} κ (dmdata (stepML κ) (conML m∅) _∪ₘₗ_ ) dm h)
                       (isExt : IsExtendingML f h) where

  open DelayMonoidData dm renaming (nextA to nextB)

  fold-uniquenessML : (x : (MultiLift A κ)) → h x ≡ (foldML setA setB dm isDMB f x)
  fold-uniquenessML x = elimML
                           ((λ x → (h x ≡ (foldML setA setB dm isDMB f x)) , setB (h x) ((foldML setA setB dm isDMB f x))))
                           (IsPreservingDM.unit-preserve isPDM)
                           (λ a →  h (conML (unitM (inl a)))
                                    ≡⟨ refl ⟩
                                    h (nowML κ a)
                                    ≡⟨ IsExtendingML.extends isExt a ⟩
                                    f a ∎)
                           (λ {x} → λ eq → h (conML (unitM (inr x)))
                                            ≡⟨ refl ⟩
                                            h (stepML κ x)
                                            ≡⟨ IsPreservingDM.next-preserve isPDM x ⟩
                                            nextB (λ α → h (x α))
                                            ≡⟨ cong nextB (later-ext (λ α → (eq α)))  ⟩
                                            nextB (λ α → foldML setA setB (dmdata nextB ε _·_) isDMB f (x α)) ∎)
                           (λ {x y} → λ eqx eqy → h (conML (x ∪ₘ y))
                                                   ≡⟨ refl ⟩
                                                   h ((conML x) ∪ₘₗ (conML y))
                                                   ≡⟨ IsPreservingDM.union-preserve isPDM (conML x) (conML y) ⟩
                                                   (h (conML x) · h (conML y))
                                                   ≡⟨ cong₂ _·_ eqx eqy ⟩
                                                   (foldML setA setB (dmdata nextB ε _·_) isDMB f (conML x) ·
                                                   foldML setA setB (dmdata nextB ε _·_) isDMB f (conML y)) ∎)
                           x

--****************************************************--
-- Composing Lift and Multiset via a distributive law --
--****************************************************--

--We now define a composite monad of the Multiset and Lift monads, formed via a distributive law.
LcM : (A : Set) → (κ : Cl) → Set
LcM A κ = myLift (Multiset A) κ

-- the unit of this monad is simply the composit of the units for Lift (nowL x) and Multiset (unitM)
nowLcM : {A : Set} {κ : Cl} → A → (LcM A κ)
nowLcM x = nowL (unitM x)

--LcM is a set.
truncLcM : {A : Set} {κ : Cl} → isSet (LcM A κ)
truncLcM = MyLiftSet.isSetmyLift trunc

--LLCM is a set
truncLLcM : {A : Set} {κ : Cl} → isSet (myLift (LcM A κ) κ)
truncLLcM = MyLiftSet.isSetmyLift truncLcM

-- we define a union on LcM, which will help in defining the distributive law.
_l∪m_ : {A : Set} {κ : Cl} → (LcM A κ) → (LcM A κ) → (LcM A κ)
nowL x l∪m nowL y = nowL (x ∪ₘ y)
nowL x l∪m stepL y = stepL (λ α → (nowL x l∪m (y α)))
stepL x l∪m y = stepL (λ α → ((x α) l∪m y))

--l∪m is associative, commutative, and nowL m∅ is a unit for l∪m
assoc-l∪m : {A : Set} {κ : Cl} → ∀(x y z : LcM A κ) → (x l∪m y) l∪m z ≡ x l∪m (y l∪m z)
assoc-l∪m (nowL x) (nowL y) (nowL z) = cong nowL (sym (ass x y z))
assoc-l∪m (nowL x) (nowL y) (stepL z) = cong stepL (later-ext λ α → assoc-l∪m (nowL x) (nowL y) (z α))
assoc-l∪m (nowL x) (stepL y) z = cong stepL (later-ext λ α → assoc-l∪m (nowL x) (y α) z)
assoc-l∪m (stepL x) y z = cong stepL (later-ext λ α → assoc-l∪m (x α) y z)

comm-l∪m : {A : Set} {κ : Cl} → ∀(x y : LcM A κ) → (x l∪m y) ≡ y l∪m x
comm-l∪m (nowL x) (nowL y) = cong nowL (com x y)
comm-l∪m (nowL x) (stepL y) = cong stepL (later-ext λ α → comm-l∪m (nowL x) (y α))
comm-l∪m (stepL x) (nowL y) = cong stepL (later-ext λ α → comm-l∪m (x α) (nowL y))
comm-l∪m (stepL x) (stepL y) = stepL (λ α → x α l∪m stepL y)
                                 ≡⟨ cong stepL (later-ext λ α → comm-l∪m (x α) (stepL y))  ⟩
                                 stepL (λ α → stepL y l∪m x α)
                                 ≡⟨ refl ⟩
                                 stepL (λ α → stepL (λ β → (y β) l∪m (x α)))
                                 ≡⟨ cong stepL (later-ext λ α → cong stepL (later-ext λ β → cong₂ _l∪m_ (sym (tick-irr y α β)) (tick-irr x α β) )) ⟩
                                 stepL (λ α → stepL (λ β → (y α) l∪m (x β)))
                                 ≡⟨ cong stepL (later-ext λ α → cong stepL (later-ext λ β → comm-l∪m (y α) (x β))) ⟩
                                 stepL (λ α → stepL (λ β → (x β) l∪m (y α)))
                                 ≡⟨ refl ⟩
                                 stepL (λ α → (stepL x) l∪m (y α))
                                 ≡⟨ cong stepL (later-ext λ α → comm-l∪m (stepL x) (y α)) ⟩
                                 stepL (λ α → y α l∪m stepL x) ∎

unit-l∪m : {A : Set} {κ : Cl} → ∀(x : LcM A κ) → x l∪m (nowL m∅) ≡ x
unit-l∪m (nowL x) = cong nowL (unitr x)
unit-l∪m (stepL x) = cong stepL (later-ext λ α → unit-l∪m (x α))

lemma-nowL-l∪m-mapL : {A : Set} {κ : Cl} → ∀(x : LcM A κ) → ∀(M : Multiset A) → nowL M l∪m x ≡ mapL κ (M ∪ₘ_) x
lemma-nowL-l∪m-mapL (nowL x) M = refl
lemma-nowL-l∪m-mapL (stepL x) M = cong stepL (later-ext (λ α → lemma-nowL-l∪m-mapL (x α) M))

--mapL κ f distributes over l∪m if f distributes over ∪ₘ
dist-mapL-l∪m : {A B : Set} {κ : Cl} → ∀(f : (Multiset A) → (Multiset B)) → ∀(fdist : ∀(m n : Multiset A) → f (m ∪ₘ n) ≡ f m ∪ₘ f n)
                                     → ∀(x y : (LcM A κ)) → mapL κ f (x l∪m y) ≡ (mapL κ f x) l∪m (mapL κ f y)
dist-mapL-l∪m f fdist (nowL x) (nowL y) = cong nowL (fdist x y)
dist-mapL-l∪m f fdist (nowL x) (stepL y) = cong stepL (later-ext λ α → dist-mapL-l∪m f fdist (nowL x) (y α))
dist-mapL-l∪m f fdist (stepL x) y = cong stepL (later-ext λ α → dist-mapL-l∪m f fdist (x α) y)

-- and why not, I also need a ll∪m:
_ll∪m_ : {A : Set} {κ : Cl} → (myLift (LcM A κ) κ) → (myLift (LcM A κ) κ) → (myLift (LcM A κ) κ)
nowL x ll∪m nowL y = nowL (x l∪m y)
nowL x ll∪m stepL y = stepL (λ α → (nowL x ll∪m (y α)))
stepL x ll∪m y = stepL (λ α → ((x α) ll∪m y))

assoc-ll∪m : {A : Set} {κ : Cl} → ∀(x y z : (myLift (LcM A κ) κ)) → (x ll∪m y) ll∪m z ≡ x ll∪m (y ll∪m z)
assoc-ll∪m (nowL x) (nowL y) (nowL z) = cong nowL (assoc-l∪m x y z)
assoc-ll∪m (nowL x) (nowL y) (stepL z) = cong stepL (later-ext λ α → assoc-ll∪m (nowL x) (nowL y) (z α))
assoc-ll∪m (nowL x) (stepL y) z = cong stepL (later-ext λ α → assoc-ll∪m (nowL x) (y α) z)
assoc-ll∪m (stepL x) y z = cong stepL (later-ext λ α → assoc-ll∪m (x α) y z)

unit-ll∪m : {A : Set} {κ : Cl} → ∀(x : myLift (LcM A κ) κ) → nowL (nowL m∅) ll∪m x ≡ x
unit-ll∪m (nowL x) = nowL (nowL m∅ l∪m x)
                      ≡⟨ cong nowL (comm-l∪m (nowL m∅) x) ⟩
                      nowL (x l∪m nowL m∅)
                      ≡⟨ cong nowL (unit-l∪m x) ⟩
                      nowL x ∎
unit-ll∪m (stepL x) = cong stepL (later-ext λ α → unit-ll∪m (x α))

lemma-nowL-ll∪m-mapL : {A : Set} {κ : Cl} → ∀(x : myLift (LcM A κ) κ) → ∀(M : LcM A κ) → nowL M ll∪m x ≡ mapL κ (M l∪m_) x
lemma-nowL-ll∪m-mapL (nowL x) M = refl
lemma-nowL-ll∪m-mapL (stepL x) M = cong stepL (later-ext (λ α → lemma-nowL-ll∪m-mapL (x α) M))

multL-ll∪m-l∪m : {A : Set} (κ : Cl) → ∀(x y : myLift (LcM A κ) κ) → MultL κ (x ll∪m y) ≡ MultL κ x l∪m MultL κ y
multL-ll∪m-l∪m κ (nowL x) (nowL y) = refl
multL-ll∪m-l∪m κ (nowL x) (stepL y) = stepL (λ α → MultL κ (nowL x ll∪m y α))
                                          ≡⟨ cong stepL (later-ext(λ α → multL-ll∪m-l∪m κ (nowL x) (y α) )) ⟩
                                          stepL (λ α → MultL κ (nowL x) l∪m MultL κ (y α))
                                          ≡⟨ refl ⟩
                                          stepL (λ α → x l∪m MultL κ (y α))
                                          ≡⟨ cong stepL (later-ext (λ α → comm-l∪m x (MultL κ (y α)))) ⟩
                                          (stepL (λ α → MultL κ (y α)) l∪m x)
                                          ≡⟨ refl ⟩
                                          (stepL (λ α → MultL κ (y α)) l∪m x)
                                          ≡⟨ comm-l∪m (stepL (λ α → MultL κ (y α))) x ⟩
                                          (x l∪m stepL (λ α → MultL κ (y α))) ∎
multL-ll∪m-l∪m κ (stepL x) y = cong stepL (later-ext (λ α → multL-ll∪m-l∪m κ (x α) y))

-- LcM is a monad via a distributive law, distributing Multiset over Lift.
-- Here is the distributive law:
distlawLcM : {A : Set} {κ : Cl} → Multiset (myLift A κ) → (LcM A κ)
distlawLcM m∅ = nowL m∅
distlawLcM (unitM (nowL x)) = nowL (unitM x)
distlawLcM (unitM (stepL x)) = stepL (λ α → distlawLcM (unitM (x α)))
distlawLcM (x ∪ₘ y) = (distlawLcM x) l∪m (distlawLcM y)
distlawLcM (ass x y z i) = assoc-l∪m (distlawLcM x) (distlawLcM y) (distlawLcM z) (~ i)
distlawLcM (com x y i) = comm-l∪m (distlawLcM x) (distlawLcM y) i
distlawLcM (unitr x i) = unit-l∪m (distlawLcM x) i
distlawLcM (trunc x y x₁ y₁ i i₁) = truncLcM (distlawLcM x) (distlawLcM y) (λ j → distlawLcM (x₁ j)) (λ j → distlawLcM (y₁ j)) i i₁

--proof that distlawLcM is indeed a distributive law:
--unit laws:
unitlawLcM1 : {A : Set} {κ : Cl} → ∀(x : myLift A κ) → (distlawLcM (unitM x)) ≡  mapL κ unitM x
unitlawLcM1 (nowL x) = refl
unitlawLcM1 (stepL x) = cong stepL (later-ext λ α → unitlawLcM1 (x α))

unitlawLcM2 : {A : Set} {κ : Cl} → ∀(M : Multiset A) → (distlawLcM {A}{κ} (mapM nowL M)) ≡ nowL M
unitlawLcM2 M = elimM
                 (λ N → ((distlawLcM (mapM nowL N) ≡ nowL N) , truncLcM (distlawLcM (mapM nowL N)) (nowL N)))
                 refl
                 (λ N → refl)
                 (λ {M N} → λ eqM eqN → distlawLcM (mapM nowL M) l∪m distlawLcM (mapM nowL N)
                                         ≡⟨ cong₂ (_l∪m_) eqM eqN ⟩
                                         ((nowL M) l∪m (nowL N))
                                         ≡⟨ refl ⟩
                                         nowL (M ∪ₘ N) ∎ )
                 M

--multiplication laws:
multlawLcM1 : {A : Set} (κ : Cl) → ∀(M : Multiset (Multiset (myLift A κ))) → distlawLcM (Multiset-mult M) ≡
                                                                             mapL κ Multiset-mult (distlawLcM (mapM distlawLcM M))
multlawLcM1 κ M = elimM
                    (λ N → ((distlawLcM (Multiset-mult N) ≡ mapL κ Multiset-mult (distlawLcM (mapM distlawLcM N))) ,
                     truncLcM (distlawLcM (Multiset-mult N)) (mapL κ Multiset-mult (distlawLcM (mapM distlawLcM N))) ))
                    refl
                    (λ N → distlawLcM N
                            ≡⟨ sym (mapL-identity (distlawLcM N)) ⟩
                            mapL κ (λ y → y) (distlawLcM N)
                            ≡⟨ cong₂ (mapL κ) (funExt (λ y → sym (Multiset-unitlaw1 y))) refl ⟩
                            mapL κ (λ y → Multiset-mult (unitM y)) (distlawLcM N)
                            ≡⟨ sym (mapmapL κ unitM Multiset-mult (distlawLcM N)) ⟩
                            mapL κ Multiset-mult (mapL κ unitM (distlawLcM N))
                            ≡⟨ cong (mapL κ Multiset-mult) (sym (unitlawLcM1 (distlawLcM N)))  ⟩
                            mapL κ Multiset-mult (distlawLcM (unitM (distlawLcM N))) ∎)
                    (λ {M N} → λ eqM eqN → (distlawLcM (Multiset-mult M) l∪m distlawLcM (Multiset-mult N))
                              ≡⟨ cong₂ _l∪m_ eqM eqN ⟩
                              (mapL κ Multiset-mult (distlawLcM (mapM distlawLcM M)) l∪m mapL κ Multiset-mult (distlawLcM (mapM distlawLcM N)))
                              ≡⟨ sym (dist-mapL-l∪m Multiset-mult (λ x y → refl) (distlawLcM (mapM distlawLcM M)) (distlawLcM (mapM distlawLcM N))) ⟩
                              mapL κ Multiset-mult (distlawLcM (mapM distlawLcM M) l∪m distlawLcM (mapM distlawLcM N)) ∎)
                    M

-- lemma before we can do the second multiplication law:

-- I don't know hot to split cases within elimM, so here is a lemma for the unitM case of the unitM case for the lemma-llum, split into nowL and stepL:
lemma-llum-unit-unitcase : {A : Set} (κ : Cl) → ∀(x : myLift A κ) → ∀(y : (myLift (myLift A κ) κ)) →
                                            (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) ll∪m (mapL κ distlawLcM (distlawLcM (unitM y)))
                                             ≡ mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m distlawLcM (unitM y))
lemma-llum-unit-unitcase κ x (nowL y) = refl
lemma-llum-unit-unitcase κ x (stepL y) = cong stepL (later-ext λ α → lemma-llum-unit-unitcase κ x (y α))

-- I don't know how to split cases within elimM, so here a lemma for the unitM case of elimM for lemma-llum, split into nowL and stepL:
lemma-llum-unitcase : {A : Set} (κ : Cl) →  ∀(x : (myLift (myLift A κ) κ))→ ∀(N : Multiset (myLift (myLift A κ) κ)) →
                                            (mapL κ distlawLcM (distlawLcM (unitM x))) ll∪m (mapL κ distlawLcM (distlawLcM N))
                                             ≡ mapL κ distlawLcM (distlawLcM (unitM x) l∪m distlawLcM N)
lemma-llum-unitcase κ (nowL x) N = elimM
                                      (λ N → ((mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) ll∪m (mapL κ distlawLcM (distlawLcM N))
                                             ≡ mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m distlawLcM N)) ,
                                             truncLLcM ((mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) ll∪m (mapL κ distlawLcM (distlawLcM N)))
                                                       ( mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m distlawLcM N)))
                                      refl
                                      (λ y → lemma-llum-unit-unitcase κ x y)
                                      (λ {M N} → λ eqM eqN → (nowL (distlawLcM (unitM x)) ll∪m mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
                                                              ≡⟨ lemma-nowL-ll∪m-mapL (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)) (distlawLcM (unitM x)) ⟩
                                                              mapL κ (distlawLcM (unitM x) l∪m_) (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
                                                              ≡⟨ mapmapL κ distlawLcM (distlawLcM (unitM x) l∪m_) (distlawLcM M l∪m distlawLcM N) ⟩
                                                              mapL κ (λ y → distlawLcM (unitM x) l∪m distlawLcM y) (distlawLcM M l∪m distlawLcM N)
                                                              ≡⟨ refl ⟩
                                                              mapL κ (λ y → distlawLcM ((unitM x) ∪ₘ y)) (distlawLcM M l∪m distlawLcM N)
                                                              ≡⟨ sym (mapmapL κ (unitM x ∪ₘ_) distlawLcM (distlawLcM M l∪m distlawLcM N)) ⟩
                                                              mapL κ distlawLcM (mapL κ ((unitM x) ∪ₘ_) (distlawLcM M l∪m distlawLcM N))
                                                              ≡⟨ cong (mapL κ distlawLcM) (sym (lemma-nowL-l∪m-mapL (distlawLcM M l∪m distlawLcM N) (unitM x))) ⟩
                                                              mapL κ distlawLcM (nowL (unitM x) l∪m (distlawLcM M l∪m distlawLcM N)) ∎)
                                      N
lemma-llum-unitcase κ (stepL x) N = cong stepL (later-ext (λ α → lemma-llum-unitcase κ (x α) N))

lemma-llum' : {A : Set} (κ : Cl) → ∀(M N : Multiset (myLift (myLift A κ) κ)) → (mapL κ distlawLcM (distlawLcM M)) ll∪m (mapL κ distlawLcM (distlawLcM N))
                                                                               ≡ mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)

lemma-llum' κ M = elimM
                    (λ M₁ → (( ∀ N → (mapL κ distlawLcM (distlawLcM M₁)) ll∪m (mapL κ distlawLcM (distlawLcM N)) ≡ mapL κ distlawLcM (distlawLcM M₁ l∪m distlawLcM N)) ,
                     λ x y i N → truncLLcM ((mapL κ distlawLcM (distlawLcM M₁)) ll∪m (mapL κ distlawLcM (distlawLcM N)))
                                            (mapL κ distlawLcM (distlawLcM M₁ l∪m distlawLcM N))
                                            (x N)
                                            (y N)
                                            i))
                    (λ N → ((nowL (nowL m∅) ll∪m mapL κ distlawLcM (distlawLcM N))
                      ≡⟨ unit-ll∪m (mapL κ distlawLcM (distlawLcM N)) ⟩
                      (mapL κ distlawLcM (distlawLcM N))
                      ≡⟨ cong (mapL κ distlawLcM) (sym (unit-l∪m (distlawLcM N))) ⟩
                      mapL κ distlawLcM (distlawLcM N l∪m nowL m∅)
                      ≡⟨ cong (mapL κ distlawLcM) (comm-l∪m (distlawLcM N) (nowL m∅)) ⟩
                      mapL κ distlawLcM (nowL m∅ l∪m distlawLcM N) ∎))
                    (λ x → λ N → lemma-llum-unitcase κ x N)
                    (λ {M M₁} → λ eqM eqM₁ → λ N → (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM M₁) ll∪m mapL κ distlawLcM (distlawLcM N))
                                             ≡⟨ cong (_ll∪m mapL κ distlawLcM (distlawLcM N)) (sym (eqM M₁)) ⟩
                                             (((mapL κ distlawLcM (distlawLcM M)) ll∪m (mapL κ distlawLcM (distlawLcM M₁))) ll∪m mapL κ distlawLcM (distlawLcM N))
                                             ≡⟨ assoc-ll∪m ((mapL κ distlawLcM (distlawLcM M))) ((mapL κ distlawLcM (distlawLcM M₁))) ((mapL κ distlawLcM (distlawLcM N))) ⟩
                                             ((mapL κ distlawLcM (distlawLcM M)) ll∪m ((mapL κ distlawLcM (distlawLcM M₁)) ll∪m mapL κ distlawLcM (distlawLcM N)))
                                             ≡⟨ cong (mapL κ distlawLcM (distlawLcM M) ll∪m_) (eqM₁ N) ⟩
                                             ((mapL κ distlawLcM (distlawLcM M) ll∪m mapL κ distlawLcM (distlawLcM M₁ l∪m distlawLcM N)))
                                             ≡⟨ refl ⟩
                                             (mapL κ distlawLcM (distlawLcM M) ll∪m mapL κ distlawLcM (distlawLcM (M₁ ∪ₘ N)))
                                             ≡⟨ eqM (M₁ ∪ₘ N) ⟩
                                             mapL κ distlawLcM (distlawLcM M l∪m (distlawLcM M₁ l∪m distlawLcM N))
                                             ≡⟨ cong (mapL κ distlawLcM) (sym (assoc-l∪m (distlawLcM M) (distlawLcM M₁) (distlawLcM N))) ⟩
                                             mapL κ distlawLcM ((distlawLcM M l∪m distlawLcM M₁) l∪m distlawLcM N) ∎)
                    M

-- then now the second multiplication law:

-- I don't know how to split cases within elimM, so here a lemma for the unitM case of elimM for multlawLcM2, split into nowL and stepL:
multlawLcM2-unitMcase : {A : Set} {κ : Cl} → ∀(x : (myLift (myLift A κ) κ)) →
                                      distlawLcM (mapM (MultL κ) (unitM x)) ≡ MultL κ (mapL κ distlawLcM (distlawLcM (unitM x)))
multlawLcM2-unitMcase (nowL x) = refl
multlawLcM2-unitMcase (stepL x) = cong stepL (later-ext λ α → multlawLcM2-unitMcase (x α))

-- and here the full proof of the second multiplication law:
multlawLcM2 : {A : Set} (κ : Cl) → ∀(M : Multiset (myLift (myLift A κ) κ)) →
                                     distlawLcM (mapM (MultL κ) M) ≡ MultL κ (mapL κ distlawLcM (distlawLcM M))
multlawLcM2 κ M = elimM
                   (λ N → ((distlawLcM (mapM (MultL κ) N) ≡ MultL κ (mapL κ distlawLcM (distlawLcM N))) ,
                          truncLcM (distlawLcM (mapM (MultL κ) N)) (MultL κ (mapL κ distlawLcM (distlawLcM N)))))
                   refl
                   (λ x → multlawLcM2-unitMcase x )
                   (λ {M N} → λ eqM eqN → distlawLcM (mapM (MultL κ) M) l∪m distlawLcM (mapM (MultL κ) N)
                                           ≡⟨ cong₂ (_l∪m_) eqM eqN ⟩
                                           (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
                                           ≡⟨ sym (multL-ll∪m-l∪m κ (mapL κ distlawLcM (distlawLcM M)) (mapL κ distlawLcM (distlawLcM N))) ⟩
                                           MultL κ ((mapL κ distlawLcM (distlawLcM M)) ll∪m (mapL κ distlawLcM (distlawLcM N)))
                                           ≡⟨ cong (MultL κ) (lemma-llum' κ M N) ⟩
                                           MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)) ∎)
                   M

--some random proofs that did not work, or work partially, that I'm not ready to through away yet:

-- lemma-llum : {A : Set} (κ : Cl) → ∀(M N : Multiset (myLift (myLift A κ) κ)) → (mapL κ distlawLcM (distlawLcM M)) ll∪m (mapL κ distlawLcM (distlawLcM N))
--                                                                                ≡ mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)
-- lemma-llum κ m∅ N = (nowL (nowL m∅) ll∪m mapL κ distlawLcM (distlawLcM N))
--                        ≡⟨ unit-ll∪m (mapL κ distlawLcM (distlawLcM N)) ⟩
--                        (mapL κ distlawLcM (distlawLcM N))
--                        ≡⟨ cong (mapL κ distlawLcM) (sym (unit-l∪m (distlawLcM N))) ⟩
--                        mapL κ distlawLcM (distlawLcM N l∪m nowL m∅)
--                        ≡⟨ cong (mapL κ distlawLcM) (comm-l∪m (distlawLcM N) (nowL m∅)) ⟩
--                        mapL κ distlawLcM (nowL m∅ l∪m distlawLcM N) ∎
-- lemma-llum κ (unitM (nowL x)) m∅ = refl
-- lemma-llum κ (unitM (nowL x)) (unitM (nowL y)) = refl
-- lemma-llum κ (unitM (nowL x)) (unitM (stepL y)) = cong stepL (later-ext (λ α → lemma-llum κ (unitM (nowL x)) (unitM (y α))))
-- lemma-llum κ (unitM (nowL x)) (M ∪ₘ N) = (nowL (distlawLcM (unitM x)) ll∪m
--                                            mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
--                                            ≡⟨ lemma-nowL-ll∪m-mapL (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)) (distlawLcM (unitM x)) ⟩
--                                            mapL κ (distlawLcM (unitM x) l∪m_) (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
--                                            ≡⟨ mapmapL κ distlawLcM (distlawLcM (unitM x) l∪m_) ((distlawLcM M l∪m distlawLcM N)) ⟩
--                                            mapL κ (λ y → distlawLcM (unitM x) l∪m (distlawLcM y)) (distlawLcM M l∪m distlawLcM N)
--                                            ≡⟨ cong₂ (mapL κ) (funExt (λ y → refl)) refl ⟩
--                                            mapL κ (λ y → distlawLcM ((unitM x) ∪ₘ y)) (distlawLcM M l∪m distlawLcM N)
--                                            ≡⟨ sym (mapmapL κ ((unitM x) ∪ₘ_) distlawLcM (distlawLcM M l∪m distlawLcM N)) ⟩
--                                            mapL κ distlawLcM (mapL κ ((unitM x) ∪ₘ_) (distlawLcM M l∪m distlawLcM N))
--                                            ≡⟨ cong (mapL κ distlawLcM) (sym (lemma-nowL-l∪m-mapL (distlawLcM M l∪m distlawLcM N) (unitM x))) ⟩
--                                            mapL κ distlawLcM (nowL (unitM x) l∪m (distlawLcM M l∪m distlawLcM N)) ∎
-- lemma-llum κ (unitM (nowL x)) (ass N N₁ N₂ i) = {!!}
-- lemma-llum κ (unitM (nowL x)) (com N N₁ i) = {!!}
-- lemma-llum κ (unitM (nowL x)) (unitr N i) = {!!}
-- lemma-llum κ (unitM (nowL x)) (trunc N N₁ x₁ y i i₁) = {!!}
-- lemma-llum κ (unitM (stepL x)) N = cong stepL (later-ext (λ α → lemma-llum κ (unitM (x α)) N))
-- lemma-llum κ  (M ∪ₘ M₁) N = (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM M₁) ll∪m mapL κ distlawLcM (distlawLcM N))
--                              ≡⟨ cong (_ll∪m mapL κ distlawLcM (distlawLcM N)) (sym (lemma-llum κ M M₁)) ⟩
--                              (((mapL κ distlawLcM (distlawLcM M)) ll∪m (mapL κ distlawLcM (distlawLcM M₁))) ll∪m mapL κ distlawLcM (distlawLcM N))
--                              ≡⟨ assoc-ll∪m ((mapL κ distlawLcM (distlawLcM M))) ((mapL κ distlawLcM (distlawLcM M₁))) ((mapL κ distlawLcM (distlawLcM N))) ⟩
--                              ((mapL κ distlawLcM (distlawLcM M)) ll∪m ((mapL κ distlawLcM (distlawLcM M₁)) ll∪m mapL κ distlawLcM (distlawLcM N)))
--                              ≡⟨ cong (mapL κ distlawLcM (distlawLcM M) ll∪m_) (lemma-llum κ M₁ N) ⟩
--                              ((mapL κ distlawLcM (distlawLcM M) ll∪m mapL κ distlawLcM (distlawLcM M₁ l∪m distlawLcM N)))
--                              ≡⟨ refl ⟩
--                              (mapL κ distlawLcM (distlawLcM M) ll∪m mapL κ distlawLcM (distlawLcM (M₁ ∪ₘ N)))
--                              ≡⟨ lemma-llum κ M (M₁ ∪ₘ N) ⟩
--                              mapL κ distlawLcM (distlawLcM M l∪m (distlawLcM M₁ l∪m distlawLcM N))
--                              ≡⟨ cong (mapL κ distlawLcM) (sym (assoc-l∪m (distlawLcM M) (distlawLcM M₁) (distlawLcM N))) ⟩
--                              mapL κ distlawLcM ((distlawLcM M l∪m distlawLcM M₁) l∪m distlawLcM N) ∎
-- lemma-llum κ  (ass M M₁ M₂ i) N = {!!}
-- lemma-llum κ  (com M M₁ i) N = {!!}
-- lemma-llum κ  (unitr M i) N = {!!}
-- lemma-llum κ  (trunc M M₁ x y i i₁) N = {!!}

-- -- lemma-multlawLcM2-unitMcase-unitMcase : {A : Set} (κ : Cl) → ∀(x : (myLift A κ)) → ∀(y : (myLift (myLift A κ) κ)) →
-- --                                           (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m MultL κ (mapL κ distlawLcM (distlawLcM (unitM y))))
-- --                                            ≡ MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m distlawLcM (unitM y)))
-- -- lemma-multlawLcM2-unitMcase-unitMcase κ x (nowL y) = refl
-- -- lemma-multlawLcM2-unitMcase-unitMcase κ x (stepL y) = (distlawLcM (unitM x) l∪m
-- --                                                         stepL (λ α → MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α))))))
-- --                                                         ≡⟨ comm-l∪m (distlawLcM (unitM x))
-- --                                                                     (stepL (λ α → MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))))) ⟩
-- --                                                         (stepL (λ α → MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α))))) l∪m
-- --                                                          distlawLcM (unitM x))
-- --                                                         ≡⟨ refl ⟩
-- --                                                         stepL (λ α → (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))) l∪m
-- --                                                         distlawLcM (unitM x)))
-- --                                                         ≡⟨ cong stepL (later-ext λ α → comm-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))))
-- --                                                                                (distlawLcM (unitM x)) ) ⟩
-- --                                                         stepL (λ α → (distlawLcM (unitM x) l∪m
-- --                                                         (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))))))
-- --                                                         ≡⟨ refl ⟩
-- --                                                         stepL (λ α → (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x))))) l∪m
-- --                                                         (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α))))))
-- --                                                         ≡⟨ cong stepL (later-ext λ α → lemma-multlawLcM2-unitMcase-unitMcase κ x (y α)) ⟩
-- --                                                         stepL (λ α → MultL κ (mapL κ distlawLcM (nowL (unitM x) l∪m distlawLcM (unitM (y α))))) ∎

-- -- lemma-multlawLcM2-unitMcase : {A : Set} (κ : Cl) → ∀(x : (myLift (myLift A κ) κ)) → ∀ (N : Multiset (myLift (myLift A κ) κ)) →
-- --                                  (MultL κ (mapL κ distlawLcM (distlawLcM (unitM x))) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                   ≡ MultL κ (mapL κ distlawLcM (distlawLcM (unitM x) l∪m distlawLcM N))

-- -- lemma-multlawLcM2 : {A : Set} (κ : Cl) → ∀(M N : Multiset (myLift (myLift A κ) κ)) →
-- --                                  (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                   ≡ MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))

-- -- lemma-multlawLcM2-unitMcase κ (nowL x) N = elimM
-- --                                             (λ N → (((MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                    ≡ (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m distlawLcM N)))) ,
-- --                                                    truncLcM (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                             (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m distlawLcM N)))
-- --                                                     ))
-- --                                             refl
-- --                                             (λ y → lemma-multlawLcM2-unitMcase-unitMcase κ x y)
-- --                                             (λ {M N} → λ eqM eqN →
-- --                                                        MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m
-- --                                                        MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
-- --                                                        ≡⟨ cong (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m_)
-- --                                                                         (sym (lemma-multlawLcM2 κ M N)) ⟩
-- --                                                        (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m
-- --                                                        (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m
-- --                                                         MultL κ (mapL κ distlawLcM (distlawLcM N))))
-- --                                                        ≡⟨ sym (assoc-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))))
-- --                                                                          (MultL κ (mapL κ distlawLcM (distlawLcM M)))
-- --                                                                          (MultL κ (mapL κ distlawLcM (distlawLcM N)))) ⟩
-- --                                                        ((MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m
-- --                                                          MultL κ (mapL κ distlawLcM (distlawLcM M))) l∪m
-- --                                                          MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                        ≡⟨ cong (_l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                         (lemma-multlawLcM2-unitMcase κ (nowL x) M) ⟩
-- --                                                        (MultL κ (mapL κ distlawLcM (nowL (unitM x) l∪m (distlawLcM M))) l∪m
-- --                                                         MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                        ≡⟨ refl ⟩
-- --                                                        (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m (distlawLcM M))) l∪m
-- --                                                         MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                        ≡⟨ refl ⟩
-- --                                                        (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x) ∪ₘ M))) l∪m
-- --                                                         MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                        ≡⟨ lemma-multlawLcM2 κ (unitM (nowL x) ∪ₘ M) N ⟩
-- --                                                        MultL κ (mapL κ distlawLcM ((distlawLcM (unitM (nowL x) ∪ₘ M)) l∪m distlawLcM N))
-- --                                                        ≡⟨ refl ⟩
-- --                                                        MultL κ (mapL κ distlawLcM ((nowL (unitM x) l∪m distlawLcM M) l∪m distlawLcM N))
-- --                                                        ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM)
-- --                                                                                (assoc-l∪m (nowL (unitM x)) (distlawLcM M) (distlawLcM N))) ⟩
-- --                                                        MultL κ (mapL κ distlawLcM (nowL (unitM x) l∪m (distlawLcM M l∪m distlawLcM N))) ∎)
-- --                                             N

-- -- lemma-multlawLcM2-unitMcase κ (stepL x) N = cong stepL (later-ext λ α → lemma-multlawLcM2-unitMcase κ (x α) N)

-- -- lemma-multlawLcM2 κ M N = elimM
-- --                           (λ M → ((MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                   ≡ MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))) ,
-- --                                   truncLcM (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                             (MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)))  )
-- --                           (nowL m∅ l∪m MultL κ (mapL κ distlawLcM (distlawLcM N))
-- --                              ≡⟨ comm-l∪m (nowL m∅) (MultL κ (mapL κ distlawLcM (distlawLcM N))) ⟩
-- --                              (MultL κ (mapL κ distlawLcM (distlawLcM N)) l∪m nowL m∅)
-- --                              ≡⟨ unit-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM N))) ⟩
-- --                              MultL κ (mapL κ distlawLcM (distlawLcM N))
-- --                              ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM) (sym (unit-l∪m (distlawLcM N)))) ⟩
-- --                              MultL κ (mapL κ distlawLcM (distlawLcM N l∪m nowL m∅ ))
-- --                              ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM) (comm-l∪m (distlawLcM N) (nowL m∅))) ⟩
-- --                              MultL κ (mapL κ distlawLcM (nowL m∅ l∪m distlawLcM N)) ∎ )
-- --                           (λ x → lemma-multlawLcM2-unitMcase κ x N )
-- --                           (λ {M₁ M₂} → λ eq1 eq2 → MultL κ (mapL κ distlawLcM (distlawLcM M₁ l∪m distlawLcM M₂)) l∪m
-- --                                                     MultL κ (mapL κ distlawLcM (distlawLcM N))
-- --                                                     ≡⟨ cong (_l∪m MultL κ (mapL κ distlawLcM (distlawLcM N))) (sym (lemma-multlawLcM2 κ M₁ M₂)) ⟩
-- --                                                     ((MultL κ (mapL κ distlawLcM (distlawLcM M₁))l∪m MultL κ (mapL κ distlawLcM (distlawLcM M₂))) l∪m
-- --                                                     MultL κ (mapL κ distlawLcM (distlawLcM N)))
-- --                                                     ≡⟨ assoc-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM M₁)))
-- --                                                                  (MultL κ (mapL κ distlawLcM (distlawLcM M₂)))
-- --                                                                  (MultL κ (mapL κ distlawLcM (distlawLcM N))) ⟩
-- --                                                     (MultL κ (mapL κ distlawLcM (distlawLcM M₁))l∪m (MultL κ (mapL κ distlawLcM (distlawLcM M₂)) l∪m
-- --                                                     MultL κ (mapL κ distlawLcM (distlawLcM N))))
-- --                                                     ≡⟨ cong (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m_) (lemma-multlawLcM2 κ M₂ N) ⟩
-- --                                                     (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m  MultL κ (mapL κ distlawLcM (distlawLcM M₂ l∪m distlawLcM N)) )
-- --                                                     ≡⟨ cong (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m_) refl ⟩
-- --                                                     (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m  MultL κ (mapL κ distlawLcM (distlawLcM (M₂ ∪ₘ N))) )
-- --                                                     ≡⟨ lemma-multlawLcM2 κ M₁ ((M₂ ∪ₘ N)) ⟩
-- --                                                     MultL κ (mapL κ distlawLcM (distlawLcM M₁ l∪m (distlawLcM M₂ l∪m distlawLcM N)))
-- --                                                     ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM) (sym (assoc-l∪m (distlawLcM M₁) (distlawLcM M₂) (distlawLcM N)))) ⟩
-- --                                                     MultL κ (mapL κ distlawLcM ((distlawLcM M₁ l∪m distlawLcM M₂) l∪m distlawLcM N)) ∎)
-- --                           M
-- --

-- lemma-lum : {A : Set} (κ : Cl) → ∀(M N : Multiset (myLift (myLift A κ) κ)) →
--                                  (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                   ≡ MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
-- lemma-lum κ m∅ N = nowL m∅ l∪m MultL κ (mapL κ distlawLcM (distlawLcM N))
--                     ≡⟨ comm-l∪m (nowL m∅) (MultL κ (mapL κ distlawLcM (distlawLcM N))) ⟩
--                     (MultL κ (mapL κ distlawLcM (distlawLcM N)) l∪m nowL m∅)
--                     ≡⟨ unit-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM N))) ⟩
--                     MultL κ (mapL κ distlawLcM (distlawLcM N))
--                     ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM) (sym (unit-l∪m (distlawLcM N)))) ⟩
--                     MultL κ (mapL κ distlawLcM (distlawLcM N l∪m nowL m∅ ))
--                     ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM) (comm-l∪m (distlawLcM N) (nowL m∅))) ⟩
--                     MultL κ (mapL κ distlawLcM (nowL m∅ l∪m distlawLcM N)) ∎
-- lemma-lum κ (unitM (nowL x)) m∅ = refl
-- lemma-lum κ (unitM (nowL x)) (unitM (nowL y)) = refl
-- lemma-lum κ (unitM (nowL x)) (unitM (stepL y)) = (distlawLcM (unitM x) l∪m
--                                                   stepL (λ α → MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α))))))
--                                                   ≡⟨ comm-l∪m (distlawLcM (unitM x))
--                                                               (stepL (λ α → MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))))) ⟩
--                                                   (stepL (λ α → MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α))))) l∪m
--                                                    distlawLcM (unitM x))
--                                                   ≡⟨ refl ⟩
--                                                   stepL (λ α → (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))) l∪m
--                                                    distlawLcM (unitM x)))
--                                                   ≡⟨ cong stepL (later-ext λ α → comm-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))))
--                                                                                (distlawLcM (unitM x)) ) ⟩
--                                                   stepL (λ α → (distlawLcM (unitM x) l∪m
--                                                   (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α)))))))
--                                                   ≡⟨ refl ⟩
--                                                   stepL (λ α → (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x))))) l∪m
--                                                   (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (y α))))))
--                                                   ≡⟨ cong stepL (later-ext λ α → lemma-lum κ (unitM (nowL x)) (unitM (y α))) ⟩
--                                                   stepL (λ α → MultL κ (mapL κ distlawLcM (nowL (unitM x) l∪m distlawLcM (unitM (y α))))) ∎
-- lemma-lum κ (unitM (nowL x)) (M ∪ₘ N) = MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m
--                                                 MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N))
--                                                 ≡⟨ cong (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m_)
--                                                         (sym (lemma-lum κ M N)) ⟩
--                                                 (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m
--                                                 (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m
--                                                  MultL κ (mapL κ distlawLcM (distlawLcM N))))
--                                                 ≡⟨ sym (assoc-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))))
--                                                                   (MultL κ (mapL κ distlawLcM (distlawLcM M)))
--                                                                   (MultL κ (mapL κ distlawLcM (distlawLcM N)))) ⟩
--                                                 ((MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)))) l∪m
--                                                   MultL κ (mapL κ distlawLcM (distlawLcM M))) l∪m
--                                                   MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                                 ≡⟨ cong (_l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                                         (lemma-lum κ (unitM (nowL x)) M) ⟩
--                                                 (MultL κ (mapL κ distlawLcM (nowL (unitM x) l∪m (distlawLcM M))) l∪m
--                                                  MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                                 ≡⟨ refl ⟩
--                                                 (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x)) l∪m (distlawLcM M))) l∪m
--                                                  MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                                 ≡⟨ refl ⟩
--                                                 (MultL κ (mapL κ distlawLcM (distlawLcM (unitM (nowL x) ∪ₘ M))) l∪m
--                                                  MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                                 ≡⟨ {!lemma-lum κ (unitM (nowL x) ∪ₘ M) N!} ⟩
--                                                 MultL κ (mapL κ distlawLcM ((distlawLcM (unitM (nowL x) ∪ₘ M)) l∪m distlawLcM N))
--                                                 ≡⟨ refl ⟩
--                                                 MultL κ (mapL κ distlawLcM ((nowL (unitM x) l∪m distlawLcM M) l∪m distlawLcM N))
--                                                 ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM)
--                                                                         (assoc-l∪m (nowL (unitM x)) (distlawLcM M) (distlawLcM N))) ⟩
--                                                 MultL κ (mapL κ distlawLcM (nowL (unitM x) l∪m (distlawLcM M l∪m distlawLcM N))) ∎
-- lemma-lum κ (unitM (nowL x)) (ass M N O i) = isProp→PathP {!!} {!!} {!!} {!!}
-- lemma-lum κ (unitM (nowL x)) (com M N i) = {!!}
-- lemma-lum κ (unitM (nowL x)) (unitr N i) = {!!}
-- lemma-lum κ (unitM (nowL x)) (trunc M N y z i i₁) = {!!}
-- lemma-lum κ (unitM (stepL x)) N = cong stepL (later-ext λ α → lemma-lum κ (unitM (x α)) N  )
-- lemma-lum κ (M₁ ∪ₘ M₂) N =  MultL κ (mapL κ distlawLcM (distlawLcM M₁ l∪m distlawLcM M₂)) l∪m
--                             MultL κ (mapL κ distlawLcM (distlawLcM N))
--                            ≡⟨ cong (_l∪m MultL κ (mapL κ distlawLcM (distlawLcM N))) (sym (lemma-lum κ M₁ M₂)) ⟩
--                            ((MultL κ (mapL κ distlawLcM (distlawLcM M₁))l∪m MultL κ (mapL κ distlawLcM (distlawLcM M₂))) l∪m
--                              MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                            ≡⟨ assoc-l∪m (MultL κ (mapL κ distlawLcM (distlawLcM M₁)))
--                                         (MultL κ (mapL κ distlawLcM (distlawLcM M₂)))
--                                         (MultL κ (mapL κ distlawLcM (distlawLcM N))) ⟩
--                            (MultL κ (mapL κ distlawLcM (distlawLcM M₁))l∪m (MultL κ (mapL κ distlawLcM (distlawLcM M₂)) l∪m
--                             MultL κ (mapL κ distlawLcM (distlawLcM N))))
--                            ≡⟨ cong (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m_) (lemma-lum κ M₂ N) ⟩
--                            (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m  MultL κ (mapL κ distlawLcM (distlawLcM M₂ l∪m distlawLcM N)) )
--                            ≡⟨ cong (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m_) refl ⟩
--                            (MultL κ (mapL κ distlawLcM (distlawLcM M₁)) l∪m  MultL κ (mapL κ distlawLcM (distlawLcM (M₂ ∪ₘ N))) )
--                            ≡⟨ lemma-lum κ M₁ ((M₂ ∪ₘ N)) ⟩
--                            MultL κ (mapL κ distlawLcM (distlawLcM M₁ l∪m (distlawLcM M₂ l∪m distlawLcM N)))
--                            ≡⟨ cong (MultL κ) (cong (mapL κ distlawLcM) (sym (assoc-l∪m (distlawLcM M₁) (distlawLcM M₂) (distlawLcM N)))) ⟩
--                            MultL κ (mapL κ distlawLcM ((distlawLcM M₁ l∪m distlawLcM M₂) l∪m distlawLcM N)) ∎
-- lemma-lum κ (ass M M₁ M₂ i) N = isProp→PathP (λ j → {!!}) (lemma-lum κ ((M ∪ₘ M₁) ∪ₘ M₂) N) (lemma-lum κ (M ∪ₘ (M₁ ∪ₘ M₂)) N) i
-- lemma-lum κ (com M M₁ i) N = λ j → comm-l∪m {!!} {!!} i
-- lemma-lum κ (unitr M i) N = λ j → {!!}
-- lemma-lum κ (trunc M M₁ x y i i₁) N = {!!}

-- --λ j → unitr (Multiset-unitlaw2 M j) i

-- -- I don't know how to split cases within elimM, so here a lemma for the unitM case of elimM for multlawLcM2, split into nowL and stepL:
-- multlawLcM2-unitMcase : {A : Set} {κ : Cl} → ∀(x : (myLift (myLift A κ) κ)) →
--                                      distlawLcM (mapM (MultL κ) (unitM x)) ≡ MultL κ (mapL κ distlawLcM (distlawLcM (unitM x)))
-- multlawLcM2-unitMcase (nowL x) = refl
-- multlawLcM2-unitMcase (stepL x) = cong stepL (later-ext λ α → multlawLcM2-unitMcase (x α))

-- -- and here the full proof of the second multiplication law:
-- multlawLcM2 : {A : Set} (κ : Cl) → ∀(M : Multiset (myLift (myLift A κ) κ)) →
--                                      distlawLcM (mapM (MultL κ) M) ≡ MultL κ (mapL κ distlawLcM (distlawLcM M))
-- multlawLcM2 κ M = elimM
--                    (λ N → ((distlawLcM (mapM (MultL κ) N) ≡ MultL κ (mapL κ distlawLcM (distlawLcM N))) ,
--                           truncLcM (distlawLcM (mapM (MultL κ) N)) (MultL κ (mapL κ distlawLcM (distlawLcM N)))))
--                    refl
--                    (λ x → multlawLcM2-unitMcase x )
--                    (λ {M N} → λ eqM eqN → distlawLcM (mapM (MultL κ) M) l∪m distlawLcM (mapM (MultL κ) N)
--                                            ≡⟨ cong₂ (_l∪m_) eqM eqN ⟩
--                                            (MultL κ (mapL κ distlawLcM (distlawLcM M)) l∪m MultL κ (mapL κ distlawLcM (distlawLcM N)))
--                                            ≡⟨ lemma-lum κ M N ⟩
--                                            MultL κ (mapL κ distlawLcM (distlawLcM M l∪m distlawLcM N)) ∎)
--                    M


module New.Correctness where

open import Function hiding (const)
open import New.Lang
open import New.Changes
open import New.Derive
open import New.LangChanges
open import New.LangOps
open import New.FunctionLemmas
open import New.Unused

⟦Γ≼ΔΓ⟧ : ∀ {Γ} (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → validΓ ρ dρ →
  ρ ≡ ⟦ Γ≼ΔΓ ⟧≼ dρ
⟦Γ≼ΔΓ⟧ ∅ ∅ tt = refl
⟦Γ≼ΔΓ⟧ (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = cong₂ _•_ refl (⟦Γ≼ΔΓ⟧ ρ dρ ρdρ)

fit-sound : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → validΓ ρ dρ →
  ⟦ t ⟧Term ρ ≡ ⟦ fit t ⟧Term dρ
fit-sound t ρ dρ ρdρ = trans
  (cong ⟦ t ⟧Term (⟦Γ≼ΔΓ⟧ ρ dρ ρdρ))
  (sym (weaken-sound t _))

correctDeriveConst : ∀ {τ} (c : Const τ) → ⟦ c ⟧Const ≡ ⟦ c ⟧Const ⊕ (⟦_⟧ΔConst c)
correctDeriveConst (lit n) = sym (right-id-int n)
correctDeriveConst plus = ext (λ m → ext (lemma m))
  where
    lemma : ∀ m n → m + n ≡ m + n + (m + - m + (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m + n) = refl

correctDeriveConst minus = ext (λ m → ext (λ n → lemma m n))
  where
    lemma : ∀ m n → m - n ≡ m - n + (m + - m - (n + - n))
    lemma m n rewrite right-inv-int m | right-inv-int n | right-id-int (m - n) = refl
correctDeriveConst cons = ext (λ v1 → ext (λ v2 → sym (update-nil (v1 , v2))))
correctDeriveConst fst = ext (λ vp → sym (update-nil (proj₁ vp)))
correctDeriveConst snd = ext (λ vp → sym (update-nil (proj₂ vp)))
correctDeriveConst linj = ext (λ va → sym (cong inj₁ (update-nil va)))
correctDeriveConst rinj = ext (λ vb → sym (cong inj₂ (update-nil vb)))
correctDeriveConst (match {t1} {t2} {t3}) = ext³ lemma
  where
    lemma : ∀ s f g →
      ⟦ match {t1} {t2} {t3} ⟧Const s f g ≡
      (⟦ match ⟧Const ⊕ ⟦ match ⟧ΔConst) s f g
    lemma (inj₁ x) f g rewrite update-nil x | update-nil (f x) = refl
    lemma (inj₂ y) f g rewrite update-nil y | update-nil (g y) = refl

validDeriveConst : ∀ {τ} (c : Const τ) → valid ⟦ c ⟧Const (⟦_⟧ΔConst c)
validDeriveConst (lit n) = tt
validDeriveConst {τ = t1 ⇒ t2 ⇒ pair .t1 .t2} cons = binary-valid (λ a da ada b db bdb → (ada , bdb)) dcons-eq
  where
    open BinaryValid ⟦ cons {t1} {t2} ⟧Const (⟦ cons ⟧ΔConst)
    dcons-eq : binary-valid-eq-hp
    dcons-eq a da ada b db bdb rewrite update-nil (a ⊕ da) | update-nil (b ⊕ db) = refl
validDeriveConst fst (a , b) (da , db) (ada , bdb) = ada , update-nil (a ⊕ da)
validDeriveConst snd (a , b) (da , db) (ada , bdb) = bdb , update-nil (b ⊕ db)

validDeriveConst plus = binary-valid (λ a da ada b db bdb → tt) dplus-eq
  where
    open BinaryValid ⟦ plus ⟧Const (⟦ plus ⟧ΔConst)
    dplus-eq : binary-valid-eq-hp
    dplus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da + (b + db)) = mn·pq=mp·nq {a} {da} {b} {db}
validDeriveConst minus = binary-valid (λ a da ada b db bdb → tt) dminus-eq
  where
    open BinaryValid ⟦ minus ⟧Const (⟦ minus ⟧ΔConst)
    dminus-eq : binary-valid-eq-hp
    dminus-eq a da ada b db bdb rewrite right-inv-int (a + da) | right-inv-int (b + db) | right-id-int (a + da - (b + db)) | sym (-m·-n=-mn {b} {db}) = mn·pq=mp·nq {a} {da} { - b} { - db}
validDeriveConst linj a da ada = sv₁ a da ada , cong inj₁ (update-nil (a ⊕ da))
validDeriveConst rinj b db bdb = sv₂ b db bdb , cong inj₂ (update-nil (b ⊕ db))
validDeriveConst (match {t1} {t2} {t3}) =
  ternary-valid dmatch-valid dmatch-eq
  where
    open TernaryValid {{chAlgt (sum t1 t2)}} {{chAlgt (t1 ⇒ t3)}} {{chAlgt (t2 ⇒ t3)}} {{chAlgt t3}} ⟦ match ⟧Const (⟦ match ⟧ΔConst)

    dmatch-valid : ternary-valid-preserve-hp
    dmatch-valid .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg = proj₁ (fdf a da ada)
    dmatch-valid .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg = proj₁ (gdg b db bdb)
    dmatch-valid .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
      rewrite changeMatchSem-lem1 f df g dg a1 b2
      = ⊝-valid (f a1) (g b2 ⊕ dg b2 (nil b2))
    dmatch-valid .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
      rewrite changeMatchSem-lem2 f df g dg b1 a2
      = ⊝-valid (g b1) (f a2 ⊕ df a2 (nil a2))
    dmatch-eq : ternary-valid-eq-hp
    dmatch-eq .(inj₁ a) .(inj₁ (inj₁ da)) (sv₁ a da ada) f df fdf g dg gdg
      rewrite update-nil (a ⊕ da)
      | update-nil (f (a ⊕ da) ⊕ df (a ⊕ da) (nil (a ⊕ da))) = proj₂ (fdf a da ada)
    dmatch-eq .(inj₂ b) .(inj₁ (inj₂ db)) (sv₂ b db bdb) f df fdf g dg gdg
      rewrite update-nil (b ⊕ db)
      | update-nil (g (b ⊕ db) ⊕ dg (b ⊕ db) (nil (b ⊕ db))) = proj₂ (gdg b db bdb)
    dmatch-eq .(inj₁ a1) .(inj₂ (inj₂ b2)) (svrp₁ a1 b2) f df fdf g dg gdg
      rewrite changeMatchSem-lem1 f df g dg a1 b2
      | update-nil b2
      | update-diff (g b2 ⊕ dg b2 (nil b2)) (f a1)
      | update-nil (g b2 ⊕ dg b2 (nil b2))
      = refl
    dmatch-eq .(inj₂ b1) .(inj₂ (inj₁ a2)) (svrp₂ b1 a2) f df fdf g dg gdg
      rewrite changeMatchSem-lem2 f df g dg b1 a2
      | update-nil a2
      | update-diff (f a2 ⊕ df a2 (nil a2)) (g b1)
      | update-nil (f a2 ⊕ df a2 (nil a2))
      = refl

validDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) →
  validΓ ρ dρ → valid (⟦ x ⟧Var ρ) (⟦ x ⟧ΔVar ρ dρ)

validDeriveVar this (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = vdv
validDeriveVar (that x) (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = validDeriveVar x ρ dρ ρdρ

correctDeriveVar : ∀ {Γ τ} → (x : Var Γ τ) →
  IsDerivative ⟦ x ⟧Var (⟦ x ⟧ΔVar)
correctDeriveVar this (v • ρ) (dv • v' • dρ) ρdρ = refl
correctDeriveVar (that x) (v • ρ) (dv • .v • dρ) (vdv , refl , ρdρ) = correctDeriveVar x ρ dρ ρdρ

validDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → validΓ ρ dρ →
    valid (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
correctDerive : ∀ {Γ τ} → (t : Term Γ τ) →
  IsDerivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm

correctDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = correctDeriveConst c
correctDerive (var x) ρ dρ ρdρ = correctDeriveVar x ρ dρ ρdρ
correctDerive (app s t) ρ dρ ρdρ rewrite sym (fit-sound t ρ dρ ρdρ) =
  let
    open ≡-Reasoning
    a0 = ⟦ t ⟧Term ρ
    da0 = ⟦ derive t ⟧Term dρ
    a0da0 = validDerive t ρ dρ ρdρ
  in
    begin
      ⟦ s ⟧Term (ρ ⊕ dρ) (⟦ t ⟧Term (ρ ⊕ dρ))
    ≡⟨ correctDerive s ρ dρ ρdρ ⟨$⟩ correctDerive t ρ dρ ρdρ ⟩
      (⟦ s ⟧Term ρ ⊕ ⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ ⊕ ⟦ t ⟧ΔTerm ρ dρ)
    ≡⟨ proj₂ (validDerive s ρ dρ ρdρ a0 da0 a0da0)  ⟩
      ⟦ s ⟧Term ρ (⟦ t ⟧Term ρ) ⊕ (⟦ s ⟧ΔTerm ρ dρ) (⟦ t ⟧Term ρ) (⟦ t ⟧ΔTerm ρ dρ)
    ∎
  where
    open import Theorem.CongApp
correctDerive (abs t) ρ dρ ρdρ = ext $ λ a →
  let
    open ≡-Reasoning
    ρ1 = a • ρ
    dρ1 = nil a • a • dρ
    ρ1dρ1 = nil-valid a , refl , ρdρ
  in
    -- equal-future-expand-derivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm (correctDerive t)
    --   ρ1 dρ1 ρ1dρ1
    --   (a • (ρ ⊕ dρ))
    --   (cong (_• ρ ⊕ dρ) (sym (update-nil a)))
    begin
      ⟦ t ⟧Term (a • ρ ⊕ dρ)
    ≡⟨ cong (λ a′ → ⟦ t ⟧Term (a′ • ρ ⊕ dρ)) (sym (update-nil a)) ⟩
      ⟦ t ⟧Term (ρ1 ⊕ dρ1)
    ≡⟨ correctDerive t ρ1 dρ1 ρ1dρ1 ⟩
      ⟦ t ⟧Term ρ1 ⊕ ⟦ t ⟧ΔTerm ρ1 dρ1
    ∎

validDerive (app s t) ρ dρ ρdρ =
  let
    f = ⟦ s ⟧Term ρ
    df = ⟦ derive s ⟧Term dρ
    v = ⟦ t ⟧Term ρ
    dv = ⟦ derive t ⟧Term dρ
    vdv = validDerive t ρ dρ ρdρ
    fdf = validDerive s ρ dρ ρdρ
    fvdfv = proj₁ (fdf v dv vdv)
  in subst (λ v′ → valid (f v) (df v′ dv)) (fit-sound t ρ dρ ρdρ) fvdfv
validDerive (abs t) ρ dρ ρdρ =
  λ a da ada →
  let
    ρ1 = a ⊕ da • ρ
    dρ1 = nil (a ⊕ da) • (a ⊕ da) • dρ
    ρ2 = a • ρ
    dρ2 = da • a • dρ
    ρ1dρ1 = nil-valid (a ⊕ da) , refl , ρdρ
    ρ2dρ2 = ada , refl , ρdρ
    rdr = validDerive t ρ2 dρ2 ρ2dρ2
    open ≡-Reasoning
   in
     rdr ,
     equal-future-derivative ⟦ t ⟧Term ⟦ t ⟧ΔTerm (correctDerive t)
       ρ1 dρ1 ρ1dρ1
       ρ2 dρ2 ρ2dρ2
       (cong (λ a′ → (a′ • ρ ⊕ dρ)) (update-nil (a ⊕ da)))
validDerive (var x) ρ dρ ρdρ = validDeriveVar x ρ dρ ρdρ
validDerive (const c) ρ dρ ρdρ rewrite ⟦ c ⟧ΔConst-rewrite ρ dρ = validDeriveConst c