{-# OPTIONS --without-K #-}
import Level as L
open import Type
open import Function
open import Algebra
open import Algebra.FunctionProperties.NP
open import Data.Nat.NP hiding (_^_)
open import Data.Nat.Properties
open import Data.One hiding (_≤_)
open import Data.Sum
open import Data.Maybe.NP
open import Data.Product
open import Data.Bits
open import Data.Zero
open import Data.Bool.NP as Bool
import Function.Equality as FE
open FE using (_⟨$⟩_ ; ≡-setoid)
import Function.Injection as Finj
import Function.Inverse as FI
open FI using (_↔_; module Inverse)
open import Function.LeftInverse using (_RightInverseOf_)
import Function.Related as FR
open import Function.Related.TypeIsomorphisms.NP
open import Relation.Binary.NP
open import Relation.Binary.Sum
open import Relation.Binary.Product.Pointwise
open import Relation.Unary.Logical
open import Relation.Binary.Logical
import Relation.Binary.PropositionalEquality.NP as ≡
open ≡ using (_≡_; _≗_)
open import Search.Type

module sum-setoid where

SearchExtFun-úber : ∀ {A B} → (SF : Search (A → B)) → SearchInd SF → SearchExtFun SF
SearchExtFun-úber sf sf-ind op {f = f}{g} f≈g = sf-ind (λ s → s op f ≡ s op g) (≡.cong₂ op) (λ x → f≈g (λ _ → ≡.refl))

SearchExtFun-úber' : ∀ {A B} → (SF : Search (A → B)) → SearchInd SF → SearchExtFun SF
SearchExtFun-úber' sf sf-ind op {f = f}{g} f≈g = sf-ind (λ s → s op f ≡ s op g) (≡.cong₂ op) (λ x → f≈g (λ _ → ≡.refl))

SearchExtoid : ∀ {A : Setoid L.zero L.zero} → Search (Setoid.Carrier A) → ★₁
SearchExtoid {A} sᴬ = ∀ {M} op {f g : A FE.⟶ ≡.setoid M} → Setoid._≈_ (A FE.⇨ ≡.setoid M) f g →  sᴬ op (_⟨$⟩_ f) ≡ sᴬ op (_⟨$⟩_ g)

sum-lin⇒sum-zero : ∀ {A} → {sum : Sum A} → SumLin sum → SumZero sum
sum-lin⇒sum-zero sum-lin = sum-lin (λ _ → 0) 0

sum-mono⇒sum-ext : ∀ {A} → {sum : Sum A} → SumMono sum → SumExt sum
sum-mono⇒sum-ext sum-mono f≗g = ℕ≤.antisym (sum-mono (ℕ≤.reflexive ∘ f≗g)) (sum-mono (ℕ≤.reflexive ∘ ≡.sym ∘ f≗g))

sum-ext+sum-hom⇒sum-mono : ∀ {A} → {sum : Sum A} → SumExt sum → SumHom sum → SumMono sum
sum-ext+sum-hom⇒sum-mono {sum = sum} sum-ext sum-hom {f} {g} f≤°g =
    sum f                         ≤⟨ m≤m+n _ _ ⟩
    sum f + sum (λ x → g x ∸ f x) ≡⟨ ≡.sym (sum-hom _ _) ⟩
    sum (λ x → f x + (g x ∸ f x)) ≡⟨ sum-ext (m+n∸m≡n ∘ f≤°g) ⟩
    sum g ∎ where open ≤-Reasoning

record SumPropoid (As : Setoid L.zero L.zero) : ★₁ where
  constructor _,_
  module ≈ᴬ = Setoid As
  open ≈ᴬ using () renaming (_≈_ to _≈ᴬ_; Carrier to A)
  field
    search     : Search A
    search-ind : SearchInd search

  ⟦search⟧ : ∀ {Aᵣ : A → A → ★}
               (Aᵣ-refl : Reflexive Aᵣ)
              → ⟦Search⟧₁ Aᵣ search
  ⟦search⟧ Aᵣ-refl Mᵣ ∙ᵣ fᵣ = search-ind (λ s → Mᵣ (s _ _) (s _ _))
                                         (λ η → ∙ᵣ η)
                                         (λ _ → fᵣ Aᵣ-refl)

  -- this one is given for completness but the asking for the Aₚ predicate
  -- to be trivial makes this result useless.
  [search] : ∀ (Aₚ : A → ★)
               (Aₚ-triv : ∀ x → Aₚ x)
             → [Search] Aₚ search
  [search] Aₚ Aₚ-triv {M} Mₚ ∙ₚ fₚ =
    search-ind (λ s → Mₚ (s _ _)) (λ η → ∙ₚ η) (λ x → fₚ (Aₚ-triv x))

  search-sg-ext : SearchSgExt search
  search-sg-ext sg {f} {g} f≈°g = search-ind (λ s → s _ f ≈ s _ g) ∙-cong f≈°g
    where open Sgrp sg

  foo : ∀ {A : ★} {R : A → A → ★} → Reflexive R → _≡_ ⇒ R
  foo R-refl ≡.refl = R-refl

  search-ext : SearchExt search
  -- search-ext op {g = g} pf = ⟦search⟧ {_≡_} ≡.refl _≡_ (λ η → ≡.cong₂ op η) (≡.trans (pf _) ∘ ≡.cong g) -- (foo (λ {x} → pf x))
  search-ext op pf = ⟦search⟧ {_≡_} ≡.refl _≡_ (λ η → ≡.cong₂ op η)
                                               (foo (λ {x} → pf x))
 -- (λ { {x} .{x} ≡.refl → pf _ })
  -- {!search-extoid op = ⟦search⟧ {_≈ᴬ_} ≈ᴬ.refl _≡_ (λ η → ≡.cong₂ op η)!}

  search-mono : SearchMono search
  search-mono _⊆_ _∙-mono_ {f} {g} f⊆°g = search-ind (λ s → s _ f ⊆ s _ g) _∙-mono_ f⊆°g

  search-swap : SearchSwap search
  search-swap sg f {sᴮ} pf = search-ind (λ s → s _ (sᴮ ∘ f) ≈ sᴮ (s _ ∘ flip f)) (λ p q → trans (∙-cong p q) (sym (pf _ _))) (λ _ → refl)
    where open Sgrp sg

  searchMon : SearchMon A
  searchMon m = search _∙_
    where open Mon m

  search-ε : Searchε searchMon
  search-ε m = search-ind (λ s → s _ (const ε) ≈ ε) (λ x≈ε y≈ε → trans (∙-cong x≈ε y≈ε) (proj₁ identity ε)) (λ _ → refl)
    where open Mon m

  search-hom : SearchMonHom searchMon
  search-hom cm f g = search-ind (λ s → s _ (f ∙° g) ≈ s _ f ∙ s _ g)
                                 (λ p₀ p₁ → trans (∙-cong p₀ p₁) (∙-interchange _ _ _ _)) (λ _ → refl)
    where open CMon cm

  search-hom′ :
      ∀ {S T}
        (_+_ : Op₂ S)
        (_*_ : Op₂ T)
        (f   : S → T)
        (g   : A → S)
        (hom : ∀ x y → f (x + y) ≡ f x * f y)
        → f (search _+_ g) ≡ search _*_ (f ∘ g)
  search-hom′ _+_ _*_ f g hom = search-ind (λ s → f (s _+_ g) ≡ s _*_ (f ∘ g))
                                           (λ p q → ≡.trans (hom _ _) (≡.cong₂ _*_ p q))
                                           (λ _ → ≡.refl)

  StableUnder : As FE.⟶ As  → ★₁
  StableUnder p = ∀ {B} (op : Op₂ B) f → search op f ≡ search op (f ∘ _⟨$⟩_ p)

  sum : Sum A
  sum = search _+_

  sum-ind : SumInd sum
  sum-ind P P+ Pf = search-ind (λ s → P (s _+_)) P+ Pf

  sum-ext : SumExt sum
  sum-ext = search-ext _+_

  sum-zero : SumZero sum
  sum-zero = search-ε ℕ+.monoid

  sum-hom : SumHom sum
  sum-hom = search-hom ℕ°.+-commutativeMonoid

  sum-mono : SumMono sum
  sum-mono = search-mono _≤_ _+-mono_

  sum-lin : SumLin sum
  sum-lin f zero    = sum-zero
  sum-lin f (suc k) = ≡.trans (sum-hom f (λ x → k * f x)) (≡.cong₂ _+_ (≡.refl {x = sum f}) (sum-lin f k))

  SumStableUnder : As FE.⟶ As → ★
  SumStableUnder p = ∀ (f : As FE.⟶ ≡.setoid ℕ) → sum (_⟨$⟩_ f) ≡ sum (_⟨$⟩_ (f FE.∘ p))

  sumStableUnder : ∀ {p} → StableUnder p → SumStableUnder p
  sumStableUnder SU-p f = SU-p _+_ (_⟨$⟩_ f)

  Card : ℕ
  Card = sum (const 1)

  count : Count A
  count f = sum (Bool.toℕ ∘ f)

  count-ext : CountExt count
  count-ext f≗g = sum-ext (≡.cong Bool.toℕ ∘ f≗g)

  CountStableUnder : As FE.⟶ As → ★
  CountStableUnder p = ∀ (f : As FE.⟶ ≡.setoid Bool) → count (_⟨$⟩_ f) ≡ count (_⟨$⟩_ (f FE.∘ p))

  countStableUnder : ∀ {p} → SumStableUnder p → CountStableUnder p
  countStableUnder sumSU-p f = sumSU-p (≡.:→-to-Π Bool.toℕ FE.∘ f)

  search-extoid : SearchExtoid {As} search
  -- search-extoid op {f = f}{g} f≈g = search-ind (λ s₁ → s₁ op (_⟨$⟩_ f) ≡ s₁ op (_⟨$⟩_ g)) (≡.cong₂ op) (λ x → f≈g (Setoid.refl As))
  search-extoid op = ⟦search⟧ {_≈ᴬ_} ≈ᴬ.refl _≡_ (λ η → ≡.cong₂ op η)

SumProp : ★ → ★₁
SumProp A = SumPropoid (≡.setoid A)

open SumPropoid public

search-swap' : ∀ {A B} cm (μA : SumPropoid A) (μB : SumPropoid B) f →
               let open CMon cm
                   sᴬ = search μA _∙_
                   sᴮ = search μB _∙_ in
               sᴬ (sᴮ ∘ f) ≈ sᴮ (sᴬ ∘ flip f)
search-swap' cm μA μB f = search-swap μA sg f (search-hom μB cm)
  where open CMon cm

sum-swap : ∀ {A B} (μA : SumPropoid A) (μB : SumPropoid B) f →
           sum μA (sum μB ∘ f) ≡ sum μB (sum μA ∘ flip f)
sum-swap = search-swap' ℕ°.+-commutativeMonoid

_≈Sum_ : ∀ {A} → (sum₀ sum₁ : Sum A) → ★
sum₀ ≈Sum sum₁ = ∀ f → sum₀ f ≡ sum₁ f

_≈Search_ : ∀ {A} → (s₀ s₁ : Search A) → ★₁
s₀ ≈Search s₁ = ∀ {B} (op : Op₂ B) f → s₀ op f ≡ s₁ op f

μ𝟙 : SumProp 𝟙
μ𝟙 = srch , ind
  where
    srch : Search 𝟙
    srch _ f = f _

    ind : SearchInd srch
    ind _ _ Pf = Pf _

μBit : SumProp Bit
μBit = searchBit , ind
  where
    searchBit : Search Bit
    searchBit _∙_ f = f 0b ∙ f 1b

    ind : SearchInd searchBit
    ind _ _P∙_ Pf = Pf 0b P∙ Pf 1b

infixr 4 _+Search_

_+Search_ : ∀ {A B} → Search A → Search B → Search (A ⊎ B)
(searchᴬ +Search searchᴮ) _∙_ f = searchᴬ _∙_ (f ∘ inj₁) ∙ searchᴮ _∙_ (f ∘ inj₂)

_+SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
                 SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ +Search sᴮ)
(Psᴬ +SearchInd Psᴮ) P P∙ Pf
  = P∙ (Psᴬ (λ s → P (λ _ f → s _ (f ∘ inj₁))) P∙ (Pf ∘ inj₁))
       (Psᴮ (λ s → P (λ _ f → s _ (f ∘ inj₂))) P∙ (Pf ∘ inj₂))

infixr 4 _+Sum_

_+Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A ⊎ B)
(sumᴬ +Sum sumᴮ) f = sumᴬ (f ∘ inj₁) + sumᴮ (f ∘ inj₂)

_+μ_ : ∀ {A B} → SumPropoid A → SumPropoid B → SumPropoid (A ⊎-setoid B)
μA +μ μB = _ , search-ind μA +SearchInd search-ind μB

infixr 4 _×Search_

-- liftM2 _,_ in the continuation monad
_×Search_ : ∀ {A B} → Search A → Search B → Search (A × B)
(searchᴬ ×Search searchᴮ) op f = searchᴬ op (λ x → searchᴮ op (curry f x))

_×SearchInd_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B}
               → SearchInd sᴬ → SearchInd sᴮ → SearchInd (sᴬ ×Search sᴮ)
(Psᴬ ×SearchInd Psᴮ) P P∙ Pf =
  Psᴬ (λ s → P (λ _ _ → s _ _)) P∙ (Psᴮ (λ s → P (λ _ _ → s _ _)) P∙ ∘ curry Pf)

_×SearchExt_ : ∀ {A B} {sᴬ : Search A} {sᴮ : Search B} →
              SearchExt sᴬ → SearchExt sᴮ → SearchExt (sᴬ ×Search sᴮ)
(sᴬ-ext ×SearchExt sᴮ-ext) sg f≗g = sᴬ-ext sg (sᴮ-ext sg ∘ curry f≗g)

