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

open import Clocked.Primitives
open import Cubical.Foundations.Prelude
open import Cubical.Data.List as List
open import Cubical.Data.List.Properties
open import Cubical.Data.Sum using (_⊎_; inl; inr)

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

-- In this document I want to define a monad, called ListLift, that is the free combination of the Lift monad and the List monad.
-- In order to do so, I will first define the Lift monad and the List monad, and check that they are indeed monads (Step 1 and 2).
-- Then I define the LiftList monad, check that it is a monad (Step 3), and finally check that it is the free monad on the algebra
-- structures of a delay algebra and a monoid (Step 4).

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

--************************--
-- Step 1: The Lift monad --
--************************--

-- Defining the monad myLift.
--(note that the return/unit is just x → nowL x)

data myLift (A : Set) (κ : Cl) : Set where
 nowL : A → (myLift A κ)
 stepL : ▹ κ (myLift A κ) → (myLift A κ)

bindL : {A B : Set} (κ : Cl) → (A → (myLift B κ)) → myLift A κ → myLift B κ
bindL κ f (nowL a) = f a
bindL κ f (stepL x) = stepL \(α) → bindL κ f (x α)

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

MultL : {A : Set} (κ : Cl) → (myLift (myLift A κ) κ) → (myLift A κ)
MultL κ = bindL κ identity

mapL : {A B : Set} (κ : Cl) → (A → B) → (myLift A κ) → (myLift B κ)
mapL κ f (nowL x) = nowL (f x)
mapL κ f (stepL x) = stepL (\ α →  mapL κ f (x α))

--checking that it is indeed a monad
-- needs to satisfy three monad laws:

-- unit is a left-identity for bind: bind (f, return) = f
-- unit is a right-identity for bind: bind (return, x) = x
-- bind is associative: bind (\x > bind (g, f(x)), x) = bind(g,bind(f, x))

-- The first of these is satisfied by definition
-- The other two laws we check here below

-- unit law, two versions to learn and remember to ways of doing guarded recursion in agda:
unitlawL : {A : Set}(κ : Cl) → ∀(x : (myLift A κ)) → (bindL {A} κ nowL x) ≡ x
unitlawL κ (nowL x) = refl
unitlawL κ (stepL x) = cong stepL (later-ext (\ α → unitlawL κ (x α)))

unitlawL' : {A : Set}(κ : Cl) → ∀(x : (myLift A κ)) → (bindL {A} κ nowL x) ≡ x
unitlawL' κ (nowL x) = refl
unitlawL' κ (stepL x) = \ i → stepL (\ α → unitlawL' κ (x α) i )

-- associative law:
associativelawL : {A B C : Set}(κ : Cl) → ∀(f : A → (myLift B κ)) → ∀ (g : B → (myLift C κ)) →
                                                ∀ (y : (myLift A κ)) → (bindL κ (\ x → (bindL κ g (f x))) y) ≡ (bindL κ g (bindL κ f y))
associativelawL κ f g (nowL x) = refl
associativelawL κ f g (stepL x) = cong stepL (((later-ext (\ α → associativelawL κ f g (x α)))))

-- Some properties that will be useful later:

-- interaction of mapL and MultL:
MultMap : {A B : Set} (κ : Cl) → ∀(x : myLift (myLift A κ) κ) → ∀(f : A → B) → mapL κ f (MultL κ x) ≡ MultL κ (mapL κ (mapL κ f) x)
MultMap κ (nowL x) f = refl
MultMap κ (stepL x) f = \ i → stepL (\ α → MultMap κ (x α) f i)

-- mapmap for mapL
mapmapL : {A B C : Set} (κ : Cl) → ∀(f : A → B) → ∀(g : B → C) → ∀(x : myLift A κ) → mapL κ g (mapL κ f x) ≡ mapL κ (\ y → g(f y)) x
mapmapL κ f g (nowL x) = refl
mapmapL κ f g (stepL x) =  (\ i → stepL (\ α → mapmapL κ f g (x α) i ))

--************************--
-- Step 2: The List monad --
--************************--

-- Defining the monad List
--List is already defined, but we define a unit and multiplication for it, so it becomes a monad

List-unit : {A : Set} → A → List A
List-unit x = [ x ]

List-mult : {A : Set} → List (List A) → List A
List-mult {A} = foldr _++_ []

List-bind : {A B : Set} → (A → List B) → List A → List B
List-bind f [] = []
List-bind f (x ∷ xs) = (f x) ++ (List-bind f xs)

-- and some other useful functions for later
safe-head : {A : Set} → A → List A → A
safe-head x []      = x
safe-head _ (x ∷ _) = x

tail : {A : Set} → List A → List A
tail [] = []
tail (x ∷ xs) = xs

-- Proving that this forms a monad
-- satisfying the laws:
-- List-mult (List-unit L) = L
-- List-mult (map List-unit L) = L
-- List-mult (List-Mult L) = List-mult (map List-mult L)
-- and both the unit and the multiplication are natural transformations

-- List-mult (List-unit L) = L
List-unitlaw1 : {A : Set} → ∀(L : List A) → List-mult (List-unit L) ≡ L
List-unitlaw1 [] = refl
List-unitlaw1 (x ∷ L) = cong (_++_ [ x ]) (List-unitlaw1 L)

-- List-mult (map List-unit L) = L
List-unitlaw2 : {A : Set} → ∀(L : List A) → List-mult (map List-unit L) ≡ L
List-unitlaw2 [] = refl
List-unitlaw2 (x ∷ L) = cong (_++_ [ x ]) (List-unitlaw2 L )

-- List-mult (List-Mult L) = List-mult (map List-mult L)
lemma : {A : Set} → ∀(L₁ L₂ : List (List A)) -> List-mult (L₁ ++ L₂) ≡ (List-mult L₁) ++ (List-mult L₂)
lemma [] L₂ = refl
lemma (L₁ ∷ L₃) L₂ = L₁ ++ List-mult (L₃ ++ L₂)
                     ≡⟨ cong (L₁ ++_) (lemma L₃ L₂) ⟩
                     L₁ ++ ((List-mult L₃) ++ (List-mult L₂))
                     ≡⟨ sym (++-assoc L₁ (List-mult L₃) (List-mult L₂)) ⟩
                     (L₁ ++ List-mult L₃) ++ List-mult L₂
                     ≡⟨ refl ⟩
                     (List-mult (L₁ ∷ L₃)) ++ (List-mult L₂) ∎

List-multlaw : {A : Set} -> ∀(L : List (List (List A))) -> List-mult (List-mult L) ≡ List-mult (map List-mult L)
List-multlaw [] = refl
List-multlaw (L ∷ L₁) = List-mult (L ++ List-mult L₁)
                        ≡⟨ lemma L (List-mult L₁) ⟩
                        (List-mult L ++ List-mult (List-mult L₁))
                        ≡⟨ cong (List-mult L ++_) (List-multlaw L₁) ⟩
                        List-mult L ++ List-mult (map List-mult L₁) ∎

-- the unit is a natural transformation:
nattrans-Listunit : {A B : Set} → ∀(f : A → B) → ∀(x : A) → map f (List-unit x) ≡ List-unit (f x)
nattrans-Listunit f x = refl

-- the multiplication is a natural transformation:
lemma-map++ : {A B : Set} → ∀(f : A → B) → ∀(xs ys : List A) → map f (xs ++ ys) ≡ (map f xs) ++ (map f ys)
lemma-map++ f [] ys = refl
lemma-map++ f (x ∷ xs) ys = cong ((f x) ∷_) (lemma-map++ f xs ys)

nattrans-Listmult : {A B : Set} → ∀(f : A → B) → ∀(xss : List (List A)) → map f (List-mult xss) ≡ List-mult (map (map f) xss)
nattrans-Listmult f [] = refl
nattrans-Listmult f (xs ∷ xss) = map f (xs ++ List-mult xss)
                                  ≡⟨ lemma-map++ f xs (List-mult xss) ⟩
                                  map f xs ++ map f (List-mult xss)
                                  ≡⟨ cong (map f xs ++_) (nattrans-Listmult f xss) ⟩
                                  map f xs ++ List-mult (map (map f) xss) ∎

--****************************--
-- Step 3: The ListLift monad --
--****************************--

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

data ListLift (A : Set) (κ : Cl) : Set where
  conLL : List (A ⊎ (▹ κ (ListLift A κ))) -> ListLift A κ

--***algebraic structure for ListLift***--

--nowLL and stepLL turn ListLift into a delay algebra structure:
nowLL : {A : Set} (κ : Cl) → A → (ListLift A κ)
nowLL κ a = conLL [ (inl a) ]

stepLL : {A : Set} (κ : Cl) → ▹ κ (ListLift A κ) → (ListLift A κ)
stepLL κ a = conLL [ (inr a) ]

--union, derived from list concatenation, turns ListLift into a monoid:
_∪_ : {A : Set} {κ : Cl} → (ListLift A κ) → (ListLift A κ) → (ListLift A κ)
_∪_ {A} {κ} (conLL x) (conLL y) = conLL (x ++ y)

--proof that this union does indeed provide a monoid structure:
conLLempty-rightunit : {A : Set} (κ : Cl) → ∀ (xs : (ListLift A κ)) → xs ∪ conLL [] ≡ xs
conLLempty-rightunit κ (conLL x) = conLL (x ++ []) ≡⟨ cong conLL (++-unit-r x) ⟩ conLL x ∎

conLLempty-leftunit : {A : Set} (κ : Cl) → ∀ (xs : (ListLift A κ)) → conLL [] ∪ xs ≡ xs
conLLempty-leftunit κ (conLL x) = refl

assoc∪ : {A : Set} {κ : Cl} → ∀(xs ys zs : (ListLift A κ)) → (xs ∪ ys) ∪ zs ≡ xs ∪ (ys ∪ zs)
assoc∪ {A} {κ} (conLL x) (conLL x₁) (conLL x₂) = cong conLL (++-assoc x x₁ x₂)

--a bind operator to make ListLift into a monad
bindLL : {A B : Set} (κ : Cl) → (A → (ListLift B κ)) → ListLift A κ → ListLift B κ
bindLL κ f (conLL []) = conLL []
bindLL κ f (conLL (inl x ∷ x₁)) = (f x) ∪ bindLL κ f (conLL x₁)
bindLL κ f (conLL (inr x ∷ x₁)) = (stepLL κ (\ α → bindLL κ f (x α))) ∪ bindLL κ f (conLL x₁)

--bind commutes with ∪
bindLL∪ : {A B : Set} (κ : Cl) → ∀(f : A → (ListLift B κ)) → ∀(xs ys : (ListLift A κ)) → bindLL κ f (xs ∪ ys) ≡ (bindLL κ f xs) ∪ (bindLL κ f ys)
bindLL∪ κ f xs (conLL []) =  bindLL κ f (xs ∪ conLL []) ≡⟨ cong (bindLL κ f) (conLLempty-rightunit κ xs)  ⟩
                                     bindLL κ f xs ≡⟨ sym (conLLempty-rightunit κ (bindLL κ f xs)) ⟩
                                     (bindLL κ f xs ∪ conLL [])∎
bindLL∪ κ f (conLL []) (conLL (x ∷ x₁)) = bindLL κ f (conLL (x ∷ x₁))
                                                 ≡⟨ sym (conLLempty-leftunit κ (bindLL κ f (conLL (x ∷ x₁)))) ⟩
                                                 (conLL [] ∪ bindLL κ f (conLL (x ∷ x₁))) ∎
bindLL∪ κ f (conLL (inl x₂ ∷ x₃)) (conLL (x ∷ x₁)) = (f x₂ ∪ bindLL κ f ((conLL x₃) ∪ (conLL (x ∷ x₁)))) ≡⟨ cong (f x₂ ∪_) (bindLL∪ κ f (conLL x₃) (conLL (x ∷ x₁))) ⟩
                                                           (f x₂ ∪ (bindLL κ f (conLL x₃) ∪ bindLL κ f (conLL (x ∷ x₁))))
                                                           ≡⟨ sym (assoc∪ (f x₂) (bindLL κ f (conLL x₃)) (bindLL κ f (conLL (x ∷ x₁))))  ⟩
                                                           ((f x₂ ∪ bindLL κ f (conLL x₃)) ∪ bindLL κ f (conLL (x ∷ x₁))) ∎
bindLL∪ κ f (conLL (inr x₂ ∷ x₃)) (conLL (x ∷ x₁)) = (conLL (inr (λ α → bindLL κ f (x₂ α)) ∷ []) ∪ bindLL κ f ((conLL x₃) ∪ (conLL (x ∷ x₁))))
                                                           ≡⟨ cong (conLL (inr (λ α → bindLL κ f (x₂ α)) ∷ []) ∪_) (bindLL∪ κ f (conLL x₃) (conLL (x ∷ x₁))) ⟩
                                                           (conLL (inr (λ α → bindLL κ f (x₂ α)) ∷ []) ∪ ((bindLL κ f (conLL x₃) ∪ bindLL κ f (conLL (x ∷ x₁)))))
                                                           ≡⟨  sym (assoc∪ (conLL (inr (λ α → bindLL κ f (x₂ α)) ∷ [])) (bindLL κ f (conLL x₃)) (bindLL κ f (conLL (x ∷ x₁))))  ⟩
                                                           ((conLL (inr (λ α → bindLL κ f (x₂ α)) ∷ []) ∪ bindLL κ f (conLL x₃)) ∪ bindLL κ f (conLL (x ∷ x₁))) ∎

--and a map function to prove naturality of bind and now
mapLL : {A B : Set} (κ : Cl) → (f : A → B) → (ListLift A κ) → (ListLift B κ)
mapLL κ f (conLL []) = conLL []
mapLL κ f (conLL (inl x ∷ x₁)) = conLL ([ inl (f x) ]) ∪ mapLL κ f (conLL x₁)
mapLL κ f (conLL (inr x ∷ x₁)) = (stepLL κ (\ α → mapLL κ f (x α))) ∪ mapLL κ f (conLL x₁)

--***proving that ListLift is a monad***--

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

--TODO: bind is a natural transformation

-- bindLL and nowLL also need to satisfy three monad laws:
-- unit is a left-identity for bind: bind (f, nowLL) = f
-- unit is a right-identity for bind: bind (nowLL, x) = x
-- bind is associative: bind (\x > bind (g, f(x)), x) = bind(g,bind(f, x))

-- unit is a left-identity for bind
unitlawLL1 :  {A B : Set} (κ : Cl) → ∀ (f : A → (ListLift B κ)) → ∀ (x : A) → (bindLL {A} κ f (nowLL κ x)) ≡ f x
unitlawLL1 κ f x = (f x ∪ conLL []) ≡⟨ conLLempty-rightunit κ (f x) ⟩ f x ∎

-- unit is a right-identity for bind
unitlawLL2 : {A : Set}(κ : Cl) → ∀(x : (ListLift A κ)) → (bindLL κ (nowLL κ) x) ≡ x
unitlawLL2 κ (conLL []) = refl
unitlawLL2 κ (conLL (inl x ∷ x₁)) = (conLL ([ inl x ]) ∪ bindLL κ (nowLL κ) (conLL x₁)) ≡⟨ cong (conLL ([ inl x ]) ∪_ ) (unitlawLL2 κ (conLL x₁)) ⟩
                                          (conLL ([ inl x ]) ∪ conLL x₁) ≡⟨ refl ⟩
                                          conLL (inl x ∷ x₁) ∎
unitlawLL2 κ (conLL (inr x ∷ x₁)) = (stepLL κ (\ α → bindLL κ (nowLL κ) (x α))) ∪ bindLL κ (nowLL κ) (conLL x₁)
                                          ≡⟨ cong ((stepLL κ (\ α → bindLL κ (nowLL κ) (x α))) ∪_) (unitlawLL2 κ (conLL x₁))  ⟩
                                          (stepLL κ (\ α → bindLL κ (nowLL κ) (x α))) ∪ conLL x₁
                                          ≡⟨  cong (_∪ conLL x₁) (\ i → stepLL κ (\ α → unitlawLL2 κ (x α) i ) )   ⟩
                                          conLL ([ inr x ]) ∪ conLL x₁
                                          ≡⟨ refl ⟩
                                          conLL (inr x ∷ x₁) ∎