infixr 4 _×Sum_

-- liftM2 _,_ in the continuation monad
_×Sum_ : ∀ {A B} → Sum A → Sum B → Sum (A × B)
(sumᴬ ×Sum sumᴮ) f = sumᴬ (λ x₀ →
                       sumᴮ (λ x₁ →
                         f (x₀ , x₁)))

infixr 4 _×μ_

_×μ_ : ∀ {A B} → SumPropoid A → SumPropoid B → SumPropoid (A ×-setoid B)
μA ×μ μB = _ , search-ind μA ×SearchInd search-ind μB

sum-const : ∀ {A} (μA : SumProp A) → ∀ k → sum μA (const k) ≡ Card μA * k
sum-const μA k
  rewrite ℕ°.*-comm (Card μA) k
        | ≡.sym (sum-lin μA (const 1) k)
        | proj₂ ℕ°.*-identity k = ≡.refl

infixr 4 _×Sum-proj₁_ _×Sum-proj₁'_ _×Sum-proj₂_ _×Sum-proj₂'_

_×Sum-proj₁_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₁) ≡ Card μB * sum μA f
(μA ×Sum-proj₁ μB) f
  rewrite sum-ext μA (sum-const μB ∘ f)
        = sum-lin μA f (Card μB)

_×Sum-proj₂_ : ∀ {A B}
                 (μA : SumProp A)
                 (μB : SumProp B)
                 f →
                 sum (μA ×μ μB) (f ∘ proj₂) ≡ Card μA * sum μB f
(μA ×Sum-proj₂ μB) f = sum-const μA (sum μB f)

_×Sum-proj₁'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μA f ≡ sum μA g →
                  sum (μA ×μ μB) (f ∘ proj₁) ≡ sum (μA ×μ μB) (g ∘ proj₁)
(μA ×Sum-proj₁' μB) {f} {g} sumf≡sumg
  rewrite (μA ×Sum-proj₁ μB) f
        | (μA ×Sum-proj₁ μB) g
        | sumf≡sumg = ≡.refl

_×Sum-proj₂'_ : ∀ {A B}
                  (μA : SumProp A) (μB : SumProp B)
                  {f} {g} →
                  sum μB f ≡ sum μB g →
                  sum (μA ×μ μB) (f ∘ proj₂) ≡ sum (μA ×μ μB) (g ∘ proj₂)
(μA ×Sum-proj₂' μB) sumf≡sumg = sum-ext μA (const sumf≡sumg)

μ-view : ∀ {A B} → (A FE.⟶ B) → SumPropoid A → SumPropoid B
μ-view {A}{B} A→B μA = searchᴮ , ind
  where
    searchᴮ : Search (Setoid.Carrier B)
    searchᴮ m f = search μA m (f ∘ _⟨$⟩_ A→B)

    ind : SearchInd searchᴮ
    ind P P∙ Pf = search-ind μA (λ s → P (λ _ f → s _ (f ∘ _⟨$⟩_ A→B))) P∙ (Pf ∘ _⟨$⟩_ A→B)

μ-iso : ∀ {A B} → (FI.Inverse A B) → SumPropoid A → SumPropoid B
μ-iso A↔B = μ-view (Inverse.to A↔B)

μ-view-preserve : ∀ {A B} (A→B : A FE.⟶ B)(B→A : B FE.⟶ A)(A≈B : A→B RightInverseOf B→A)
                  (f : A FE.⟶ ≡.setoid ℕ) (μA : SumPropoid A)
                → sum μA (_⟨$⟩_ f) ≡ sum (μ-view A→B μA) (_⟨$⟩_ (f FE.∘  B→A))
μ-view-preserve {A}{B} A→B B→A A≈B f μA = sum-ext μA (λ x → FE.cong f (Setoid.sym A (A≈B x) ))

μ-iso-preserve : ∀ {A B} (A↔B : A ↔ B) f (μA : SumProp A) → sum μA f ≡ sum (μ-iso A↔B μA) (f ∘ _⟨$⟩_ (Inverse.from A↔B))
μ-iso-preserve A↔B f μA = μ-view-preserve (Inverse.to A↔B) (Inverse.from A↔B)
                            (Inverse.left-inverse-of A↔B)
                          (≡.:→-to-Π f) μA

open import Data.Fin using (Fin; zero; suc)
open import Data.Vec.NP as Vec using (Vec; tabulate; _++_) renaming (map to vmap; sum to vsum; foldr to vfoldr; foldr₁ to vfoldr₁)

vmsum : ∀ m {n} → let open Mon m in
                  Vec C n → C
vmsum m = vfoldr _ _∙_ ε
  where open Monoid m

vsgsum : ∀ sg {n} → let open Sgrp sg in
                    Vec C (suc n) → C
vsgsum sg = vfoldr₁ _∙_
  where open Sgrp sg

-- let's recall that: tabulate f ≗ vmap f (allFin n)

-- searchMonFin : ∀ n → SearchMon (Fin n)
-- searchMonFin n m f = vmsum m (tabulate f)

searchFinSuc : ∀ n → Search (Fin (suc n))
searchFinSuc n _∙_ f = vfoldr₁ _∙_ (tabulate f)

μMaybe : ∀ {A} → SumProp A → SumProp (Maybe A)
μMaybe μA = srch , ind where
  srch : Search (Maybe _)
  srch _∙_ f = f nothing ∙ search μA _∙_ (f ∘ just)
  ind : SearchInd srch
  ind P _P∙_ Pf = Pf nothing
               P∙ search-ind μA (λ s → P (λ op f → s op (f ∘ just))  ) _P∙_ (Pf ∘ just)

μMaybeIso : ∀ {A} → SumProp A → SumProp (Maybe A)
μMaybeIso μA = μ-iso (FI.sym Maybe↔𝟙⊎ FI.∘ lift-⊎) (μ𝟙 +μ μA)

μMaybe^ : ∀ {A} n → SumProp A → SumProp (Maybe^ n A)
μMaybe^ zero    μA = μA
μMaybe^ (suc n) μA = μMaybe (μMaybe^ n μA)

μFinSuc : ∀ n → SumProp (Fin (suc n))
μFinSuc n = searchFinSuc n , ind n
  where ind : ∀ n → SearchInd (searchFinSuc n)
        ind zero    P P∙ Pf = Pf zero
        ind (suc n) P P∙ Pf = P∙ (Pf zero) (ind n (λ s → P (λ op f → s op (f ∘ suc))) P∙ (Pf ∘ suc))
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


record R (A : Set) : Set where
  constructor c₂
  field
    f : A → A

  g : A → A
  g x = f (f x)

open R public

_ : (@0 A : Set) → R A → A → A
_ = λ A → g {A = A}


module Everything where

open import Relation.Binary.Core

postulate A : Set
postulate _≤_ : A → A → Set
postulate tot≤ : Total _≤_
postulate trans≤ : Transitive _≤_

open import BBHeap.Everything _≤_ tot≤ trans≤

open import BHeap.Everything _≤_ tot≤

open import BTree.Complete.Alternative.Correctness {A}

open import BubbleSort.Everything _≤_ tot≤ trans≤

open import Heapsort.Everything _≤_ tot≤ trans≤

open import InsertSort.Everything _≤_ tot≤

open import List.Permutation.Base.Bag A

open import Mergesort.Everything _≤_ tot≤

open import PLRTree.Everything _≤_ tot≤ trans≤

open import Quicksort.Everything _≤_ tot≤ trans≤

open import SelectSort.Everything _≤_ tot≤ trans≤

open import TreeSort.Everything _≤_ tot≤ trans≤


module System.IO.Transducers.Properties where

open import System.IO.Transducers.Properties.Category public
open import System.IO.Transducers.Properties.Monoidal public
open import System.IO.Transducers.Properties.LaxBraided public
open import System.IO.Transducers.Properties.Equivalences public


module RMonads.Restriction where

open import Library
open import Categories
open import Functors
open import Naturals
open import Monads
open import RMonads

open Cat
open Fun

restrictM : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}(J : Fun C D) →
            Monad D → RMonad J
restrictM J M = record {
  T    = T ∘ OMap J;
  η    = η;
  bind = bind;
  law1 = law1;
  law2 = law2;
  law3 = law3}
  where open Monad M

open import Monads.MonadMorphs
open import RMonads.RMonadMorphs

restrictMM : ∀{a b c d}{C : Cat {a}{b}}{D : Cat {c}{d}}{M M' : Monad D}
             (J : Fun C D) → MonadMorph M M' →
             RMonadMorph (restrictM J M) (restrictM J M')
restrictMM J MM = record {
  morph   = λ{X} → morph {OMap J X};
  lawη    = lawη;
  lawbind = lawbind}
  where open MonadMorph MM
open import Adjunctions
open import RAdjunctions

restrictA : ∀{a b c d e f}{C : Cat {a}{b}}{D : Cat {c}{d}}{E : Cat {e}{f}}
            (J : Fun C D) → Adj D E → RAdj J E
restrictA J A = record{
  L        = L ○ J;
  R        = R;
  left     = left;
  right    = right;
  lawa     = lawa;
  lawb     = lawb;
  natleft  = natleft ∘ HMap J;
  natright = natright ∘ HMap J}
  where open Adj A


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

module Dodo.Binary.Filter where

-- Stdlib imports
import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; _≢_; refl; subst; cong; cong₂) renaming (sym to ≡-sym; trans to ≡-trans)
open import Level using (Level; _⊔_)
open import Data.Empty using (⊥)
open import Data.Product using (∃-syntax; _,_)
open import Relation.Unary using (Pred; _∈_)
open import Relation.Binary using (Rel; Transitive)
open import Relation.Binary.Construct.Closure.Transitive using (TransClosure; [_]; _∷_)
-- Local imports
open import Dodo.Unary.Equality
open import Dodo.Unary.Unique
open import Dodo.Binary.Equality
open import Dodo.Binary.Transitive

-- # Definitions

-- | A value of type `A` with a proof that it satisfies the given predicate `P`.
--
--
-- # Design Decision: Alternative to `P x`
--
-- One might argue that a function could just as well take:
-- > f : {x : A} → P x → ...
--
-- In that case, the `with-pred` constructor adds nothing. However, crucially,
-- the inhabitant of `A` is /not/ included in the type signature of `WithPred`.
-- This means, a relation may be defined over elements of type `WithPred`.
-- While a relation /cannot/ be defined over elements of type `P x`, because
-- `x` varies.
data WithPred {a ℓ : Level} {A : Set a} (P : Pred A ℓ) : Set (a ⊔ ℓ) where
  with-pred : (x : A) → P x → WithPred P

-- | Helper for extracting element equality from an instance of `WithPred`.
--
-- This is tricky to unify otherwise in larger contexts, as `Px` and `Py` have
-- different /types/ when `x` and `y` are unequal.
with-pred-≡ : ∀ {a ℓ : Level} {A : Set a} {P : Pred A ℓ} {x y : A} {Px : P x} {Py : P y}
  → with-pred x Px ≡ with-pred y Py
    -------------------------------
  → x ≡ y
with-pred-≡ refl = refl

-- | Instances of `WithPred` are equal if they are defined over the same value,
-- and its predicate is unique.
with-pred-unique : ∀ {a ℓ : Level} {A : Set a} {P : Pred A ℓ}
  → UniquePred P
  → {x y : A}
  → x ≡ y
  → (Px : P x) (Py : P y)
    -------------------------------
  → with-pred x Px ≡ with-pred y Py
with-pred-unique uniqueP {x} refl Px Py = cong (with-pred x) (uniqueP _ Px Py)

with-pred-≢ : ∀ {a ℓ : Level} {A : Set a} {P : Pred A ℓ}
  → UniquePred P
  → {x y : A} {Px : P x} {Py : P y}
  → with-pred x Px ≢ with-pred y Py
    -------------------------------
  → x ≢ y
with-pred-≢ uniqueP Px≢Py x≡y = Px≢Py (with-pred-unique uniqueP x≡y _ _)

-- | A relation whose elements all satisfy `P`.
--
-- Note that this differs from defining:
-- > R ∩₂ ( P ×₂ P )
--
-- In that case, the type signature is still identical to the type signature of
-- `R` (except for the universe level). However, `filter-rel` alters the type,
-- which proves no other inhabitants can exist.
--
-- This is in particular useful for properties that are declared over an entire
-- relation (such as `Trichotomous`), while they should only hold over a subset
-- of it.
--
--
-- # Example
--
-- For instance, consider:
-- (1) > Trichotomous _≡_ (filter-rel P R)
-- and
-- (2) > Trichotomous _≡_ (R ∩₂ ( P ×₂ P ))
--
-- Where the corresponding types are:
-- > R : Rel A ℓzero
-- > P : Pred A ℓzero
--
-- The type of the relation in (1) is then:
-- > filter-rel P R : Rel (WithPred P) ℓzero
-- While the type of the relation in (2) is:
-- > (R ∩₂ (P ×₂ P)) : Rel A ℓzero
--
-- So, for (2), defining `Trichotomous` means that it finds an instance of
-- `P` for both elements, even when no such `P x` exists; Which leads to a
-- contradiction. Whereas (1) will only find the relation if `P` holds for both
-- elements.
--
-- Effectively, (2) implies:
-- > ∀ (x : A) → P x
--
-- Whereas (1) makes no such strong claims.
filter-rel : ∀ {a ℓ₁ ℓ₂ : Level} {A : Set a}
  → (P : Pred A ℓ₁)
  → Rel A ℓ₂
    -------------------
  → Rel (WithPred P) ℓ₂
filter-rel P R (with-pred x Px) (with-pred y Py) = R x y

-- | Effectively the inverse of `filter-rel`.
--
-- It loses the type-level restrictions, but preserves the restrictions on
-- value-level.
unfilter-rel : ∀ {a ℓ₁ ℓ₂ : Level} {A : Set a}
  → {P : Pred A ℓ₁}
  → Rel (WithPred P) ℓ₂
    -------------------
  → Rel A (ℓ₁ ⊔ ℓ₂)
unfilter-rel R x y = ∃[ Px ] ∃[ Py ] R (with-pred x Px) (with-pred y Py)

-- | Helper for unwrapping the value from the `with-pred` constructor.
un-with-pred : {a ℓ : Level} {A : Set a} {P : Pred A ℓ}
  → WithPred P
    ----------
  → A
un-with-pred (with-pred x _) = x

⁺-strip-filter : {a ℓ₁ ℓ₂ : Level} {A : Set a}
  → {P : Pred A ℓ₁}
  → {R : Rel A ℓ₂}
  → {x y : A}
  → {Px : P x} {Py : P y}
  → TransClosure (filter-rel P R) (with-pred x Px) (with-pred y Py)
    ---------------------------------------------------------------
  → TransClosure R x y
⁺-strip-filter [ x∼y ] = [ x∼y ]
⁺-strip-filter (_∷_ {_} {with-pred z Pz} Rxz R⁺zy) = Rxz ∷ ⁺-strip-filter R⁺zy

-- | Apply a relation filter to a chain /from right to left/.
--
-- This applies when a predicate `P x` is true whenever `R x y` and `P y` are true.
-- Then, for any chain where `P` holds for the final element, it holds for every
-- element in the chain.
⁺-filter-relˡ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {R : Rel A ℓ₂}
  → (f : ∀ {x y : A} → P y → R x y → P x)
  → {x y : A}
  → (Px : P x) (Py : P y)
  → (R⁺xy : TransClosure R x y)
    ---------------------------------------------------------------
  → TransClosure (filter-rel P R) (with-pred x Px) (with-pred y Py)
⁺-filter-relˡ f Px Py [ Rxy ]        = [ Rxy ]
⁺-filter-relˡ f Px Py ( Rxz ∷ R⁺zy ) = Rxz ∷ ⁺-filter-relˡ f (⁺-predˡ f R⁺zy Py) Py R⁺zy

-- | Apply a relation filter to a chain /from left to right/.
--
-- This applies when a predicate `P y` is true whenever `R x y` and `P x` are true.
-- Then, for any chain where `P` holds for the first element, it holds for every
-- element in the chain.
⁺-filter-relʳ : {a ℓ₁ ℓ₂ : Level} {A : Set a} {P : Pred A ℓ₁} {R : Rel A ℓ₂}
  → (f : ∀ {x y : A} → P x → R x y → P y)
  → {x y : A}
  → (Px : P x) (Py : P y)
  → (R⁺xy : TransClosure R x y)
    ---------------------------------------------------------------
  → TransClosure (filter-rel P R) (with-pred x Px) (with-pred y Py)
⁺-filter-relʳ f Px Py [ Rxy ]        = [ Rxy ]
⁺-filter-relʳ f Px Py ( Rxz ∷ R⁺zy ) = Rxz ∷ ⁺-filter-relʳ f (f Px Rxz) Py R⁺zy

-- # Properties

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

  with-pred-⊆₁ :
      P ⊆₁ Q
    → WithPred P
      ----------
    → WithPred Q
  with-pred-⊆₁ P⊆Q (with-pred x Px) = with-pred x (⊆₁-apply P⊆Q Px)

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

  filter-rel-⊆₂ :
      (R : Rel A ℓ₁)
    → {P : Pred A ℓ₂}
      ----------------------------------
    → unfilter-rel (filter-rel P R) ⊆₂ R
  filter-rel-⊆₂ R {P} = ⊆: ⊆-proof
    where
    ⊆-proof : unfilter-rel (filter-rel P R) ⊆₂' R
    ⊆-proof _ _ (_ , _ , Rxy) = Rxy

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

  filter-rel-preserves-⊆₁ :
      P ⊆₁ Q
      --------------------------------------------------------------
    → unfilter-rel (filter-rel P R) ⊆₂ unfilter-rel (filter-rel Q R)
  filter-rel-preserves-⊆₁ P₁⊆P₂ = ⊆: lemma
    where
    lemma : unfilter-rel (filter-rel P R) ⊆₂' unfilter-rel (filter-rel Q R)
    lemma _ _ (P₁x , P₁y , Qxy) = (⊆₁-apply P₁⊆P₂ P₁x , ⊆₁-apply P₁⊆P₂ P₁y , Qxy)

  -- |
  --
  -- Note that this does /not/ hold in general for subsets of relations.
  -- That is, the following does /not/ hold:
  -- > Q ⊆₂ R → Transitive R → Transitive Q
  --
  -- After all, if `Q x y` and `Q y z` hold, then `R x y` and `R y z` hold,
  -- then `R x z` holds. However, it does not mean that `Q x z` holds.
  trans-filter-rel-⊆₁ :
      P ⊆₁ Q
    → Transitive (filter-rel Q R)
      ---------------------------
    → Transitive (filter-rel P R)
  trans-filter-rel-⊆₁ P⊆Q transQR {Pi} {Pj} {Pk} Rij Rjk =
    let Qi = with-pred-⊆₁ P⊆Q Pi
        Qj = with-pred-⊆₁ P⊆Q Pj
        Qk = with-pred-⊆₁ P⊆Q Pk
    in Q⇒P {Pi} {Pk} (transQR {Qi} {Qj} {Qk} (P⇒Q {Pi} {Pj} Rij) (P⇒Q {Pj} {Pk} Rjk))
    where
    P⇒Q : ∀ {x y : WithPred P} → filter-rel P R x y → filter-rel Q R (with-pred-⊆₁ P⊆Q x) (with-pred-⊆₁ P⊆Q y)
    P⇒Q {with-pred _ _} {with-pred _ _} Rxy = Rxy

    Q⇒P : ∀ {x y : WithPred P} → filter-rel Q R (with-pred-⊆₁ P⊆Q x) (with-pred-⊆₁ P⊆Q y) → filter-rel P R x y
    Q⇒P {with-pred _ _} {with-pred _ _} Rxy = Rxy

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

  filter-rel-preserved-⊆₂ :
      R ⊆₂ Q
      --------------------------------------------------------------
    → unfilter-rel (filter-rel P R) ⊆₂ unfilter-rel (filter-rel P Q)
  filter-rel-preserved-⊆₂ R⊆Q = ⊆: lemma
    where
    lemma : unfilter-rel (filter-rel P R) ⊆₂' unfilter-rel (filter-rel P Q)
    lemma x y (Px , Py , Rxy) = Px , Py , ⊆₂-apply R⊆Q Rxy

-- # Operations

module _ {a ℓ₁ ℓ₂ : Level} {A : Set a} {R : Rel A ℓ₁} {P : Pred A ℓ₂} {x y : A} where

  filter-rel-dom :
      unfilter-rel (filter-rel P R) x y
      ---------------------------------
    → x ∈ P
  filter-rel-dom (Px , Py , Rxy) = Px

  filter-rel-codom :
      unfilter-rel (filter-rel P R) x y
      ---------------------------------
    → y ∈ P
  filter-rel-codom (Px , Py , Rxy) = Py


------------------------------------------------------------------------------
-- Common FOL definitions
------------------------------------------------------------------------------

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

module Common.FOL where

infix  6 ∃
infix  4 _≡_
infixr 4 _,_

postulate D : Set

-- The existential quantifier type on D.
data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

-- The identity type on D.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x


-- 2012-02-22
module CorrectPrintingOfVariablesInSortCheckingForData where

data Bool : Set where
  true false : Bool

if_then_else_ : {A : Set2} → Bool → A → A → A
if true then a else b = a
if false then a else b = b

data foo : (y : Bool) → if y then Set else Set

data foo where
  bar : foo true

-- This should print
--   if y then Set else Set != Set of type Set₁
-- and not
--   if @0 then ...


-- Andreas, 2012-11-06 this has been fixed with issue 655
module Issue378 where

infix  7 _≡_
infixl 9 _+_

postulate
  ℕ    : Set
  _≡_  : ℕ → ℕ → Set
  zero : ℕ
  _+_  : ℕ → ℕ → ℕ

postulate
  S₁ : ∀ {m n o} → m ≡ n → m ≡ o → n ≡ o
  S₅ : ∀ n → zero + n ≡ n

-- Calling Auto on the hole generates the invalid expression
-- S₁ (S₅ .n) (S₅ .n).
refl : ∀ {n} → n ≡ n
refl = {!-m!}
-- C-c C-a should work now


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

module Function.Fiber where

open import Level
open import Data.Sigma.Base
open import Path
open import Cubical.Foundations.Everything using (fiber) public


{-# OPTIONS --cubical --safe #-}
module Issue4949 where

open import Agda.Builtin.Cubical.Path
open import Agda.Primitive.Cubical renaming (primIMax to _∨_)
open import Agda.Builtin.Unit
open import Agda.Builtin.Sigma

open import Agda.Builtin.Cubical.Glue renaming (prim^glue to glue)

idIsEquiv : ∀ {ℓ} (A : Set ℓ) → isEquiv (\ (x : A) → x)
equiv-proof (idIsEquiv A) y =
  ((y , \ _ → y) , λ z i → z .snd (primINeg i) , λ j → z .snd (primINeg i ∨ j))

idEquiv : ∀ {ℓ} (A : Set ℓ) → Σ _ (isEquiv {A = A} {B = A})
idEquiv A .fst = \ x → x
idEquiv A .snd = idIsEquiv A

Glue : ∀ {ℓ ℓ'} (A : Set ℓ) {φ : I}
       → (Te : Partial φ (Σ (Set ℓ') \ T → Σ _ (isEquiv {A = T} {B = A})))
       → Set ℓ'
Glue A Te = primGlue A (λ x → Te x .fst) (λ x → Te x .snd)

ua : ∀ {ℓ} {A B : Set ℓ} → A ≃ B → A ≡ B
ua {A = A} {B = B} e i = Glue B (λ { (i = i0) → (A , e)
                                   ; (i = i1) → (B , idEquiv B) })

⊤₀ = ⊤
⊤₁ = Σ ⊤ \ _ → ⊤

prf : isEquiv {A = ⊤₀} {B = ⊤₁} _
equiv-proof prf y = (_ , \ i → _) , (\ y → \ i → _ , (\ j → _))

u : ⊤₀ ≡ ⊤₁
u = ua ((λ _ → _) , prf)

uniq : ∀ i j → u (i ∨ j)
uniq i j = glue (λ { (i = i0) (j = i0) → tt ; (i = i1) → tt , tt ; (j = i1) → tt , tt }) _

-- comparing the partial element argument of `glue` should happen at the right type.
-- if it does not we get problems with eta.
test : ∀ j → uniq i0 j ≡ glue (λ { (i0 = i0) (j = i0) → tt ; (j = i1) → tt , tt }) (tt , tt)
test j = \ k → uniq i0 j


module STLC4 where

open import Data.Nat
open import Data.Nat.Properties using (≤-antisym; ≤-trans; ≰⇒>; ≤-step)
-- open import Data.List
open import Data.Empty using (⊥-elim)
open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; trans; cong; cong₂; subst)
open import Relation.Nullary.Decidable using (map)
open import Relation.Nullary
open import Data.Product

-- de Bruijn indexed lambda calculus
infix  5 ƛ_
infixl 7 _∙_
infix  9 var_

data Term : Set where
  var_  : (x : ℕ) → Term
  ƛ_    : Term → Term
  _∙_   :  Term → Term → Term

shift : (n i : ℕ) → Term → Term
shift free i (var x) with x ≥? free
shift free i (var x) | yes p = var (x + i) -- free
shift free i (var x) | no ¬p = var x -- bound
shift free i (ƛ M)   = ƛ shift (suc free) i M
shift free i (M ∙ N) = shift free i M ∙ shift free i N

infixl 10 _[_/_]
_[_/_] : Term → Term → ℕ → Term
(var x) [ N / i ] with compare x i
((var x) [ N / .(suc (x + k)) ])  | less .x k = var x
((var x) [ N / .x ])              | equal .x = shift 0 x N
((var .(suc (i + k))) [ N / i ])  | greater .i k = var (i + k)
(ƛ M)   [ N / i ] = ƛ (M [ N / suc i ])
(L ∙ M) [ N / i ] = L [ N / i ] ∙ M [ N / i ]

-- substitute the 0th var in M for N
infixl 10 _[_]
_[_] : Term → Term → Term
M [ N ] = M [ N / 0 ]

-- β reduction
infix 3 _β→_
data _β→_ : Term → Term → Set where

  β-ƛ-∙ : ∀ {M N} → ((ƛ M) ∙ N) β→ (M [ N ])

  β-ƛ : ∀ {M N} → M β→ N → ƛ M β→ ƛ N

  β-∙-l : ∀ {L M N} → M β→ N → M ∙ L β→ N ∙ L

  β-∙-r : ∀ {L M N} → M β→ N → L ∙ M β→ L ∙ N

module TransRefl where
  -- the reflexive and transitive closure of _β→_
  infix  2 _β→*_
  infixr 2 _→*_
  data _β→*_ : Term → Term → Set where

    ∎ : ∀ {M} → M β→* M

    _→*_
      : ∀ {L M N}
      → L β→ M
      → M β→* N
      --------------
      → L β→* N

  infixl 3 _<β>_
  _<β>_ : ∀ {M N O} → M β→* N → N β→* O → M β→* O
  _<β>_ {M} {.M} {O} ∎            N→O = N→O
  _<β>_ {M} {N}  {O} (L→M →* M→N) N→O = L→M →* M→N <β> N→O

  infixr 2 _→⟨⟩_
  _→⟨⟩_
    : ∀ {M}
    → ∀ N
    → N β→* M
    --------------
    → N β→* M
  M →⟨⟩ Q = Q

  infixr 2 _→⟨_⟩_
  _→⟨_⟩_
    : ∀ {M N}
    → ∀ L
    → L β→ M
    → M β→* N
    --------------
    → L β→* N
  L →⟨ P ⟩ Q = P →* Q

  infixr 2 _→*⟨_⟩_
  _→*⟨_⟩_
    : ∀ {M N}
    → ∀ L
    → L β→* M
    → M β→* N
    --------------
    → L β→* N
  L →*⟨ P ⟩ Q = P <β> Q

  infix 3 _→∎
  _→∎ : ∀ M → M β→* M
  M →∎ = ∎

  hop : ∀ {M N} → M β→ N → M β→* N
  hop {M} {N} M→N = M→N →* ∎

open TransRefl

-- the symmetric closure of _β→*_
module Eq where
  infix  1 _β≡_
  data _β≡_ : Term → Term → Set where
    β-sym : ∀ {M N}
        → M β→* N
        → N β→* M
        -------
        → M β≡ N

  infixr 2 _=*⟨_⟩_
  _=*⟨_⟩_
    : ∀ {M N}
    → ∀ L
    → L β≡ M
    → M β≡ N
    --------------
    → L β≡ N
  L =*⟨ β-sym A B ⟩ β-sym C D = β-sym (A <β> C) (D <β> B)

  infixr 2 _=*⟨⟩_
  _=*⟨⟩_
    : ∀ {N}
    → ∀ L
    → L β≡ N
    --------------
    → L β≡ N
  L =*⟨⟩ β-sym C D = β-sym C D

  infix 3 _=∎
  _=∎ : ∀ M → M β≡ M
  M =∎ = β-sym ∎ ∎

  forward : ∀ {M N} → M β≡ N → M β→* N
  forward (β-sym A _) = A

  backward : ∀ {M N} → M β≡ N → N β→* M
  backward (β-sym _ B) = B

module Example where

  test-1 : ƛ (ƛ var 1) ∙ var 0 β→* ƛ var 0
  test-1 =
          ƛ (ƛ var 1) ∙ var 0
      →⟨ β-ƛ β-ƛ-∙ ⟩
          ƛ var 0
      →∎

  test-0 : ƛ (ƛ var 0 ∙ var 1) ∙ (ƛ var 0 ∙ var 1) β→* ƛ var 0 ∙ var 0
  test-0 =
          ƛ (ƛ var 0 ∙ var 1) ∙ (ƛ var 0 ∙ var 1)
      →⟨ β-ƛ β-ƛ-∙ ⟩
          ƛ (var 0 ∙ var 1) [ ƛ var 0 ∙ var 1 ]
      →⟨⟩
          ƛ (var 0 ∙ var 1) [ ƛ var 0 ∙ var 1 / 0 ]
      →⟨⟩
          ƛ (var 0) [ ƛ var 0 ∙ var 1 / 0 ] ∙ (var 1) [ ƛ var 0 ∙ var 1 / 0 ]
      →⟨⟩
          ƛ shift 0 0 (ƛ var 0 ∙ var 1) ∙ var 0
      →⟨⟩
          ƛ (ƛ shift 1 0 (var 0 ∙ var 1)) ∙ var 0
      →⟨⟩
          ƛ (ƛ shift 1 0 (var 0) ∙ shift 1 0 (var 1)) ∙ var 0
      →⟨⟩
          ƛ ((ƛ var 0 ∙ var 1) ∙ var 0)
      →⟨ β-ƛ β-ƛ-∙ ⟩
          ƛ (var 0 ∙ var 1) [ var 0 / 0 ]
      →⟨⟩
          ƛ var 0 ∙ var 0
    →∎

  Z : Term
  Z = ƛ ƛ var 0

  SZ : Term
  SZ = ƛ ƛ var 1 ∙ var 0

  PLUS : Term
  PLUS = ƛ ƛ ƛ ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)

  test-2 : PLUS ∙ Z ∙ SZ β→* SZ
  test-2 =
      PLUS ∙ Z ∙ SZ
    →⟨ β-∙-l β-ƛ-∙ ⟩
      (ƛ ƛ ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 0 ] ∙ SZ
    →⟨⟩
      (ƛ ((ƛ ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 1 ])) ∙ SZ
    →⟨⟩
      (ƛ (ƛ (ƛ var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 2 ])) ∙ SZ
    →⟨⟩
      (ƛ (ƛ (ƛ ((var 3 ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)) [ ƛ ƛ var 0 / 3 ])))) ∙ SZ
    →⟨⟩
      (ƛ (ƛ (ƛ (ƛ (ƛ var 0)) ∙ var 1 ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
    →⟨ β-∙-l (β-ƛ (β-ƛ (β-ƛ (β-∙-l β-ƛ-∙)))) ⟩
      (ƛ (ƛ (ƛ (ƛ var 0) [ var 1 / 0 ] ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
    →⟨⟩
      (ƛ (ƛ (ƛ (ƛ (var 0) [ var 1 / 1 ]) ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
    →⟨⟩
      (ƛ (ƛ (ƛ (ƛ var 0) ∙ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
    →⟨ β-∙-l (β-ƛ (β-ƛ (β-ƛ β-ƛ-∙))) ⟩
      (ƛ (ƛ (ƛ (var 0) [ var 2 ∙ var 1 ∙ var 0 / 0 ]))) ∙ SZ
    →⟨⟩
      (ƛ (ƛ (ƛ (var 2 ∙ var 1 ∙ var 0)))) ∙ SZ
    →⟨ β-ƛ-∙ ⟩
      (ƛ (ƛ (var 2 ∙ var 1 ∙ var 0))) [ SZ / 0 ]
    →⟨⟩
      ƛ (ƛ (var 2 ∙ var 1 ∙ var 0) [ SZ / 2 ])
    →⟨⟩
      ƛ (ƛ shift 0 2 SZ ∙ var 1 ∙ var 0)
    →⟨⟩
      ƛ (ƛ (ƛ ƛ var 1 ∙ var 0) ∙ var 1 ∙ var 0)
    →⟨ β-ƛ (β-ƛ (β-∙-l β-ƛ-∙)) ⟩
      ƛ (ƛ (ƛ var 1 ∙ var 0) [ var 1 / 0 ] ∙ var 0)
    →⟨⟩
      ƛ (ƛ (ƛ ((var 1 ∙ var 0) [ var 1 / 1 ])) ∙ var 0)
    →⟨⟩
      ƛ (ƛ (ƛ ((var 1) [ var 1 / 1 ] ∙ (var 0) [ var 1 / 1 ])) ∙ var 0)
    →⟨⟩
      ƛ (ƛ (ƛ (shift 0 1 (var 1) ∙ var 0)) ∙ var 0)
    →⟨⟩
      ƛ (ƛ (ƛ (var 2 ∙ var 0)) ∙ var 0)
    →⟨ β-ƛ (β-ƛ β-ƛ-∙) ⟩
      ƛ (ƛ (var 2 ∙ var 0) [ var 0 / 0 ])
    →⟨⟩
      ƛ (ƛ (var 2) [ var 0 / 0 ] ∙ var 0)
    →⟨⟩
      ƛ (ƛ var 1 ∙ var 0)
    →∎

-- lemmas

cong-ƛ : {M N : Term} → M β→* N → ƛ M β→* ƛ N
cong-ƛ ∎            = ∎
cong-ƛ (M→N →* N→O) = β-ƛ M→N →* cong-ƛ N→O

cong-∙-l : {L M N : Term} → M β→* N → M ∙ L β→* N ∙ L
cong-∙-l ∎            = ∎
cong-∙-l (M→N →* N→O) = β-∙-l M→N →* cong-∙-l N→O

cong-∙-r : {L M N : Term} → M β→* N → L ∙ M β→* L ∙ N
cong-∙-r ∎            = ∎
cong-∙-r (M→N →* N→O) = β-∙-r M→N →* cong-∙-r N→O

-- shift-subst : ∀ freeM i n M N → (shift (suc (suc free)) i M) [ shift free i N / n ] β→* shift (suc free) i (M [ N / n ])
--
--      N  ---- shfit n   ---> N'
--      |                      |
--    M[_]          shfit n+2 [_]
--      |                      |
--    M[N] ---- shfit n+1 ---> N'
--
shift-subst : ∀ free i n M N → (shift (suc (suc free)) i M) [ shift free i N / n ] β→* shift (suc free) i (M [ N / n ])
shift-subst free i n (var x) N with compare x n
shift-subst free i .(suc (x + k)) (var x) N | less .x k with x ≥? suc free
shift-subst free i .(suc (x + k)) (var x) N | less .x k | yes p with suc (suc free) ≤? x
shift-subst free i .(suc (x + k)) (var x) N | less .x k | yes p | yes q = {!   !}
shift-subst free i .(suc (x + k)) (var x) N | less .x k | yes p | no ¬q = {!   !}
shift-subst free i .(suc (x + k)) (var x) N | less .x k | no ¬p = {!   !}
shift-subst free i n (var .n) N | equal .n = {!   !}
shift-subst free i n (var .(suc (n + k))) N | greater .n k = {!   !}
shift-subst free i n (ƛ M) N =
    ƛ (shift (suc (suc (suc free))) i M [ shift free i N / suc n ])
  →*⟨ cong-ƛ {! shift-subst (suc free) i (suc n) M N  !} ⟩
    {!   !}
  →*⟨ {!   !} ⟩
    ƛ (shift (suc (suc (suc free))) i M [ shift (suc free) i N / suc n ])
  →*⟨ cong-ƛ (shift-subst (suc free) i (suc n) M N) ⟩
    ƛ (shift (suc (suc free)) i (M [ N / suc n ]))
  →∎
shift-subst free i n (M ∙ L) N =
    shift (suc (suc free)) i M [ shift free i N / n ] ∙ shift (suc (suc free)) i L [ shift free i N / n ]
  →*⟨ cong-∙-l (shift-subst free i n M N) ⟩
    shift (suc free) i (M [ N / n ]) ∙ shift (suc (suc free)) i L [ shift free i N / n ]
  →*⟨ cong-∙-r (shift-subst free i n L N) ⟩
    shift (suc free) i (M [ N / n ]) ∙ shift (suc free) i (L [ N / n ])
  →∎

cong-shift-app0 : (free i : ℕ) → (M N : Term) → shift free i ((ƛ M) ∙ N) β→* shift free i (M [ N ])
cong-shift-app0 free i (var x) N = {!   !}
cong-shift-app0 free i (ƛ M) N =
    (ƛ (ƛ shift (suc (suc free)) i M)) ∙ shift free i N
  →*⟨ hop β-ƛ-∙ ⟩
    (ƛ shift (suc (suc free)) i M) [ shift free i N / 0 ]
  →⟨⟩
    ƛ (shift (suc (suc free)) i M) [ shift free i N / 1 ]
  →*⟨ cong-ƛ (shift-subst free i _ M N) ⟩
    ƛ shift (suc free) i (M [ N / 1 ])
  →∎
cong-shift-app0 free i (M ∙ L) N =
    (ƛ shift (suc free) i M ∙ shift (suc free) i L) ∙ shift free i N
  →*⟨ cong-∙-l {! cong-shift-app0 free i M L   !} ⟩
    {!   !} ∙ shift free i N
  →*⟨ {!   !} ⟩
    {!   !}
  →*⟨ {!   !} ⟩
    {!   !}
  →*⟨ {!   !} ⟩
    shift free i (M [ N ]) ∙ shift free i (L [ N ])
  →∎

-- cong-shift-app : (free i : ℕ) → (M N : Term) → shift free i ((ƛ M) ∙ N) β→* shift free i (M [ N ])
-- cong-shift-app free i (var x) (var y) = {!   !}
-- cong-shift-app free i (var x) (ƛ N)   = {!   !}
-- cong-shift-app free i (var x) (N ∙ O) = {!   !}
-- cong-shift-app free i (ƛ M)   (var y) = {!   !}
-- cong-shift-app free i (ƛ M)   (ƛ N)   = {!   !}
-- cong-shift-app free i (ƛ M)   (N ∙ O) = {!   !}
-- cong-shift-app free i (M ∙ L) (var y) = {!   !}
-- cong-shift-app free i (M ∙ L) (ƛ N)   = {!   !}
-- cong-shift-app free i (M ∙ L) (N ∙ O) = {!   !}

cong-shift : (free i : ℕ) → (M N : Term) → M β→ N → shift free i M β→* shift free i N
cong-shift free i (ƛ M) (ƛ N) (β-ƛ M→N) = cong-ƛ (cong-shift (suc free) i M N M→N)
cong-shift free i (.(ƛ M) ∙ N) .(M [ N / 0 ]) (β-ƛ-∙ {M}) = cong-shift-app0 free i M N
cong-shift free i (M ∙ L) .(N ∙ L) (β-∙-l {N = N} M→N) = cong-∙-l (cong-shift free i M N M→N)
cong-shift free i (M ∙ L) .(M ∙ N) (β-∙-r {N = N} M→N) = cong-∙-r (cong-shift free i L N M→N)

cong-[] : ∀ {i M N} (L : Term) → M β→ N → L [ M / i ] β→* L [ N / i ]
cong-[] {i} (var x) M→N with compare x i
cong-[] {.(suc (x + k))} (var x)              M→N | less .x k   = ∎
cong-[] {.x} {M} {N}     (var x)              M→N | equal .x    = cong-shift 0 x M N M→N
cong-[] {.m}             (var .(suc (m + k))) M→N | greater m k = ∎
cong-[] (ƛ L) M→N = cong-ƛ (cong-[] L M→N)
cong-[] {i} {M} {N} (L ∙ K) M→N =
    L [ M / i ] ∙ K [ M / i ]
  →*⟨ cong-∙-l (cong-[] L M→N) ⟩
    L [ N / i ] ∙ K [ M / i ]
  →*⟨ cong-∙-r (cong-[] K M→N) ⟩
    L [ N / i ] ∙ K [ N / i ]
  →∎

lemma : ∀ {M N O} → ƛ M β→ N → M [ O ] β→* N ∙ O
lemma {ƛ M}   (β-ƛ {N = ƛ N}   M→N) = {!   !}
lemma {M ∙ L} (β-ƛ {N = var x} M→N) = {!   !}
lemma {M ∙ L} (β-ƛ {N = ƛ N}   M→N) = {!   !}
lemma {M ∙ L} (β-ƛ {N = N ∙ K} M→N) = {!   !}

-- single-step
β→confluent : ∀ {M N O} → (M β→ N) → (M β→ O) → ∃ (λ P → (N β→* P) × (O β→* P))
β→confluent (β-ƛ-∙ {M} {N})         β-ƛ-∙               = M [ N ] , ∎ , ∎
β→confluent (β-ƛ-∙ {M} {N})         (β-∙-l {N = O} M→O) = {!   !}
  -- O ∙ N , lemma M→O , ∎
β→confluent (β-ƛ-∙ {M} {N})         (β-∙-r {N = O} M→O) = M [ O ] , cong-[] M M→O , hop β-ƛ-∙
β→confluent (β-ƛ   {M} {N}     M→N) (β-ƛ   {N = O} M→O) with β→confluent M→N M→O
β→confluent (β-ƛ   {M} {N}     M→N) (β-ƛ   {N = O} M→O) | P , N→P , O→P = ƛ P , cong-ƛ N→P , cong-ƛ O→P
β→confluent (β-∙-l {L} {N = N} M→N) (β-ƛ-∙ {M})         = N ∙ L , ∎ , lemma M→N
β→confluent (β-∙-l {L} {M} {N} M→N) (β-∙-l {N = O} M→O) with β→confluent M→N M→O
β→confluent (β-∙-l {L} {M} {N} M→N) (β-∙-l {N = O} M→O) | P , N→P , O→P = P ∙ L , cong-∙-l N→P , cong-∙-l O→P
β→confluent (β-∙-l {L} {M} {N} M→N) (β-∙-r {N = O} L→O) = N ∙ O , hop (β-∙-r L→O) , hop (β-∙-l M→N)
β→confluent (β-∙-r {M = M} {N} M→N) (β-ƛ-∙ {L})         = L [ N ] , (hop β-ƛ-∙) , cong-[] L M→N
β→confluent (β-∙-r {L} {M} {N} M→N) (β-∙-l {N = O} M→O) = O ∙ N , hop (β-∙-l M→O) , hop (β-∙-r M→N)
β→confluent (β-∙-r {M = M} {N} M→N) (β-∙-r {N = O} M→O) with β→confluent M→N M→O
β→confluent (β-∙-r {L} {M} {N} M→N) (β-∙-r {N = O} M→O) | P , N→P , O→P = (L ∙ P) , cong-∙-r N→P , cong-∙-r O→P

-- β→confluent : (M N O : Term) → (M β→ N) → (M β→ O) → ∃ (λ P → (N β→* P) × (O β→* P))
-- β→confluent .((ƛ _) ∙ _) ._           ._            β-ƛ-∙ β-ƛ-∙ = {!   !}
-- β→confluent .((ƛ _) ∙ _) ._           .(_ ∙ _)      β-ƛ-∙ (β-∙-l M→O) = {!   !}
-- β→confluent .((ƛ _) ∙ _) ._           .((ƛ _) ∙ _)  β-ƛ-∙ (β-∙-r M→O) = {!   !}
-- β→confluent .(ƛ _)       .(ƛ _)       .(ƛ _)        (β-ƛ M→N) (β-ƛ M→O) = {!   !}
-- β→confluent .((ƛ _) ∙ _) .(_ ∙ _)     ._            (β-∙-l M→N) β-ƛ-∙ = {!   !}
-- β→confluent .(_ ∙ _)     .(_ ∙ _)     .(_ ∙ _)      (β-∙-l M→N) (β-∙-l M→O) = {!   !}
-- β→confluent .(_ ∙ _)     .(_ ∙ _)     .(_ ∙ _)      (β-∙-l M→N) (β-∙-r M→O) = {!   !}
-- β→confluent .((ƛ _) ∙ _) .((ƛ _) ∙ _) ._            (β-∙-r M→N) β-ƛ-∙ = {!   !}
-- β→confluent .(_ ∙ _)     .(_ ∙ _)     .(_ ∙ _)      (β-∙-r M→N) (β-∙-l M→O) = {!   !}
-- β→confluent .(_ ∙ M)     .(_ ∙ N)     .(_ ∙ O)      (β-∙-r {M = M} {N} M→N) (β-∙-r {N = O} M→O) with β→confluent M N O M→N M→O
-- β→confluent .(_ ∙ M)     .(_ ∙ N)     .(_ ∙ O)      (β-∙-r {M = M} {N} M→N) (β-∙-r {N = O} M→O) | P , N→P , O→P = {!   !}


module NaturalAndLevelDifferent where

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

{-# BUILTIN NATURAL ℕ #-}
{-# BUILTIN LEVEL   ℕ #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Definitions of algebraic structures like monoids and rings
-- (packed in records together with sets, operations, etc.)
------------------------------------------------------------------------

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

module Algebra where

open import Algebra.Core public
open import Algebra.Definitions public
open import Algebra.Structures public
open import Algebra.Bundles public


module Issue778M (Param : Set) where

data Nat : Set where
  zero : Nat
  suc : Nat -> Nat

pred : Nat → Nat
pred = λ { zero → zero; (suc n) → n }
  where aux = zero


{-# OPTIONS --without-K #-}
module FT-Fin where

import Data.Fin as F
import Data.Nat as N

open import FT
open import FT-Nat using (toℕ)

------------------------------------------------------------------
-- Finite Types and the natural numbers are intimately related.
--
toFin : (b : FT) → F.Fin (N.suc (toℕ b))
toFin b = F.fromℕ (toℕ b)

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


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

module Data.Unit.Properties where

open import Data.Unit
open import Prelude

isProp⊤ : isProp ⊤
isProp⊤ _ _ = refl


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

module Data.List.Syntax where

open import Data.List
open import Prelude

open import Data.Vec.Sigma using () renaming (toList to [_]) public
open import Data.Vec.Sigma

[_][_] : ∀ n → Vec A n → List A
[ n ][ xs ] = toList {n = n} xs

-- record ListSyntax {a b} (A : Type a) (B : Type b) : Type (a ℓ⊔ b) where
--   field [_] : B → List A

-- open ListSyntax ⦃ ... ⦄ public

-- instance
--   cons : ⦃ _ : ListSyntax A B ⦄ →  ListSyntax A (A × B)
--   [_] ⦃ cons ⦄ (x , xs) = x ∷ [ xs ]

-- instance
--   sing : ListSyntax A A
--   [_] ⦃ sing ⦄ = _∷ []


module Basic.Compiler.SplitCode where

open import Basic.Compiler.Code
open import Basic.AST
open import Basic.BigStep
open import Utils.Monoid

open import Data.Vec hiding (_++_; [_]; _∷ʳ_)
open import Data.Bool renaming (if_then_else_ to ifBool_then_else_)
open import Data.Nat
open import Data.List hiding ([_])
open import Relation.Binary.PropositionalEquality
open import Function
open import Data.Product
open import Algebra
import Level as L

private
  module LM {a}{A : Set a} = Algebra.Monoid (Data.List.monoid A)

{-
Exercise 3.5

This code logically belongs to either Compiler.Code or Compiler.CorrectFrom.
It has its own module solely because it slows down typechecking for the module
it's in, which is rather annoying.
-}

▷*-split :
  ∀ {n}{s s' : State n}{e e'} c₁ {c₂}
  → (p : ⟨ c₁ <> c₂ , e , s ⟩▷*⟨ [] , e' , s' ⟩)
  → ∃₂ λ s'' e''
  → ∃₂ λ (p1 : ⟨ c₁ , e  , s    ⟩▷*⟨ [] , e'' , s'' ⟩)
         (p2 : ⟨ c₂ , e'' , s'' ⟩▷*⟨ [] , e'  , s'  ⟩)
  → ▷*-length p1 + ▷*-length p2 ≡ ▷*-length p

▷*-split []       p = _ , _ , done , p , refl
▷*-split (.ADD ∷ cs) (ADD a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , ADD a b ∷ p1 , p2 , cong suc eqn
▷*-split (.MUL ∷ cs) (MUL a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , MUL a b ∷ p1 , p2 , cong suc eqn
▷*-split (.SUB ∷ cs) (SUB a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , SUB a b ∷ p1 , p2 , cong suc eqn
▷*-split (.EQ ∷ cs) (EQ a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , EQ a b ∷ p1 , p2 , cong suc eqn
▷*-split (.LT ∷ cs) (LT a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , LT a b ∷ p1 , p2 , cong suc eqn
▷*-split (.LTE ∷ cs) (LTE a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , LTE a b ∷ p1 , p2 , cong suc eqn
▷*-split (.AND ∷ cs) (AND a b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , AND a b ∷ p1 , p2 , cong suc eqn
▷*-split (.(PUSH n₁) ∷ cs) (PUSH n₁ ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , PUSH n₁ ∷ p1 , p2 , cong suc eqn
▷*-split (.TRUE ∷ cs) (TRUE ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , TRUE ∷ p1 , p2 , cong suc eqn
▷*-split (.FALSE ∷ cs) (FALSE ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , FALSE ∷ p1 , p2 , cong suc eqn
▷*-split (.NOT ∷ cs) (NOT b ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , NOT b ∷ p1 , p2 , cong suc eqn
▷*-split (.(FETCH x) ∷ cs) (FETCH x ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , FETCH x ∷ p1 , p2 , cong suc eqn
▷*-split (.(STORE x) ∷ cs) (STORE x ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , STORE x ∷ p1 , p2 , cong suc eqn
▷*-split (.NOOP ∷ cs) (NOOP ∷ p) with ▷*-split cs p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , NOOP ∷ p1 , p2 , cong suc eqn
▷*-split (._ ∷ cs){c₂} (BRANCH{ca}{cb}{._}{t}{e} ∷ p)
  rewrite sym $ LM.assoc (ifBool t then ca else cb) cs c₂
  with ▷*-split ((ifBool t then ca else cb) <> cs) p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , BRANCH ∷ p1 , p2 , cong suc eqn
▷*-split (._ ∷ cs){c₁} (LOOP{ca}{cb}{._}{e}{s} ∷ p)
  rewrite sym $ LM.assoc ca (BRANCH (cb ∷ʳ LOOP ca cb) (NOOP ∷ []) ∷ cs) c₁
  with ▷*-split (ca <> (BRANCH (cb ∷ʳ LOOP ca cb) (NOOP ∷ []) ∷ cs)) p
... | s'' , e'' , p1 , p2 , eqn = s'' , e'' , LOOP ∷ p1 , p2 , cong suc eqn


module Properties.Contradiction where

data ⊥ : Set where

¬ : Set → Set
¬ A = A → ⊥

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


------------------------------------------------------------------------
-- A README directed towards readers of the paper
-- "Correct-by-Construction Pretty-Printing"
--
-- Nils Anders Danielsson
------------------------------------------------------------------------

{-# OPTIONS --guardedness #-}

module README.Correct-by-Construction-Pretty-Printing where

------------------------------------------------------------------------
-- 2: Grammars

-- The basic grammar data type, including its semantics. Only a small
-- number of derived combinators is defined directly for this data
-- type. It is proved that an inductive version of this type would be
-- quite restrictive.

import Grammar.Infinite.Basic

-- The extended grammar data type mentioned in Section 4.3, along with
-- a semantics and lots of derived combinators. This type is proved to
-- be no more expressive than the previous one; but it is also proved
-- that every language that can be recursively enumerated can be
-- represented by a (unit-valued) grammar.

import Grammar.Infinite

------------------------------------------------------------------------
-- 3: Pretty-Printers

import Pretty

------------------------------------------------------------------------
-- 4: Examples

-- Reusable document combinators introduced in this section.

import Pretty

-- The symbol combinator and the heuristic procedure
-- trailing-whitespace.

import Grammar.Infinite

-- 4.1: Boolean literals.

import Examples.Bool

-- 4.2: Expressions, and 4.3: Expressions, Take Two.

import Examples.Expression

-- 4.4: Identifiers.

import Examples.Identifier

-- 4.5: Other Examples.

-- Some of these examples are not mentioned in the paper.

-- Another expression example based on one in Matsuda and Wang's
-- "FliPpr: A Prettier Invertible Printing System".

import Examples.Expression

-- An example based on one in Swierstra and Chitil's "Linear, bounded,
-- functional pretty-printing".

import Examples.Identifier-list

-- Two examples, both based on examples in Wadler's "A prettier
-- printer".

import Examples.Tree
import Examples.XML

-- The fill combinator.

import Pretty

-- A general grammar and pretty-printer for binary operators of
-- various (not necessarily linearly ordered) precedences.

import Examples.Precedence

------------------------------------------------------------------------
-- 5: Renderers

import Renderer

-- Unambiguous and Parser.

import Grammar.Infinite


module Arity where

open import OscarPrelude

record Arity : Set
 where
  constructor ⟨_⟩
  field
    arity : Nat

open Arity public

instance EqArity : Eq Arity
Eq._==_ EqArity _ = decEq₁ (cong arity) ∘ (_≟_ on arity $ _)


module Data.Either.Proofs where

import      Lvl
open import Data
open import Data.Either as Either
open import Data.Either.Equiv
open import Function.Equals
open import Functional
open import Logic.Propositional
open import Logic.Predicate
open import Structure.Setoid
open import Structure.Function
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Function.Multi
open import Structure.Operator
open import Structure.Relator.Properties
open import Syntax.Transitivity
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓ₄ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑ₄ ℓₑ₅ ℓₑ₆ : Lvl.Level
private variable A B C A₁ A₂ A₃ B₁ B₂ B₃ : Type{ℓ}

module _ ⦃ equiv-C : Equiv{ℓₑ₃}(C) ⦄ where
  map1-values : {f : A → C}{g : B → C}{e : A ‖ B} → (∃(x ↦ map1 f g e ≡ f(x)) ∨ ∃(x ↦ map1 f g e ≡ g(x)))
  map1-values {e = Either.Left  a} = [∨]-introₗ ([∃]-intro a ⦃ reflexivity(_≡_) ⦄)
  map1-values {e = Either.Right b} = [∨]-introᵣ ([∃]-intro b ⦃ reflexivity(_≡_) ⦄)

module _ where
  module _ ⦃ _ : Equiv{ℓₑ}(A ‖ B) ⦄ where
    mapLeft-preserves-id : Names.Preserving₀ ⦃ [⊜]-equiv ⦄ (mapLeft {A₁ = A}{B = B})(id)(id)
    _⊜_.proof (mapLeft-preserves-id) {Left  x} = reflexivity(_≡_)
    _⊜_.proof (mapLeft-preserves-id) {Right x} = reflexivity(_≡_)

    mapRight-preserves-id : Names.Preserving₀ ⦃ [⊜]-equiv ⦄ (mapRight {A = A}{B₁ = B})(id)(id)
    _⊜_.proof (mapRight-preserves-id) {Left  x} = reflexivity(_≡_)
    _⊜_.proof (mapRight-preserves-id) {Right x} = reflexivity(_≡_)

    swap-involution : (Either.swap ∘ Either.swap {A = A}{B = B} ⊜ id)
    _⊜_.proof swap-involution {Left  _} = reflexivity(_≡_)
    _⊜_.proof swap-involution {Right _} = reflexivity(_≡_)

  module _ ⦃ _ : let _ = A₁ ; _ = A₂ ; _ = A₃ ; _ = B in Equiv{ℓₑ}(A₃ ‖ B) ⦄ {f : A₂ → A₃} {g : A₁ → A₂} where
    mapLeft-preserves-[∘] : (mapLeft(f ∘ g) ⊜ (mapLeft f) ∘ (mapLeft g))
    _⊜_.proof mapLeft-preserves-[∘] {Left  x} = reflexivity(_≡_)
    _⊜_.proof mapLeft-preserves-[∘] {Right x} = reflexivity(_≡_)

  module _ ⦃ _ : let _ = A ; _ = B₁ ; _ = B₂ ; _ = B₃ in Equiv{ℓₑ}(A ‖ B₃) ⦄ {f : B₂ → B₃} {g : B₁ → B₂} where
    mapRight-preserves-[∘] : (mapRight(f ∘ g) ⊜ (mapRight f) ∘ (mapRight g))
    _⊜_.proof mapRight-preserves-[∘] {Left  x} = reflexivity(_≡_)
    _⊜_.proof mapRight-preserves-[∘] {Right x} = reflexivity(_≡_)

  module _ ⦃ _ : Equiv{ℓₑ}(A ‖ B) ⦄ where
    map-preserves-id : (map id id ⊜ id)
    _⊜_.proof map-preserves-id {Left  x} = reflexivity(_≡_)
    _⊜_.proof map-preserves-id {Right x} = reflexivity(_≡_)

module _
  ⦃ equiv-A₁ : Equiv{ℓₑ₁}(A₁) ⦄
  ⦃ equiv-B₁ : Equiv{ℓₑ₂}(B₁) ⦄
  ⦃ equiv-A₂ : Equiv{ℓₑ₃}(A₂) ⦄
  ⦃ equiv-B₂ : Equiv{ℓₑ₄}(B₂) ⦄
  ⦃ equiv-AB₁ : Equiv{ℓₑ₅}(A₁ ‖ B₁) ⦄ ⦃ ext-AB₁ : Extensionality(equiv-AB₁) ⦄
  ⦃ equiv-AB₂ : Equiv{ℓₑ₆}(A₂ ‖ B₂) ⦄ ⦃ ext-AB₂ : Extensionality(equiv-AB₂) ⦄
  {f : A₁ → A₂}
  {g : B₁ → B₂}
  where

  open Extensionality ⦃ … ⦄

  instance
    map-function : BinaryOperator(Either.map {A₁ = A₁}{A₂ = A₂}{B₁ = B₁}{B₂ = B₂})
    _⊜_.proof (BinaryOperator.congruence map-function (intro p₁) (intro p₂)) {Left  _} = congruence₁(Left)  p₁
    _⊜_.proof (BinaryOperator.congruence map-function (intro p₁) (intro p₂)) {Right _} = congruence₁(Right) p₂

  instance
    map-injective : ⦃ inj-f : Injective(f) ⦄ → ⦃ inj-g : Injective(g) ⦄ → Injective(Either.map f g)
    Injective.proof map-injective {Left x}  {Left  y} p = congruence₁(Either.Left)  (injective(f) (injective(Either.Left)  p))
    Injective.proof map-injective {Left x}  {Right y} p with () ← Left-Right-inequality p
    Injective.proof map-injective {Right x} {Left  y} p with () ← Left-Right-inequality (symmetry(_≡_) p)
    Injective.proof map-injective {Right x} {Right y} p = congruence₁(Either.Right) (injective(g) (injective(Either.Right) p))

  instance
    map-surjective : ⦃ surj-f : Surjective(f) ⦄ → ⦃ surj-g : Surjective(g) ⦄ → Surjective(Either.map f g)
    Surjective.proof map-surjective {Left  y} with [∃]-intro x ⦃ p ⦄ ← surjective(f){y} = [∃]-intro (Left  x) ⦃ congruence₁(Left)  p ⦄
    Surjective.proof map-surjective {Right y} with [∃]-intro x ⦃ p ⦄ ← surjective(g){y} = [∃]-intro (Right x) ⦃ congruence₁(Right) p ⦄

  instance
    map-bijective : ⦃ bij-f : Bijective(f) ⦄ → ⦃ bij-g : Bijective(g) ⦄ → Bijective(Either.map f g)
    map-bijective = injective-surjective-to-bijective(Either.map f g) where
      instance
        inj-f : Injective(f)
        inj-f = bijective-to-injective(f)
      instance
        inj-g : Injective(g)
        inj-g = bijective-to-injective(g)
      instance
        surj-f : Surjective(f)
        surj-f = bijective-to-surjective(f)
      instance
        surj-g : Surjective(g)
        surj-g = bijective-to-surjective(g)

module _
  ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  ⦃ equiv-AB : Equiv{ℓₑ}(A ‖ B) ⦄ ⦃ ext-AB : Extensionality(equiv-AB) ⦄
  where

  map-mapLeft-mapRight : ∀{f : B → A}{g : C → B} → (map f g ≡ mapLeft f ∘ mapRight g)
  _⊜_.proof (map-mapLeft-mapRight) {[∨]-introₗ _} = reflexivity(_≡_)
  _⊜_.proof (map-mapLeft-mapRight) {[∨]-introᵣ _} = reflexivity(_≡_)

  instance
    map1-function : ⦃ equiv-C : Equiv{ℓₑ₃}(C) ⦄ → BinaryOperator{B = (A ‖ B) → C}(map1)
    _⊜_.proof (BinaryOperator.congruence map1-function (intro p₁) (intro p₂)) {Left  _} = p₁
    _⊜_.proof (BinaryOperator.congruence map1-function (intro p₁) (intro p₂)) {Right _} = p₂


module Type.Identity.Heterogenous where

import      Lvl
open import Type

data HId {ℓ} : ∀{A : Type{ℓ}}{B : Type{ℓ}} → A → B → Type{Lvl.𝐒(ℓ)} where
  instance intro : ∀{T : Type{ℓ}}{x : T} → HId x x


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

open import lib.Basics
open import lib.cubical.Square
open import lib.types.Bool
open import lib.types.Cofiber
open import lib.types.Lift
open import lib.types.Paths
open import lib.types.Pointed
open import lib.types.PushoutFmap
open import lib.types.Sigma
open import lib.types.Span
open import lib.types.Suspension
open import lib.types.Wedge

module lib.types.BigWedge where

module _ {i j} {A : Type i} where

  {- the function for cofiber -}
  bigwedge-f : (X : A → Ptd j) → A → Σ A (de⊙ ∘ X)
  bigwedge-f X a = a , pt (X a)

  bigwedge-span : (A → Ptd j) → Span
  bigwedge-span X = cofiber-span (bigwedge-f X)

  BigWedge : (A → Ptd j) → Type (lmax i j)
  BigWedge X = Cofiber (bigwedge-f X)

  bwbase : {X : A → Ptd j} → BigWedge X
  bwbase = cfbase

  bwin : {X : A → Ptd j} → (a : A) → de⊙ (X a) → BigWedge X
  bwin = curry cfcod

  ⊙BigWedge : (A → Ptd j) → Ptd (lmax i j)
  ⊙BigWedge X = ⊙[ BigWedge X , bwbase ]

  bwglue : {X : A → Ptd j} → (a : A) → bwbase {X} == bwin a (pt (X a))
  bwglue = cfglue

  ⊙bwin : {X : A → Ptd j} → (a : A) → X a ⊙→ ⊙BigWedge X
  ⊙bwin a = (bwin a , ! (bwglue a))

  module BigWedgeElim {X : A → Ptd j} {k} {P : BigWedge X → Type k}
    (base* : P bwbase) (in* : (a : A) (x : de⊙ (X a)) → P (bwin a x))
    (glue* : (a : A) → base* == in* a (pt (X a)) [ P ↓ bwglue a ])
    = CofiberElim {f = bigwedge-f X} {P = P} base* (uncurry in*) glue*

  BigWedge-elim = BigWedgeElim.f

  module BigWedgeRec {X : A → Ptd j} {k} {C : Type k}
    (base* : C) (in* : (a : A) → de⊙ (X a) → C)
    (glue* : (a : A) → base* == in* a (pt (X a)))
    = CofiberRec {f = bigwedge-f X} {C = C} base* (uncurry in*) glue*

module _ {i j₀ j₁} {A : Type i} {X₀ : A → Ptd j₀} {X₁ : A → Ptd j₁}
  (Xeq : ∀ a → X₀ a ⊙≃ X₁ a) where

  bigwedge-span-emap-r : SpanEquiv (cofiber-span (bigwedge-f X₀)) (cofiber-span (bigwedge-f X₁))
  bigwedge-span-emap-r = span-map (idf _) (Σ-fmap-r λ a → fst (⊙–> (Xeq a))) (idf _)
    (comm-sqr λ _ → idp) (comm-sqr λ a → pair= idp (⊙–>-pt (Xeq a))) ,
    idf-is-equiv _ , Σ-isemap-r (λ a → snd (Xeq a)) , idf-is-equiv _

  BigWedge-emap-r : BigWedge X₀ ≃ BigWedge X₁
  BigWedge-emap-r = Pushout-emap bigwedge-span-emap-r

  ⊙BigWedge-emap-r : ⊙BigWedge X₀ ⊙≃ ⊙BigWedge X₁
  ⊙BigWedge-emap-r = ≃-to-⊙≃ BigWedge-emap-r idp

module _ {i₀ i₁ j} {A₀ : Type i₀} {A₁ : Type i₁}
  (X : A₁ → Ptd j) (Aeq : A₀ ≃ A₁) where

  bigwedge-span-emap-l : SpanEquiv (cofiber-span (bigwedge-f (X ∘ –> Aeq))) (cofiber-span (bigwedge-f X))
  bigwedge-span-emap-l = span-map (idf _) (Σ-fmap-l (de⊙ ∘ X) (–> Aeq)) (–> Aeq)
    (comm-sqr λ _ → idp) (comm-sqr λ _ → idp) ,
    idf-is-equiv _ , Σ-isemap-l (de⊙ ∘ X) (snd Aeq) , snd Aeq

  BigWedge-emap-l : BigWedge (X ∘ –> Aeq) ≃ BigWedge X
  BigWedge-emap-l = Pushout-emap bigwedge-span-emap-l

  ⊙BigWedge-emap-l : ⊙BigWedge (X ∘ –> Aeq) ⊙≃ ⊙BigWedge X
  ⊙BigWedge-emap-l = ≃-to-⊙≃ BigWedge-emap-l idp

module _ {i} {A : Type i} (X : A → Ptd i) where

  extract-glue-from-BigWedge-is-const :
    ∀ bw → extract-glue {s = bigwedge-span X} bw == north
  extract-glue-from-BigWedge-is-const = BigWedge-elim
    idp
    (λ x y → ! (merid x))
    (↓-='-from-square ∘ λ x →
      ExtractGlue.glue-β x ∙v⊡
        tr-square (merid x)
      ⊡v∙ ! (ap-cst north (cfglue x)))

{- A BigWedge indexed by Bool is just a binary Wedge -}
module _ {i} (Pick : Bool → Ptd i) where

  BigWedge-Bool-equiv-Wedge : BigWedge Pick ≃ Wedge (Pick true) (Pick false)
  BigWedge-Bool-equiv-Wedge = equiv f g f-g g-f
    where
    module F = BigWedgeRec {X = Pick}
      {C = Wedge (Pick true) (Pick false)}
      (winl (pt (Pick true)))
      (λ {true → winl; false → winr})
      (λ {true → idp; false → wglue})

    module G = WedgeRec {X = Pick true} {Y = Pick false}
      {C = BigWedge Pick}
      (bwin true)
      (bwin false)
      (! (bwglue true) ∙ bwglue false)

    f = F.f
    g = G.f

    abstract
      f-g : ∀ w → f (g w) == w
      f-g = Wedge-elim
        (λ _ → idp)
        (λ _ → idp)
        (↓-∘=idf-in' f g $
          ap f (ap g wglue)
            =⟨ ap (ap f) G.glue-β ⟩
          ap f (! (bwglue true) ∙ bwglue false)
            =⟨ ap-∙ f (! (bwglue true)) (bwglue false) ⟩
          ap f (! (bwglue true)) ∙ ap f (bwglue false)
            =⟨ ap-! f (bwglue true)
               |in-ctx (λ w → w ∙ ap f (bwglue false)) ⟩
          ! (ap f (bwglue true)) ∙ ap f (bwglue false)
            =⟨ F.glue-β true
               |in-ctx (λ w → ! w ∙ ap f (bwglue false)) ⟩
          ap f (bwglue false)
            =⟨ F.glue-β false ⟩
          wglue =∎)

      g-f : ∀ bw → g (f bw) == bw
      g-f = BigWedge-elim
        (! (bwglue true))
        (λ {true → λ _ → idp; false → λ _ → idp})
        (λ {true → ↓-∘=idf-from-square g f $
              ap (ap g) (F.glue-β true) ∙v⊡
              bl-square (bwglue true);
            false → ↓-∘=idf-from-square g f $
              (ap (ap g) (F.glue-β false) ∙ G.glue-β) ∙v⊡
              lt-square (! (bwglue true)) ⊡h vid-square})


open import Everything

module Test.Test0 where

  test-functor-surjidentity : ∀
    {𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂}
    ⦃ functor : Functor 𝔬₁ 𝔯₁ ℓ₁ 𝔬₂ 𝔯₂ ℓ₂ ⦄
    (open Functor functor)
    → Surjidentity.type _∼₁_ _∼₂_ _∼̇₂_ functor-smap ε₁ ε₂
  test-functor-surjidentity = surjidentity

  -- test-functor-transextensionality ⦃ functor ⦄ = let open Functor ⦃ … ⦄ in transextensionality1


module Partiality where

{- port from http://www.soimort.org/posts/programs-and-proofs/ -}

open import Data.Bool using (Bool; false; true)
open import Data.Maybe using (Maybe; just; nothing)
open import Data.Char using (_==_) renaming (Char to Symbol)
open import Coinduction using (∞; ♯_; ♭)
-- open import Category.Monad.Partiality renaming (monad to PM)
-- open import Category.Monad using (RawMonad; module RawMonad)

data Expr : Set where
  var : Symbol → Expr
  lambda : Symbol → Expr → Expr
  app : Expr → Expr → Expr

data Function : Set where
  def : Expr → Function

mutual

  data Env : Set where
    ε : Env
    _↦_,_ : Symbol → Value → Env → Env

  data Value : Set where
    closure : Function → Env → Value
    exception : Value

lookup : Symbol → Env → Maybe Value
lookup sym ε = nothing
lookup sym (sym′ ↦ val , env) with sym == sym′
... | true = just val
... | false = lookup sym env

-- partiality monad
data _⊥ (A : Set) : Set where
  now : A → A ⊥
  later : ∞ (A ⊥) → A ⊥

return : {a : Set} → a → a ⊥
return = now

_>>=_ : {a b : Set} → a ⊥ → (a → b ⊥) → b ⊥
(now x) >>= f = f x
(later x) >>= f = later (♯ (♭ x >>= f))
infixl 40 _>>=_

{-# TERMINATING #-}
force : Value ⊥ → Value
force (now x) = x
force (later x) = force (♭ x)

mutual

  {-# TERMINATING #-} -- TODO: ???
  interp : Expr → Env → Value ⊥
  interp (var x) env with lookup x env
  ... | just val = now val
  ... | nothing = now exception
  interp (lambda x e) env = now (closure (def (lambda x e)) env)
  interp (app e₁ e₂) env = later (♯ apply (interp e₁ env) (interp e₂ env))

  apply : Value ⊥ → Value ⊥ → Value ⊥
  apply (later f) a = later (♯ apply (♭ f) a)
  apply (now (closure (def (lambda x e)) env)) a =
                               a >>= \a′ → interp e (x ↦ a′ , env)
    -- let open RawMonad PM in a >>= \a′ → interp e (x ↦ a′ , env)
  apply _ _ = now exception

e0 = ε
t1 = lambda 'a' (var 'a')
t2 = app (lambda 'x' (var 'x')) (lambda 'a' (var 'a'))
t3 = app (app (lambda 'f' (lambda 'x' (app (var 'f') (var 'x'))))
              (lambda 'a' (var 'a')))
         (lambda 'b' (var 'b'))
t4 = app (lambda 'x' (app (var 'x') (var 'x')))
         (lambda 'x' (app (var 'x') (var 'x')))

r1 = force (interp t1 e0)
r2 = force (interp t2 e0)
r3 = force (interp t3 e0)
r4 = force (interp t4 e0)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Coinductive vectors
------------------------------------------------------------------------

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

module Codata.Musical.Covec where

open import Codata.Musical.Notation
open import Codata.Musical.Conat as Coℕ using (Coℕ; zero; suc; _+_)
open import Codata.Musical.Cofin using (Cofin; zero; suc)
open import Codata.Musical.Colist as Colist using (Colist; []; _∷_)
open import Data.Nat.Base using (ℕ; zero; suc)
open import Data.Vec using (Vec; []; _∷_)
open import Data.Product using (_,_)
open import Function using (_∋_)
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as P using (_≡_)

------------------------------------------------------------------------
-- The type

infixr 5 _∷_
data Covec {a} (A : Set a) : Coℕ → Set a where
  []  : Covec A zero
  _∷_ : ∀ {n} (x : A) (xs : ∞ (Covec A (♭ n))) → Covec A (suc n)

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

 ∷-injectiveˡ : ∀ {a b} {n} {as bs} → (Covec A (suc n) ∋ a ∷ as) ≡ b ∷ bs → a ≡ b
 ∷-injectiveˡ P.refl = P.refl

 ∷-injectiveʳ : ∀ {a b} {n} {as bs} → (Covec A (suc n) ∋ a ∷ as) ≡ b ∷ bs → as ≡ bs
 ∷-injectiveʳ P.refl = P.refl

------------------------------------------------------------------------
-- Some operations

map : ∀ {a b} {A : Set a} {B : Set b} {n} → (A → B) → Covec A n → Covec B n
map f []       = []
map f (x ∷ xs) = f x ∷ ♯ map f (♭ xs)

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

 fromVec : ∀ {n} → Vec A n → Covec A (Coℕ.fromℕ n)
 fromVec []       = []
 fromVec (x ∷ xs) = x ∷ ♯ fromVec xs

 fromColist : (xs : Colist A) → Covec A (Colist.length xs)
 fromColist []       = []
 fromColist (x ∷ xs) = x ∷ ♯ fromColist (♭ xs)

 take : ∀ m {n} → Covec A (m + n) → Covec A m
 take zero    xs       = []
 take (suc n) (x ∷ xs) = x ∷ ♯ take (♭ n) (♭ xs)

 drop : ∀ m {n} → Covec A (Coℕ.fromℕ m + n) → Covec A n
 drop zero    xs       = xs
 drop (suc n) (x ∷ xs) = drop n (♭ xs)

 replicate : ∀ n → A → Covec A n
 replicate zero    x = []
 replicate (suc n) x = x ∷ ♯ replicate (♭ n) x

 lookup : ∀ {n} → Cofin n → Covec A n → A
 lookup zero    (x ∷ xs) = x
 lookup (suc n) (x ∷ xs) = lookup n (♭ xs)

 infixr 5 _++_

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

 [_] : A → Covec A (suc (♯ zero))
 [ x ] = x ∷ ♯ []

------------------------------------------------------------------------
-- Equality and other relations

-- xs ≈ ys means that xs and ys are equal.

 infix 4 _≈_

 data _≈_ : ∀ {n} (xs ys : Covec A n) → Set a where
   []  : [] ≈ []
   _∷_ : ∀ {n} x {xs ys}
         (xs≈ : ∞ (♭ xs ≈ ♭ ys)) → _≈_ {n = suc n} (x ∷ xs) (x ∷ ys)

-- x ∈ xs means that x is a member of xs.

 infix 4 _∈_

 data _∈_ : ∀ {n} → A → Covec A n → Set a where
   here  : ∀ {n x  } {xs}                   → _∈_ {n = suc n} x (x ∷ xs)
   there : ∀ {n x y} {xs} (x∈xs : x ∈ ♭ xs) → _∈_ {n = suc n} x (y ∷ xs)

-- xs ⊑ ys means that xs is a prefix of ys.

 infix 4 _⊑_

 data _⊑_ : ∀ {m n} → Covec A m → Covec A n → Set a where
   []  : ∀ {n} {ys : Covec A n} → [] ⊑ ys
   _∷_ : ∀ {m n} x {xs ys} (p : ∞ (♭ xs ⊑ ♭ ys)) →
         _⊑_ {m = suc m} {suc n} (x ∷ xs) (x ∷ ys)

------------------------------------------------------------------------
-- Some proofs

setoid : ∀ {a} → Set a → Coℕ → Setoid _ _
setoid A n = record
  { Carrier       = Covec A n
  ; _≈_           = _≈_
  ; isEquivalence = record
    { refl  = refl
    ; sym   = sym
    ; trans = trans
    }
  }
  where
  refl : ∀ {n} → Reflexive (_≈_ {n = n})
  refl {x = []}     = []
  refl {x = x ∷ xs} = x ∷ ♯ refl

  sym : ∀ {n} → Symmetric (_≈_ {A = A} {n})
  sym []        = []
  sym (x ∷ xs≈) = x ∷ ♯ sym (♭ xs≈)

  trans : ∀ {n} → Transitive (_≈_ {A = A} {n})
  trans []        []         = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

poset : ∀ {a} → Set a → Coℕ → Poset _ _ _
poset A n = record
  { Carrier        = Covec A n
  ; _≈_            = _≈_
  ; _≤_            = _⊑_
  ; isPartialOrder = record
    { isPreorder = record
      { isEquivalence = Setoid.isEquivalence (setoid A n)
      ; reflexive     = reflexive
      ; trans         = trans
      }
    ; antisym  = antisym
    }
  }
  where
  reflexive : ∀ {n} → _≈_ {n = n} ⇒ _⊑_
  reflexive []        = []
  reflexive (x ∷ xs≈) = x ∷ ♯ reflexive (♭ xs≈)

  trans : ∀ {n} → Transitive (_⊑_ {n = n})
  trans []        _          = []
  trans (x ∷ xs≈) (.x ∷ ys≈) = x ∷ ♯ trans (♭ xs≈) (♭ ys≈)

  tail : ∀ {n x y xs ys} →
         _∷_ {n = n} x xs ⊑ _∷_ {n = n} y ys → ♭ xs ⊑ ♭ ys
  tail (_ ∷ p) = ♭ p

  antisym : ∀ {n} → Antisymmetric (_≈_ {n = n}) _⊑_
  antisym []       [] = []
  antisym (x ∷ p₁) p₂ = x ∷ ♯ antisym (♭ p₁) (tail p₂)

map-cong : ∀ {a b} {A : Set a} {B : Set b} {n} (f : A → B) → _≈_ {n = n} =[ map f ]⇒ _≈_
map-cong f []        = []
map-cong f (x ∷ xs≈) = f x ∷ ♯ map-cong f (♭ xs≈)

take-⊑ : ∀ {a} {A : Set a} m {n} (xs : Covec A (m + n)) → take m xs ⊑ xs
take-⊑ zero    xs       = []
take-⊑ (suc n) (x ∷ xs) = x ∷ ♯ take-⊑ (♭ n) (♭ xs)

------------------------------------------------------------------------
-- Legacy

import Codata.Covec as C
open import Codata.Thunk
import Size

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

  fromMusical : ∀ {i n} → Covec A n → C.Covec A i (Coℕ.fromMusical n)
  fromMusical []       = C.[]
  fromMusical (x ∷ xs) = x C.∷ λ where .force → fromMusical (♭ xs)

  toMusical : ∀ {n} → C.Covec A Size.∞ n → Covec A (Coℕ.toMusical n)
  toMusical C.[]       = []
  toMusical (x C.∷ xs) = x ∷ ♯ toMusical (xs .force)


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommAlgebra.QuotientAlgebra where
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Powerset using (_∈_; _⊆_)
open import Cubical.Foundations.Structure

open import Cubical.HITs.SetQuotients hiding (_/_)
open import Cubical.Data.Unit
open import Cubical.Data.Sigma.Properties using (Σ≡Prop)

open import Cubical.Algebra.CommRing
import Cubical.Algebra.CommRing.QuotientRing as CommRing
import Cubical.Algebra.Ring.QuotientRing as Ring
open import Cubical.Algebra.CommRing.Ideal hiding (IdealsIn)
open import Cubical.Algebra.CommAlgebra
open import Cubical.Algebra.CommAlgebra.Ideal
open import Cubical.Algebra.CommAlgebra.Kernel
open import Cubical.Algebra.CommAlgebra.Instances.Unit
open import Cubical.Algebra.Algebra.Base using (IsAlgebraHom; isPropIsAlgebraHom)
open import Cubical.Algebra.Ring
open import Cubical.Algebra.Ring.Ideal using (isIdeal)
open import Cubical.Algebra.CommRingSolver.Reflection
open import Cubical.Algebra.Algebra.Properties
open AlgebraHoms using (compAlgebraHom)

private
  variable
    ℓ : Level

module _ {R : CommRing ℓ} (A : CommAlgebra R ℓ) (I : IdealsIn A) where
  open CommRingStr {{...}} hiding (_-_; -_; dist; ·Lid; ·Rdist+) renaming (_·_ to _·R_; _+_ to _+R_)
  open CommAlgebraStr {{...}}
  open RingTheory (CommRing→Ring (CommAlgebra→CommRing A)) using (-DistR·)
  instance
    _ : CommRingStr _
    _ = snd R
    _ : CommAlgebraStr _ _
    _ = snd A

  _/_ : CommAlgebra R ℓ
  _/_ = commAlgebraFromCommRing
           ((CommAlgebra→CommRing A) CommRing./ I)
           (λ r → elim (λ _ → squash/) (λ x → [ r ⋆ x ]) (eq r))
           (λ r s → elimProp (λ _ → squash/ _ _)
                             λ x i → [ ((r ·R s) ⋆ x ≡⟨ ⋆-assoc r s x ⟩
                                         r ⋆ (s ⋆ x) ∎) i ])
           (λ r s → elimProp (λ _ → squash/ _ _)
                             λ x i → [ ((r +R s) ⋆ x ≡⟨ ⋆-ldist r s x ⟩
                                       r ⋆ x + s ⋆ x ∎) i ])
           (λ r → elimProp2 (λ _ _ → squash/ _ _)
                            λ x y i → [ (r ⋆ (x + y)  ≡⟨ ⋆-rdist r x y ⟩
                                        r ⋆ x + r ⋆ y ∎) i ])
           (elimProp (λ _ → squash/ _ _)
                     (λ x i →  [ (1r ⋆ x ≡⟨ ⋆-lid x ⟩ x ∎) i ]))
           λ r → elimProp2 (λ _ _ → squash/ _ _)
                           λ x y i → [ ((r ⋆ x) · y ≡⟨ ⋆-lassoc r x y ⟩
                                       r ⋆ (x · y) ∎) i ]

          where
                open CommIdeal using (isCommIdeal)
                eq : (r : fst R) (x y : fst A) → x - y ∈ (fst I) →  [ r ⋆ x ] ≡ [ r ⋆ y ]
                eq r x y x-y∈I = eq/ _ _
                  (subst (λ u → u ∈ fst I)
                  ((r ⋆ 1a) · (x - y)               ≡⟨ ·Rdist+ (r ⋆ 1a) x (- y) ⟩
                    (r ⋆ 1a) · x + (r ⋆ 1a) · (- y) ≡[ i ]⟨ (r ⋆ 1a) · x + -DistR· (r ⋆ 1a) y i ⟩
                    (r ⋆ 1a) · x - (r ⋆ 1a) · y     ≡[ i ]⟨ ⋆-lassoc r 1a x i
                                                            - ⋆-lassoc r 1a y i ⟩
                    r ⋆ (1a · x) - r ⋆ (1a · y)     ≡[ i ]⟨ r ⋆ (·Lid x i) - r ⋆ (·Lid y i) ⟩
                    r ⋆ x - r ⋆ y ∎ )
                  (isCommIdeal.·Closed (snd I) _ x-y∈I))

  quotientHom : CommAlgebraHom A (_/_)
  fst quotientHom x = [ x ]
  IsAlgebraHom.pres0 (snd quotientHom) = refl
  IsAlgebraHom.pres1 (snd quotientHom) = refl
  IsAlgebraHom.pres+ (snd quotientHom) _ _ = refl
  IsAlgebraHom.pres· (snd quotientHom) _ _ = refl
  IsAlgebraHom.pres- (snd quotientHom) _ = refl
  IsAlgebraHom.pres⋆ (snd quotientHom) _ _ = refl

module _ {R : CommRing ℓ} (A : CommAlgebra R ℓ) (I : IdealsIn A) where
  open CommRingStr {{...}} hiding (_-_; -_; dist; ·Lid; ·Rdist+) renaming (_·_ to _·R_; _+_ to _+R_)
  open CommAlgebraStr ⦃...⦄

  instance
    _ : CommRingStr _
    _ = snd R
    _ : CommAlgebraStr _ _
    _ = snd A

  private
    LRing = CommAlgebra→Ring (A / I)
    RRing = (CommAlgebra→Ring A) Ring./ (CommIdeal→Ideal I)

  -- sanity check / maybe a helper function some day
  CommForget/ : RingEquiv (CommAlgebra→Ring (A / I)) ((CommAlgebra→Ring A) Ring./ (CommIdeal→Ideal I))
  fst CommForget/ =
    isoToEquiv
      (iso
        (rec (isSetRing LRing) (λ a → [ a ]) λ a b a-b∈I → eq/ a b a-b∈I)
        (rec (isSetRing RRing) (λ a → [ a ]) (λ a b a-b∈I → eq/ a b a-b∈I))
        (elimProp (λ _ → isSetRing LRing _ _) λ _ → refl)
        (elimProp (λ _ → isSetRing RRing _ _) (λ _ → refl)))
  IsRingHom.pres0 (snd CommForget/) = refl
  IsRingHom.pres1 (snd CommForget/) = refl
  IsRingHom.pres+ (snd CommForget/) = elimProp2 (λ _ _ → isSetRing RRing _ _) (λ _ _ → refl)
  IsRingHom.pres· (snd CommForget/) = elimProp2 (λ _ _ → isSetRing RRing _ _) (λ _ _ → refl)
  IsRingHom.pres- (snd CommForget/) = elimProp (λ _ → isSetRing RRing _ _) (λ _ → refl)

  open IsAlgebraHom
  inducedHom : (B : CommAlgebra R ℓ) (ϕ : CommAlgebraHom A B)
               → (fst I) ⊆ (fst (kernel A B ϕ))
               → CommAlgebraHom (A / I) B
  fst (inducedHom B ϕ I⊆kernel) =
    let open RingTheory (CommRing→Ring (CommAlgebra→CommRing B))
        instance
          _ : CommAlgebraStr R _
          _ = snd B
          _ : CommRingStr _
          _ = snd (CommAlgebra→CommRing B)
    in rec (isSetCommAlgebra B) (λ x → fst ϕ x)
        λ a b a-b∈I →
          equalByDifference
            (fst ϕ a) (fst ϕ b)
            ((fst ϕ a) - (fst ϕ b)     ≡⟨ cong (λ u → (fst ϕ a) + u) (sym (IsAlgebraHom.pres- (snd ϕ) _)) ⟩
             (fst ϕ a) + (fst ϕ (- b)) ≡⟨ sym (IsAlgebraHom.pres+ (snd ϕ) _ _) ⟩
             fst ϕ (a - b)             ≡⟨ I⊆kernel (a - b) a-b∈I ⟩
             0r ∎)
  pres0 (snd (inducedHom B ϕ kernel⊆I)) = pres0 (snd ϕ)
  pres1 (snd (inducedHom B ϕ kernel⊆I)) = pres1 (snd ϕ)
  pres+ (snd (inducedHom B ϕ kernel⊆I)) = elimProp2 (λ _ _ → isSetCommAlgebra B _ _) (pres+ (snd ϕ))
  pres· (snd (inducedHom B ϕ kernel⊆I)) = elimProp2 (λ _ _ → isSetCommAlgebra B _ _) (pres· (snd ϕ))
  pres- (snd (inducedHom B ϕ kernel⊆I)) = elimProp (λ _ → isSetCommAlgebra B _ _) (pres- (snd ϕ))
  pres⋆ (snd (inducedHom B ϕ kernel⊆I)) = λ r → elimProp (λ _ → isSetCommAlgebra B _ _) (pres⋆ (snd ϕ) r)

  injectivePrecomp : (B : CommAlgebra R ℓ) (f g : CommAlgebraHom (A / I) B)
                     → f ∘a (quotientHom A I) ≡ g ∘a (quotientHom A I)
                     → f ≡ g
  injectivePrecomp B f g p =
    Σ≡Prop
      (λ h → isPropIsAlgebraHom (CommRing→Ring R) (snd (CommAlgebra→Algebra (A / I))) h (snd (CommAlgebra→Algebra B)))
      (descendMapPath (fst f) (fst g) (isSetCommAlgebra B)
                      λ x → λ i → fst (p i) x)

{- trivial quotient -}
module _ {R : CommRing ℓ} (A : CommAlgebra R ℓ) where
  open CommAlgebraStr (snd A)

  oneIdealQuotient : CommAlgebraEquiv (A / (1Ideal A)) (UnitCommAlgebra R)
  fst oneIdealQuotient =
    isoToEquiv (iso (fst (terminalMap R (A / (1Ideal A))))
                    (λ _ → [ 0a ])
                    (λ _ → isPropUnit* _ _)
                    (elimProp (λ _ → squash/ _ _)
                              λ a → eq/ 0a a tt*))
  snd oneIdealQuotient = snd (terminalMap R (A / (1Ideal A)))

  zeroIdealQuotient : CommAlgebraEquiv A (A / (0Ideal A))
  fst zeroIdealQuotient =
    let open RingTheory (CommRing→Ring (CommAlgebra→CommRing A))
    in isoToEquiv (iso (fst (quotientHom A (0Ideal A)))
                    (rec (isSetCommAlgebra A) (λ x → x) λ x y x-y≡0 → equalByDifference x y x-y≡0)
                    (elimProp (λ _ → squash/ _ _) λ _ → refl)
                    λ _ → refl)
  snd zeroIdealQuotient = snd (quotientHom A (0Ideal A))

[_]/ : {R : CommRing ℓ} {A : CommAlgebra R ℓ} {I : IdealsIn A}
       → (a : fst A) → fst (A / I)
[ a ]/ = [ a ]

module _ {R : CommRing ℓ} (A : CommAlgebra R ℓ) (I : IdealsIn A) where
  open CommIdeal using (isPropIsCommIdeal)

  private
    π = quotientHom A I

  kernel≡I : kernel A (A / I) π ≡ I
  kernel≡I =
    kernel A (A / I) π ≡⟨ Σ≡Prop
                            (isPropIsCommIdeal (CommAlgebra→CommRing A))
                            refl ⟩
    _                  ≡⟨  CommRing.kernel≡I {R = CommAlgebra→CommRing A} I ⟩
    I ∎

private
  module _ (R : CommRing ℓ) where
    open CommRingStr (snd R)
    lemma : (y : (fst R)) → y ≡ y - 0r
    lemma = solve R

isZeroFromIdeal : {R : CommRing ℓ} {A : CommAlgebra R ℓ} {I : IdealsIn A}
                  → (x : ⟨ A ⟩) → x ∈ (fst I) → fst (quotientHom A I) x ≡ CommAlgebraStr.0a (snd (A / I))
isZeroFromIdeal {A = A} {I = I} x x∈I = eq/ x 0a (subst (λ y → y ∈ (fst I)) step x∈I )
  where
    open CommAlgebraStr (snd A)
    step : x ≡ x - 0a
    step = lemma (CommAlgebra→CommRing A) x
    0' : ⟨ A / I ⟩
    0' = fst (quotientHom A I) 0a


module Category.Monad.Either {i}(Exc : Set i)(I : Set i) where

open import Level hiding (lift)
open import Data.Sum

open import Category.Monad
open import Category.Monad.Predicate
open import Relation.Unary
open import Relation.Unary.PredicateTransformer

pattern left x = inj₁ x
pattern right x = inj₂ x

EitherT : Pt I i → Pt I i
EitherT M P = M (λ i → Exc ⊎ P i)

module EitherT {M : Pt I i}(Mon : RawPMonad {ℓ = i} M) where

  private module Mon = RawPMonad Mon

  -- right-biased sum
  open RawPMonad
  monad : RawPMonad {ℓ = i} (EitherT M)
  return? monad px = Mon.return? (right px)
  _=<?_ monad {P}{Q} f px = g Mon.=<? px
    where
      g : (λ i → Exc ⊎ P i) ⊆ EitherT M Q
      g (left x) = Mon.return? (left x)
      g (right y) = f y

  _recoverWith_ : ∀ {P i} → EitherT M P i → (∀ {i} → Exc → EitherT M P i) → EitherT M P i
  _recoverWith_ {P} c f = g Mon.=<? c
    where
      g : (λ i → Exc ⊎ P i) ⊆ EitherT M P
      g (left x) = f x
      g (right y) = Mon.return? (right y)

  lift : ∀ {P} → M P ⊆ EitherT M P
  lift x = (λ z → Mon.return? (right z)) Mon.=<? x


module UnSized.SimpleCell where

open import Data.Product
open import Data.String.Base

open import UnSizedIO.Object
open import UnSizedIO.IOObject
open import UnSizedIO.ConsoleObject

open import UnSizedIO.Base hiding (main)
open import UnSizedIO.Console hiding (main)

open import NativeIO

data CellMethod A : Set where
    get : CellMethod A
    put : A → CellMethod A

CellResult : ∀{A} → CellMethod A → Set
CellResult {A} get = A
CellResult (put _) = Unit

-- cellI is the interface of the object of a simple cell
cellI : (A : Set) → Interface
Method  (cellI A)    =  CellMethod A
Result  (cellI A) m  =  CellResult m

-- cellC is the type of consoleObjects with interface (cellI String)
CellC : Set
CellC = ConsoleObject (cellI String)

-- cellO is a program for a simple cell which
-- when get is called writes "getting s" for the string s of the object
-- and when putting s writes "putting s" for the string

-- cellP is constructor for the consoleObject for interface (cellI String)
cellP : (s : String) → CellC
force (method (cellP s) get) =
  exec' (putStrLn ("getting (" ++ s ++ ")")) λ _ →
  delay (return' (s , cellP s))
force (method (cellP s) (put x)) =
  exec' (putStrLn ("putting (" ++ x ++ ")")) λ _ →
  delay (return' (_ , (cellP x)))

-- Program is another program

program : String → IOConsole Unit
program arg =
  let c₀ = cellP "Start" in
  method c₀ get       >>= λ{ (s , c₁) →
  exec1 (putStrLn s)         >>
  method c₁ (put arg) >>= λ{ (_ , c₂) →
  method c₂ get       >>= λ{ (s' , c₃) →
  exec1 (putStrLn s')        }}}

main : NativeIO Unit
main = translateIOConsole (program "hello")