-- bind is associative
assoclawLL : {A B C : Set}(κ : Cl) → ∀(f : A → (ListLift B κ)) → ∀ (g : B → (ListLift C κ)) → ∀ (x : (ListLift A κ))
                     → (bindLL κ (\ y → (bindLL κ g (f y))) x) ≡ (bindLL κ g (bindLL κ f x))
assoclawLL {A} {B} {C} κ f g (conLL []) = refl
assoclawLL {A} {B} {C} κ f g (conLL (inl x ∷ x₁)) = (bindLL κ g (f x) ∪ bindLL κ (λ y → bindLL κ g (f y)) (conLL x₁))
                                                          ≡⟨ cong (bindLL κ g (f x) ∪_) (assoclawLL κ f g (conLL x₁)) ⟩
                                                          (bindLL κ g (f x) ∪ bindLL κ g (bindLL κ f (conLL x₁)))
                                                          ≡⟨ sym (bindLL∪ κ g (f x) (bindLL κ f (conLL x₁))) ⟩
                                                          bindLL κ g (f x ∪ bindLL κ f (conLL x₁)) ∎
assoclawLL {A} {B} {C} κ f g (conLL (inr x ∷ x₁)) =  (conLL (inr (λ α → bindLL κ (λ y → bindLL κ g (f y)) (x α)) ∷ []) ∪ bindLL κ (λ y → bindLL κ g (f y)) (conLL x₁))
                                                           ≡⟨ cong (conLL (inr (λ α → bindLL κ (λ y → bindLL κ g (f y)) (x α)) ∷ []) ∪_) (assoclawLL κ f g (conLL x₁)) ⟩
                                                           (conLL (inr (λ α → bindLL κ (λ y → bindLL κ g (f y)) (x α)) ∷ []) ∪ (bindLL κ g (bindLL κ f (conLL x₁))))
                                                           ≡⟨ cong (_∪ (bindLL κ g (bindLL κ f (conLL x₁)))) (\ i → stepLL κ (\ α → assoclawLL κ f g (x α) i ) ) ⟩
                                                           ((bindLL κ g (conLL (inr (λ α → bindLL κ f (x α)) ∷ []))) ∪ (bindLL κ g (bindLL κ f (conLL x₁))) )
                                                           ≡⟨ sym (bindLL∪ κ g (conLL (inr (λ α → bindLL κ f (x α)) ∷ [])) (bindLL κ f (conLL x₁))) ⟩
                                                           bindLL κ g (conLL (inr (λ α → bindLL κ f (x α)) ∷ []) ∪ bindLL κ f (conLL x₁)) ∎

-- If I want to do it via fixpoints instead:

module WithFix where
  LiftList : (A : Set) → (κ : Cl) → Set
  LiftList A κ = fix (\ (X : ▹ κ Set) → List(A ⊎ (▸ κ \ α → (X α))))

  nowLLfix : {A : Set} (κ : Cl) → A → (LiftList A κ)
  nowLLfix κ a = [ (inl a) ]

  stepLLfix : {A : Set} (κ : Cl) → ▹ κ (LiftList A κ) → (LiftList A κ)
  stepLLfix {A} κ a = transport
                     (λ i →
                        fix-eq (λ (X : ▹ κ Type) → List (A ⊎ (▸ κ (λ α → X α)))) (~ i))
                     [ (inr a) ]

--***********************************************************************--
-- Step 4: The ListLift monad as the free delay-algebra and monoid monad --
--***********************************************************************--

-- We already know that (ListLift, stepLL) forms a delay algebra structure
-- and (Listlift, conLL [], _∪_) forms a monoid.
-- What we need to show is that ListLift 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 monoid
-- given a function f : A → B, there is a unique function ListLift A → B extending f that preserves the algebra structures.

record IsDelayalg {A : Set}(κ : Cl)(nextA : ▹ κ A → A) : Set where
  constructor isdelayalg

record IsMonoid {A : Set} (ε : A) (_·_ : A → A → A) : Set where
  constructor ismonoid

  field
    assoc : (x y z : A) → (x · y) · z ≡ x · (y · z)
    leftid : (x : A) → ε · x ≡ x
    rightid : (x : A) → x · ε ≡ x

record DelayMonoidData (A : Set) (κ : Cl) : Set where
  constructor dmdata
  field
    nextA : ▹ κ A → A
    ε : A
    _·_ : A → A → A

record IsDelayMonoid {A : Set}(κ : Cl) (dm : DelayMonoidData A κ) : Set where
  constructor isdelaymonoid

  open DelayMonoidData dm
  field
    isMonoid : IsMonoid (ε) (_·_)
    isDelayalg : IsDelayalg κ (nextA)

  open IsMonoid isMonoid public
  open IsDelayalg isDelayalg public

record IsPreservingDM {A B : Set}(κ : Cl) dmA dmB (g : A → B) : Set where
  constructor ispreservingDM

  open DelayMonoidData dmA renaming (ε to εA)
  open DelayMonoidData dmB renaming (ε to εB; nextA to nextB; _·_ to _*_)
  field
    unit-preserve : g (εA) ≡ εB
    next-preserve : (x : ▹ κ A) → g (nextA x) ≡ nextB (\ α → g (x α))
    union-preserve : (x y : A) → g (x · y) ≡ (g x) * (g y)

record IsExtending {A B : Set}{κ : Cl} (f : A → B) (h : (ListLift A κ) → B) : Set where
  constructor isextending

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

--fold defines the function we are after
fold : {A B : Set}{κ : Cl} → isSet A → isSet B → ∀ dm → IsDelayMonoid {B} κ dm → (A → B) → (ListLift A κ) → B
fold setA setB (dmdata nextB ε _·_) isDMB f (conLL []) = ε
fold setA setB dm@(dmdata nextB ε _·_) isDMB f (conLL (inl x ∷ x₁)) = (f x) · fold setA setB dm isDMB f (conLL x₁)
fold setA setB dm@(dmdata nextB ε _·_) isDMB f (conLL (inr x ∷ x₁)) = (nextB (\ α → fold setA setB dm isDMB f (x α))) · fold setA setB dm isDMB f (conLL x₁)

--fold extends the function f : A → B
--  direct proof:
fold-extends-f : {A B : Set}{κ : Cl} → ∀(setA : isSet A) → ∀(setB : isSet B) → ∀ dm → ∀(isDMB : IsDelayMonoid {B} κ dm) →
                   ∀ (f : A → B) → ∀ (x : A) → fold setA setB dm isDMB f (nowLL κ x) ≡ f x
fold-extends-f setA setB dm isDMB f x = IsDelayMonoid.rightid isDMB (f x)

--  or via the record "IsExtending":
fold-extends : {A B : Set}{κ : Cl} → ∀(setA : isSet A) → ∀(setB : isSet B) → ∀ dm → ∀(isDMB : IsDelayMonoid {B} κ dm) →
                   ∀ (f : A → B) → IsExtending f (fold setA setB dm isDMB f)
IsExtending.extends (fold-extends setA setB dm isDMB f) x = IsDelayMonoid.rightid isDMB (f x)

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

  --fold preseves the DelayMonoid structure
  fold-preserves : IsPreservingDM {ListLift A κ}{B} κ (dmdata (stepLL κ) (conLL []) _∪_) dm (fold setA setB dm isDMB f)
  unit-preserve fold-preserves = refl
  next-preserve fold-preserves x = IsDelayMonoid.rightid isDMB (nextB (λ α → fold setA setB dm isDMB f (x α)))
  union-preserve fold-preserves (conLL xs) (conLL ys) = lemma-union xs ys
    where
      lemma-union : ∀ xs ys → fold setA setB dm isDMB f (conLL xs ∪ conLL ys) ≡
                      (fold setA setB dm isDMB f (conLL xs) ·
                      fold setA setB dm isDMB f (conLL ys))
      lemma-union [] y = sym (IsDelayMonoid.leftid isDMB
                                  (fold setA setB dm isDMB f (conLL y)))
      lemma-union (inl x ∷ x₁) y = (f x · fold setA setB dm isDMB f (conLL (x₁ ++ y)))
                                   ≡⟨ cong (f x ·_) (lemma-union x₁ y) ⟩
                                   ((f x · (fold setA setB dm isDMB f (conLL x₁) ·
                                            fold setA setB dm isDMB f (conLL y))))
                                   ≡⟨ sym (IsDelayMonoid.assoc isDMB (f x)
                                             (fold setA setB dm isDMB f (conLL x₁))
                                             (fold setA setB dm isDMB f (conLL y))) ⟩
                                   ((f x · fold setA setB dm isDMB f (conLL x₁)) ·
                                           fold setA setB dm isDMB f (conLL y)) ∎
      lemma-union (inr x ∷ x₁) y =
                                (nextB (λ α → fold setA setB dm isDMB f (x α)) ·
                                  fold setA setB dm isDMB f (conLL (x₁ ++ y)))
                                ≡⟨ cong (nextB (λ α → fold setA setB dm isDMB f (x α)) ·_)
                                    (lemma-union
                                       x₁ y) ⟩
                                ( (nextB (λ α → fold setA setB dm isDMB f (x α)) ·
                                    (fold setA setB dm isDMB f (conLL x₁) ·
                                     fold setA setB dm isDMB f (conLL y))))
                                ≡⟨ sym (IsDelayMonoid.assoc isDMB
                                    (nextB (λ α → fold setA setB dm isDMB f (x α)))
                                    (fold setA setB dm isDMB f (conLL x₁))
                                    (fold setA setB dm isDMB f (conLL y)))  ⟩
                                ((nextB (λ α → fold setA setB dm isDMB f (x α)) ·
                                  fold setA setB dm isDMB f (conLL x₁)) ·
                                  fold setA setB dm isDMB f (conLL y)) ∎

--and fold 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 : ListLift A κ → B)
                       (setA : isSet A) (setB : isSet B) (dm : _) (isDMB : IsDelayMonoid {B} κ dm)
                       (f : A → B) (isPDM : IsPreservingDM {ListLift A κ}{B} κ (dmdata (stepLL κ) (conLL []) _∪_ ) dm h)
                       (isExt : IsExtending f h) where

  open DelayMonoidData dm renaming (nextA to nextB)

  fold-uniquenessLL : (x : (ListLift A κ)) → h x ≡ (fold setA setB dm isDMB f x)
  fold-uniquenessLL (conLL []) = h (conLL [])
                                 ≡⟨ IsPreservingDM.unit-preserve isPDM ⟩
                                 ε
                                 ≡⟨ refl ⟩
                                 fold setA setB dm isDMB f (conLL []) ∎
  fold-uniquenessLL (conLL (inl x ∷ x₁)) = h (conLL (inl x ∷ x₁))
                                           ≡⟨ refl ⟩
                                           h ((conLL [ inl x ]) ∪ (conLL x₁))
                                           ≡⟨ IsPreservingDM.union-preserve isPDM (conLL [ inl x ]) (conLL x₁) ⟩
                                           ((h (conLL [ inl x ])) ·
                                             (h (conLL x₁)) )
                                           ≡⟨ cong (_· (h (conLL x₁)) ) (IsExtending.extends isExt x)  ⟩
                                           (f x · (h (conLL x₁)))
                                           ≡⟨ cong (f x ·_)(fold-uniquenessLL (conLL x₁)) ⟩
                                           (f x · fold setA setB dm isDMB f (conLL x₁)) ∎
  fold-uniquenessLL (conLL (inr x ∷ x₁)) =  h (conLL (inr x ∷ x₁))
                                            ≡⟨ cong (h ) refl ⟩
                                            h ((conLL [ inr x ]) ∪ (conLL x₁))
                                            ≡⟨ IsPreservingDM.union-preserve isPDM (conLL [ inr x ]) (conLL x₁) ⟩
                                            (h (conLL [ inr x ])) ·
                                              (h (conLL x₁))
                                            ≡⟨ cong (_· h (conLL x₁)) refl ⟩
                                            ((h (stepLL κ x)) ·
                                              (h (conLL x₁)) )
                                            ≡⟨ cong (_· h (conLL x₁)) (IsPreservingDM.next-preserve isPDM x) ⟩
                                            (((nextB (λ α → h (x α))) · (h (conLL x₁))))
                                            ≡⟨ cong (_· h (conLL x₁)) (cong (nextB)
                                               (later-ext (\ α → fold-uniquenessLL (x α)))) ⟩
                                            ((nextB (λ α → fold setA setB dm isDMB f (x α))) · (h (conLL x₁)))
                                            ≡⟨ cong (nextB (λ α → fold setA setB dm isDMB f (x α)) ·_)
                                                 (fold-uniquenessLL (conLL x₁)) ⟩
                                            (nextB (λ α → fold setA setB dm isDMB f (x α)) ·
                                                fold setA setB dm isDMB f (conLL x₁)) ∎

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

--We now define a composite monad of the List and Lift monads, formed via a distributive law.

LcL : (A : Set) → (κ : Cl) → Set
LcL A κ = myLift (List A) κ

-- the unit of this monad is simply the composit of the units for Lift (nowL x) and List ([x])
nowLcL : {A : Set} {κ : Cl} → A → (LcL A κ)
nowLcL x = nowL [ x ]

-- LcL is a monad via a distributive law, distributing List over Lift.
-- Here is the distributive law:
distlawLcL : {A : Set} (κ : Cl) → List (myLift A κ) → (LcL A κ)
distlawLcL κ [] = nowL []
distlawLcL κ (nowL x ∷ xs) = MultL κ (nowL (mapL κ (([ x ]) ++_) (distlawLcL κ xs)))
distlawLcL κ (stepL x ∷ xs) = stepL (\ α → distlawLcL κ ((x α) ∷ xs))

--proof that distlawLcL is indeed a distributive law:
--unit laws:
unitlawLcL1 : {A : Set} (κ : Cl) → ∀(x : myLift A κ) → (distlawLcL κ (List-unit x )) ≡  mapL κ List-unit x
unitlawLcL1 κ (nowL x) = refl
unitlawLcL1 κ (stepL x) = (\ i → stepL (\ α → unitlawLcL1 κ (x α) i ))

unitlawLcL2 : {A : Set} (κ : Cl) → ∀(xs : List A) → (distlawLcL κ (map nowL xs)) ≡  nowL xs
unitlawLcL2 κ [] = refl
unitlawLcL2 κ (x ∷ xs) = mapL κ (λ ys → x ∷ ys) (distlawLcL κ (map nowL xs))
                          ≡⟨ cong (mapL κ (λ ys → x ∷ ys)) (unitlawLcL2 κ xs) ⟩
                          mapL κ (λ ys → x ∷ ys) (nowL xs)
                          ≡⟨ refl ⟩
                          nowL (x ∷ xs) ∎

--multiplication laws:

-- In the proof of the first multiplication law, I need a lemma about list concatenation,
-- namely that putting a singleton list in front of a list of lists, and concatening the result
-- yields the same list as putting the element of the signleton in front of the first list in the list of lists,
-- and then concatenating the result.
-- The lemma is split into two parts, first the general result as described in words here,
-- followed by the specific situation in which I need it in the proofs below.
lemma7a : {A : Set} → ∀(x : A) → ∀(xss : (List (List A))) → List-mult ((x ∷ safe-head [] xss) ∷ tail xss ) ≡ List-mult (([ x ]) ∷ xss)
lemma7a x [] = refl
lemma7a x (xs ∷ xss) = refl

lemma7b : {A : Set} (κ : Cl) → ∀(y : myLift (List (List A)) κ) → ∀(x : A) →
           mapL κ (λ xss → List-mult ((x ∷ safe-head [] xss) ∷ tail xss)) y ≡ mapL κ (λ xss → List-mult (([ x ]) ∷ xss)) y
lemma7b κ (nowL xss) x = cong nowL (lemma7a x xss)
lemma7b κ (stepL xss) x = (\ i → stepL (\ α → lemma7b κ (xss α) x i ))

-- in addition, I need this rather technical lemma that allows me to pull a mapL through the distributive law.
-- without it, I could not finish the proof.
lemma8 :  {A : Set} (κ : Cl) → ∀(x : A) → ∀(xs : myLift (List A) κ) → ∀(xss : List (myLift (List A) κ)) →
                 mapL κ (λ yss → ((x ∷ safe-head [] yss) ∷ tail yss)) (distlawLcL κ (xs ∷ xss)) ≡ distlawLcL κ (mapL κ (λ ys → x ∷ ys) xs ∷ xss)
lemma8 κ x (nowL ys) [] = refl
lemma8 κ x (stepL ys) [] = (\ i → stepL (λ α → lemma8 κ x (ys α) [] i ))
lemma8 κ x (nowL []) (zs ∷ xss) =  mapL κ (λ yss → (x ∷ safe-head [] yss) ∷ tail yss) (mapL κ (λ zss → [] ∷ zss) (distlawLcL κ (zs ∷ xss)))
                                   ≡⟨ mapmapL κ ((λ zss → [] ∷ zss)) ((λ yss → (x ∷ safe-head [] yss) ∷ tail yss)) (distlawLcL κ (zs ∷ xss)) ⟩
                                   mapL κ (λ yss → (x ∷ safe-head [] ([] ∷ yss)) ∷ tail ([] ∷ yss)) (distlawLcL κ (zs ∷ xss))
                                   ≡⟨ refl ⟩
                                   mapL κ (λ yss → (x ∷ []) ∷ yss) (distlawLcL κ (zs ∷ xss)) ∎
lemma8 κ x (nowL (y ∷ ys)) (zs ∷ xss) = mapL κ (λ yss → (x ∷ safe-head [] yss) ∷ tail yss) (mapL κ (λ zss → (y ∷ ys) ∷ zss) (distlawLcL κ (zs ∷ xss)))
                                         ≡⟨ mapmapL κ ((λ zss → (y ∷ ys) ∷ zss)) ((λ yss → (x ∷ safe-head [] yss) ∷ tail yss)) (distlawLcL κ (zs ∷ xss)) ⟩
                                         mapL κ (λ yss → (x ∷ safe-head []((y ∷ ys) ∷ yss)) ∷ tail((y ∷ ys) ∷ yss)) (distlawLcL κ (zs ∷ xss))
                                         ≡⟨ refl ⟩
                                         mapL κ (λ yss → (x ∷ y ∷ ys) ∷ yss) (distlawLcL κ (zs ∷ xss)) ∎
lemma8 κ x (stepL ys) (zs ∷ xss) = (\ i → stepL (λ α → lemma8 κ x (ys α) (zs ∷ xss) i ))

--now we are ready to prove the multiplication laws:
multlawLcL1 : {A : Set} (κ : Cl) → ∀(xss : List (List (myLift A κ))) → distlawLcL κ (List-mult xss) ≡
                                     mapL κ List-mult (distlawLcL κ (map (distlawLcL κ) xss))
multlawLcL1 κ [] = refl
multlawLcL1 κ ([] ∷ xss) = distlawLcL κ (List-mult xss)
                            ≡⟨ multlawLcL1 κ xss ⟩
                            mapL κ List-mult (distlawLcL κ (map (distlawLcL κ) xss))
                            ≡⟨ refl ⟩
                            mapL κ (λ ys → List-mult ([] ∷ ys)) (distlawLcL κ (map (distlawLcL κ) xss))
                            ≡⟨ sym (mapmapL κ (\ ys → [] ∷ ys) List-mult ((distlawLcL κ (map (distlawLcL κ) xss)))) ⟩
                            mapL κ List-mult (mapL κ (λ ys → [] ∷ ys) (distlawLcL κ (map (distlawLcL κ) xss))) ∎
multlawLcL1 κ ((nowL x ∷ []) ∷ xss) =  mapL κ (λ ys → x ∷ ys) (distlawLcL κ (List-mult xss))
                                         ≡⟨ cong (mapL κ (λ ys → x ∷ ys)) (multlawLcL1 κ xss) ⟩
                                         mapL κ (λ ys → x ∷ ys) (mapL κ List-mult (distlawLcL κ (map (distlawLcL κ) xss)))
                                         ≡⟨ mapmapL κ List-mult (λ ys → x ∷ ys) (distlawLcL κ (map (distlawLcL κ) xss)) ⟩
                                         mapL κ (λ ys → x ∷ List-mult ys) (distlawLcL κ (map (distlawLcL κ) xss))
                                         ≡⟨ refl ⟩
                                         mapL κ (λ ys → List-mult (([ x ]) ∷ ys)) (distlawLcL κ (map (distlawLcL κ) xss))
                                         ≡⟨ sym( mapmapL κ (λ ys → ([ x ]) ∷ ys) List-mult (distlawLcL κ (map (distlawLcL κ) xss))) ⟩
                                         mapL κ List-mult (mapL κ (λ ys → ([ x ]) ∷ ys) (distlawLcL κ (map (distlawLcL κ) xss))) ∎
multlawLcL1 κ ((nowL x ∷ y ∷ xs) ∷ xss) = mapL κ (λ ys → x ∷ ys) (distlawLcL κ (List-mult ((y ∷ xs) ∷ xss)))
                                            ≡⟨ cong (mapL κ (λ ys → x ∷ ys)) (multlawLcL1 κ ((y ∷ xs) ∷ xss)) ⟩
                                            mapL κ (λ ys → x ∷ ys) (mapL κ List-mult (distlawLcL κ (map (distlawLcL κ) ((y ∷ xs) ∷ xss))))
                                            ≡⟨ mapmapL κ List-mult (λ ys → x ∷ ys) (distlawLcL κ (map (distlawLcL κ) ((y ∷ xs) ∷ xss))) ⟩
                                            mapL κ (λ yss → x ∷ (List-mult yss)) (distlawLcL κ (map (distlawLcL κ) ((y ∷ xs) ∷ xss)))
                                            ≡⟨ refl ⟩
                                            mapL κ (λ yss → x ∷ List-mult yss) (distlawLcL κ (distlawLcL κ (y ∷ xs) ∷ map (distlawLcL κ) xss))
                                            ≡⟨ refl ⟩
                                            mapL κ (λ yss → List-mult (([ x ]) ∷ yss)) (distlawLcL κ (distlawLcL κ (y ∷ xs) ∷ map (distlawLcL κ) xss))
                                            ≡⟨ sym (lemma7b κ ((distlawLcL κ (distlawLcL κ (y ∷ xs) ∷ map (distlawLcL κ) xss))) x) ⟩
                                            mapL κ (λ yss → List-mult ((x ∷ safe-head [] yss) ∷ tail yss)) (distlawLcL κ (distlawLcL κ (y ∷ xs) ∷ map (distlawLcL κ) xss))
                                            ≡⟨ sym (mapmapL κ ((λ yss → ((x ∷ safe-head [] yss) ∷ tail yss))) List-mult
                                                ((distlawLcL κ (distlawLcL κ (y ∷ xs) ∷ map (distlawLcL κ) xss)))) ⟩
                                            mapL κ List-mult (mapL κ (λ yss → ((x ∷ safe-head [] yss) ∷ tail yss)) (distlawLcL κ (distlawLcL κ (y ∷ xs) ∷ map (distlawLcL κ) xss)))
                                            ≡⟨ cong (mapL κ List-mult) (lemma8 κ x ((distlawLcL κ (y ∷ xs))) ((map (distlawLcL κ) xss))) ⟩
                                            mapL κ List-mult (distlawLcL κ (mapL κ (λ ys → x ∷ ys) (distlawLcL κ (y ∷ xs)) ∷ (map (distlawLcL κ) xss))) ∎
multlawLcL1 κ ((stepL x ∷ xs) ∷ xss) = (\ i → stepL (\ α → multlawLcL1 κ ((x α ∷ xs) ∷ xss) i ))

lemma9a : {A : Set} (κ : Cl) → ∀(x : ▹ κ (myLift A κ)) → ∀(y : ▹ κ (myLift (List (myLift A κ)) κ)) →
                   MultL κ (stepL (λ α → stepL (λ β → mapL κ (λ ys → distlawLcL κ (x α ∷ ys)) (y β)))) ≡
                   MultL κ (stepL (λ β → stepL (λ α → mapL κ (λ ys → distlawLcL κ (x α ∷ ys)) (y β))))
lemma9a κ x y = cong (MultL κ) (cong stepL (later-ext λ α → cong stepL (later-ext λ β →
                     cong₂ (mapL κ) (funExt (λ ys → cong (distlawLcL _) (cong₂ _∷_ (tick-irr x α β) refl)))
                                    (sym (tick-irr y α β)))))

lemma9 : {A : Set} (κ : Cl) → ∀(x : ▹ κ (myLift A κ)) → ∀(y : myLift (List (myLift A κ)) κ) →
            MultL κ (stepL (λ α → (mapL κ (λ ys → distlawLcL κ (x α ∷ ys)) y))) ≡ MultL κ (mapL κ (λ ys → stepL (λ α → distlawLcL κ (x α ∷ ys))) y)
lemma9 κ x (nowL y) = refl
lemma9 κ x (stepL y) = stepL (λ α → stepL (λ β → MultL κ (mapL κ (λ ys → distlawLcL κ (x α ∷ ys)) (y β))))
                        ≡⟨ lemma9a κ x y ⟩
                        stepL (λ β → stepL (λ α → MultL κ (mapL κ (λ ys → distlawLcL κ (x α ∷ ys)) (y β))))
                        ≡⟨ ( (\ i → stepL (\ β → lemma9 κ x (y β) i ))) ⟩
                        stepL (λ β → MultL κ (mapL κ (λ ys → stepL (λ α → distlawLcL κ (x α ∷ ys))) (y β))) ∎

multlawLcL2 : {A : Set} (κ : Cl) → ∀(xs : List (myLift (myLift A κ) κ)) → distlawLcL κ (map (MultL κ) xs) ≡
                                     MultL κ (mapL κ (distlawLcL κ) (distlawLcL κ xs))
multlawLcL2 κ [] = refl
multlawLcL2 κ (nowL (nowL x) ∷ xs) = distlawLcL κ ((nowL x) ∷ map (MultL κ) xs)
                                        ≡⟨ refl ⟩
                                        mapL κ (λ ys → x ∷ ys) (distlawLcL κ (map (MultL κ) xs))
                                        ≡⟨ cong (mapL κ (λ ys → x ∷ ys)) (multlawLcL2 κ xs) ⟩
                                        mapL κ (λ ys → x ∷ ys) (MultL κ (mapL κ (distlawLcL κ) (distlawLcL κ xs)))
                                        ≡⟨ MultMap κ (mapL κ (distlawLcL κ) (distlawLcL κ xs)) (λ ys → x ∷ ys)  ⟩
                                        MultL κ  (mapL κ (mapL κ (λ ys → x ∷ ys)) (mapL κ (distlawLcL κ) (distlawLcL κ xs)) )
                                        ≡⟨ cong (MultL κ) (mapmapL κ ((distlawLcL κ)) (mapL κ (λ ys → x ∷ ys)) ((distlawLcL κ xs))) ⟩
                                        MultL κ (mapL κ (λ ys → mapL κ (λ zs → x ∷ zs) (distlawLcL κ ys)) (distlawLcL κ xs))
                                        ≡⟨ refl ⟩
                                        MultL κ (mapL κ (λ ys → (distlawLcL κ) ((nowL x) ∷ ys)) (distlawLcL κ xs))
                                        ≡⟨ cong (MultL κ) (sym (mapmapL κ ((λ ys → (nowL x) ∷ ys)) ((distlawLcL κ)) ((distlawLcL κ xs)))) ⟩
                                        MultL κ (mapL κ (distlawLcL κ) (mapL κ (λ ys → (nowL x) ∷ ys) (distlawLcL κ xs))) ∎
multlawLcL2 κ (nowL (stepL x) ∷ xs) = distlawLcL κ ((stepL x) ∷ map (MultL κ) xs)
                                        ≡⟨ refl ⟩
                                        stepL (λ α → distlawLcL κ (x α ∷ map (MultL κ) xs))
                                        ≡⟨ refl ⟩
                                        stepL (λ α → distlawLcL κ (map (MultL κ) ((nowL (x α)) ∷ xs)))
                                        ≡⟨ (\ i → stepL (\ α → multlawLcL2 κ (((nowL (x α)) ∷ xs)) i )) ⟩
                                        stepL (λ α → MultL κ (mapL κ (distlawLcL κ) (distlawLcL κ ((nowL (x α) ∷ xs)))) )
                                        ≡⟨ refl ⟩
                                        MultL κ (stepL (λ α → (mapL κ (distlawLcL κ) (distlawLcL κ ((nowL (x α) ∷ xs))))))
                                        ≡⟨ refl ⟩
                                        MultL κ (stepL (λ α → (mapL κ (distlawLcL κ) (mapL κ (λ ys → x α ∷ ys) (distlawLcL κ xs)))))
                                        ≡⟨ cong (MultL κ) ((λ i → stepL (\ α → (mapmapL κ ((λ ys → x α ∷ ys)) ((distlawLcL κ)) ((distlawLcL κ xs))) i ))) ⟩
                                        MultL κ (stepL (λ α → (mapL κ (λ ys → distlawLcL κ (x α ∷ ys)) (distlawLcL κ xs))))
                                        ≡⟨ lemma9 κ x (distlawLcL κ xs) ⟩
                                        MultL κ (mapL κ (λ ys → stepL (λ α → distlawLcL κ (x α ∷ ys))) (distlawLcL κ xs))
                                        ≡⟨ refl ⟩
                                        MultL κ (mapL κ (λ ys → (distlawLcL κ) ((stepL x) ∷ ys)) (distlawLcL κ xs))
                                        ≡⟨ cong (MultL κ) (sym (mapmapL κ ((λ ys → (stepL x) ∷ ys)) ((distlawLcL κ)) ((distlawLcL κ xs)))) ⟩
                                        MultL κ (mapL κ (distlawLcL κ) (mapL κ (λ ys → (stepL x) ∷ ys) (distlawLcL κ xs))) ∎
multlawLcL2 κ (stepL x ∷ xs) = (\ i → stepL (\ α → multlawLcL2 κ ((x α ∷ xs)) i ))

-- Bonusmaterial:

-- we define a union on LcL.
_l∪l_ : {A : Set} {κ : Cl} → (LcL A κ) → (LcL A κ) → (LcL A κ)
nowL x l∪l nowL y = nowL (x ++ y)
nowL x l∪l stepL y = stepL (\ α → (nowL x l∪l (y α)))
stepL x l∪l y = stepL (\ α → ((x α) l∪l y))

--nowL [] is a unit for l∪l
left-unitl∪l : {A : Set} {κ : Cl} → ∀(x : LcL A κ) → (nowL []) l∪l x ≡ x
left-unitl∪l (nowL x) = refl
left-unitl∪l (stepL x) = stepL (λ α → nowL [] l∪l x α)
                    ≡⟨ ((\ i → stepL (\ α → left-unitl∪l (x α) i ))) ⟩
                    stepL (λ α → x α)
                    ≡⟨ refl ⟩
                    stepL x ∎

right-unitl∪l : {A : Set} {κ : Cl} → ∀(x : LcL A κ) → x l∪l (nowL []) ≡ x
right-unitl∪l (nowL x) = cong nowL (++-unit-r x)
right-unitl∪l (stepL x) = stepL (λ α →  x α l∪l nowL [])
                    ≡⟨ ((\ i → stepL (\ α → right-unitl∪l (x α) i ))) ⟩
                    stepL (λ α → x α)
                    ≡⟨ refl ⟩
                    stepL x ∎

--mapL κ f distributes over l∪l if f distributes over ++
dist-mapL-l∪l : {A B : Set} (κ : Cl) → ∀(f : (List A) → (List B)) → ∀(fcom : ∀(xs : List A) → ∀(ys : List A) → f (xs ++ ys) ≡ f xs ++ f ys) →
                                ∀(x : (LcL A κ)) → ∀(y : LcL A κ) →  mapL κ f (x l∪l y) ≡ (mapL κ f x) l∪l (mapL κ f y)
dist-mapL-l∪l κ f fcom (nowL x) (nowL y) = cong nowL (fcom x y)
dist-mapL-l∪l κ f fcom (nowL x) (stepL y) = (\ i → stepL (\ α → dist-mapL-l∪l κ f fcom (nowL x) (y α) i ))
dist-mapL-l∪l κ f fcom (stepL x) y  = \ i → stepL (\ α → dist-mapL-l∪l κ f fcom (x α) y i )


module Extensions.Nat where

open import Prelude
open import Data.Nat.Base
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties

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

<-+ : ∀ {m n m' n'} → m ≤ m' → n ≤ n' → m + n ≤ m' + n'
<-+ {zero} {zero} z≤n z≤n = z≤n
<-+ {suc m} (s≤s m<m') x = s≤s (<-+ m<m' x)
<-+ {zero} {suc n} {zero} z≤n (s≤s n<n') = s≤s n<n'
<-+ {zero} {suc n} {suc m'} z≤n (s≤s n<n') = s≤s (<-+ {m' = m'} z≤n (≤-step n<n'))

<-unique : ∀ {i u} (p q : i < u) → p ≡ q
<-unique (s≤s z≤n) (s≤s z≤n) = refl
<-unique (s≤s (s≤s p)) (s≤s (s≤s q)) = sym (cong s≤s (<-unique (s≤s q) (s≤s p)))


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

open import Level
open import Categories.Category.Core using (Category)
open import Categories.Category
open import Categories.Monad

module Categories.Adjoint.Construction.Adjunctions {o ℓ e} {C : Category o ℓ e} (M : Monad C)  where

open Category C

open import Categories.Adjoint
open import Categories.Functor
open import Categories.Morphism
open import Categories.Functor.Properties
open import Categories.NaturalTransformation.Core
open import Categories.NaturalTransformation.NaturalIsomorphism -- using (_≃_; unitorʳ; unitorˡ)
open import Categories.Morphism.Reasoning as MR
open import Categories.Tactic.Category

-- three things:
-- 1. the category of adjunctions splitting a given Monad
-- 2. the proof that EM(M) is the terminal object here
-- 3. the proof that KL(M) is the initial object here

record SplitObj : Set (suc o ⊔ suc ℓ ⊔ suc e) where
  field
    D : Category o ℓ e
    F : Functor C D
    G : Functor D C
    adj : F ⊣ G
    eqM : G ∘F F ≃ Monad.F M

record Split⇒ (X Y : SplitObj) : Set (suc o ⊔ suc ℓ ⊔ suc e) where
  constructor Splitc⇒
  private
    module X = SplitObj X
    module Y = SplitObj Y
  field
    H : Functor X.D Y.D
    HF≃F' : H ∘F X.F ≃ Y.F
    G'H≃G : Y.G ∘F H ≃ X.G

Split : Monad C → Category _ _ _
Split M = record
  { Obj = SplitObj
  ; _⇒_ = Split⇒
  ; _≈_ = λ U V → Split⇒.H U ≃ Split⇒.H V
  ; id = split-id
  ; _∘_ = comp
  ; assoc = λ { {f = f} {g = g} {h = h} → associator (Split⇒.H f) (Split⇒.H g) (Split⇒.H h) }
  ; sym-assoc = λ { {f = f} {g = g} {h = h} → sym-associator (Split⇒.H f) (Split⇒.H g) (Split⇒.H h) }
  ; identityˡ = unitorˡ
  ; identityʳ = unitorʳ
  ; identity² = unitor²
  ; equiv = record { refl = refl ; sym = sym ; trans = trans }
  ; ∘-resp-≈ = _ⓘₕ_
  }
  where
  open NaturalTransformation
  split-id : {A : SplitObj} → Split⇒ A A
  split-id = record
    { H = Categories.Functor.id
    ; HF≃F' = unitorˡ
    ; G'H≃G = unitorʳ
    }
  comp : {A B X : SplitObj} → Split⇒ B X → Split⇒ A B → Split⇒ A X
  comp {A = A} {B = B} {X = X} (Splitc⇒ Hᵤ HF≃F'ᵤ G'H≃Gᵤ) (Splitc⇒ Hᵥ HF≃F'ᵥ G'H≃Gᵥ) = record
    { H = Hᵤ ∘F Hᵥ
    ; HF≃F' = HF≃F'ᵤ ⓘᵥ (Hᵤ ⓘˡ HF≃F'ᵥ) ⓘᵥ associator (SplitObj.F A) Hᵥ Hᵤ
    ; G'H≃G = G'H≃Gᵥ ⓘᵥ (G'H≃Gᵤ ⓘʳ Hᵥ) ⓘᵥ sym-associator Hᵥ Hᵤ (SplitObj.G X)
    }

open import Categories.Object.Terminal (Split M)
open import Categories.Object.Initial (Split M)
open import Categories.Category.Construction.EilenbergMoore
open import Categories.Category.Construction.Kleisli

EM-object : SplitObj
EM-object = record { D = {! EilenbergMoore M !}
                   ; F = {!   !}
                   ; G = {!   !}
                   ; adj = {!   !}
                   ; eqM = {!   !}
                   }

EM-terminal : IsTerminal EM-object
EM-terminal = {!   !}


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

open import Cubical.Core.Everything
open import Cubical.Relation.Binary
open import Cubical.Algebra.Semigroup

module Cubical.Algebra.Semigroup.Construct.Quotient {c ℓ} (S : Semigroup c) {R : Rel (Semigroup.Carrier S) ℓ} (isEq : IsEquivalence R)
                                                              (closed : Congruent₂ R (Semigroup._•_ S)) where

open import Cubical.Foundations.Prelude
open import Cubical.Algebra.Properties
open import Cubical.HITs.SetQuotients

open Semigroup S
open IsEquivalence isEq

import Cubical.Algebra.Magma.Construct.Quotient magma isEq closed as QMagma
open QMagma public hiding (M/R-isMagma; M/R)

•ᴿ-assoc : Associative _•ᴿ_
•ᴿ-assoc = elimProp3 (λ _ _ _ → squash/ _ _) (λ x y z → cong [_] (assoc x y z))

S/R-isSemigroup : IsSemigroup Carrier/R _•ᴿ_
S/R-isSemigroup = record
  { isMagma = QMagma.M/R-isMagma
  ; assoc   = •ᴿ-assoc
  }

S/R : Semigroup (ℓ-max c ℓ)
S/R = record { isSemigroup = S/R-isSemigroup }


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

open import lib.Basics
open import lib.types.Group
open import lib.types.Unit
open import lib.groups.SubgroupProp
open import lib.groups.Homomorphism
open import lib.groups.Isomorphism
open import lib.groups.Lift

module lib.groups.Unit where

Unit-group-structure : GroupStructure Unit
Unit-group-structure = record
  { ident = unit
  ; inv = λ _ → unit
  ; comp = λ _ _ → unit
  ; unit-l = λ _ → idp
  ; assoc = λ _ _ _ → idp
  ; inv-l = λ _ → idp
  }

Unit-group : Group lzero
Unit-group = group _ Unit-is-set Unit-group-structure

0ᴳ = Unit-group

abstract
  Unit-group-is-trivial : is-trivialᴳ Unit-group
  Unit-group-is-trivial = λ _ → idp

  iso-Unit-is-trivial : ∀ {i} {G : Group i} → G ≃ᴳ Unit-group → is-trivialᴳ G
  iso-Unit-is-trivial G-iso-0 = iso-preserves'-trivial G-iso-0 Unit-group-is-trivial

0ᴳ-is-trivial = Unit-group-is-trivial
iso-0ᴳ-is-trivial = iso-Unit-is-trivial

trivial-iso-Unit : ∀ {i} {G : Group i} → is-trivialᴳ G → G ≃ᴳ Unit-group
trivial-iso-Unit {G = G} G-triv = group-hom (λ _ → tt) (λ _ _ → idp) ,
  is-eq _ (λ _ → Group.ident G) (λ _ → idp) (λ _ → ! (G-triv _))

trivial-iso-0ᴳ = trivial-iso-Unit

{- the following should be replaced by [is-trivial] completely -}

abstract
  contr-iso-Unit : ∀ {i} (G : Group i) → is-contr (Group.El G) → G ≃ᴳ Unit-group
  contr-iso-Unit G pA = ≃-to-≃ᴳ (contr-equiv-Unit pA) (λ _ _ → idp)
contr-iso-0ᴳ = contr-iso-Unit

Unit-group-is-abelian : is-abelian 0ᴳ
Unit-group-is-abelian _ _ = idp

0ᴳ-is-abelian = Unit-group-is-abelian

Unit-abgroup : AbGroup₀
Unit-abgroup = Unit-group , Unit-group-is-abelian

0ᴳ-abgroup = Unit-abgroup

abstract
  hom₁-Unit-is-trivial : ∀ {i} (G : AbGroup i) → is-trivialᴳ (hom-group Unit-group G)
  hom₁-Unit-is-trivial G φ = group-hom= $ λ= λ _ → GroupHom.pres-ident φ

hom₁-0ᴳ-is-trivial = hom₁-Unit-is-trivial


------------------------------------------------------------------------------
-- Agda-Prop Library.
-- Theorems of ∧ connective.
------------------------------------------------------------------------------

open import Data.Nat using ( ℕ )

module Data.PropFormula.Theorems.Conjunction ( n : ℕ ) where

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

open import Data.PropFormula.Syntax n
open import Data.PropFormula.Theorems.Classical n

open import Function using ( _$_ ; _∘_  )

-------------------------------------------------------------------------- ∎

-- Theorem.
∧-assoc₁
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ∧ (ψ ∧ γ)
  → Γ ⊢ (φ ∧ ψ) ∧ γ

-- Proof.
∧-assoc₁ Γ⊢φ∧ψ∧γ =
  ∧-intro
    (∧-intro
      (∧-proj₁  Γ⊢φ∧ψ∧γ)
      ((∧-proj₁ ∘ ∧-proj₂) Γ⊢φ∧ψ∧γ))
    ((∧-proj₂ ∘ ∧-proj₂) Γ⊢φ∧ψ∧γ)

-------------------------------------------------------------------------- ∎

-- Theorem.
∧-assoc₂
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ∧ ψ) ∧ γ
  → Γ ⊢ φ ∧ (ψ ∧ γ)

-- Proof.
∧-assoc₂ Γ⊢φ∧ψ∧γ =
  ∧-intro
    (∧-proj₁ (∧-proj₁ Γ⊢φ∧ψ∧γ))
    (∧-intro
      (∧-proj₂ (∧-proj₁ Γ⊢φ∧ψ∧γ))
      (∧-proj₂ Γ⊢φ∧ψ∧γ))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-assoc
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ∧ (ψ ∧ γ)) ⇔ ((φ ∧ ψ) ∧ γ)

-- Proof.
∧-assoc {Γ} {φ}{ψ}{γ} =
  ⇔-intro
    (∧-assoc₁ (assume (φ ∧ (ψ ∧ γ))))
    (∧-assoc₂ (assume (φ ∧ ψ ∧ γ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-comm
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ φ ∧ ψ
  → Γ ⊢ ψ ∧ φ

-- Proof.
∧-comm Γ⊢φ∧ψ =
  ∧-intro
    (∧-proj₂ Γ⊢φ∧ψ)
    (∧-proj₁ Γ⊢φ∧ψ)
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-dist₁
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ∧ (ψ ∨ γ)
  → Γ ⊢ (φ ∧ ψ) ∨ (φ ∧ γ)

-- Proof.
∧-dist₁ {φ = φ}{ψ}{γ} Γ⊢φ∧ψ∨γ =
  ⊃-elim
    (⊃-intro $
      ∨-elim
        (∨-intro₁ (φ ∧ γ)
          (∧-intro
            (weaken ψ (∧-proj₁ Γ⊢φ∧ψ∨γ))
            (assume  ψ)))
        (∨-intro₂ (φ ∧ ψ)
          (∧-intro
            (weaken γ  (∧-proj₁ Γ⊢φ∧ψ∨γ))
            (assume  γ))))
    (∧-proj₂ Γ⊢φ∧ψ∨γ)
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-dist₂
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ (φ ∧ ψ) ∨ (φ ∧ γ)
  → Γ ⊢ φ ∧ (ψ ∨ γ)

-- Proof.
∧-dist₂ {φ = φ}{ψ}{γ} =
  ⊃-elim
    (⊃-intro
      (∨-elim
        (∧-intro
          (∧-proj₁
            (assume (φ ∧ ψ)))
          (∨-intro₁ γ
            (∧-proj₂
              (assume (φ ∧ ψ)))))
        (∧-intro
          (∧-proj₁
            (assume (φ ∧ γ)))
          (∨-intro₂ ψ
            (∧-proj₂
              (assume (φ ∧ γ)))))))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-dist
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ∧ (ψ ∨ γ) ⇔ (φ ∧ ψ) ∨ (φ ∧ γ)

-- Proof.
∧-dist {φ = φ}{ψ}{γ} =
  ⇔-intro
    (∧-dist₁ (assume (φ ∧ (ψ ∨ γ))))
    (∧-dist₂ (assume (φ ∧ ψ ∨ (φ ∧ γ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-dmorgan₁
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ¬ (φ ∧ ψ)
  → Γ ⊢ ¬ φ ∨ ¬ ψ
¬∧-to-¬∨¬ = ∧-dmorgan₁

-- Proof.
∧-dmorgan₁ {Γ}{φ}{ψ} =
  ⊃-elim $
    ⊃-intro $
      RAA $
        ¬-elim
          (weaken (¬ (¬ φ ∨ ¬ ψ)) $
            assume $ ¬ (φ ∧ ψ))
          (∧-intro
            (RAA
              (¬-elim
                (weaken (¬ φ) $
                  assume {Γ = Γ , ¬ (φ ∧ ψ)} $ ¬ (¬ φ ∨ ¬ ψ))
                (∨-intro₁ (¬ ψ)
                  (assume {Γ = Γ , ¬ (φ ∧ ψ) , ¬ (¬ φ ∨ ¬ ψ)} $ ¬ φ))))
            (RAA
              (¬-elim {Γ = Γ , ¬ (φ ∧ ψ) , ¬ (¬ φ ∨ ¬ ψ) , ¬ ψ}
                (weaken (¬ ψ) $
                  assume {Γ = Γ , ¬ (φ ∧ ψ)} $ ¬ (¬ φ ∨ ¬ ψ))
                (∨-intro₂ (¬ φ)
                  (assume {Γ = Γ , ¬ (φ ∧ ψ) , ¬ (¬ φ ∨ ¬ ψ)} $ ¬ ψ )))))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-dmorgan₂
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ¬ φ ∨ ¬ ψ
  → Γ ⊢ ¬ (φ ∧ ψ)
¬∨¬-to-¬∧ = ∧-dmorgan₂

-- Proof.
∧-dmorgan₂ {Γ}{φ}{ψ} =
  ⊃-elim $
    ⊃-intro $
      ∨-elim {Γ = Γ}
        (¬-intro $
          ¬-elim
            (weaken (φ ∧ ψ) $
              assume (¬ φ))
            (∧-proj₁ $
              assume {Γ = Γ , ¬ φ} (φ ∧ ψ)))
        (¬-intro $
          ¬-elim
            (weaken (φ ∧ ψ) $ assume (¬ ψ))
          (∧-proj₂ $
            assume {Γ = Γ , ¬ ψ} (φ ∧ ψ)))
-------------------------------------------------------------------------- ∎

-- Theorem.
∧-dmorgan
  : ∀ {Γ} {φ ψ}
  → Γ ⊢ ¬ φ ∨ ¬ ψ ⇔ ¬ (φ ∧ ψ)
¬∨¬-⇔-¬∧ = ∧-dmorgan

-- Proof.
∧-dmorgan {Γ}{φ}{ψ} =
  ⇔-intro
    (∧-dmorgan₂
      (assume (¬ φ ∨ ¬ ψ)))
    (∧-dmorgan₁
      (assume (¬ (φ ∧ ψ))))
-------------------------------------------------------------------------- ∎

-- Theorem.
subst⊢∧₁
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ φ ⊃ γ
  → Γ ⊢ φ ∧ ψ
  → Γ ⊢ γ ∧ ψ

-- Proof.
subst⊢∧₁ Γ⊢φ⊃ψ Γ⊢φ∧ψ =
  ∧-intro
    (⊃-elim (∧-proj₁ (∧-intro Γ⊢φ⊃ψ Γ⊢φ∧ψ)) (∧-proj₁ Γ⊢φ∧ψ))
    (∧-proj₂ Γ⊢φ∧ψ)
-------------------------------------------------------------------------- ∎

-- Theorem.
subst⊢∧₂
  : ∀ {Γ} {φ ψ γ}
  → Γ ⊢ ψ ⊃ γ
  → Γ ⊢ φ ∧ ψ
  → Γ ⊢ φ ∧ γ

-- Proof.
subst⊢∧₂ {Γ}{φ}{ψ} Γ⊢φ⊃ψ Γ⊢φ∧ψ =
  ∧-intro
    (∧-proj₁ Γ⊢φ∧ψ)
    (⊃-elim Γ⊢φ⊃ψ (∧-proj₂ Γ⊢φ∧ψ))
-------------------------------------------------------------------------- ∎

-- Theorem.
¬∧-to-⊥
  : ∀ {Γ} {φ}
  → Γ ⊢ ¬ φ ∧ φ
  → Γ ⊢ ⊥

-- Proof.
¬∧-to-⊥ {Γ}{φ} Γ⊢φ = ¬-elim (∧-proj₁ Γ⊢φ) (∧-proj₂ Γ⊢φ)
-------------------------------------------------------------------------- ∎


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

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import LogicalFormulae
open import Sets.EquivalenceRelations
open import Setoids.Setoids

module Setoids.Intersection.Definition {a b : _} {A : Set a} (S : Setoid {a} {b} A) where

open Setoid S
open Equivalence eq
open import Setoids.Subset S

intersectionPredicate : {c d : _} {pred1 : A → Set c} {pred2 : A → Set d} (s1 : subset pred1) (s2 : subset pred2) → A → Set (c ⊔ d)
intersectionPredicate {pred1 = pred1} {pred2} s1 s2 a = pred1 a && pred2 a

intersection : {c d : _} {pred1 : A → Set c} {pred2 : A → Set d} (s1 : subset pred1) (s2 : subset pred2) → subset (intersectionPredicate s1 s2)
intersection s1 s2 {x1} {x2} x1=x2 (inS1 ,, inS2) = s1 x1=x2 inS1 ,, s2 x1=x2 inS2


{-# OPTIONS --safe --experimental-lossy-unification #-}
module Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly-Quotient where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Nat
open import Cubical.Data.Vec
open import Cubical.Data.Vec.OperationsNat
open import Cubical.Data.FinData

open import Cubical.Relation.Nullary

open import Cubical.Algebra.DirectSum.DirectSumHIT.Base
open import Cubical.Algebra.Ring
open import Cubical.Algebra.CommRing
open import Cubical.Algebra.CommRing.FGIdeal
open import Cubical.Algebra.CommRing.QuotientRing
open import Cubical.Algebra.CommRing.Instances.Int renaming (ℤCommRing to ℤCR)

open import Cubical.Algebra.CommRing.Instances.Polynomials.MultivariatePoly
  renaming (PolyCommRing to A[X1,···,Xn] ; Poly to A[x1,···,xn])

private variable
  ℓ : Level

-----------------------------------------------------------------------------
-- General Nth polynome / quotient
-- Better to declare an alias

PolyCommRing-Quotient : (A : CommRing ℓ) → {n m : ℕ} → FinVec (fst (A[X1,···,Xn] A n)) m → CommRing ℓ
PolyCommRing-Quotient A {n} {m} v = A[X1,···,Xn] A n / genIdeal (A[X1,···,Xn] A n) v

-----------------------------------------------------------------------------
-- Notation in the general case and some real cases 1, 2, 3

module _
  (Ar@(A , Astr) : CommRing ℓ)
  (n : ℕ)
  where

  <Xkʲ> : (k j : ℕ) →  FinVec (A[x1,···,xn] Ar n) 1
  <Xkʲ> k j zero = base (genδℕ-Vec n k j 0) (CommRingStr.1r Astr)

  A[X1,···,Xn]/<Xkʲ> : (k j : ℕ) → CommRing ℓ
  A[X1,···,Xn]/<Xkʲ> k j = (A[X1,···,Xn] Ar n) / (genIdeal ((A[X1,···,Xn] Ar n)) (<Xkʲ> k j))

  A[x1,···,xn]/<xkʲ> : (k j : ℕ) → Type ℓ
  A[x1,···,xn]/<xkʲ> k j = fst (A[X1,···,Xn]/<Xkʲ> k j)

  <X1,···,Xn> : FinVec (A[x1,···,xn] Ar n) n
  <X1,···,Xn> = λ k → base (δℕ-Vec n (toℕ k)) (CommRingStr.1r Astr)

  A[X1,···,Xn]/<X1,···,Xn> : CommRing ℓ
  A[X1,···,Xn]/<X1,···,Xn> = (A[X1,···,Xn] Ar n) / (genIdeal ((A[X1,···,Xn] Ar n)) <X1,···,Xn>)

  A[x1,···,xn]/<x1,···,xn> : Type ℓ
  A[x1,···,xn]/<x1,···,xn> = fst A[X1,···,Xn]/<X1,···,Xn>


{-# OPTIONS --cubical --safe #-}
module Cubical.Data.Prod.Properties where

open import Cubical.Core.Everything

open import Cubical.Data.Prod.Base
open import Cubical.Data.Sigma

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

private
  variable
    ℓ ℓ' : Level
    A B  : Type ℓ

-- Swapping is an equivalence

swap : A × B → B × A
swap (x , y) = (y , x)

swap-invol : (xy : A × B) → swap (swap xy) ≡ xy
swap-invol (_ , _) = refl

isEquivSwap : (A : Type ℓ) (B : Type ℓ') → isEquiv (λ (xy : A × B) → swap xy)
isEquivSwap A B = isoToIsEquiv (iso swap swap swap-invol swap-invol)

swapEquiv : (A : Type ℓ) (B : Type ℓ') → A × B ≃ B × A
swapEquiv A B = (swap , isEquivSwap A B)

swapEq : (A : Type ℓ) (B : Type ℓ') → A × B ≡ B × A
swapEq A B = ua (swapEquiv A B)

private
  open import Cubical.Data.Nat

  -- As × is defined as a datatype this computes as expected
  -- (i.e. "C-c C-n test1" reduces to (2 , 1)). If × is implemented
  -- using Sigma this would be "transp (λ i → swapEq ℕ ℕ i) i0 (1 , 2)"
  test : ℕ × ℕ
  test = transp (λ i → swapEq ℕ ℕ i) i0 (1 , 2)

  testrefl : test ≡ (2 , 1)
  testrefl = refl

-- equivalence between the sigma-based definition and the inductive one
A×B≡A×ΣB : A × B ≡ A ×Σ B
A×B≡A×ΣB = isoToPath (iso (λ { (a , b) → (a , b)})
                          (λ { (a , b) → (a , b)})
                          (λ _ → refl)
                          (λ { (a , b) → refl }))

-- truncation for products
hLevelProd : (n : ℕ) → isOfHLevel n A → isOfHLevel n B → isOfHLevel n (A × B)
hLevelProd {A = A} {B = B} n h1 h2 =
  let h : isOfHLevel n (A ×Σ B)
      h = isOfHLevelΣ n h1 (λ _ → h2)
  in transport (λ i → isOfHLevel n (A×B≡A×ΣB {A = A} {B = B} (~ i))) h


------------------------------------------------------------------------------
-- From inductive PA to standard axiomatic PA
------------------------------------------------------------------------------

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

-- From the definition of PA using Agda data types and primitive
-- recursive functions for addition and multiplication, we can prove
-- the following axioms (see (Machover 1996, p. 263) and (Hájek and
-- Pudlák 1998, p. 28)):

-- PA₁. 0 ≠ n'
-- PA₂. m' = n' → m = n
-- PA₃. 0 + n = n
-- PA₄. m' + n = (m + n)'
-- PA₅. 0 * n = 0
-- PA₆. m' * n = n + (m * n)
-- Axiom of induction:
-- φ(0) → (∀n.φ(n) → φ(succ n)) → ∀n.φ(n), for any formulae φ

module PA.Inductive2Standard where

open import PA.Inductive.Base

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

PA₁ : ∀ {n} → zero ≢ succ n
PA₁ ()

PA₂ : ∀ {m n} → succ m ≡ succ n → m ≡ n
PA₂ refl = refl

PA₃ : ∀ n → zero + n ≡ n
PA₃ n = refl

PA₄ : ∀ m n → succ m + n ≡ succ (m + n)
PA₄ m n = refl

PA₅ : ∀ n → zero * n ≡ zero
PA₅ n = refl

PA₆ : ∀ m n → succ m * n ≡ n + m * n
PA₆ m n = refl

------------------------------------------------------------------------------
-- References
--
-- Machover, Moshé (1996). Set theory, Logic and their
-- Limitations. Cambridge University Press.

-- Hájek, Petr and Pudlák, Pavel (1998). Metamathematics of
-- First-Order Arithmetic. 2nd printing. Springer.


-- Andreas, 2016-02-09, issue and test case by Nisse

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

open import Common.Level

postulate
  _≡_  : ∀ {a} {A : Set a} → A → A → Set a
  refl : ∀ {a} {A : Set a} (x : A) → x ≡ x

record R a p : Set (lsuc (a ⊔ p)) where
  field
    elim : {A : Set a} (P : {x y : A} → x ≡ y → Set p) →
           (∀ x → P (refl x)) →
           ∀ {x y} (x≡y : x ≡ y) → P x≡y

module _ (eq : ∀ {a p} → R a p) where

  open module M {a p} = R (eq {a} {p})

  postulate

    elim-refl   : ∀ {a p} {A : Set a} (P : {x y : A} → x ≡ y → Set p)
                  (r : ∀ x → P (refl x)) {x} →
                  elim P r (refl x) ≡ r x
    cong        : ∀ {a b} {A : Set a} {B : Set b}
                  (f : A → B) {x y : A} → x ≡ y → f x ≡ f y
    subst       : ∀ {a p} {A : Set a} (P : A → Set p) {x y : A} →
                  x ≡ y → P x → P y
    subst-refl  : ∀ {a p} {A : Set a} (P : A → Set p) {x} (p : P x) →
                  subst P (refl x) p ≡ p
    trans       : ∀ {a} {A : Set a} {x y z : A} → x ≡ y → y ≡ z → x ≡ z
    cong₂       : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
                  (f : A → B → C) {x y : A} {u v : B} →
                  x ≡ y → u ≡ v → f y v ≡ f x u
    trans-reflʳ : ∀ {a} {A : Set a} {x y : A} (x≡y : x ≡ y) →
                  trans x≡y (refl y) ≡ x≡y
    trans-reflˡ : ∀ {a} {A : Set a} {x y : A} (x≡y : x ≡ y) →
                  trans (refl x) x≡y ≡ x≡y

  [subst≡]≡[trans≡trans] :
    ∀ {a} {A : Set a} {x y : A} {p : x ≡ y} {q : x ≡ x} {r : y ≡ y} →
    (subst (λ z → z ≡ z) p q ≡ r)
      ≡
    (trans q p ≡ trans p r)
  [subst≡]≡[trans≡trans] {p = p} {q} {r} = elim
    (λ {x y} p → {q : x ≡ x} {r : y ≡ y} →
                 (subst (λ z → z ≡ z) p q ≡ r)
                   ≡
                 (trans q p ≡ trans p r))
    (λ x {q r} →
       trans (cong (λ x → x ≡ _) (subst-refl (λ z → z ≡ z) _))
             (cong₂ _≡_ (trans-reflʳ _) (trans-reflˡ _)))
    p

  foo :
    ∀ {a} {A : Set a} {x : A} {q : x ≡ x} {r : x ≡ x} →
    [subst≡]≡[trans≡trans] {p = refl x} {q = q} {r = r} ≡
    [subst≡]≡[trans≡trans] {p = refl x} {q = q} {r = r}
  foo = elim-refl ? ?


module Vector where

infixr 10 _∷_

data ℕ : Set where
  zero : ℕ
  suc  : ℕ → ℕ

{-# BUILTIN NATURAL ℕ    #-}
{-# BUILTIN ZERO    zero #-}
{-# BUILTIN SUC     suc  #-}

infixl 6 _+_

_+_ : ℕ → ℕ → ℕ
0 + n = n
suc m + n = suc (m + n)

data Vec (A : Set) : ℕ → Set where
  []  : Vec A 0
  _∷_ : ∀ {n} → A → Vec A n → Vec A (suc n)

_++_ : ∀ {A n m} → Vec A n → Vec A m → Vec A (n + m)
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

infix 4 _≡_

data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

subst : {A : Set} → (P : A → Set) → ∀{x y} → x ≡ y → P x → P y
subst P refl p = p

cong : {A B : Set} (f : A → B) → {x y : A} → x ≡ y → f x ≡ f y
cong f refl = refl

vec : ∀ {A} (k : ℕ) → Set
vec {A} k = Vec A k

plus_zero : {n : ℕ} → n + 0 ≡ n
plus_zero {zero}  = refl
plus_zero {suc n} = cong suc plus_zero

plus_suc : {n : ℕ} → n + (suc 0) ≡ suc n
plus_suc {zero}  = refl
plus_suc {suc n} = cong suc (plus_suc {n})

reverse : ∀ {A n} → Vec A n → Vec A n
reverse []       = []
reverse {A} {suc n} (x ∷ xs) = subst vec (plus_suc {n}) (reverse xs ++ (x ∷ []))


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Algebra.Ideal where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Logic using ([_]; _∈_)

open import Cubical.Algebra.Ring

private
  variable
    ℓ : Level

module _ (R' : Ring {ℓ}) where

  open Ring R' renaming (Carrier to R)

  {- by default, 'ideal' means two-sided ideal -}
  record isIdeal (I : R → hProp ℓ) : Type ℓ where
    field
      +-closed : {x y : R} → x ∈ I → y ∈ I → (x + y) ∈ I
      -closed : {x : R} → x ∈ I → - x ∈ I
      0r-closed : 0r ∈ I
      ·-closedLeft : {x : R} → (r : R) → x ∈ I → r · x ∈ I
      ·-closedRight : {x : R} → (r : R) → x ∈ I → x · r ∈ I

  Ideal : Type _
  Ideal = Σ[ I ∈ (R → hProp ℓ) ] isIdeal I

  record isLeftIdeal (I : R → hProp ℓ) : Type ℓ where
    field
      +-closed : {x y : R} → x ∈ I → y ∈ I → (x + y) ∈ I
      -closed : {x : R} → x ∈ I → - x ∈ I
      0r-closed : 0r ∈ I
      ·-closedLeft : {x : R} → (r : R) → x ∈ I → r · x ∈ I

  record isRightIdeal (I : R → hProp ℓ) : Type ℓ where
    field
      +-closed : {x y : R} → x ∈ I → y ∈ I → (x + y) ∈ I
      -closed : {x : R} → x ∈ I → - x ∈ I
      0r-closed : 0r ∈ I
      ·-closedRight : {x : R} → (r : R) → x ∈ I → x · r ∈ I

  {- Examples of ideals -}
  zeroSubset : (x : R) → hProp ℓ
  zeroSubset x = (x ≡ 0r) , isSetRing R' _ _

  open Theory R'

  isIdealZeroIdeal : isIdeal zeroSubset
  isIdealZeroIdeal = record
                       { +-closed = λ x≡0 y≡0 → _ + _    ≡⟨ cong (λ u → u + _) x≡0 ⟩
                                                0r + _   ≡⟨ +-lid _ ⟩
                                                _        ≡⟨ y≡0 ⟩
                                                0r        ∎
                       ; -closed = λ x≡0 → - _ ≡⟨ cong (λ u → - u) x≡0 ⟩
                                           - 0r ≡⟨ 0-selfinverse ⟩
                                           0r ∎
                       ; 0r-closed = refl
                       ; ·-closedLeft = λ r x≡0 → r · _ ≡⟨ cong (λ u → r · u) x≡0 ⟩
                                                  r · 0r ≡⟨ 0-rightNullifies r  ⟩
                                                  0r ∎
                       ; ·-closedRight = λ r x≡0 → _ · r ≡⟨ cong (λ u → u · r) x≡0 ⟩
                                                   0r · r ≡⟨ 0-leftNullifies r ⟩
                                                   0r ∎
                       }

  zeroIdeal : Ideal
  zeroIdeal = zeroSubset , isIdealZeroIdeal


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

-- A cartesian functor preserves products (of cartesian categories)
module Categories.Functor.Cartesian where

open import Data.Product using (Σ; _,_)
open import Level

open import Categories.Category.Cartesian
open import Categories.Category using (Category; _[_,_])
open import Categories.Category.Product
open import Categories.Functor using (Functor; _∘F_)
open import Categories.NaturalTransformation using (NaturalTransformation)

private
  variable
    o ℓ e o′ ℓ′ e′ : Level

record CartesianF {A : Category o ℓ e} {B : Category o′ ℓ′ e′} (CA : Cartesian A) (CB : Cartesian B)
  (F : Functor A B) : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′) where
  private
    module CA = Cartesian CA
    module CB = Cartesian CB
  field
    -- F is product preserving
    ε : B [ CB.⊤ , Functor.F₀ F CA.⊤ ]
    ⊗-homo : NaturalTransformation (CB.⊗ ∘F (F ⁂ F)) (F ∘F CA.⊗)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Vectors where at least one element satisfies a given property
------------------------------------------------------------------------

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

module Data.Vec.Relation.Unary.Any {a} {A : Set a} where

open import Data.Empty
open import Data.Fin
open import Data.Nat using (zero; suc)
open import Data.Sum using (_⊎_; inj₁; inj₂; [_,_]′)
open import Data.Vec as Vec using (Vec; []; [_]; _∷_)
open import Data.Product as Prod using (∃; _,_)
open import Level using (_⊔_)
open import Relation.Nullary using (¬_; yes; no)
open import Relation.Nullary.Negation using (contradiction)
import Relation.Nullary.Decidable as Dec
open import Relation.Unary

------------------------------------------------------------------------
-- Any P xs means that at least one element in xs satisfies P.

data Any {p} (P : A → Set p) : ∀ {n} → Vec A n → Set (a ⊔ p) where
  here  : ∀ {n x} {xs : Vec A n} (px  : P x)      → Any P (x ∷ xs)
  there : ∀ {n x} {xs : Vec A n} (pxs : Any P xs) → Any P (x ∷ xs)

------------------------------------------------------------------------
-- Operations on Any

module _ {p} {P : A → Set p} {n x} {xs : Vec A n} where

-- If the tail does not satisfy the predicate, then the head will.

  head : ¬ Any P xs → Any P (x ∷ xs) → P x
  head ¬pxs (here px)   = px
  head ¬pxs (there pxs) = contradiction pxs ¬pxs

-- If the head does not satisfy the predicate, then the tail will.
  tail : ¬ P x → Any P (x ∷ xs) → Any P xs
  tail ¬px (here  px)  = ⊥-elim (¬px px)
  tail ¬px (there pxs) = pxs

-- Convert back and forth with sum
  toSum : Any P (x ∷ xs) → P x ⊎ Any P xs
  toSum (here px)   = inj₁ px
  toSum (there pxs) = inj₂ pxs

  fromSum : P x ⊎ Any P xs → Any P (x ∷ xs)
  fromSum = [ here , there ]′

map : ∀ {p q} {P : A → Set p} {Q : A → Set q} →
      P ⊆ Q → ∀ {n} → Any P {n} ⊆ Any Q {n}
map g (here px)   = here (g px)
map g (there pxs) = there (map g pxs)

index : ∀ {p} {P : A → Set p} {n} {xs : Vec A n} → Any P xs → Fin n
index (here  px)  = zero
index (there pxs) = suc (index pxs)

-- If any element satisfies P, then P is satisfied.
satisfied : ∀ {p} {P : A → Set p} {n} {xs : Vec A n} → Any P xs → ∃ P
satisfied (here px)   = _ , px
satisfied (there pxs) = satisfied pxs

------------------------------------------------------------------------
-- Properties of predicates preserved by Any

module _ {p} {P : A → Set p} where

  any : Decidable P → ∀ {n} → Decidable (Any P {n})
  any P? []       = no λ()
  any P? (x ∷ xs) with P? x
  ... | yes px = yes (here px)
  ... | no ¬px = Dec.map′ there (tail ¬px) (any P? xs)

  satisfiable : Satisfiable P → ∀ {n} → Satisfiable (Any P {suc n})
  satisfiable (x , p) {zero}  = x ∷ [] , here p
  satisfiable (x , p) {suc n} = Prod.map (x ∷_) there (satisfiable (x , p))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Morphisms between algebraic structures
------------------------------------------------------------------------

module Algebra.Morphism where

open import Relation.Binary
open import Algebra
open import Algebra.FunctionProperties
import Algebra.Properties.Group as GroupP
open import Function
open import Data.Product
open import Level
import Relation.Binary.EqReasoning as EqR

------------------------------------------------------------------------
-- Basic definitions

module Definitions {f t ℓ}
                   (From : Set f) (To : Set t) (_≈_ : Rel To ℓ) where
  Morphism : Set _
  Morphism = From → To

  Homomorphic₀ : Morphism → From → To → Set _
  Homomorphic₀ ⟦_⟧ ∙ ∘ = ⟦ ∙ ⟧ ≈ ∘

  Homomorphic₁ : Morphism → Fun₁ From → Op₁ To → Set _
  Homomorphic₁ ⟦_⟧ ∙_ ∘_ = ∀ x → ⟦ ∙ x ⟧ ≈ ∘ ⟦ x ⟧

  Homomorphic₂ : Morphism → Fun₂ From → Op₂ To → Set _
  Homomorphic₂ ⟦_⟧ _∙_ _∘_ =
    ∀ x y → ⟦ x ∙ y ⟧ ≈ (⟦ x ⟧ ∘ ⟦ y ⟧)

------------------------------------------------------------------------
-- An example showing how a morphism type can be defined

-- Ring homomorphisms.

record _-Ring⟶_ {r₁ r₂ r₃ r₄}
                (From : Ring r₁ r₂) (To : Ring r₃ r₄) :
                Set (r₁ ⊔ r₂ ⊔ r₃ ⊔ r₄) where
  private
    module F = Ring From
    module T = Ring To
  open Definitions F.Carrier T.Carrier T._≈_

  field
    ⟦_⟧     : Morphism
    ⟦⟧-cong : ⟦_⟧ Preserves F._≈_ ⟶ T._≈_
    +-homo  : Homomorphic₂ ⟦_⟧ F._+_ T._+_
    *-homo  : Homomorphic₂ ⟦_⟧ F._*_ T._*_
    1-homo  : Homomorphic₀ ⟦_⟧ F.1#  T.1#

  open EqR T.setoid

  0-homo : Homomorphic₀ ⟦_⟧ F.0# T.0#
  0-homo =
    GroupP.left-identity-unique T.+-group ⟦ F.0# ⟧ ⟦ F.0# ⟧ (begin
      T._+_ ⟦ F.0# ⟧ ⟦ F.0# ⟧ ≈⟨ T.sym (+-homo F.0# F.0#) ⟩
      ⟦ F._+_ F.0# F.0# ⟧     ≈⟨ ⟦⟧-cong (proj₁ F.+-identity F.0#) ⟩
      ⟦ F.0# ⟧                ∎)

  -‿homo : Homomorphic₁ ⟦_⟧ F.-_ T.-_
  -‿homo x =
    GroupP.left-inverse-unique T.+-group ⟦ F.-_ x ⟧ ⟦ x ⟧ (begin
      T._+_ ⟦ F.-_ x ⟧ ⟦ x ⟧ ≈⟨ T.sym (+-homo (F.-_ x) x) ⟩
      ⟦ F._+_ (F.-_ x) x ⟧   ≈⟨ ⟦⟧-cong (proj₁ F.-‿inverse x) ⟩
      ⟦ F.0# ⟧               ≈⟨ 0-homo ⟩
      T.0#                   ∎)


module ExtInterface.Data.Product where

-- TODO: Write to Agda team about the lack of compilability of Sigma.
-- I assumed that the builtin flag would allow to compile Σ into (,)
-- but it doesn't. That's why this microfile exists

infixr 4 ⟨_,_⟩
infixr 2 _×_

data _×_ (A B : Set) : Set where
  ⟨_,_⟩ : A → B → A × B

{-# COMPILE GHC _×_ = data (,) ((,)) #-} -- Yeah, kinda abstract

proj₁ : ∀ {A B : Set} → A × B → A
proj₁ ⟨ x , y ⟩ = x

proj₂ : ∀ {A B : Set} → A × B → B
proj₂ ⟨ x , y ⟩ = y

map : ∀ {A B C D : Set}
    → (A → C) → (B → D) → A × B → C × D
map f g ⟨ x , y ⟩ = ⟨ f x , g y ⟩

map₁ : ∀ {A B C : Set}
     → (A → C) → A × B → C × B
map₁ f = map f (λ x → x)

map₂ : ∀ {A B D : Set}
     → (B → D) → A × B → A × D
map₂ g = map (λ x → x) g


module Membership where

open import Data.Sum
open import Data.List
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Data.List.Any as Any
open Any.Membership-≡

-- _∈_

∈-++-pos : ∀ {A : Set} {x : A} xs ys → x ∈ xs ++ ys
           → (x ∈ xs) ⊎ (x ∈ ys)
∈-++-pos [] ys x∈ = inj₂ x∈
∈-++-pos (x ∷ xs) ys (here refl) = inj₁ (here refl)
∈-++-pos (x ∷ xs) ys (there x∈) with ∈-++-pos xs ys x∈
... | inj₁ x∈xs = inj₁ (there x∈xs)
... | inj₂ x∈ys = inj₂ x∈ys

∈-++-r : ∀ {A : Set} {x : A} xs {ys}
           → x ∈ ys → x ∈ (xs ++ ys)
∈-++-r [] x∈ = x∈
∈-++-r (y ∷ xs) x∈ = there (∈-++-r xs x∈)

∈-++-l : ∀ {A : Set} {x : A} {xs} ys
           → x ∈ xs → x ∈ (xs ++ ys)
∈-++-l ys (here refl) = here refl
∈-++-l ys (there x∈) = there (∈-++-l ys x∈)

∈-++-weaken : ∀ {A : Set} {x : A} xs ys zs
              → x ∈ (xs ++ zs) → x ∈ (xs ++ ys ++ zs)
∈-++-weaken [] ys zs x∈ = ∈-++-r ys x∈
∈-++-weaken (x ∷ xs) ys zs (here refl) = here refl
∈-++-weaken (_ ∷ xs) ys zs (there x∈) = there (∈-++-weaken xs ys zs x∈)

-- _∉_

∉-++-l : ∀ {A : Set} {x : A} xs ys → x ∉ xs ++ ys → x ∉ xs
∉-++-l ._ ys x∉xs++ys (here eq) = x∉xs++ys (here eq)
∉-++-l .(x' ∷ xs) ys x∉xs++ys (there {x'} {xs} pxs) =
  ∉-++-l xs ys (λ p → x∉xs++ys (there p)) pxs

∉-++-r : ∀ {A : Set} {x : A} xs ys → x ∉ xs ++ ys → x ∉ ys
∉-++-r [] ys x∉xs++ys x∈ys = x∉xs++ys x∈ys
∉-++-r (x' ∷ xs) ys x∉xs++ys x∈ys = ∉-++-r xs ys (λ p → x∉xs++ys (there p)) x∈ys

postulate
  ∉-∷ : ∀ {A : Set} {y x : A} {xs}
        → ¬ (y ≡ x) → y ∉ xs → y ∉ (x ∷ xs)

∉-++-join : ∀ {A : Set} {x : A}
            → ∀ xs ys → x ∉ xs → x ∉ ys → x ∉ xs ++ ys
∉-++-join [] ys x∉xs x∉ys x∈ys = x∉ys x∈ys
∉-++-join (_ ∷ xs) ys x∉xs x∉ys (here refl) = x∉xs (here refl)
∉-++-join (_ ∷ xs) ys x∉xxs x∉ys (there pxs) = ∉-++-join xs ys (λ x∉xs → x∉xxs (there x∉xs)) x∉ys pxs

∉-++-weaken : ∀ {A : Set} {x : A} xs ys zs
              → x ∉ (xs ++ ys ++ zs) → x ∉ (xs ++ zs)
∉-++-weaken xs ys zs x∉xyz x∈xz = x∉xyz (∈-++-weaken xs ys zs x∈xz)

∉-∷-hd : ∀ {A : Set} {x y : A} xs → x ∉ (y ∷ xs) → ¬ (x ≡ y)
∉-∷-hd {x} {._} xs x∉ refl = x∉ (here refl)

∉-∷-tl : ∀ {A : Set} {x y : A} xs → x ∉ (y ∷ xs) → x ∉ xs
∉-∷-tl {x} {y} xs x∉ x∈ = x∉ (there x∈)


module BTree.Complete.Alternative.Correctness {A : Set} where

open import BTree {A}
open import BTree.Equality {A}
open import BTree.Equality.Properties {A}
open import BTree.Complete.Base {A}
open import BTree.Complete.Base.Properties {A}
open import BTree.Complete.Alternative {A} renaming (Complete to Complete' ; _⋘_ to _⋘'_ ; _⋙_ to _⋙'_ ; _⋗_ to _⋗'_)
open import Data.Sum renaming (_⊎_ to _∨_)

lemma-⋗'-⋗ : {l r : BTree} → l ⋗' r → l ⋗ r
lemma-⋗'-⋗ (⋗lf x) = ⋗lf x
lemma-⋗'-⋗ (⋗nd {r = r} {l' = l'} x x' _ l'≃r' l⋗'l') = ⋗nd x x' r l' (lemma-⋗-≃ (lemma-⋗'-⋗ l⋗'l') l'≃r')

lemma-⋙'-⋗ : {l r : BTree} → l ⋙' r → l ⋗ r
lemma-⋙'-⋗ (⋙lf x) = ⋗lf x
lemma-⋙'-⋗ (⋙rl {r = r} {l' = l'} x x' l≃r l'⋘'r' l⋗'r') = ⋗nd x x' r l' (lemma-⋗'-⋗ l⋗'r')
lemma-⋙'-⋗ (⋙rr {r = r} {l' = l'} x x' l≃r l'⋙'r' l≃l') = ⋗nd x x' r l' (lemma-≃-⋗ l≃l' (lemma-⋙'-⋗ l'⋙'r'))

lemma-⋘'-⋗ : {l r : BTree} → l ⋘' r → l ≃ r ∨ l ⋗ r
lemma-⋘'-⋗ lf⋘ = inj₁ ≃lf
lemma-⋘'-⋗ (ll⋘ {r = r} {l' = l'} x x' l⋘'r l'≃r' r≃l')
    with lemma-⋘'-⋗ l⋘'r
... | inj₁ l≃r = inj₁ (≃nd x x' l≃r (trans≃ l≃r r≃l') l'≃r')
... | inj₂ l⋗r = inj₂ (⋗nd x x' r l' (lemma-⋗-≃ l⋗r (trans≃ r≃l' l'≃r')))
lemma-⋘'-⋗ (lr⋘ {r = r} {l' = l'} x x' _ l'≃r' l⋗'l') = inj₂ (⋗nd x x' r l' (lemma-⋗-≃ (lemma-⋗'-⋗ l⋗'l') l'≃r'))

lemma-⋘'-⋘ : {l r : BTree} → l ⋘' r → l ⋘ r
lemma-⋘'-⋘ lf⋘ = eq⋘ ≃lf
lemma-⋘'-⋘ (ll⋘ {r = r} {l' = l'} x x' l⋘'r l'≃r' r≃l')
    with lemma-⋘'-⋗ l⋘'r
... | inj₁ l≃r = eq⋘ (≃nd x x' l≃r (trans≃ l≃r r≃l') l'≃r')
... | inj₂ l⋗r = gt⋘ (np⋗ x l⋗r) (p≃ x' l'≃r') (⋗nd x x' r l' (lemma-⋗-≃ l⋗r (trans≃ r≃l' l'≃r')))
lemma-⋘'-⋘ (lr⋘ {r = r} {l' = l'} x x' l⋙'r l'≃r' l⋗'l') = gt⋘ (np⋗ x (lemma-⋙'-⋗ l⋙'r)) (p≃ x' l'≃r') (⋗nd x x' r l' (lemma-⋗-≃ (lemma-⋗'-⋗ l⋗'l') l'≃r'))

lemma-⋙'-⋙ : {l r : BTree} → l ⋙' r → l ⋙ r
lemma-⋙'-⋙ l⋙'r = ⋙gt (lemma-⋙'-⋗ l⋙'r)

lemma-complete'-complete : {t : BTree} → Complete' t → Complete t
lemma-complete'-complete leaf = leaf
lemma-complete'-complete (left x c'l c'r l⋘'r) = left x (lemma-complete'-complete c'l) (lemma-complete'-complete c'r) (lemma-⋘'-⋘ l⋘'r)
lemma-complete'-complete (right x c'l c'r l⋙'r) = right x (lemma-complete'-complete c'l) (lemma-complete'-complete c'r) (lemma-⋙'-⋙ l⋙'r)


-- This document shows how to encode GADTs using `IFix`.

{-# OPTIONS --type-in-type #-}

module ScottVec where

-- The kind of church-encoded type-level natural numbers.
Nat = (Set -> Set) -> Set -> Set

zero : Nat
zero = λ f z -> z

suc : Nat -> Nat
suc = λ n f z -> f (n f z)

plus : Nat -> Nat -> Nat
plus = λ n m f z -> n f (m f z)

-- Our old friend.
{-# NO_POSITIVITY_CHECK #-}
record IFix {I : Set} (F : (I -> Set) -> I -> Set) (i : I) : Set where
  constructor wrap
  field unwrap : F (IFix F) i
open IFix

-- Scott-encoded vectors (a vector is a list with statically-known length).

-- As usually the pattern vector of a Scott-encoded data type encodes pattern-matching.
VecF : Set -> (Nat -> Set) -> Nat -> Set
VecF
  = λ A Rec n
  -> (R : Nat -> Set)                  -- The type of the result depends on the vector's length.
  -> (∀ p -> A -> Rec p -> R (suc p))  -- The encoded `cons` constructor.
  -> R zero                            -- The encoded `nil` constructor.
  -> R n

Vec : Set -> Nat -> Set
Vec = λ (A : Set) -> IFix (VecF A)

nil : ∀ A -> Vec A zero
nil = λ A -> wrap λ R f z -> z

cons : ∀ A n -> A -> Vec A n -> Vec A (suc n)
cons = λ A n x xs -> wrap λ R f z -> f n x xs

open import Data.Empty
open import Data.Unit.Base
open import Data.Nat.Base using (ℕ; _+_)

-- Type-safe `head`.
head : ∀ A n -> Vec A (suc n) -> A
head A n xs =
  unwrap
    xs
    (λ p -> p (λ _ -> A) ⊤)  -- `p (λ _ -> A) ⊤` returns `A` when `p` is `suc p'` for some `p'`
                             -- and `⊤` when `p` is `zero`
    (λ p x xs' -> x)         -- In the `cons` case `suc p (λ _ -> A) ⊤` reduces to `A`,
                             -- hence we return the list element of type `A`.
    tt                       -- In the `nil` case `zero (λ _ -> A) ⊤` reduces to `⊤`,
                             -- hence we return the only value of that type.

{- Note [Type-safe `tail`]
It's not obvious if type-safe `tail` can be implemented with this setup. This is because even
though `Vec` is Scott-encoded, the type-level natural are Church-encoded (obviously we could
have Scott-encoded type-level naturals in Agda just as well, but not in Zerepoch Core), which
makes `pred` hard, which makes `tail` non-trivial.

I did try using Scott-encoded naturals in Agda, that makes `tail` even more straightforward
than `head`:

    tail : ∀ A n -> Vec A (suc n) -> Vec A n
    tail A n xs =
      unwrap
        xs
        (λ p -> ((B : ℕ -> Set) -> B (pred p) -> B n) -> Vec A n)
        (λ p x xs' coe -> coe (Vec A) xs')
        (λ coe -> coe (Vec A) (nil A))
        (λ B x -> x)
-}

-- Here we pattern-match on `xs` and if it's non-empty, i.e. of type `Vec ℕ (suc p)` for some `p`,
-- then we also get access to a coercion function that allows us to coerce the second list from
-- `Vec ℕ n` to the same `Vec ℕ (suc p)` and call the type-safe `head` over it.
-- Note that we don't even need to encode the `n ~ suc p` and `n ~ zero` equality constraints in
-- the definition of `vecF` and can recover coercions along those constraints by adding the
-- `Vec ℕ n -> Vec ℕ p` argument to the motive.
sumHeadsOr0 : ∀ n -> Vec ℕ n -> Vec ℕ n -> ℕ
sumHeadsOr0 n xs ys =
  unwrap
    xs
    (λ p -> (Vec ℕ n -> Vec ℕ p) -> ℕ)
    (λ p i _ coe -> i + head ℕ p (coe ys))
    (λ _ -> 0)
    (λ x -> x)


module Lvl.Proofs where

open import Data.Tuple as Tuple using ()
open import Logic.Predicate
open import Lvl
open import Structure.Setoid
open import Structure.Function.Domain
open import Structure.Relator.Equivalence
open import Structure.Relator.Properties
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ : Lvl.Level
private variable T : Type{ℓ}

instance
  LvlUp-equiv : ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → Equiv(Lvl.Up{ℓ}(T))
  Equiv._≡_ (LvlUp-equiv {ℓ = ℓ}) (up x) (up y) = Lvl.Up{ℓ}(x ≡ y)
  Up.obj (Reflexivity.proof (Equivalence.reflexivity (Equiv.equivalence LvlUp-equiv))) = reflexivity(_≡_)
  Up.obj (Symmetry.proof (Equivalence.symmetry (Equiv.equivalence LvlUp-equiv)) (up p)) = symmetry(_≡_) p
  Up.obj (Transitivity.proof (Equivalence.transitivity (Equiv.equivalence LvlUp-equiv)) (up p) (up q)) = transitivity(_≡_) p q

instance
  LvlUpObj-bijective : ⦃ equiv : Equiv{ℓₑ}(T) ⦄ → Bijective(Lvl.Up.obj{ℓ}{T = T})
  Up.obj (∃.witness (Tuple.left (Bijective.proof LvlUpObj-bijective {y}))) = y
  ∃.proof (Tuple.left (Bijective.proof LvlUpObj-bijective)) = reflexivity(_≡_)
  Up.obj (Tuple.right (Bijective.proof LvlUpObj-bijective) p q) = transitivity(_≡_) p (symmetry(_≡_) q)


-- Andreas, 2011-04-15
-- {-# OPTIONS -v tc.meta:20 #-}
module SameMeta where

infix 10 _≡_

data _≡_ {A : Set}(a : A) : A -> Set where
  refl : a ≡ a

infixr 5 _×_ _,_

data _×_ (A B : Set) : Set where
  _,_ : A -> B -> A × B

postulate A : Set

same : let X : A -> A -> A -> A × A
           X = _
       in {x y z : A} -> X x y y ≡ (x , y)
                       × X x x y ≡ X x y y
same = refl , refl
-- second equation triggers pruning of second variable of X
-- which makes the first equation linear and solvable


------------------------------------------------------------------------
-- The Agda standard library
--
-- Conat Literals
------------------------------------------------------------------------

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

module Codata.Cofin.Literals where

open import Data.Nat
open import Agda.Builtin.FromNat
open import Codata.Conat
open import Codata.Conat.Properties
open import Codata.Cofin
open import Relation.Nullary.Decidable

number : ∀ n → Number (Cofin n)
number n = record
  { Constraint = λ k → True (suc k ℕ≤? n)
  ; fromNat    = λ n {{p}} → fromℕ< (toWitness p)
  }


module Structure.Function.Linear where

import      Lvl
open import Logic
open import Logic.Propositional
open import Relator.Equals
open import Relator.Equals.Proofs
open import Type

-- TODO: Remove this
module _ {ℓ₁}{ℓ₂}{ℓ₃} {V₁ : Type{ℓ₁}} {V₂ : Type{ℓ₂}} {S : Type{ℓ₃}} where
  record LinearMap  (_+₁_ : V₁ → V₁ → V₁) (_⋅₁_ : S → V₁ → V₁)  (_+₂_ : V₂ → V₂ → V₂) (_⋅₂_ : S → V₂ → V₂) (f : V₁ → V₂) : Stmt{ℓ₁ Lvl.⊔ ℓ₂ Lvl.⊔ ℓ₃} where
    field
      additivity   : ∀{v₁ v₂ : V₁} → (f(v₁ +₁ v₂) ≡ f(v₁) +₂ f(v₂))
      homogeneity1 : ∀{s : S} → ∀{v : V₁} → (f(s ⋅₁ v) ≡ s ⋅₂ f(v))


module Sets.PredicateSet.Relations{ℓₗ}{ℓₒ} where

import      Lvl
open import Functional
open import Logic.Propositional{ℓₗ Lvl.⊔ ℓₒ}
open import Logic.Predicate{ℓₗ}{ℓₒ}
open import Numeral.Finite
open import Numeral.Natural
import      Relator.Equals
open import Sets.PredicateSet
open import Structure.Function.Domain

Empty : ∀{T} → PredSet{ℓₗ}{ℓₒ}(T) → Stmt
Empty(S) = (∀{x} → (x ∉' S)) where
  _∉'_ = _∉_ {ℓₗ}{ℓₒ}

NonEmpty : ∀{T} → PredSet{ℓₗ}{ℓₒ}(T) → Stmt
NonEmpty(S) = ∃(x ↦ (x ∈' S)) where
  _∈'_ = _∈_ {ℓₗ}{ℓₒ}


open import bool

module braun-tree{ℓ} (A : Set ℓ) (_<A_ : A → A → 𝔹) where

open import bool-thms
open import eq
open import list
open import nat
open import nat-thms
open import product
open import sum

-- the index n is the size of the tree (number of elements of type A)
data braun-tree : (n : ℕ) → Set ℓ where
  bt-empty : braun-tree 0
  bt-node : ∀ {n m : ℕ} →
            A → braun-tree n → braun-tree m →
            n ≡ m ∨ n ≡ suc m →
            braun-tree (suc (n + m))

{- we will keep smaller (_<A_) elements closer to the root of the Braun tree as we insert -}
bt-insert : ∀ {n : ℕ} → A → braun-tree n → braun-tree (suc n)

bt-insert a bt-empty = bt-node a bt-empty bt-empty (inj₁ refl)

bt-insert a (bt-node{n}{m} a' l r p)
  rewrite +comm n m with p | if a <A a' then (a , a') else (a' , a)
bt-insert a (bt-node{n}{m} a' l r _) | inj₁ p | (a1 , a2)
  rewrite p = (bt-node a1 (bt-insert a2 r) l (inj₂ refl))
bt-insert a (bt-node{n}{m} a' l r _) | inj₂ p | (a1 , a2) =
  (bt-node a1 (bt-insert a2 r) l (inj₁ (sym p)))

bt-replace-min : ∀{n : ℕ} → A → braun-tree (suc n) → braun-tree (suc n)
bt-replace-min a (bt-node _ bt-empty bt-empty u) = (bt-node a bt-empty bt-empty u)
bt-replace-min a (bt-node _ bt-empty (bt-node _ _ _ _) (inj₁ ()))
bt-replace-min a (bt-node _ bt-empty (bt-node _ _ _ _) (inj₂ ()))
bt-replace-min a (bt-node _ (bt-node _ _ _ _) bt-empty (inj₁ ()))
bt-replace-min a (bt-node a' (bt-node x l r u) bt-empty (inj₂ y)) with a <A x
bt-replace-min a (bt-node a' (bt-node x l r u) bt-empty (inj₂ y)) | tt = (bt-node a (bt-node x l r u) bt-empty (inj₂ y))
bt-replace-min a (bt-node a' (bt-node x l r u) bt-empty (inj₂ y)) | ff =
 (bt-node x (bt-replace-min a (bt-node x l r u)) bt-empty (inj₂ y))
bt-replace-min a (bt-node a' (bt-node x l r u) (bt-node x' l' r' u') v) with a <A x && a <A x'
bt-replace-min a (bt-node a' (bt-node x l r u) (bt-node x' l' r' u') v) | tt =
 (bt-node a (bt-node x l r u) (bt-node x' l' r' u') v)
bt-replace-min a (bt-node a' (bt-node x l r u) (bt-node x' l' r' u') v) | ff with x <A x'
bt-replace-min a (bt-node a' (bt-node x l r u) (bt-node x' l' r' u') v) | ff | tt =
 (bt-node x (bt-replace-min a (bt-node x l r u)) (bt-node x' l' r' u') v)
bt-replace-min a (bt-node a' (bt-node x l r u) (bt-node x' l' r' u') v) | ff | ff =
 (bt-node x' (bt-node x l r u) (bt-replace-min a (bt-node x' l' r' u')) v)

{- thanks to Matías Giovannini for the excellent post
     http://alaska-kamtchatka.blogspot.com/2010/02/braun-trees.html
   explaining how to do delete -}
bt-delete-min : ∀ {p : ℕ} → braun-tree (suc p) → braun-tree p
bt-delete-min (bt-node a bt-empty bt-empty u) = bt-empty
bt-delete-min (bt-node a bt-empty (bt-node _ _ _ _) (inj₁ ()))
bt-delete-min (bt-node a bt-empty (bt-node _ _ _ _) (inj₂ ()))
bt-delete-min (bt-node a (bt-node{n'}{m'} a' l' r' u') bt-empty u) rewrite +0 (n' + m') = bt-node a' l' r' u'
bt-delete-min (bt-node a
                (bt-node{n}{m} x l1 r1 u1)
                (bt-node{n'}{m'} x' l2 r2 u2) u)
  rewrite +suc(n + m)(n' + m') | +suc n (m + (n' + m'))
        | +comm(n + m)(n' + m') =
  if (x <A x') then
    (bt-node x (bt-node x' l2 r2 u2)
      (bt-delete-min (bt-node x l1 r1 u1)) (lem{n}{m}{n'}{m'} u))
  else
    (bt-node x' (bt-replace-min x (bt-node x' l2 r2 u2))
      (bt-delete-min (bt-node x l1 r1 u1)) (lem{n}{m}{n'}{m'} u))
  where lem : {n m n' m' : ℕ} → suc (n + m) ≡ suc (n' + m') ∨ suc (n + m) ≡ suc (suc (n' + m')) →
              suc (n' + m') ≡ n + m ∨ suc (n' + m') ≡ suc (n + m)
        lem{n}{m}{n'}{m'} (inj₁ x) = inj₂ (sym x)
        lem (inj₂ y) = inj₁ (sym (suc-inj y))

bt-remove-min : ∀ {p : ℕ} → braun-tree (suc p) → A × braun-tree p
bt-remove-min (bt-node a l r u) = a , bt-delete-min (bt-node a l r u)

----------------------------------------------------------------------
-- this version stores data at the leaves instead of at the nodes
----------------------------------------------------------------------
data braun-tree' : (n : ℕ) → Set ℓ where
  bt'-leaf : A → braun-tree' 1
  bt'-node : ∀ {n m : ℕ} →
            braun-tree' n → braun-tree' m →
            n =ℕ m ≡ tt ⊎ n =ℕ m + 1 ≡ tt →
            braun-tree' (n + m)

bt'-insert : ∀ {n : ℕ} → A → braun-tree' n → braun-tree' (suc n)
bt'-insert a (bt'-leaf a') = bt'-node (bt'-leaf a) (bt'-leaf a') (inj₁ refl)
bt'-insert a (bt'-node{n}{m} l r p) rewrite +comm n m with p
bt'-insert a (bt'-node{n}{m} l r p) | inj₁ p' rewrite =ℕ-to-≡{n} p' = (bt'-node (bt'-insert a r) l (inj₂ lem))
  where lem : suc m =ℕ m + 1 ≡ tt
        lem rewrite +comm m 1 = =ℕ-refl m
bt'-insert a (bt'-node{n}{m} l r p) | inj₂ p' = (bt'-node (bt'-insert a r) l (inj₁ (lem n m p')))
  where lem : ∀ n m → n =ℕ m + 1 ≡ tt → suc m =ℕ n ≡ tt
        lem n m p' rewrite =ℕ-to-≡{n} p' | +comm m 1 = =ℕ-refl m

𝕃-to-braun-tree' : A → (l : 𝕃 A) → braun-tree' (suc (length l))
𝕃-to-braun-tree' a [] = bt'-leaf a
𝕃-to-braun-tree' a (a' :: as) = bt'-insert a (𝕃-to-braun-tree' a' as)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Data.List.Any.Membership instantiated with propositional equality,
-- along with some additional definitions.
------------------------------------------------------------------------

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

module Data.List.Membership.Propositional {a} {A : Set a} where

open import Data.List.Relation.Unary.Any using (Any)
open import Relation.Binary.PropositionalEquality using (_≡_; _≢_; setoid; subst)

import Data.List.Membership.Setoid as SetoidMembership

------------------------------------------------------------------------
-- Re-export contents of setoid membership

open SetoidMembership (setoid A) public hiding (lose)

------------------------------------------------------------------------
-- Different members

_≢∈_ : ∀ {x y : A} {xs} → x ∈ xs → y ∈ xs → Set _
_≢∈_ x∈xs y∈xs = ∀ x≡y → subst (_∈ _) x≡y x∈xs ≢ y∈xs

------------------------------------------------------------------------
-- Other operations

lose : ∀ {p} {P : A → Set p} {x xs} → x ∈ xs → P x → Any P xs
lose = SetoidMembership.lose (setoid A) (subst _)


{-# OPTIONS --without-K --safe #-}
open import Categories.Category using (Category; module Definitions)

-- Definition of the "Twisted" Functor between certain Functor Categories
module Categories.Functor.Instance.Twisted {o ℓ e o′ ℓ′ e′} (𝒞 : Category o ℓ e) (𝒟 : Category o′ ℓ′ e′) where

import Categories.Category.Construction.TwistedArrow as TW
open import Categories.Category.Product
open import Categories.Category.Construction.Functors
open import Categories.Functor
open import Categories.NaturalTransformation using (NaturalTransformation; ntHelper)

open import Data.Product using (_,_)

private
  module C = Category 𝒞

Twist : Functor (Product C.op 𝒞) 𝒟 → Functor (TW.TwistedArrow 𝒞) 𝒟
Twist F = record
  { F₀ = λ x → F₀ (dom x , cod x)
  ; F₁ = λ f → F₁ (dom⇐ f , cod⇒ f)
  ; identity = identity
  ; homomorphism = homomorphism
  ; F-resp-≈ = F-resp-≈
  }
  where
  open Functor F
  open TW.Morphism
  open TW.Morphism⇒

Twist′ : Functor (Product C.op 𝒞) 𝒟 → Functor (Category.op (TW.TwistedArrow C.op)) 𝒟
Twist′ F = record
  { F₀ = λ x → F₀ (dom x , cod x)
  ; F₁ = λ f → F₁ (dom⇐ f , cod⇒ f)
  ; identity = identity
  ; homomorphism = homomorphism
  ; F-resp-≈ = F-resp-≈
  }
  where
  open Functor F
  open TW.Morphism
  open TW.Morphism⇒

Twisted : Functor (Functors (Product C.op 𝒞) 𝒟) (Functors (TW.TwistedArrow 𝒞) 𝒟)
Twisted = record
  { F₀ = Twist
  ; F₁ = Nat
  ; identity = D.Equiv.refl
  ; homomorphism = D.Equiv.refl
  ; F-resp-≈ = λ f≈g → f≈g
  }
  where
  open TW.Morphism
  open TW.Morphism⇒
  module D = Category 𝒟
  Nat : {F G : Functor (Product C.op 𝒞) 𝒟} → NaturalTransformation F G → NaturalTransformation (Twist F) (Twist G)
  Nat nt = ntHelper record
    { η = λ x → η nt (dom x , cod x)
    ; commute = λ f → commute nt (dom⇐ f , cod⇒ f)
    }
    where
    open NaturalTransformation


{-# OPTIONS --cubical --safe --postfix-projections #-}

module Cardinality.Infinite.ManifestEnumerable where

open import Prelude
open import Data.List.Kleene
open import Data.Fin
import Data.Nat as ℕ
open import Data.Nat using (_+_)
open import Cubical.Data.Sigma.Properties
open import Cubical.Foundations.Prelude using (J)
import Data.List.Kleene.Membership as Kleene
open import Codata.Stream
open import Cardinality.Infinite.Split

open import HITs.PropositionalTruncation.Sugar

private
  variable
    u : Level
    U : A → Type u
    s : Level
    S : ℕ → Type s

-- ℰ : Type a → Type a
-- ℰ A = Σ[ xs ⦂ Stream A ] Π[ x ⦂ A ] ∥ x ∈ xs ∥

-- ℰ≡ℕ↠ : ℰ A ≡ (ℕ ↠ A)
-- ℰ≡ℕ↠ = refl

-- _∥Σ∥_ : ℰ A → (∀ x → ℰ (U x)) → ℰ (Σ A U)
-- (xs ∥Σ∥ ys) .fst = cantor (xs .fst) (fst ∘ ys)
-- (xs ∥Σ∥ ys) .snd (x , y) =
--   concat-∈
--     (x , y)
--     (xs .fst * (fst ∘ ys)) ∥$∥
--     ⦇ (*-cover x (xs .fst) y (fst ∘ ys)) (xs .snd x) (ys x .snd y) ⦈


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

open import Algebra

module Data.FingerTree.Reasoning
  {r m}
  (ℳ : Monoid r m)
  where

open Monoid ℳ renaming (Carrier to 𝓡)

open import Data.FingerTree.MonoidSolver ℳ using (solve-macro)

open import Data.Unit using (⊤)
open import Reflection using (TC; Term)

macro
  _↯ : Term → Term → TC ⊤
  _↯ = solve-macro

infixr 2 ∙≫_ ≪∙_
∙≫_ : ∀ {x y z} → x ≈ y → z ∙ x ≈ z ∙ y
∙≫_ = ∙-cong refl

≪∙_ : ∀ {x y z} → x ≈ y → x ∙ z ≈ y ∙ z
≪∙ x = ∙-cong x refl

infixl 1 _⍮_
_⍮_ : ∀ {x y z} → x ≈ y → y ≈ z → x ≈ z
_⍮_ = trans

infixl 1 trans⁻¹
trans⁻¹ : ∀ {x y z : 𝓡} → y ≈ z → x ≈ y → x ≈ z
trans⁻¹ x y = trans y x

syntax trans⁻¹ y≈z x≈y = x≈y ⍮′ y≈z

infixr 2 _↢_ ↣-syntax ↣↣-syntax
_↢_ : ∀ x {y} → x ≈ y → x ≈ y
_ ↢ x≈y = x≈y

↣-syntax : ∀ {x} y → x ≈ y → x ≈ y
↣-syntax _ x≈y = x≈y

syntax ↣-syntax y x≈y = x≈y ↣ y

↣↣-syntax : ∀ x y → x ≈ y → x ≈ y
↣↣-syntax _ _ x≈y = x≈y

syntax ↣↣-syntax x y x≈y = x ↣⟨ x≈y ⟩↣ y

infixl 6 _∙>_ _<∙_
_∙>_ : ∀ x {y z} → y ≈ z → x ∙ y ≈ x ∙ z
_ ∙> y≈z = ∙≫ y≈z

_<∙_ : ∀ {x y} → x ≈ y → ∀ z → x ∙ z ≈ y ∙ z
x≈y <∙ _ = ≪∙ x≈y


module Prelude.List.Properties where

open import Prelude.Function

open import Prelude.Bool
open import Prelude.Bool.Properties

open import Prelude.Nat
open import Prelude.Nat.Properties

open import Prelude.Semiring

open import Prelude.List.Base

open import Prelude.Decidable

open import Prelude.Monoid
open import Prelude.Semigroup

open import Prelude.Equality
open import Prelude.Equality.Inspect
open import Prelude.Variables

open import Prelude.Strict

foldr-map-fusion : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
                     (f : B → C → C) (g : A → B) (z : C) (xs : List A) →
                     foldr f z (map g xs) ≡ foldr (f ∘ g) z xs
foldr-map-fusion f g z [] = refl
foldr-map-fusion f g z (x ∷ xs)
  rewrite foldr-map-fusion f g z xs
        = refl

foldl-map-fusion : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c}
                     (f : C → B → C) (g : A → B) (z : C) (xs : List A) →
                     foldl f z (map g xs) ≡ foldl (λ x y → f x (g y)) z xs
foldl-map-fusion f g z [] = refl
foldl-map-fusion f g z (x ∷ xs)
  rewrite foldl-map-fusion f g (f z (g x)) xs
        = refl

foldl-assoc : ∀ {a} {A : Set a} (f : A → A → A) →
                (∀ x y z → f x (f y z) ≡ f (f x y) z) →
                ∀ y z xs → foldl f (f y z) xs ≡ f y (foldl f z xs)
foldl-assoc f assoc y z [] = refl
foldl-assoc f assoc y z (x ∷ xs)
  rewrite sym (assoc y z x)
        = foldl-assoc f assoc y (f z x) xs

foldl-foldr : ∀ {a} {A : Set a} (f : A → A → A) (z : A) →
                (∀ x y z → f x (f y z) ≡ f (f x y) z) →
                (∀ x → f z x ≡ x) → (∀ x → f x z ≡ x) →
                ∀ xs → foldl f z xs ≡ foldr f z xs
foldl-foldr f z assoc idl idr [] = refl
foldl-foldr f z assoc idl idr (x ∷ xs)
  rewrite sym (foldl-foldr f z assoc idl idr xs)
        | idl x ⟨≡⟩ʳ idr x
        = foldl-assoc f assoc x z xs

foldl!-foldl : ∀ {a b} {A : Set a} {B : Set b} (f : B → A → B) z (xs : List A) →
                 foldl! f z xs ≡ foldl f z xs
foldl!-foldl f z [] = refl
foldl!-foldl f z (x ∷ xs) = forceLemma (f z x) (λ z′ → foldl! f z′ xs) ⟨≡⟩
                            foldl!-foldl f (f z x) xs

-- Properties of _++_

map-++ : ∀ {a b} {A : Set a} {B : Set b} (f : A → B) (xs ys : List A) →
           map f (xs ++ ys) ≡ map f xs ++ map f ys
map-++ f []       ys = refl
map-++ f (x ∷ xs) ys = f x ∷_ $≡ map-++ f xs ys

product-++ : (xs ys : List Nat) → productR (xs ++ ys) ≡ productR xs * productR ys
product-++ []       ys = sym (add-zero-r _)
product-++ (x ∷ xs) ys = x *_ $≡ product-++ xs ys ⟨≡⟩ mul-assoc x _ _


module sum-thms where

open import eq
open import sum
open import list
open import product
open import negation

inj₁-inj : ∀{ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}{x : A}{x'} → inj₁{ℓ}{ℓ'}{A}{B} x ≡ inj₁ x' → x ≡ x'
inj₁-inj refl = refl

¬∨ : ∀ {A B : Set} → ¬ A ∧ ¬ B → ¬ (A ∨ B)
¬∨ (u , u') (inj₁ x) = u x
¬∨ (u , u') (inj₂ y) = u' y

¬Σ : ∀{A : Set}{B : A → Set} → (∀(x : A) → ¬ B x) → ¬ Σ A B
¬Σ p (a , b) = p a b

¬∧1 : ∀ {A B : Set} → ¬ A → ¬ (A ∧ B)
¬∧1 f (a , b) = f a

¬∧2 : ∀ {A B : Set} → ¬ B → ¬ (A ∧ B)
¬∧2 f (a , b) = f b

¬∀ : ∀{A : Set}{B : A → Set} → Σ A (λ x → ¬ B x) → ¬ ∀(x : A) → B x
¬∀ (a , b) f = b (f a)


mutual
  data ℕμ : Set where
    zero : ℕμ
    succ : ℕμ → ℕμ
    delay : ℕν → ℕμ

  record ℕν : Set where
    coinductive
    field step : ℕμ

open ℕν public

mutual
  data _≤μ_ : ℕμ → ℕμ → Set where
    -- Standard part of the order
    le₀ : (y : ℕμ) → zero ≤μ y
    leₛ : {x y : ℕμ} → x ≤μ y → succ x ≤μ succ y
    -- We can have finite delays on the left and on the right...
    le-stepₗ : {m : ℕν} {y : ℕμ} → step m ≤μ y → delay m ≤μ y
    le-stepᵣ : {x : ℕμ} {n : ℕν} → x ≤μ step n → x ≤μ delay n
    -- or an abritrary sequence of delays on both sides.
    le-step : {m n : ℕν} → m ≤ n → delay m ≤μ delay n

  record _≤_ (m n : ℕν) : Set where
    coinductive
    field step≤ : (step m) ≤μ (step m)

open _≤_ public

≤μ-refl : (x : ℕμ) → x ≤μ x
≤-refl : (m : ℕν) → m ≤ m

step≤ (≤-refl m) = ≤μ-refl (step m)

≤μ-refl zero = le₀ zero
≤μ-refl (succ x) = leₛ (≤μ-refl x)
≤μ-refl (delay x) = le-step (≤-refl x)


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

open import Categories.Category
open import Categories.Object.Zero

-- Kernels of morphisms.
-- https://ncatlab.org/nlab/show/kernel
module Categories.Object.Kernel {o ℓ e} {𝒞 : Category o ℓ e} (zero : Zero 𝒞) where

open import Level using (_⊔_)

open import Categories.Morphism 𝒞
open import Categories.Morphism.Reasoning 𝒞
  hiding (glue)

open Category 𝒞
open Zero zero

open HomReasoning

private
  variable
    A B X : Obj
    f h i j k : A ⇒ B

-- Note: We could define Kernels directly as equalizers or as pullbacks, but it seems somewhat
-- cleaner to just define them "as is" to avoid mucking about with extra morphisms that can
-- get in the way. For example, if we defined them as 'Pullback f !' then our 'p₂' projection
-- would _always_ be trivially equal to '¡ : K ⇒ zero'.

record IsKernel {A B K} (k : K ⇒ A) (f : A ⇒ B) : Set (o ⊔ ℓ ⊔ e) where
  field
    commute : f ∘ k ≈ zero⇒
    universal : ∀ {X} {h : X ⇒ A} → f ∘ h ≈ zero⇒ → X ⇒ K
    factors : ∀ {eq : f ∘ h ≈ zero⇒} → h ≈ k ∘ universal eq
    unique : ∀ {eq : f ∘ h ≈ zero⇒} → h ≈ k ∘ i → i ≈ universal eq

  universal-resp-≈ : ∀ {eq : f ∘ h ≈ zero⇒} {eq′ : f ∘ i ≈ zero⇒} →
    h ≈ i → universal eq ≈ universal eq′
  universal-resp-≈ h≈i = unique (⟺ h≈i ○ factors)

  universal-∘ : f ∘ k ∘ h ≈ zero⇒
  universal-∘ {h = h} = begin
    f ∘ k ∘ h ≈⟨ pullˡ commute ⟩
    zero⇒ ∘ h ≈⟨ pullʳ (⟺ (¡-unique (¡ ∘ h))) ⟩
    zero⇒ ∎

record Kernel {A B} (f : A ⇒ B) : Set (o ⊔ ℓ ⊔ e) where
  field
     {kernel} : Obj
     kernel⇒ : kernel ⇒ A
     isKernel : IsKernel kernel⇒ f

  open IsKernel isKernel public

IsKernel⇒Kernel : IsKernel k f → Kernel f
IsKernel⇒Kernel {k = k} isKernel = record
  { kernel⇒ = k
  ; isKernel = isKernel
  }