{-# OPTIONS --safe #-}

module Cubical.Data.SumFin.Properties where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv renaming (_∙ₑ_ to _⋆_)
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Function
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Unit
open import Cubical.Data.Bool
open import Cubical.Data.Nat
open import Cubical.Data.Nat.Order
import Cubical.Data.Fin as Fin
import Cubical.Data.Fin.LehmerCode as LehmerCode
open import Cubical.Data.SumFin.Base as SumFin
open import Cubical.Data.Sum
open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation as Prop

open import Cubical.Relation.Nullary

private
  variable
    ℓ : Level
    k : ℕ

SumFin→Fin : Fin k → Fin.Fin k
SumFin→Fin = SumFin.elim (λ {k} _ → Fin.Fin k) Fin.fzero Fin.fsuc

Fin→SumFin : Fin.Fin k → Fin k
Fin→SumFin = Fin.elim (λ {k} _ → Fin k) fzero fsuc

Fin→SumFin-fsuc : (fk : Fin.Fin k) → Fin→SumFin (Fin.fsuc fk) ≡ fsuc (Fin→SumFin fk)
Fin→SumFin-fsuc = Fin.elim-fsuc (λ {k} _ → Fin k) fzero fsuc

SumFin→Fin→SumFin : (fk : Fin k) → Fin→SumFin (SumFin→Fin fk) ≡ fk
SumFin→Fin→SumFin = SumFin.elim (λ fk → Fin→SumFin (SumFin→Fin fk) ≡ fk)
                                refl λ {k} {fk} eq →
  Fin→SumFin (Fin.fsuc (SumFin→Fin fk)) ≡⟨ Fin→SumFin-fsuc (SumFin→Fin fk) ⟩
  fsuc (Fin→SumFin (SumFin→Fin fk))     ≡⟨ cong fsuc eq ⟩
  fsuc fk                               ∎

Fin→SumFin→Fin : (fk : Fin.Fin k) → SumFin→Fin (Fin→SumFin fk) ≡ fk
Fin→SumFin→Fin = Fin.elim (λ fk → SumFin→Fin (Fin→SumFin fk) ≡ fk)
                          refl λ {k} {fk} eq →
  SumFin→Fin (Fin→SumFin (Fin.fsuc fk)) ≡⟨ cong SumFin→Fin (Fin→SumFin-fsuc fk) ⟩
  Fin.fsuc (SumFin→Fin (Fin→SumFin fk)) ≡⟨ cong Fin.fsuc eq ⟩
  Fin.fsuc fk                           ∎

SumFin≃Fin : ∀ k → Fin k ≃ Fin.Fin k
SumFin≃Fin _ =
  isoToEquiv (iso SumFin→Fin Fin→SumFin Fin→SumFin→Fin SumFin→Fin→SumFin)

SumFin≡Fin : ∀ k → Fin k ≡ Fin.Fin k
SumFin≡Fin k = ua (SumFin≃Fin k)

enum : (n : ℕ)(p : n < k) → Fin k
enum n p = Fin→SumFin (n , p)

enumElim : (P : Fin k → Type ℓ) → ((n : ℕ)(p : n < k) → P (enum _ p)) → (i : Fin k) → P i
enumElim P f i = subst P (SumFin→Fin→SumFin i) (f (SumFin→Fin i .fst) (SumFin→Fin i .snd))

-- Closure properties of SumFin under type constructors

SumFin⊎≃ : (m n : ℕ) → (Fin m ⊎ Fin n) ≃ (Fin (m + n))
SumFin⊎≃ 0 n = ⊎-swap-≃ ⋆ ⊎-⊥-≃
SumFin⊎≃ (suc m) n = ⊎-assoc-≃ ⋆ ⊎-equiv (idEquiv ⊤) (SumFin⊎≃ m n)

SumFinΣ≃ : (n : ℕ)(f : Fin n → ℕ) → (Σ (Fin n) (λ x → Fin (f x))) ≃ (Fin (totalSum f))
SumFinΣ≃ 0 f = ΣEmpty _
SumFinΣ≃ (suc n) f =
    Σ⊎≃
  ⋆ ⊎-equiv (ΣUnit (λ tt → Fin (f (inl tt)))) (SumFinΣ≃ n (λ x → f (inr x)))
  ⋆ SumFin⊎≃ (f (inl tt)) (totalSum (λ x → f (inr x)))

SumFin×≃ : (m n : ℕ) → (Fin m × Fin n) ≃ (Fin (m · n))
SumFin×≃ m n = SumFinΣ≃ m (λ _ → n) ⋆ pathToEquiv (λ i → Fin (totalSumConst {m = m} n i))

SumFinΠ≃ : (n : ℕ)(f : Fin n → ℕ) → ((x : Fin n) → Fin (f x)) ≃ (Fin (totalProd f))
SumFinΠ≃ 0 _ = isContr→≃Unit (isContrΠ⊥) ⋆ invEquiv (⊎-⊥-≃)
SumFinΠ≃ (suc n) f =
    Π⊎≃
  ⋆ Σ-cong-equiv (ΠUnit (λ tt → Fin (f (inl tt)))) (λ _ → SumFinΠ≃ n (λ x → f (inr x)))
  ⋆ SumFin×≃ (f (inl tt)) (totalProd (λ x → f (inr x)))

isNotZero : ℕ → ℕ
isNotZero 0 = 0
isNotZero (suc n) = 1

SumFin∥∥≃ : (n : ℕ) → ∥ Fin n ∥ ≃ Fin (isNotZero n)
SumFin∥∥≃ 0 = propTruncIdempotent≃ (isProp⊥)
SumFin∥∥≃ (suc n) =
    isContr→≃Unit (inhProp→isContr ∣ inl tt ∣ isPropPropTrunc)
  ⋆ isContr→≃Unit (isContrUnit) ⋆ invEquiv (⊎-⊥-≃)

ℕ→Bool : ℕ → Bool
ℕ→Bool 0 = false
ℕ→Bool (suc n) = true

SumFin∥∥DecProp : (n : ℕ) → ∥ Fin n ∥ ≃ Bool→Type (ℕ→Bool n)
SumFin∥∥DecProp 0 = uninhabEquiv (Prop.rec isProp⊥ ⊥.rec) ⊥.rec
SumFin∥∥DecProp (suc n) = isContr→≃Unit (inhProp→isContr ∣ inl tt ∣ isPropPropTrunc)

-- negation of SumFin

SumFin¬ : (n : ℕ) → (¬ Fin n) ≃ Bool→Type (isZero n)
SumFin¬ 0 = isContr→≃Unit isContr⊥→A
SumFin¬ (suc n) = uninhabEquiv (λ f → f fzero) ⊥.rec

-- SumFin 1 is equivalent to unit

Fin1≃Unit : Fin 1 ≃ Unit
Fin1≃Unit = ⊎-⊥-≃

isContrSumFin1 : isContr (Fin 1)
isContrSumFin1 = isOfHLevelRespectEquiv 0 (invEquiv Fin1≃Unit) isContrUnit

-- SumFin 2 is equivalent to Bool

SumFin2≃Bool : Fin 2 ≃ Bool
SumFin2≃Bool = ⊎-equiv (idEquiv _) ⊎-⊥-≃ ⋆ isoToEquiv Iso-⊤⊎⊤-Bool

-- decidable predicate over SumFin

SumFinℙ≃ : (n : ℕ) → (Fin n → Bool) ≃ Fin (2 ^ n)
SumFinℙ≃ 0 = isContr→≃Unit (isContrΠ⊥) ⋆ invEquiv (⊎-⊥-≃)
SumFinℙ≃ (suc n) =
    Π⊎≃
  ⋆ Σ-cong-equiv (UnitToType≃ Bool ⋆ invEquiv SumFin2≃Bool) (λ _ → SumFinℙ≃ n)
  ⋆ SumFin×≃ 2 (2 ^ n)

-- decidable subsets of SumFin

Bool→ℕ : Bool → ℕ
Bool→ℕ true = 1
Bool→ℕ false = 0

trueCount : {n : ℕ}(f : Fin n → Bool) → ℕ
trueCount {n = 0} _ = 0
trueCount {n = suc n} f = Bool→ℕ (f (inl tt)) + (trueCount (f ∘ inr))

SumFinDec⊎≃ : (n : ℕ)(t : Bool) → (Bool→Type t ⊎ Fin n) ≃ (Fin (Bool→ℕ t + n))
SumFinDec⊎≃ _ true = idEquiv _
SumFinDec⊎≃ _ false = ⊎-swap-≃ ⋆ ⊎-⊥-≃

SumFinSub≃ : (n : ℕ)(f : Fin n → Bool) → Σ _ (Bool→Type ∘ f) ≃ Fin (trueCount f)
SumFinSub≃ 0 _ = ΣEmpty _
SumFinSub≃ (suc n) f =
    Σ⊎≃
  ⋆ ⊎-equiv (ΣUnit (Bool→Type ∘ f ∘ inl)) (SumFinSub≃ n (f ∘ inr))
  ⋆ SumFinDec⊎≃ _ (f (inl tt))

-- decidable quantifier

trueForSome : (n : ℕ)(f : Fin n → Bool) → Bool
trueForSome 0 _ = false
trueForSome (suc n) f = f (inl tt) or trueForSome n (f ∘ inr)

trueForAll : (n : ℕ)(f : Fin n → Bool) → Bool
trueForAll 0 _ = true
trueForAll (suc n) f = f (inl tt) and trueForAll n (f ∘ inr)

SumFin∃→ : (n : ℕ)(f : Fin n → Bool) → Σ _ (Bool→Type ∘ f) → Bool→Type (trueForSome n f)
SumFin∃→ 0 _ = ΣEmpty _ .fst
SumFin∃→ (suc n) f =
    Bool→Type⊎' _ _
  ∘ map-⊎ (ΣUnit (Bool→Type ∘ f ∘ inl) .fst) (SumFin∃→ n (f ∘ inr))
  ∘ Σ⊎≃ .fst

SumFin∃← : (n : ℕ)(f : Fin n → Bool) → Bool→Type (trueForSome n f) → Σ _ (Bool→Type ∘ f)
SumFin∃← 0 _ = ⊥.rec
SumFin∃← (suc n) f =
    invEq Σ⊎≃
  ∘ map-⊎ (invEq (ΣUnit (Bool→Type ∘ f ∘ inl))) (SumFin∃← n (f ∘ inr))
  ∘ Bool→Type⊎ _ _

SumFin∃≃ : (n : ℕ)(f : Fin n → Bool) → ∥ Σ (Fin n) (Bool→Type ∘ f) ∥ ≃ Bool→Type (trueForSome n f)
SumFin∃≃ n f =
  propBiimpl→Equiv isPropPropTrunc isPropBool→Type
    (Prop.rec isPropBool→Type (SumFin∃→ n f))
    (∣_∣ ∘ SumFin∃← n f)

SumFin∀≃ : (n : ℕ)(f : Fin n → Bool) → ((x : Fin n) → Bool→Type (f x)) ≃ Bool→Type (trueForAll n f)
SumFin∀≃ 0 _ = isContr→≃Unit (isContrΠ⊥)
SumFin∀≃ (suc n) f =
    Π⊎≃
  ⋆ Σ-cong-equiv (ΠUnit (Bool→Type ∘ f ∘ inl)) (λ _ → SumFin∀≃ n (f ∘ inr))
  ⋆ Bool→Type×≃ _ _

-- internal equality

SumFin≡ : (n : ℕ) → (a b : Fin n) → Bool
SumFin≡ 0 _ _ = true
SumFin≡ (suc n) (inl tt) (inl tt) = true
SumFin≡ (suc n) (inl tt) (inr y) = false
SumFin≡ (suc n) (inr x) (inl tt) = false
SumFin≡ (suc n) (inr x) (inr y) = SumFin≡ n x y

isSetSumFin : (n : ℕ)→ isSet (Fin n)
isSetSumFin 0 = isProp→isSet isProp⊥
isSetSumFin (suc n) = isSet⊎ (isProp→isSet isPropUnit) (isSetSumFin n)

SumFin≡≃ : (n : ℕ) → (a b : Fin n) → (a ≡ b) ≃ Bool→Type (SumFin≡ n a b)
SumFin≡≃ 0 _ _ = isContr→≃Unit (isProp→isContrPath isProp⊥ _ _)
SumFin≡≃ (suc n) (inl tt) (inl tt) = isContr→≃Unit (inhProp→isContr refl (isSetSumFin _ _ _))
SumFin≡≃ (suc n) (inl tt) (inr y) = invEquiv (⊎Path.Cover≃Path _ _) ⋆ uninhabEquiv ⊥.rec* ⊥.rec
SumFin≡≃ (suc n) (inr x) (inl tt) = invEquiv (⊎Path.Cover≃Path _ _) ⋆ uninhabEquiv ⊥.rec* ⊥.rec
SumFin≡≃ (suc n) (inr x) (inr y) = invEquiv (_ , isEmbedding-inr x y) ⋆ SumFin≡≃ n x y

-- propositional truncation of Fin

-- decidability of Fin

DecFin : (n : ℕ) → Dec (Fin n)
DecFin 0 = no (idfun _)
DecFin (suc n) = yes fzero

-- propositional truncation of Fin

Dec∥Fin∥ : (n : ℕ) → Dec ∥ Fin n ∥
Dec∥Fin∥ n = Dec∥∥ (DecFin n)

-- some properties about cardinality

fzero≠fone : {n : ℕ} → ¬ (fzero ≡ fsuc fzero)
fzero≠fone {n = n} = SumFin≡≃ (suc (suc n)) fzero (fsuc fzero) .fst

Fin>0→isInhab : (n : ℕ) → 0 < n → Fin n
Fin>0→isInhab 0 p = ⊥.rec (¬-<-zero p)
Fin>0→isInhab (suc n) p = fzero

Fin>1→hasNonEqualTerm : (n : ℕ) → 1 < n → Σ[ i ∈ Fin n ] Σ[ j ∈ Fin n ] ¬ i ≡ j
Fin>1→hasNonEqualTerm 0 p = ⊥.rec (snotz (≤0→≡0 p))
Fin>1→hasNonEqualTerm 1 p = ⊥.rec (snotz (≤0→≡0 (pred-≤-pred p)))
Fin>1→hasNonEqualTerm (suc (suc n)) _ = fzero , fsuc fzero , fzero≠fone

isEmpty→Fin≡0 : (n : ℕ) → ¬ Fin n → 0 ≡ n
isEmpty→Fin≡0 0 _ = refl
isEmpty→Fin≡0 (suc n) p = ⊥.rec (p fzero)

isInhab→Fin>0 : (n : ℕ) → Fin n → 0 < n
isInhab→Fin>0 0 i = ⊥.rec i
isInhab→Fin>0 (suc n) _ = suc-≤-suc zero-≤

hasNonEqualTerm→Fin>1 : (n : ℕ) → (i j : Fin n) → ¬ i ≡ j → 1 < n
hasNonEqualTerm→Fin>1 0 i _ _ = ⊥.rec i
hasNonEqualTerm→Fin>1 1 i j p = ⊥.rec (p (isContr→isProp isContrSumFin1 i j))
hasNonEqualTerm→Fin>1 (suc (suc n)) _ _ _ = suc-≤-suc (suc-≤-suc zero-≤)

Fin≤1→isProp : (n : ℕ) → n ≤ 1 → isProp (Fin n)
Fin≤1→isProp 0 _ = isProp⊥
Fin≤1→isProp 1 _ = isContr→isProp isContrSumFin1
Fin≤1→isProp (suc (suc n)) p = ⊥.rec (¬-<-zero (pred-≤-pred p))

isProp→Fin≤1 : (n : ℕ) → isProp (Fin n) → n ≤ 1
isProp→Fin≤1 0 _ = ≤-solver 0 1
isProp→Fin≤1 1 _ = ≤-solver 1 1
isProp→Fin≤1 (suc (suc n)) p = ⊥.rec (fzero≠fone (p fzero (fsuc fzero)))

-- automorphisms of SumFin

SumFin≃≃ : (n : ℕ) → (Fin n ≃ Fin n) ≃ Fin (LehmerCode.factorial n)
SumFin≃≃ _ =
    equivComp (SumFin≃Fin _) (SumFin≃Fin _)
  ⋆ LehmerCode.lehmerEquiv
  ⋆ LehmerCode.lehmerFinEquiv
  ⋆ invEquiv (SumFin≃Fin _)


module Generic.Lib.Data.List where

open import Data.List.Base hiding ([]) renaming (fromMaybe to maybeToList) public
open List public

open import Generic.Lib.Intro
open import Generic.Lib.Equality.Propositional
open import Generic.Lib.Decidable
open import Generic.Lib.Category
open import Generic.Lib.Data.Nat
open import Generic.Lib.Data.Maybe
open import Generic.Lib.Data.Sum
open import Generic.Lib.Data.Product

import Data.List.Categorical as List

infix 4 _∈_

foldr₁ : ∀ {α} {A : Set α} -> (A -> A -> A) -> A -> List A -> A
foldr₁ f z  []          = z
foldr₁ f z (x ∷ [])     = x
foldr₁ f z (x ∷ y ∷ xs) = f x (foldr₁ f z (y ∷ xs))

mapInd : ∀ {α β} {A : Set α} {B : Set β} -> (ℕ -> A -> B) -> List A -> List B
mapInd f  []      = []
mapInd f (x ∷ xs) = f 0 x ∷ mapInd (f ∘ suc) xs

mapM : ∀ {α β} {A : Set α} {B : Set β} {M : Set β -> Set β} {{mMonad : RawMonad M}}
     -> (A -> M B) -> List A -> M (List B)
mapM {{mMonad}} = List.TraversableM.mapM mMonad

downFromTo : ℕ -> ℕ -> List ℕ
downFromTo n m = map (m +_) (downFrom (n ∸ m))

Any : ∀ {α β} {A : Set α} -> (A -> Set β) -> List A -> Set β
Any B  []      = ⊥
Any B (x ∷ []) = B x
Any B (x ∷ xs) = B x ⊎ Any B xs

_∈_ : ∀ {α} {A : Set α} -> A -> List A -> Set
x ∈ xs = Any (x ≡_) xs

here : ∀ {α β} {A : Set α} {B : A -> Set β} {x} xs -> B x -> Any B (x ∷ xs)
here  []      y = y
here (x ∷ xs) y = inj₁ y

phere : ∀ {α} {A : Set α} {x : A} xs -> x ∈ x ∷ xs
phere xs = here xs refl

there : ∀ {α β} {A : Set α} {B : A -> Set β} {x} xs -> Any B xs -> Any B (x ∷ xs)
there  []      ()
there (x ∷ xs) a  = inj₂ a

mapAny : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ}
       -> ∀ xs -> (∀ {x} -> B x -> C x) -> Any B xs -> Any C xs
mapAny  []           g  ()
mapAny (x ∷ [])      g  y       = g y
mapAny (x ∷ x′ ∷ xs) g (inj₁ y) = inj₁ (g y)
mapAny (x ∷ x′ ∷ xs) g (inj₂ r) = inj₂ (mapAny (x′ ∷ xs) g r)

All : ∀ {α β} {A : Set α} -> (A -> Set β) -> List A -> Set β
All B  []      = ⊤
All B (x ∷ xs) = B x × All B xs

allToList : ∀ {α β} {A : Set α} {B : Set β} {xs : List A} -> All (const B) xs -> List B
allToList {xs = []}      tt      = []
allToList {xs = x ∷ xs} (y , ys) = y ∷ allToList ys

allIn : ∀ {α β} {A : Set α} {B : A -> Set β} -> ∀ xs -> (∀ {x} -> x ∈ xs -> B x) -> All B xs
allIn  []      g = tt
allIn (x ∷ xs) g = g (phere xs) , allIn xs (g ∘ there xs)

mapAll : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} {xs : List A}
       -> (∀ {x} -> B x -> C x) -> All B xs -> All C xs
mapAll {xs = []}     g  tt      = tt
mapAll {xs = x ∷ xs} g (y , ys) = g y , mapAll g ys

unmap : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : Set γ} {xs : List A}
      -> (∀ {x} -> B x -> C) -> All B xs -> List C
unmap g = allToList ∘ mapAll g

mapAllInd : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} {xs}
          -> (∀ {x} -> ℕ -> B x -> C x) -> All B xs -> All C xs
mapAllInd {xs = []}     g  tt      = tt
mapAllInd {xs = x ∷ xs} g (y , ys) = g 0 y , mapAllInd (g ∘ suc) ys

traverseAll : ∀ {α β γ} {A : Set α} {B : A -> Set β} {C : A -> Set γ} {xs : List A}
                {F : Set γ -> Set γ} {{fFunctor : RawFunctor F}} {{fApplicative : RawApplicative F}}
            -> (∀ {x} -> B x -> F (C x)) -> All B xs -> F (All C xs)
traverseAll {xs = []}     g  tt      = pure tt
traverseAll {xs = x ∷ xs} g (y , ys) = _,_ <$> g y <*> traverseAll g ys

splitList : ∀ {α β} {A : Set α} {B : A -> Set β} -> List (Σ A B) -> Σ (List A) (All B)
splitList  []            = [] , tt
splitList ((x , y) ∷ ps) = pmap (_∷_ x) (_,_ y) (splitList ps)

lookupAllConst : ∀ {α β} {A : Set α} {B : Set β} {{bEq : Eq B}} {xs : List A}
               -> B -> All (const B) xs -> Maybe (∃ (_∈ xs))
lookupAllConst {xs = []}     y  tt      = nothing
lookupAllConst {xs = x ∷ xs} y (z , ys) = if y == z
  then just (_ , phere xs)
  else second (there xs) <$> lookupAllConst y ys


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

module Compilation.Data where

open import Context
open import Type.Core

open import Function
open import Data.Product
open import Data.List.Base

infixr 6 _⇒ᶜ_

{- Note [Type denotations]
The denotation of a System Fωμ type is an Agda type that somehow corresponds to the original type.
For System Fωμ types we'll be using simple and straightforward denotations. For example, we map

    π ⋆ (Var vz ⇒ Var vz)

to

    (A : Set) -> A -> A

and

    Lam (Var vz) ∙ (π ⋆ (Var vz ⇒ Var vz))

to

    (λ x -> x) ((A : Set) -> A -> A)

which computes to

    (A : Set) -> A -> A

The latter is due to the fact that we map System Fωμ lambdas to Agda lambdas and System Fωμ
applications to Agda applications and hence get type normalization of denotations for free.
-}

{- Note [Kind denotations]
Of course before taking denotations of System Fωμ types, we need to be able to take denotations
of System Fωμ kinds. We map a System Fωμ `⋆` to an Agda `Set` and a System Fωμ `_⇒ᵏ_` to an Agda
`_->_`. For example the denotation of

  (⋆ ⇒ᵏ ⋆) ⇒ᵏ ⋆

is

  (Set -> Set) -> Set
-}

-- | The Agda meaning of a kind.
⟦_⟧ᵏ : Kind -> Set
⟦ ⋆      ⟧ᵏ = Set
⟦ σ ⇒ᵏ τ ⟧ᵏ = ⟦ σ ⟧ᵏ -> ⟦ τ ⟧ᵏ

-- | The Agda meaning of a System Fωμ type in an environment.
evalᵗ : ∀ {Θ σ} -> Env ⟦_⟧ᵏ Θ -> Θ ⊢ᵗ σ -> ⟦ σ ⟧ᵏ
evalᵗ ρ (Var v) = lookupᵉ v ρ                      -- Look up a variable in the current context.
evalᵗ ρ (Lam β) = λ A -> evalᵗ (ρ ▷ A) β           -- Map a System Fωμ lambda to an Agda lambda.
evalᵗ ρ (φ ∙ α) = evalᵗ ρ φ (evalᵗ ρ α)            -- Map a System Fωμ application to an Agda application.
evalᵗ ρ (α ⇒ β) = evalᵗ ρ α -> evalᵗ ρ β           -- Map a System Fωμ arrow to an Agda arrow.
evalᵗ ρ (π σ β) = (A : ⟦ σ ⟧ᵏ) -> evalᵗ (ρ ▷ A) β  -- Map a System Fωμ `all` to an Agda `∀`.
evalᵗ ρ (μ ψ α) = IFix (evalᵗ ρ ψ) (evalᵗ ρ α)     -- Map a System Fωμ `ifix` to an Agda `IFix`.

-- | The Agda meaning of a closed System Fωμ type.
⟦_⟧ᵗ : ∀ {σ} -> Type⁽⁾ σ -> ⟦ σ ⟧ᵏ
⟦_⟧ᵗ = evalᵗ ∅

{- Note [Representing data types]
We represent a single data type as a list of constructor types. Each constructor type is defined in
a non-empty context where the first bound variable is for handling recursion and other variables are
parameters of the data type (there can be none). Each constructor type is a sequence of `_⇒ᶜ_`
that ends in `endᶜ` where `endᶜ` is a placeholder that will later be substituted either for
a type being defined or a type we eliminate the data type into or the unit type,
depending on how we denote constructors (there are multiple ways).

Consider the `list` data type. Its pattern functor binds two variables:

1. one responsible for recursion
2. one for the type of the elements stored in a list

Since we define constructors in contexts, the list constructors are defined in

    ε ▻ (⋆ ⇒ ⋆) ▻ ⋆

(the parens are for clarity, they're not really needed). The types of the constructors are

    1. List A                 -- The type of the `nil` constructor.
    2. A -> List A -> List A  -- The type of the `cons` constructor.

and we translate them to

    1. endᶜ
    2. Var vz ⇒ᶜ Var (vs vz) ∙ Var vz ⇒ᶜ endᶜ

A more interesting example is

    data InterList (A B : Set) : Set where
      InterNil  : InterList A B
      InterCons : A -> B -> InterList B A -> InterList A B

The types of its constructors are described as

    1. endᶜ
    2. Var (vs vz) ⇒ᶜ Var vz ⇒ᶜ Var (vs vs vz) ∙ Var vz ∙ Var (vs vz) ⇒ᶜ endᶜ

Below we define the data type that describes constructors and some basic functions over it.
-}

-- | The type of a constructor is of the `σ₁ ⇒ … ⇒ σₙ ⇒ end` form
-- where each `σ` is a type of kind `⋆`.
data Cons Θ : Set where
  endᶜ : Cons Θ
  _⇒ᶜ_ : (α : Star Θ) -> (ξ : Cons Θ) -> Cons Θ

-- | Convert the type of a constructor to an actual type of kind `⋆`.
--
-- > consToType (α₁ ⇒ᶜ … ⇒ᶜ αₙ ⇒ᶜ endᶜ) β = α₁ ⇒ … ⇒ αₙ ⇒ β
consToType : ∀ {Θ} -> Cons Θ -> Star Θ -> Star Θ
consToType  endᶜ    β = β
consToType (α ⇒ᶜ ξ) β = α ⇒ consToType ξ β

-- | Rename the type of a constructor.
renᶜ : ∀ {Θ Ξ} -> Θ ⊆ Ξ -> Cons Θ -> Cons Ξ
renᶜ ι  endᶜ    = endᶜ
renᶜ ι (α ⇒ᶜ ξ) = renᵗ ι α ⇒ᶜ renᶜ ι ξ

-- The family we use as an example in docs below.
module ProdTreeTree where
  mutual
    data ProdTree (A : Set) (B : Set) : Set where
      Prod : Tree (A × B) -> ProdTree A B

    data Tree (A : Set) : Set where
      Leaf : A -> Tree A
      Fork : ProdTree A A -> Tree A

  open import Data.Nat.Base
  open import Data.Bool.Base

  private
    example : ProdTree ℕ Bool
    example
      = Prod ∘ Fork ∘ Prod ∘ Fork ∘ Prod ∘ Leaf
      $ ( ( 0
          , false
          )
        , ( 1
          , true
          )
        )
      , ( ( 2
          , false
          )
        , (3
          , true
          )
        )

-- | A data description is parameterized by a context of contexts of kinds. Inner contexts are those
-- single data types are defined in. Outer contexts are needed in order to allow to define mutually
-- recursive data types. I.e. each element of an outer context is an inner context, in which
-- a single data type is defined.
--
-- A single data type is described as a list of described constructors. The context of each
-- constructor consists of
--
--   1. all the data types being defined (because we allow mutually recursive data types)
--   2. the particular inner context of the data type that the constructor constructs
--
-- For example, consider the `ProdTree`/`Tree` family of data types defined above
--
-- Since there are two data types in this family, the length of the outer context is 2.
-- Since `ProdTree` is parameterized by two types, it's inner context is `ε ▻ ⋆ ▻ ⋆`.
-- Since `Tree` is parameterized by one type, it's inner context is `ε ▻ ⋆`.
-- I.e. the context this whole family is defined in, is
--
-- > ε ▻ (ε ▻ ⋆ ▻ ⋆) ▻ (ε ▻ ⋆)
--
-- The context that the constructor of `ProdTree` is defined in, consists of
--
--     1. References to both `ProdTree` and `Tree` which have the `⋆ ⇒ᵏ ⋆ ⇒ᵏ ⋆` and  `⋆ ⇒ᵏ ⋆`
--        kinds respectively.
--     2. The inner context of `ProdTree` which has two parameters `A` and `B`, each of kind `⋆`.
--
-- hence the final context is
--
-- > ε ▻ {- ProdTree :: -} (⋆ ⇒ᵏ ⋆ ⇒ᵏ ⋆) ▻ {- Tree :: -} (⋆ ⇒ᵏ ⋆) ▻ {- A :: -} ⋆ ▻ {- B :: -} ⋆
--
-- (things in `{- … -}` are comments that assign names to variables for clarity).
--
-- Analogously, the context that the constructors of Tree` are defined in, is
--
-- > ε ▻ {- ProdTree :: -} (⋆ ⇒ᵏ ⋆ ⇒ᵏ ⋆) ▻ {- Tree :: -} (⋆ ⇒ᵏ ⋆) ▻ {- A :: -} ⋆
--
-- I.e. the same as the one of `ProdTree`, except we bind only one type parameter, because `Tree`
-- has only one type parameter.
record Data Ξ (Θs : Con Conᵏ) : Set where
  constructor PackData
  field constructors : Seq (λ Θ -> List (Cons (Ξ ▻▻ mapᶜ (λ Θᵢ -> conToKind Θᵢ ⋆) Θs ▻▻ Θ))) Θs

Data⁺ : Con Conᵏ -> Set
Data⁺ Θs = ∀ {Ξ} -> Data Ξ Θs

module prodTreeTree where
  -- The encoded `ProdTree`/`Tree` family from the above looks like this:
  -- (`∀ Q -> (A -> B -> Q) -> Q` is the Scott-encoded `A × B`)
  prodTreeTree : Data⁺ (ε ▻ (ε ▻ ⋆ ▻ ⋆) ▻ (ε ▻ ⋆))
  prodTreeTree
    = PackData
    $ ø
    ▶ ( -- `Tree (∀ Q -> (A -> B -> Q) -> Q) -> ProdTree A B`
        Var (vs vs vz) ∙ π ⋆ ((Var (vs vs vz) ⇒ Var (vs vz) ⇒ Var vz) ⇒ Var vz) ⇒ᶜ endᶜ
      ∷ []
      )
    ▶ ( -- `A -> Tree A`
        Var vz ⇒ᶜ endᶜ
      ∷ -- `ProdTree A A -> Tree A`
        Var (vs vs vz) ∙ Var vz ∙ Var vz ⇒ᶜ endᶜ
      ∷ []
      )


open import Relation.Binary.Core

module BBHeap.Subtyping.Properties {A : Set}
                  (_≤_ : A → A → Set)
                  (trans≤ : Transitive _≤_) where

open import BBHeap _≤_
open import BBHeap.Subtyping  _≤_ trans≤
open import BBHeap.Properties  _≤_
open import Bound.Lower A
open import Bound.Lower.Order _≤_
open import Bound.Lower.Order.Properties _≤_ trans≤
open import List.Permutation.Base A
open import List.Permutation.Base.Equivalence A

subtyping⋘l : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b) → h ⋘ h' → subtyping b''≤b h ⋘ h'
subtyping⋘l b''≤b lf⋘ = lf⋘
subtyping⋘l b''≤b (ll⋘ b≤x b'≤x' l⋘r l'⋘r' l'≃r' r≃l') = ll⋘ (transLeB b''≤b b≤x) b'≤x' l⋘r l'⋘r' l'≃r' r≃l'
subtyping⋘l b''≤b (lr⋘ b≤x b'⋘x' l⋙r l'⋘r' l'≃r' l⋗l') = lr⋘ (transLeB b''≤b b≤x) b'⋘x' l⋙r l'⋘r' l'≃r' l⋗l'

subtyping⋘ : {b b' b'' b''' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b)(b'''≤b' : LeB b''' b') → h ⋘ h' → subtyping b''≤b h ⋘ subtyping b'''≤b' h'
subtyping⋘ b''≤b b'''≤b' lf⋘ = lf⋘
subtyping⋘ b''≤b b'''≤b' (ll⋘ b≤x b'≤x' l⋘r l'⋘r' l'≃r' r≃l') = ll⋘ (transLeB b''≤b b≤x) (transLeB b'''≤b' b'≤x') l⋘r l'⋘r' l'≃r' r≃l'
subtyping⋘ b''≤b b'''≤b' (lr⋘ b≤x b'⋘x' l⋙r l'⋘r' l'≃r' l⋗l') = lr⋘ (transLeB b''≤b b≤x) (transLeB b'''≤b' b'⋘x') l⋙r l'⋘r' l'≃r' l⋗l'

subtyping⋙r : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b' : LeB b'' b') → h ⋙ h' → h ⋙ subtyping b''≤b' h'
subtyping⋙r b''≤b' (⋙lf b≤x) = ⋙lf b≤x
subtyping⋙r b''≤b' (⋙rl b≤x b'≤x' l⋘r l≃r l'⋘r' l⋗r') = ⋙rl b≤x (transLeB b''≤b' b'≤x') l⋘r l≃r l'⋘r' l⋗r'
subtyping⋙r b''≤b' (⋙rr b≤x b'⋘x' l⋘r l≃r l'⋙r' l≃l') = ⋙rr b≤x (transLeB b''≤b' b'⋘x') l⋘r l≃r l'⋙r' l≃l'

subtyping⋙ : {b b' b'' b''' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b)(b'''≤b' : LeB b''' b') → h ⋙ h' → subtyping b''≤b h ⋙ subtyping b'''≤b' h'
subtyping⋙ b''≤b b'''≤b' (⋙lf b≤x) = ⋙lf (transLeB b''≤b b≤x)
subtyping⋙ b''≤b b'''≤b' (⋙rl b≤x b'≤x' l⋘r l≃r l'⋘r' l⋗r') = ⋙rl (transLeB b''≤b b≤x) (transLeB b'''≤b' b'≤x') l⋘r l≃r l'⋘r' l⋗r'
subtyping⋙ b''≤b b'''≤b' (⋙rr b≤x b'⋘x' l⋘r l≃r l'⋙r' l≃l') = ⋙rr (transLeB b''≤b b≤x) (transLeB b'''≤b' b'⋘x') l⋘r l≃r l'⋙r' l≃l'

subtyping≃r : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b' : LeB b'' b') → h ≃ h' → h ≃ subtyping b''≤b' h'
subtyping≃r b''≤b' ≃lf = ≃lf
subtyping≃r b''≤b' (≃nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l≃l') = ≃nd b≤x (transLeB b''≤b' b'≤x') l⋘r l'⋘r' l≃r l'≃r' l≃l'

subtyping≃l : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b) → h ≃ h' → subtyping b''≤b h ≃ h'
subtyping≃l b''≤b h≃h' = sym≃ (subtyping≃r b''≤b (sym≃ h≃h'))

subtyping≃ : {b b' b'' b''' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b)(b'''≤b' : LeB b''' b') → h ≃ h' → subtyping b''≤b h ≃ subtyping b'''≤b' h'
subtyping≃ b''≤b b'''≤b' h≃h' = subtyping≃r b'''≤b' (subtyping≃l b''≤b h≃h')

subtyping⋗r : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b' : LeB b'' b') → h ⋗ h' → h ⋗ subtyping b''≤b' h'
subtyping⋗r b''≤b' (⋗lf b≤x) = ⋗lf b≤x
subtyping⋗r b''≤b' (⋗nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l⋗l') = ⋗nd b≤x (transLeB b''≤b' b'≤x') l⋘r l'⋘r' l≃r l'≃r' l⋗l'

subtyping⋗l : {b b' b'' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b) → h ⋗ h' → subtyping b''≤b h ⋗ h'
subtyping⋗l b''≤b (⋗lf b≤x) = ⋗lf (transLeB b''≤b b≤x)
subtyping⋗l b''≤b (⋗nd b≤x b'≤x' l⋘r l'⋘r' l≃r l'≃r' l⋗l') = ⋗nd (transLeB b''≤b b≤x) b'≤x' l⋘r l'⋘r' l≃r l'≃r' l⋗l'

subtyping⋗ : {b b' b'' b''' : Bound}{h : BBHeap b}{h' : BBHeap b'}(b''≤b : LeB b'' b)(b'''≤b' : LeB b''' b') → h ⋗ h' → subtyping b''≤b h ⋗ subtyping b'''≤b' h'
subtyping⋗ b''≤b b'''≤b' h⋗h' = subtyping⋗r b'''≤b' (subtyping⋗l b''≤b h⋗h')

lemma-subtyping# : {b b' : Bound}(b'≤b : LeB b' b)(h : BBHeap b) → # (subtyping b'≤b h) ≡ # h
lemma-subtyping# b'≤b leaf = refl
lemma-subtyping# b'≤b (left b≤x l⋘r) = refl
lemma-subtyping# b'≤b (right b≤x l⋙r) = refl

lemma-subtyping≡ : {b b' : Bound}(b'≤b : LeB b' b)(h : BBHeap b) → (flatten (subtyping b'≤b h)) ≡ flatten h
lemma-subtyping≡ b'≤b leaf = refl
lemma-subtyping≡ b'≤b (left {l = l} {r = r} b≤x l⋘r) rewrite lemma-subtyping≡ b≤x l | lemma-subtyping≡ b≤x r = refl
lemma-subtyping≡ b'≤b (right {l = l} {r = r} b≤x l⋙r) rewrite lemma-subtyping≡ b≤x l | lemma-subtyping≡ b≤x r = refl

lemma-subtyping∼ : {b b' : Bound}(b'≤b : LeB b' b)(h : BBHeap b) → flatten (subtyping b'≤b h) ∼ flatten h
lemma-subtyping∼ b'≤b leaf = ∼[]
lemma-subtyping∼ b'≤b (left b≤x l⋘r) = ∼x /head /head refl∼
lemma-subtyping∼ b'≤b (right b≤x l⋙r) = ∼x /head /head refl∼


{-# OPTIONS --without-K  #-}
module sets.fin where

open import sets.fin.core public
-- open import sets.fin.properties public
-- open import sets.fin.ordering public
-- open import sets.fin.universe public


------------------------------------------------------------------------------
-- A proof that is rejected using the --without-K option
------------------------------------------------------------------------------

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

module Lists where

open import FOTC.Base
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.List
open import FOTC.Data.List.PropertiesI
open import FOTC.Data.List.WF-Relation.LT-Cons
open import FOTC.Data.List.WF-Relation.LT-Length

------------------------------------------------------------------------------
-- LTC → LTL.

-- 25 April 2014. The proof is accepted using Cockx's --without-K
-- implementation.
LTC→LTL : ∀ {xs ys} → List xs → LTC xs ys → LTL xs ys
LTC→LTL Lxs (x , refl) = lg-x<lg-x∷xs x Lxs

LTC→LTL' : ∀ {xs ys} → List xs → LTC xs ys → LTL xs ys
LTC→LTL' {xs} {ys} Lxs (x , h) =
  subst (λ ys' → length xs < length ys')
        (sym h)
        (lg-x<lg-x∷xs x Lxs)


{-# OPTIONS --safe --postfix-projections #-}
module Cubical.Algebra.OrderedCommMonoid.PropCompletion where
{-
  The completion of an ordered monoid, viewed as monoidal prop-enriched category.
  This is used in the construction of the upper naturals, which is an idea of David
  Jaz Myers presented here

  https://felix-cherubini.de/myers-slides-II.pdf

  It should be straight forward, but tedious,
  to generalize this to enriched monoidal categories.
-}

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Function
open import Cubical.Foundations.Structure
open import Cubical.Foundations.HLevels

open import Cubical.Functions.Logic
open import Cubical.Functions.Embedding

open import Cubical.Data.Sigma

open import Cubical.HITs.PropositionalTruncation renaming (rec to propTruncRec; rec2 to propTruncRec2)

open import Cubical.Algebra.CommMonoid.Base
open import Cubical.Algebra.OrderedCommMonoid

open import Cubical.Relation.Binary.Poset

private
  variable
    ℓ : Level

module PropCompletion (ℓ : Level) (M : OrderedCommMonoid ℓ ℓ) where
  open OrderedCommMonoidStr (snd M)
  _≤p_ : fst M → fst M → hProp ℓ
  n ≤p m = (n ≤ m) , (is-prop-valued _ _)

  isUpwardClosed : (s : fst M → hProp ℓ) → Type _
  isUpwardClosed s = (n m : fst M) → n ≤ m → fst (s n) → fst (s m)

  isPropUpwardClosed : (N : fst M → hProp ℓ) → isProp (isUpwardClosed N)
  isPropUpwardClosed N =
    isPropΠ4 (λ _ m _ _ → snd (N m))

  isSetM→Prop : isSet (fst M → hProp ℓ)
  isSetM→Prop = isOfHLevelΠ 2 λ _ → isSetHProp

  M↑ : Type _
  M↑ = Σ[ s ∈ (fst M → hProp ℓ)] isUpwardClosed s

  isSetM↑ : isSet M↑
  isSetM↑ = isOfHLevelΣ 2 isSetM→Prop λ s → isOfHLevelSuc 1 (isPropUpwardClosed s)

  _isUpperBoundOf_ : fst M → M↑ → Type ℓ
  n isUpperBoundOf s = fst (fst s n)

  isBounded : (s : M↑) → Type _
  isBounded s = ∃[ m ∈ (fst M) ] (m isUpperBoundOf s)

  isPropIsBounded : (s : M↑) → isProp (isBounded s)
  isPropIsBounded s = isPropPropTrunc

  _^↑ : fst M → M↑
  n ^↑ = n ≤p_ , isUpwardClosed≤
    where
      isUpwardClosed≤ : {m : fst M} → isUpwardClosed (m ≤p_)
      isUpwardClosed≤ = λ {_ _ n≤k m≤n → is-trans _ _ _ m≤n n≤k}

  isBounded^ : (m : fst M) → isBounded (m ^↑)
  isBounded^ m = ∣ (m , (is-refl m)) ∣₁

  1↑ : M↑
  1↑ = ε ^↑

  _·↑_ : M↑ → M↑ → M↑
  s ·↑ l = seq , seqIsUpwardClosed
         where
           seq : fst M → hProp ℓ
           seq n = (∃[ (a , b) ∈ (fst M) × (fst M) ] fst ((fst s a) ⊓ (fst l b) ⊓ ((a · b) ≤p n) )) ,
                   isPropPropTrunc
           seqIsUpwardClosed : isUpwardClosed seq
           seqIsUpwardClosed n m n≤m =
             propTruncRec
               isPropPropTrunc
               λ {((a , b) , wa , (wb , a·b≤n)) → ∣ (a , b) , wa , (wb , is-trans _ _ _ a·b≤n n≤m) ∣₁}

  ·presBounded : (s l : M↑) (bs : isBounded s) (bl : isBounded l) → isBounded (s ·↑ l)
  ·presBounded s l =
    propTruncRec2
      isPropPropTrunc
      λ {(m , s≤m) (k , l≤k)
          → ∣ (m · k) , ∣ (m , k) , (s≤m , (l≤k , (is-refl (m · k)))) ∣₁ ∣₁
        }

  {- convenience functions for the proof that ·↑ is the multiplication of a monoid -}
  typeAt : fst M → M↑ → Type _
  typeAt n s = fst (fst s n)

  M↑Path : {s l : M↑} → ((n : fst M) → typeAt n s ≡ typeAt n l) → s ≡ l
  M↑Path {s = s} {l = l} pwPath = path
     where
       seqPath : fst s ≡ fst l
       seqPath i n = subtypePathReflection (λ A → isProp A , isPropIsProp)
                                           (fst s n)
                                           (fst l n)
                                           (pwPath n) i
       path : s ≡ l
       path = subtypePathReflection (λ s → isUpwardClosed s , isPropUpwardClosed s) s l seqPath

  pathFromImplications : (s l : M↑)
           → ((n : fst M) → typeAt n s → typeAt n l)
           → ((n : fst M) → typeAt n l → typeAt n s)
           → s ≡ l
  pathFromImplications s l s→l l→s =
      M↑Path λ n → cong fst (propPath n)
            where propPath : (n : fst M) → fst s n ≡ fst l n
                  propPath n = ⇒∶ s→l n
                               ⇐∶ l→s n

  ^↑Pres· : (x y : fst M) → (x · y) ^↑ ≡ (x ^↑) ·↑ (y ^↑)
  ^↑Pres· x y = pathFromImplications ((x · y) ^↑) ((x ^↑) ·↑ (y ^↑)) (⇐) ⇒
    where
      ⇐ : (n : fst M) → typeAt n ((x · y) ^↑) → typeAt n ((x ^↑) ·↑ (y ^↑))
      ⇐ n x·y≤n = ∣ (x , y) , ((is-refl _) , ((is-refl _) , x·y≤n)) ∣₁

      ⇒ : (n : fst M) → typeAt n ((x ^↑) ·↑ (y ^↑)) → typeAt n ((x · y) ^↑)
      ⇒ n = propTruncRec
              (snd (fst ((x · y) ^↑) n))
              λ {((m , l) , x≤m , (y≤l , m·l≤n))
                  → is-trans _ _ _
                             (is-trans _ _ _ (MonotoneR x≤m)
                                             (MonotoneL y≤l))
                             m·l≤n
                }

  ·↑Comm : (s l : M↑) → s ·↑ l ≡ l ·↑ s
  ·↑Comm s l = M↑Path λ n → cong fst (propPath n)
    where implication : (s l : M↑) (n : fst M) → fst (fst (s ·↑ l) n) → fst (fst (l ·↑ s) n)
          implication s l n = propTruncRec
                             isPropPropTrunc
                             (λ {((a , b) , wa , (wb , a·b≤n))
                               → ∣ (b , a) , wb , (wa , subst (λ k → fst (k ≤p n)) (·Comm a b) a·b≤n) ∣₁ })
          propPath : (n : fst M) → fst (s ·↑ l) n ≡ fst (l ·↑ s) n
          propPath n = ⇒∶ implication s l n
                       ⇐∶ implication l s n

  ·↑Rid : (s : M↑) → s ·↑ 1↑ ≡ s
  ·↑Rid s = pathFromImplications (s ·↑ 1↑) s (⇒) ⇐
    where ⇒ : (n : fst M) → typeAt n (s ·↑ 1↑) → typeAt n s
          ⇒ n = propTruncRec
                  (snd (fst s n))
                  (λ {((a , b) , sa , (1b , a·b≤n))
                     → (snd s) a n ( subst (_≤ n) (·IdR a) (is-trans _ _ _ (MonotoneL 1b) a·b≤n)) sa })
          ⇐ : (n : fst M) → typeAt n s → typeAt n (s ·↑ 1↑)
          ⇐ n = λ sn → ∣ (n , ε) , (sn , (is-refl _ , subst (_≤ n) (sym (·IdR n)) (is-refl _))) ∣₁

  ·↑Assoc : (s l k : M↑) → s ·↑ (l ·↑ k) ≡ (s ·↑ l) ·↑ k
  ·↑Assoc s l k = pathFromImplications (s ·↑ (l ·↑ k)) ((s ·↑ l) ·↑ k) (⇒) ⇐
    where ⇒ : (n : fst M) → typeAt n (s ·↑ (l ·↑ k)) → typeAt n ((s ·↑ l) ·↑ k)
          ⇒ n = propTruncRec
                isPropPropTrunc
                λ {((a , b) , sa , (l·kb , a·b≤n))
                     → propTruncRec
                         isPropPropTrunc
                         (λ {((a' , b') , la' , (kb' , a'·b'≤b))
                         → ∣ ((a · a') , b') , ∣ (a , a') , (sa , (la' , is-refl _)) ∣₁ , kb' ,
                             (let a·⟨a'·b'⟩≤n = (is-trans _ _ _ (MonotoneL a'·b'≤b) a·b≤n)
                              in subst (_≤ n) (·Assoc a a' b') a·⟨a'·b'⟩≤n) ∣₁
                            }) l·kb
                   }
          ⇐ : _
          ⇐ n = propTruncRec
                isPropPropTrunc
                λ {((a , b) , s·l≤a , (k≤b , a·b≤n))
                     → propTruncRec
                         isPropPropTrunc
                         (λ {((a' , b') , s≤a' , (l≤b' , a'·b'≤a))
                         → ∣ (a' , b' · b) , s≤a' , ( ∣ (b' , b) , l≤b' , (k≤b , is-refl _) ∣₁ ,
                             (let ⟨a'·b'⟩·b≤n = (is-trans _ _ _ (MonotoneR a'·b'≤a) a·b≤n)
                              in subst (_≤ n) (sym (·Assoc a' b' b)) ⟨a'·b'⟩·b≤n) ) ∣₁
                            }) s·l≤a
                   }

  asCommMonoid : CommMonoid (ℓ-suc ℓ)
  asCommMonoid = makeCommMonoid 1↑ _·↑_ isSetM↑ ·↑Assoc ·↑Rid ·↑Comm

  {-
    Poset structure on M↑
  -}
  _≤↑_ : (s l : M↑) → Type _
  s ≤↑ l = (m : fst M) → fst ((fst l) m) → fst ((fst s) m)

  isBounded→≤↑ : (s : M↑) → isBounded s → ∃[ m ∈ fst M ] (s ≤↑ (m ^↑))
  isBounded→≤↑ s =
    propTruncRec
      isPropPropTrunc
      λ {(m , mIsBound)
           → ∣ m , (λ n m≤n → snd s m n m≤n mIsBound) ∣₁
        }

  ≤↑IsProp : (s l : M↑) → isProp (s ≤↑ l)
  ≤↑IsProp s l = isPropΠ2 (λ x p → snd (fst s x))

  ≤↑IsRefl : (s : M↑) → s ≤↑ s
  ≤↑IsRefl s = λ m x → x

  ≤↑IsTrans : (s l t : M↑) → s ≤↑ l → l ≤↑ t → s ≤↑ t
  ≤↑IsTrans s l t p q x = (p x) ∘ (q x)

  ≤↑IsAntisym : (s l : M↑) → s ≤↑ l → l ≤↑ s → s ≡ l
  ≤↑IsAntisym s l p q = pathFromImplications _ _ q p

  {-
    Compatability with the monoid structure
  -}
  ·↑IsRMonotone : (l t s : M↑) → l ≤↑ t → (l ·↑ s) ≤↑ (t ·↑ s)
  ·↑IsRMonotone l t s p x =
    propTruncRec
      isPropPropTrunc
      λ { ((a , b) , l≤a , (s≤b , a·b≤x)) → ∣ (a , b) , p a l≤a , s≤b , a·b≤x ∣₁}

  ·↑IsLMonotone : (l t s : M↑) → l ≤↑ t → (s ·↑ l) ≤↑ (s ·↑ t)
  ·↑IsLMonotone l t s p x =
    propTruncRec
      isPropPropTrunc
      λ {((a , b) , s≤a , (l≤b , a·b≤x)) → ∣ (a , b) , s≤a , p b l≤b , a·b≤x ∣₁}

  asOrderedCommMonoid : OrderedCommMonoid (ℓ-suc ℓ) ℓ
  asOrderedCommMonoid .fst = _
  asOrderedCommMonoid .snd .OrderedCommMonoidStr._≤_ = _≤↑_
  asOrderedCommMonoid .snd .OrderedCommMonoidStr._·_ = _·↑_
  asOrderedCommMonoid .snd .OrderedCommMonoidStr.ε = 1↑
  asOrderedCommMonoid .snd .OrderedCommMonoidStr.isOrderedCommMonoid =
    IsOrderedCommMonoidFromIsCommMonoid
          (CommMonoidStr.isCommMonoid (snd asCommMonoid))
          ≤↑IsProp ≤↑IsRefl ≤↑IsTrans ≤↑IsAntisym ·↑IsRMonotone ·↑IsLMonotone

  boundedSubstructure : OrderedCommMonoid (ℓ-suc ℓ) ℓ
  boundedSubstructure =
    makeOrderedSubmonoid
      asOrderedCommMonoid
      (λ s → (isBounded s , isPropIsBounded s))
      ·presBounded
      (isBounded^ ε)

PropCompletion :
    OrderedCommMonoid ℓ ℓ
  → OrderedCommMonoid (ℓ-suc ℓ) ℓ
PropCompletion M = PropCompletion.asOrderedCommMonoid _ M

BoundedPropCompletion :
     OrderedCommMonoid ℓ ℓ
  → OrderedCommMonoid (ℓ-suc ℓ) ℓ
BoundedPropCompletion M = PropCompletion.boundedSubstructure _ M

isSetBoundedPropCompletion :
     (M : OrderedCommMonoid ℓ ℓ)
   → isSet (⟨ BoundedPropCompletion M ⟩)
isSetBoundedPropCompletion M =
  isSetΣSndProp (isSetOrderedCommMonoid (PropCompletion M))
                λ x → PropCompletion.isPropIsBounded _ M x


{-# OPTIONS --without-K #-}
module Inspect where

open import Data.Unit.Core

open import SimpleHoTT using (refl;_≡_)

------------------------------------------------------------------------
-- Inspect on steroids (borrowed from standard library)

-- Inspect on steroids can be used when you want to pattern match on
-- the result r of some expression e, and you also need to "remember"
-- that r ≡ e.

data Reveal_is_ {a} {A : Set a} (x : Hidden A) (y : A) : Set a where
  ⟪_⟫ : (eq : reveal x ≡ y) → Reveal x is y

inspect : ∀ {a b} {A : Set a} {B : A → Set b}
          (f : (x : A) → B x) (x : A) → Reveal (hide f x) is (f x)
inspect f x = ⟪ refl (f x) ⟫


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

module Algebra.Construct.Free.Semilattice.Union where

open import Prelude
open import Path.Reasoning
open import Algebra

open import Algebra.Construct.Free.Semilattice.Definition
open import Algebra.Construct.Free.Semilattice.Eliminators

infixr 5 _∪_
_∪_ : 𝒦 A → 𝒦 A → 𝒦 A
_∪_ = λ xs ys → [ union′ ys ]↓ xs
  where
  union′ : 𝒦 A → A ↘ 𝒦 A
  [ union′ ys ]-set = trunc
  [ union′ ys ] x ∷ xs = x ∷ xs
  [ union′ ys ][] = ys
  [ union′ ys ]-dup = dup
  [ union′ ys ]-com = com

∪-assoc : (xs ys zs : 𝒦 A) → (xs ∪ ys) ∪ zs ≡ xs ∪ (ys ∪ zs)
∪-assoc = λ xs ys zs → ∥ ∪-assoc′ ys zs ∥⇓ xs
  where
  ∪-assoc′ : (ys zs : 𝒦 A) → xs ∈𝒦 A ⇒∥ (xs ∪ ys) ∪ zs ≡ xs ∪ (ys ∪ zs) ∥
  ∥ ∪-assoc′ ys zs ∥-prop = trunc _ _
  ∥ ∪-assoc′ ys zs ∥[] = refl
  ∥ ∪-assoc′ ys zs ∥ x ∷ xs ⟨ Pxs ⟩ = cong (x ∷_) Pxs

∪-identityʳ : (xs : 𝒦 A) → xs ∪ [] ≡ xs
∪-identityʳ = ∥ ∪-identityʳ′ ∥⇓
  where
  ∪-identityʳ′ : xs ∈𝒦 A ⇒∥ xs ∪ [] ≡ xs ∥
  ∥ ∪-identityʳ′ ∥-prop = trunc _ _
  ∥ ∪-identityʳ′ ∥[] = refl
  ∥ ∪-identityʳ′ ∥ x ∷ xs ⟨ Pxs ⟩ = cong (x ∷_) Pxs

cons-distrib-∪ : (x : A) (xs ys : 𝒦 A) → x ∷ xs ∪ ys ≡ xs ∪ (x ∷ ys)
cons-distrib-∪ = λ x xs ys → ∥ cons-distrib-∪′ x ys ∥⇓ xs
  where
  cons-distrib-∪′ : (x : A) (ys : 𝒦 A) → xs ∈𝒦 A ⇒∥ x ∷ xs ∪ ys ≡ xs ∪ (x ∷ ys) ∥
  ∥ cons-distrib-∪′ x ys ∥-prop = trunc _ _
  ∥ cons-distrib-∪′ x ys ∥[] = refl
  ∥ cons-distrib-∪′ x ys ∥ z ∷ xs ⟨ Pxs ⟩ =
    x ∷ ((z ∷ xs) ∪ ys) ≡⟨⟩
    x ∷ z ∷ (xs ∪ ys) ≡⟨ com x z (xs ∪ ys) ⟩
    z ∷ x ∷ (xs ∪ ys) ≡⟨ cong (z ∷_) Pxs ⟩
    ((z ∷ xs) ∪ (x ∷ ys)) ∎

∪-comm : (xs ys : 𝒦 A) → xs ∪ ys ≡ ys ∪ xs
∪-comm = λ xs ys → ∥ ∪-comm′ ys ∥⇓ xs
  where
  ∪-comm′ : (ys : 𝒦 A) → xs ∈𝒦 A ⇒∥ xs ∪ ys ≡ ys ∪ xs ∥
  ∥ ∪-comm′ ys ∥-prop = trunc _ _
  ∥ ∪-comm′ ys ∥[] = sym (∪-identityʳ ys)
  ∥ ∪-comm′ ys ∥ x ∷ xs ⟨ Pxs ⟩ =
    (x ∷ xs) ∪ ys ≡⟨⟩
    x ∷ (xs ∪ ys) ≡⟨ cong (x ∷_) Pxs ⟩
    x ∷ (ys ∪ xs) ≡⟨⟩
    (x ∷ ys) ∪ xs ≡⟨ cons-distrib-∪ x ys xs ⟩
    ys ∪ (x ∷ xs) ∎

∪-idem : (xs : 𝒦 A) → xs ∪ xs ≡ xs
∪-idem = ∥ ∪-idem′ ∥⇓
  where
  ∪-idem′ : xs ∈𝒦 A ⇒∥ xs ∪ xs ≡ xs ∥
  ∥ ∪-idem′ ∥-prop = trunc _ _
  ∥ ∪-idem′ ∥[] = refl
  ∥ ∪-idem′ ∥ x ∷ xs ⟨ Pxs ⟩ =
    ((x ∷ xs) ∪ (x ∷ xs)) ≡˘⟨ cons-distrib-∪ x (x ∷ xs) xs ⟩
    x ∷ x ∷ (xs ∪ xs) ≡⟨ dup x (xs ∪ xs) ⟩
    x ∷ (xs ∪ xs) ≡⟨ cong (x ∷_) Pxs ⟩
    x ∷ xs ∎

module _ {a} {A : Type a} where
  open Semilattice
  open CommutativeMonoid
  open Monoid
  𝒦-semilattice : Semilattice a
  𝒦-semilattice .commutativeMonoid .monoid .𝑆 = 𝒦 A
  𝒦-semilattice .commutativeMonoid .monoid ._∙_ = _∪_
  𝒦-semilattice .commutativeMonoid .monoid .ε = []
  𝒦-semilattice .commutativeMonoid .monoid .assoc = ∪-assoc
  𝒦-semilattice .commutativeMonoid .monoid .ε∙ _ = refl
  𝒦-semilattice .commutativeMonoid .monoid .∙ε = ∪-identityʳ
  𝒦-semilattice .commutativeMonoid .comm = ∪-comm
  𝒦-semilattice .idem = ∪-idem


module ImportTests.ExtractFunction where

open import ExtractFunction
open import Data.Nat
open import Data.Bool
checkFunction1 : ℕ
checkFunction1 = function1 2 3

checkFunction2 : ℕ
checkFunction2 = function2 4 true


{-# OPTIONS --safe #-}
module Cubical.Data.Int.MoreInts.DeltaInt where

open import Cubical.Data.Int.MoreInts.DeltaInt.Base public

open import Cubical.Data.Int.MoreInts.DeltaInt.Properties public


{-# OPTIONS --universe-polymorphism #-}
module Categories.Yoneda where

open import Level
open import Data.Product

open import Categories.Support.Equivalence
open import Categories.Support.EqReasoning

open import Categories.Category
import Categories.Functor as Cat
open import Categories.Functor using (Functor; module Functor)
open import Categories.Functor.Hom
import Categories.Morphisms as Mor
open import Categories.NaturalTransformation using (NaturalTransformation; module NaturalTransformation)
open import Categories.NaturalIsomorphism
open import Categories.Product
open import Categories.FunctorCategory
open import Categories.Presheaves
open import Categories.Agda

Embed : ∀ {o ℓ e} → (C : Category o ℓ e) → Functor C (Presheaves C)
Embed C = record
  { F₀ = λ x → Hom[ C ][-, x ]
  ; F₁ = λ f → record
    { η = λ X → record
      { _⟨$⟩_ = λ g → f ∘ g
      ; cong = λ x → ∘-resp-≡ʳ x
      }
    ; commute = commute′ f
    }
  ; identity = λ x≡y → trans identityˡ x≡y
  ; homomorphism = λ x≡y → trans (∘-resp-≡ʳ x≡y) assoc
  ; F-resp-≡ = λ f≡g h≡i → ∘-resp-≡ f≡g h≡i
  }
  where
  open Category C
  open Equiv

  .commute′ : {A B X Y : Obj} (f : A ⇒ B) (g : Y ⇒ X) {x y : X ⇒ A} → x ≡ y → f ∘ id ∘ x ∘ g ≡ id ∘ (f ∘ y) ∘ g
  commute′ f g {x} {y} x≡y =
    begin
      f ∘ id ∘ x ∘ g
    ↑⟨ assoc ⟩
      (f ∘ id) ∘ x ∘ g
    ≈⟨ ∘-resp-≡ˡ id-comm ⟩
      (id ∘ f) ∘ x ∘ g
    ≈⟨ ∘-resp-≡ʳ (∘-resp-≡ˡ x≡y) ⟩
      (id ∘ f) ∘ y ∘ g
    ≈⟨ assoc ⟩
      id ∘ f ∘ y ∘ g
    ↑⟨ ∘-resp-≡ʳ assoc ⟩
      id ∘ (f ∘ y) ∘ g
    ∎
    where open HomReasoning

module Embed {o ℓ e} C = Functor (Embed {o} {ℓ} {e} C)

Nat[Embed[_][c],F] : ∀ {o ℓ e} → (C : Category o ℓ e) -> Functor (Product (Presheaves C) (Category.op C)) (ISetoids _ _)
Nat[Embed[ C ][c],F] = Hom[ Presheaves C ][-,-] Cat.∘ ((Embed.op C Cat.∘ snd) ※ fst)
 where
   fst = πˡ {C = Presheaves C} {D = Category.op C}
   snd = πʳ {C = Presheaves C} {D = Category.op C}

F[c∈_] : ∀ {o ℓ e} → (C : Category o ℓ e) -> Functor (Product (Presheaves C) (Category.op C)) (ISetoids _ _)
F[c∈_] {o} {ℓ} {e} C = Lift-IS (suc e ⊔ suc ℓ ⊔ o) (o ⊔ ℓ) Cat.∘ eval {C = Category.op C} {D = ISetoids ℓ e}

yoneda : ∀ {o ℓ e} → (C : Category o ℓ e) -> NaturalIsomorphism Nat[Embed[ C ][c],F] F[c∈ C ]
yoneda C = record { F⇒G = F⇒G; F⇐G = F⇐G; iso = iso }
 where
  open NaturalTransformation
  open Categories.Functor.Functor
  open import Categories.Support.SetoidFunctions
  module C = Category C
  open C.Equiv
  module M = Mor (ISetoids _ _)
  F⇒G : NaturalTransformation Nat[Embed[ C ][c],F] F[c∈ C ]
  F⇒G = record {
   η = λ {(F , c) →
          record { _⟨$⟩_ = λ ε → lift (η ε c ⟨$⟩ C.id);
                   cong  = λ x → lift (x refl) }};
   commute = λ { {F , c₁} {G , c₂} (ε , f) {φ} {ψ} φ≡ψ → lift
     (let module s = Setoid (F₀ G c₂)
          module sr = SetoidReasoning (F₀ G c₂)
          module t = Setoid (F₀ F c₂)
          module tr = SetoidReasoning (F₀ F c₂)
       in s.sym (sr.begin
       F₁ G f ⟨$⟩ (η ε c₁ ⟨$⟩ (η ψ c₁ ⟨$⟩ C.id))
         sr.↑⟨ commute ε f (Setoid.refl (F₀ F c₁)) ⟩
       η ε c₂ ⟨$⟩ (F₁ F f ⟨$⟩ (η ψ c₁ ⟨$⟩ C.id))
         sr.↓⟨ cong (η ε c₂) (tr.begin
               F₁ F f ⟨$⟩ (η ψ c₁ ⟨$⟩ C.id)
                 tr.↑⟨ commute ψ f (refl {x = C.id}) ⟩
               η ψ c₂ ⟨$⟩ C.id C.∘ C.id C.∘ f
                 tr.↑⟨ φ≡ψ (trans C.identityʳ (trans (sym C.identityˡ) (sym C.identityˡ))) ⟩
               η φ c₂ ⟨$⟩ f C.∘ C.id
                 tr.∎) ⟩
       η ε c₂ ⟨$⟩ (η φ c₂ ⟨$⟩ f C.∘ C.id) sr.∎  )) }}

  F⇐G : NaturalTransformation F[c∈ C ] Nat[Embed[ C ][c],F]
  F⇐G = record {
   η = λ {(F , c) →
     record { _⟨$⟩_ = λ Fc →
                record { η = λ X →
                           record { _⟨$⟩_ = λ f → F₁ F f ⟨$⟩ lower Fc;
                                    cong  = λ eq → F-resp-≡ F eq (Setoid.refl (F₀ F c)) };
                         commute = λ {X} {Y} h {f} {g} f≡g →
                           let module s = Setoid (F₀ F Y)
                               module sr = SetoidReasoning (F₀ F Y)
                            in sr.begin
                               F₁ F (C.id C.∘ f C.∘ h) ⟨$⟩ lower Fc
                                 sr.↓⟨  F-resp-≡ F (trans C.identityˡ (C.∘-resp-≡ˡ f≡g)) (Setoid.refl (F₀ F c)) ⟩
                               F₁ F (g C.∘ h) ⟨$⟩ lower Fc
                                 sr.↓⟨ homomorphism F (Setoid.refl (F₀ F c)) ⟩
                               F₁ F h ⟨$⟩ (F₁ F g ⟨$⟩ lower Fc)
                                 sr.∎ };
              cong  = λ i≡j {X} {f} {g} f≡g → F-resp-≡ F f≡g (lower i≡j) }};
   commute = λ { {F , c₁} {G , c₂} (ε , e) {lift i} {lift j} i≡j {X} {f} {g} f≡g →
     let module s = Setoid (F₀ G X)
         module sr = SetoidReasoning (F₀ G X)
      in sr.begin
         F₁ G f ⟨$⟩ (F₁ G e ⟨$⟩ (η ε c₁ ⟨$⟩ i))
           sr.↑⟨ homomorphism G {f = e} {g = f} (Setoid.refl (F₀ G c₁)) ⟩
         F₁ G (e C.∘ f) ⟨$⟩ (η ε c₁ ⟨$⟩ i)
           sr.↑⟨ commute ε (e C.∘ f) (Setoid.refl (F₀ F c₁)) ⟩
         η ε X ⟨$⟩ (F₁ F (e C.∘ f) ⟨$⟩ i)
           sr.↓⟨ cong (η ε X) (F-resp-≡ F (C.∘-resp-≡ʳ f≡g) (lower i≡j)) ⟩
         η ε X ⟨$⟩ (F₁ F (e C.∘ g) ⟨$⟩ j)
           sr.∎}}

  module F⇐G = NaturalTransformation F⇐G
  module F⇒G = NaturalTransformation F⇒G

  iso : (X : Category.Obj (Product (Presheaves C) C.op)) → M.Iso (F⇒G.η X) (F⇐G.η X)
  iso (F , c) = record {
    isoˡ = λ { {ε₁} {ε₂} ε₁≡ε₂ {X} {f} {g} f≡g →
      let module s = Setoid (F₀ F X)
          open SetoidReasoning (F₀ F X)
       in begin
           F₁ F f ⟨$⟩ (η ε₁ c ⟨$⟩ C.id)
             ↑⟨ commute ε₁ f {C.id} {C.id} refl ⟩
           η ε₁ X ⟨$⟩ C.id C.∘ C.id C.∘ f
             ↓⟨ ε₁≡ε₂ (trans C.identityˡ (trans C.identityˡ f≡g)) ⟩
           η ε₂ X ⟨$⟩ g
             ∎ };
    isoʳ = λ eq → lift (identity F (lower eq)) }

yoneda-iso : ∀ {o ℓ e} → (C : Category o ℓ e) (c d : Category.Obj C) ->
               let open Mor (ISetoids _ _) in
                  Functor.F₀ Hom[ Presheaves C ][ Embed.F₀ C c ,-] (Embed.F₀ C d)
                ≅ Functor.F₀ (Lift-IS (suc e ⊔ suc ℓ ⊔ o) (o ⊔ ℓ)) (Functor.F₀ (Embed.F₀ C d) c)
yoneda-iso C c d = record { f = ⇒.η X; g = ⇐.η X;
                            iso = iso X }
  where
    open NaturalIsomorphism (yoneda C)
    module iso F,c = Mor.Iso (iso F,c)
    X = ((Embed.F₀ C d) , c)

yoneda-inj : ∀ {o ℓ e} → (C : Category o ℓ e) (c d : Category.Obj C) -> NaturalIsomorphism (Embed.F₀ C c) (Embed.F₀ C d)
              -> Mor._≅_ C c d
yoneda-inj C c d ηiso = record { f = ⇒.η c ⟨$⟩ C.id; g = ⇐.η d ⟨$⟩ C.id;
            iso = record { isoˡ = Lemma.lemma c d ηiso;
                           isoʳ = Lemma.lemma d c (IsEquivalence.sym Categories.NaturalIsomorphism.equiv ηiso)
                         } }
  where
    open import Categories.Support.SetoidFunctions
    open import Relation.Binary
    module C = Category C
    open C.HomReasoning
    module Lemma (c d : C.Obj) (ηiso : NaturalIsomorphism (Embed.F₀ C c) (Embed.F₀ C d)) where
      open NaturalIsomorphism ηiso
      module iso c = Mor.Iso (iso c)
      .lemma : (⇐.η d ⟨$⟩ C.id) C.∘ (⇒.η c ⟨$⟩ C.id) C.≡ C.id
      lemma = begin
                (⇐.η d ⟨$⟩ C.id) C.∘ (⇒.η c ⟨$⟩ C.id)
              ↑⟨ C.identityˡ ⟩
                C.id C.∘ (⇐.η d ⟨$⟩ C.id) C.∘ (⇒.η c ⟨$⟩ C.id)
              ↑⟨ ⇐.commute (⇒.η c ⟨$⟩ C.id) {C.id} C.Equiv.refl ⟩
                ⇐.η c ⟨$⟩ C.id C.∘ C.id C.∘ (⇒.η c ⟨$⟩ C.id)
              ↓⟨ cong (⇐.η c) (C.Equiv.trans C.identityˡ C.identityˡ) ⟩
                ⇐.η c ⟨$⟩ (⇒.η c ⟨$⟩ C.id)
              ↓⟨ iso.isoˡ c C.Equiv.refl ⟩
                C.id
              ∎
    open NaturalIsomorphism ηiso


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some code related to indexed AVL trees that relies on the K rule
------------------------------------------------------------------------

{-# OPTIONS --with-K --safe #-}

open import Relation.Binary
open import Relation.Binary.PropositionalEquality using (_≡_; refl; subst)

module Data.AVL.Indexed.WithK
       {k r} (Key : Set k) {_<_ : Rel Key r}
       (isStrictTotalOrder : IsStrictTotalOrder _≡_ _<_) where

strictTotalOrder = record { isStrictTotalOrder = isStrictTotalOrder }

open import Data.Product
open import Data.AVL.Indexed strictTotalOrder as AVL hiding (Value)

module _ {v} {V′ : Key → Set v} where

  private
    V : AVL.Value v
    V = AVL.MkValue V′ (subst V′)

  node-injectiveˡ : ∀ {hˡ hʳ h l u k}
    {lk₁ : Tree V l [ proj₁ k ] hˡ} {lk₂ : Tree V l [ proj₁ k ] hˡ}
    {ku₁ : Tree V [ proj₁ k ] u hʳ} {ku₂ : Tree V [ proj₁ k ] u hʳ}
    {bal₁ bal₂ : hˡ ∼ hʳ ⊔ h} →
    node k lk₁ ku₁ bal₁ ≡ node k lk₂ ku₂ bal₂ → lk₁ ≡ lk₂
  node-injectiveˡ refl = refl

  node-injectiveʳ : ∀ {hˡ hʳ h l u k}
    {lk₁ : Tree V l [ proj₁ k ] hˡ} {lk₂ : Tree V l [ proj₁ k ] hˡ}
    {ku₁ : Tree V [ proj₁ k ] u hʳ} {ku₂ : Tree V [ proj₁ k ] u hʳ}
    {bal₁ bal₂ : hˡ ∼ hʳ ⊔ h} →
    node k lk₁ ku₁ bal₁ ≡ node k lk₂ ku₂ bal₂ → ku₁ ≡ ku₂
  node-injectiveʳ refl = refl

  node-injective-bal : ∀ {hˡ hʳ h l u k}
    {lk₁ : Tree V l [ proj₁ k ] hˡ} {lk₂ : Tree V l [ proj₁ k ] hˡ}
    {ku₁ : Tree V [ proj₁ k ] u hʳ} {ku₂ : Tree V [ proj₁ k ] u hʳ}
    {bal₁ bal₂ : hˡ ∼ hʳ ⊔ h} →
    node k lk₁ ku₁ bal₁ ≡ node k lk₂ ku₂ bal₂ → bal₁ ≡ bal₂
  node-injective-bal refl = refl


{-# OPTIONS --universe-polymorphism #-}
module Categories.Bicategory.Helpers where

-- quite a bit of the code below is taken from Categories.2-Category
open import Data.Nat using (_+_)
open import Function using (flip)
open import Data.Product using (_,_; curry)

open import Categories.Category
open import Categories.Categories using (Categories)
import Categories.Functor
open import Categories.Terminal using (OneC; One; unit)
open import Categories.Object.Terminal using (module Terminal)
open import Categories.Bifunctor hiding (identityˡ; identityʳ; assoc) renaming (id to idF; _≡_ to _≡F_; _∘_ to _∘F_)
open import Categories.NaturalIsomorphism
open import Categories.NaturalTransformation using (NaturalTransformation) renaming (_≡_ to _≡ⁿ_; id to idⁿ)
open import Categories.Product using (Product; assocʳ; πˡ; πʳ)

module BicategoryHelperFunctors {o ℓ t e} (Obj : Set o) (_⇒_ : (A B : Obj) → Category ℓ t e)
    (—⊗— : {A B C : Obj} → Bifunctor (B ⇒ C) (A ⇒ B) (A ⇒ C))
    (id : {A : Obj} → Functor {ℓ} {t} {e} OneC (A ⇒ A)) where

  open Terminal (One {ℓ} {t} {e})

  _∘_ : {A B C : Obj} {L R : Category ℓ t e} → Functor L (B ⇒ C) → Functor R (A ⇒ B) → Bifunctor L R (A ⇒ C)
  _∘_ {A} {B} {C} F G = reduce-× {D₁ = B ⇒ C} {D₂ = A ⇒ B} —⊗— F G

  -- convenience!
  module _⇒_ (A B : Obj) = Category (A ⇒ B)
  open _⇒_ public using () renaming (Obj to _⇒₁_)

  private module imp⇒ {X Y : Obj} = Category (X ⇒ Y)
  open imp⇒ public using () renaming (_⇒_ to _⇒₂_; id to id₂; _∘_ to _•_; _≡_ to _≡₂_)

  id₁ : ∀ {A} → A ⇒₁ A
  id₁ {A} = Functor.F₀ (id {A}) unit

  id₁₂ : ∀ {A} → id₁ {A} ⇒₂ id₁ {A}
  id₁₂ {A} = id₂ {A = id₁ {A}}

  infixr 9 _∘₁_
  _∘₁_ : ∀ {A B C} → B ⇒₁ C → A ⇒₁ B → A ⇒₁ C
  _∘₁_ = curry (Functor.F₀ —⊗—)

  -- horizontal composition
  infixr 9 _∘₂_
  _∘₂_ : ∀ {A B C} {g g′ : B ⇒₁ C} {f f′ : A ⇒₁ B} (β : g ⇒₂ g′) (α : f ⇒₂ f′) → (g ∘₁ f) ⇒₂ (g′ ∘₁ f′)
  _∘₂_ = curry (Functor.F₁ —⊗—)

  -- left whiskering
  infixl 9 _◃_
  _◃_ : ∀ {A B C} {g g′ : B ⇒₁ C} → g ⇒₂ g′ → (f : A ⇒₁ B) → (g ∘₁ f) ⇒₂ (g′ ∘₁ f)
  β ◃ f = β ∘₂ id₂

  -- right whiskering
  infixr 9 _▹_
  _▹_ : ∀ {A B C} (g : B ⇒₁ C) → {f f′ : A ⇒₁ B} → f ⇒₂ f′ → (g ∘₁ f) ⇒₂ (g ∘₁ f′)
  g ▹ α = id₂ ∘₂ α

  module Coherence
      (identityˡ : {A B : Obj} → NaturalIsomorphism  (id ∘ idF {C = A ⇒ B}) (πʳ {C = ⊤} {A ⇒ B}))
      (identityʳ : {A B : Obj} → NaturalIsomorphism (idF {C = A ⇒ B} ∘ id) (πˡ {C = A ⇒ B}))
      (assoc : {A B C D : Obj} → NaturalIsomorphism  (idF ∘ —⊗—) ((—⊗— ∘ idF) ∘F assocʳ (C ⇒ D) (B ⇒ C) (A ⇒ B)) ) where

    open Categories.NaturalTransformation.NaturalTransformation

     -- left/right are inverted between in certain situations!
    -- private so as to not clash with the ones in Bicategory itself
    private
      ρᵤ : {A B : Obj} (f : A ⇒₁ B) → (id₁ ∘₁ f) ⇒₂ f
      ρᵤ f = η (NaturalIsomorphism.F⇒G identityˡ) (unit , f)

      λᵤ : {A B : Obj} (f : A ⇒₁ B) → (f ∘₁ id₁) ⇒₂ f
      λᵤ f = η (NaturalIsomorphism.F⇒G identityʳ) (f , unit)

      α : {A B C D : Obj} (f : A ⇒₁ B) (g : B ⇒₁ C) (h : C ⇒₁ D) →
          (h ∘₁ (g ∘₁ f)) ⇒₂ ((h ∘₁ g) ∘₁ f)
      α f g h = η (NaturalIsomorphism.F⇒G assoc) (h , g , f)

    -- Triangle identity.  Look how closely it matches with the one on
    -- http://ncatlab.org/nlab/show/bicategory
    Triangle : {A B C : Obj} (f : A ⇒₁ B) (g : B ⇒₁ C) → Set e
    Triangle f g = (g ▹ ρᵤ f) ≡₂ ((λᵤ g ◃ f) • (α f id₁ g))

    -- Pentagon identity.  Ditto.
    Pentagon : {A B C D E : Obj} (f : A ⇒₁ B) (g : B ⇒₁ C) (h : C ⇒₁ D) (i : D ⇒₁ E) → Set e
    Pentagon f g h i = ((α g h i ◃ f) • (α f (h ∘₁ g) i)) • (i ▹ α f g h) ≡₂ (α f g (i ∘₁ h) • α (g ∘₁ f) h i)


head : #$\forall$# {A n} → Vec A (1 + n) → A

zip : #$\forall$# {A B n} → Vec A n → Vec B n → Vec (A × B) n

take : #$\forall$# {A} m {n} → Vec A (m + n) → Vec A m


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

open import Definition.Typed.EqualityRelation

module Definition.LogicalRelation.Properties.Universe {{eqrel : EqRelSet}} where
open EqRelSet {{...}}

open import Definition.Untyped
open import Definition.Typed
open import Definition.LogicalRelation
open import Definition.LogicalRelation.ShapeView
open import Definition.LogicalRelation.Irrelevance

open import Tools.Embedding

-- Helper function for reducible terms of type U for specific type derivations.
univEq′ : ∀ {l Γ A} ([U] : Γ ⊩⟨ l ⟩U) → Γ ⊩⟨ l ⟩ A ∷ U / U-intr [U] → Γ ⊩⟨ ⁰ ⟩ A
univEq′ (noemb (Uᵣ .⁰ 0<1 ⊢Γ)) (Uₜ A₁ d typeA A≡A [A]) = [A]
univEq′ (emb 0<1 x) (ιx [A]) = univEq′ x [A]

-- Reducible terms of type U are reducible types.
univEq : ∀ {l Γ A} ([U] : Γ ⊩⟨ l ⟩ U) → Γ ⊩⟨ l ⟩ A ∷ U / [U] → Γ ⊩⟨ ⁰ ⟩ A
univEq [U] [A] = univEq′ (U-elim [U])
                         (irrelevanceTerm [U] (U-intr (U-elim [U])) [A])

-- Helper function for reducible term equality of type U for specific type derivations.
univEqEq′ : ∀ {l l′ Γ A B} ([U] : Γ ⊩⟨ l ⟩U) ([A] : Γ ⊩⟨ l′ ⟩ A)
         → Γ ⊩⟨ l ⟩ A ≡ B ∷ U / U-intr [U]
         → Γ ⊩⟨ l′ ⟩ A ≡ B / [A]
univEqEq′ (noemb (Uᵣ .⁰ 0<1 ⊢Γ)) [A]
          (Uₜ₌ A₁ B₁ d d′ typeA typeB A≡B [t] [u] [t≡u]) =
  irrelevanceEq [t] [A] [t≡u]
univEqEq′ (emb 0<1 x) [A] (ιx [A≡B]) = univEqEq′ x [A] [A≡B]

-- Reducible term equality of type U is reducible type equality.
univEqEq : ∀ {l l′ Γ A B} ([U] : Γ ⊩⟨ l ⟩ U) ([A] : Γ ⊩⟨ l′ ⟩ A)
         → Γ ⊩⟨ l ⟩ A ≡ B ∷ U / [U]
         → Γ ⊩⟨ l′ ⟩ A ≡ B / [A]
univEqEq [U] [A] [A≡B] =
  let [A≡B]′ = irrelevanceEqTerm [U] (U-intr (U-elim [U])) [A≡B]
  in  univEqEq′ (U-elim [U]) [A] [A≡B]′


------------------------------------------------------------------------
-- The Agda standard library
--
-- Reflection-based solver for monoid equalities
------------------------------------------------------------------------
--
-- This solver automates the construction of proofs of equivalences
-- between monoid expressions.
-- When called like so:
--
--   proof : ∀ x y z → (x ∙ y) ∙ z ≈ x ∙ (y ∙ z) ∙ ε
--   proof x y z = solve mon
--
-- The following diagram describes what happens under the hood:
--
--            ┌▸x ∙ (y ∙ (z ∙ ε)) ════ x ∙ (y ∙ (z ∙ ε))◂┐
--            │         ║                      ║         │
--            │         ║                      ║         │
--          [_⇓]        ║                      ║        [_⇓]
--          ╱           ║                      ║          ╲
--         ╱            ║                      ║           ╲
-- (x ∙′ y) ∙′ z      homo                   homo    x ∙′ (y ∙′ z) ∙′ ε′
--   ▴     ╲            ║                      ║           ╱       ▴
--   │      ╲           ║                      ║          ╱        │
--   │       [_↓]       ║                      ║        [_↓]       │
--   │        │         ║                      ║         │         │
--   │        │         ║                      ║         │         │
--   │        └───▸(x ∙ y) ∙ z          x ∙ (y ∙ z) ∙ ε◂─┘         │
--   │                  │                      │                   │
--   │                  │                      │                   │
--   └────reflection────┘                      └───reflection──────┘
--
-- The actual output—the proof constructed by the solver—is represented
-- by the double-lined path (══).
--
-- We start at the bottom, with our two expressions.
-- Through reflection, we convert these two expressions to their AST
-- representations, in the Expr type.
-- We then can evaluate the AST in two ways: one simply gives us back
-- the two expressions we put in ([_↓]), and the other normalises
-- ([_⇓]).
-- We use the homo function to prove equivalence between these two
-- forms: joining up these two proofs gives us the desired overall
-- proof.

-- Note: What's going on with the Monoid parameter?
--
-- This module is not parameterised over a monoid, which is contrary
-- to what you might expect. Instead, we take the monoid record as an
-- argument to the solve macro, and then pass it around as an
-- argument wherever we need it.
--
-- We need to get the monoid record at the call site, not the import
-- site, to ensure that it's consistent with the rest of the context.
-- For instance, if we wanted to produce `x ∙ y` using the monoid record
-- as imported, we would run into problems:
-- * If we tried to just reflect on the expression itself
--   (quoteTerm (x ∙ y)) we would likely get some de Bruijn indices
--   wrong (in x and y), and ∙ might not even be in scope where the
--   user wants us to solve! If they're solving an expression like
--   x + (y + z), they can pass in the +-0-monoid, but don't have to
--   open it themselves.
-- * If instead we tried to construct a term which accesses the _∙_
--   field on the reflection of the record, we'd run into similar
--   problems again. While the record is a parameter for us, it might
--   not be for the user.
-- Basically, we need the Monoid we're looking at to be exactly the
-- same as the one the user is looking at, and in order to do that we
-- quote it at the call site.

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

module Tactic.MonoidSolver where

open import Algebra
open import Function

open import Data.Bool    as Bool    using (Bool; _∨_; if_then_else_)
open import Data.Maybe   as Maybe   using (Maybe; just; nothing; maybe)
open import Data.List    as List    using (List; _∷_; [])
open import Data.Nat     as ℕ       using (ℕ; suc; zero)
open import Data.Product as Product using (_×_; _,_)

open import Agda.Builtin.Reflection
open import Reflection.Argument
open import Reflection.Term using (getName; _⋯⟅∷⟆_)
open import Reflection.TypeChecking.MonadSyntax

import Relation.Binary.Reasoning.Setoid as SetoidReasoning

----------------------------------------------------------------------
-- The Expr type with homomorphism proofs
----------------------------------------------------------------------

infixl 7 _∙′_
data Expr {a} (A : Set a) : Set a where
  _∙′_  : Expr A → Expr A → Expr A
  ε′    : Expr A
  [_↑]  : A → Expr A

module _ {m₁ m₂} (monoid : Monoid m₁ m₂) where

  open Monoid monoid
  open SetoidReasoning setoid

  -- Convert the AST to an expression (i.e. evaluate it) without
  -- normalising.
  [_↓] : Expr Carrier → Carrier
  [ x ∙′ y  ↓] = [ x ↓] ∙ [ y ↓]
  [ ε′      ↓] = ε
  [ [ x ↑]  ↓] = x

  -- Convert an AST to an expression (i.e. evaluate it) while
  -- normalising.
  --
  -- This first function actually converts an AST to the Cayley
  -- representation of the underlying monoid.
  -- This obeys the monoid laws up to beta-eta equality, which is the
  -- property which gives us the "normalising" behaviour we want.
  [_⇓]′ : Expr Carrier → Carrier → Carrier
  [ x ∙′ y  ⇓]′ z = [ x ⇓]′ ([ y ⇓]′ z)
  [ ε′      ⇓]′ y = y
  [ [ x ↑]  ⇓]′ y = x ∙ y

  [_⇓] : Expr Carrier → Carrier
  [ x ⇓] = [ x ⇓]′ ε

  homo′ : ∀ x y → [ x ⇓] ∙ y ≈ [ x ⇓]′ y
  homo′ ε′ y       = identityˡ y
  homo′ [ x ↑] y   = ∙-congʳ (identityʳ x)
  homo′ (x ∙′ y) z = begin
    [ x ∙′ y ⇓] ∙ z       ≡⟨⟩
    [ x ⇓]′ [ y ⇓] ∙ z    ≈˘⟨ ∙-congʳ (homo′ x [ y ⇓]) ⟩
    ([ x ⇓] ∙ [ y ⇓]) ∙ z ≈⟨ assoc [ x ⇓] [ y ⇓] z ⟩
    [ x ⇓] ∙ ([ y ⇓] ∙ z) ≈⟨ ∙-congˡ (homo′ y z) ⟩
    [ x ⇓] ∙ ([ y ⇓]′ z)  ≈⟨ homo′ x ([ y ⇓]′ z) ⟩
    [ x ⇓]′ ([ y ⇓]′ z)   ∎

  homo : ∀ x → [ x ⇓] ≈ [ x ↓]
  homo ε′       = refl
  homo [ x ↑]   = identityʳ x
  homo (x ∙′ y) = begin
    [ x ∙′ y ⇓]     ≡⟨⟩
    [ x ⇓]′ [ y ⇓]  ≈˘⟨ homo′ x [ y ⇓] ⟩
    [ x ⇓] ∙ [ y ⇓] ≈⟨ ∙-cong (homo x) (homo y) ⟩
    [ x ↓] ∙ [ y ↓] ∎

----------------------------------------------------------------------
-- Helpers for reflection
----------------------------------------------------------------------

_==_ = primQNameEquality
{-# INLINE _==_ #-}

getArgs : Term → Maybe (Term × Term)
getArgs (def _ xs) = go xs
  where
  go : List (Arg Term) → Maybe (Term × Term)
  go (vArg x ∷ vArg y ∷ []) = just (x , y)
  go (x ∷ xs)               = go xs
  go _                      = nothing
getArgs _ = nothing

----------------------------------------------------------------------
-- Getting monoid names
----------------------------------------------------------------------

-- We try to be flexible here, by matching two kinds of names.
-- The first is the field accessor for the monoid record itself.
-- However, users will likely want to use the solver with
-- expressions like:
--
--   xs ++ (ys ++ zs) ≡ (xs ++ ys) ++ zs
--
-- So we also evaluate the field accessor to find functions like ++.

record MonoidNames : Set where
  field
    is-∙ : Name → Bool
    is-ε : Name → Bool

buildMatcher : Name → Maybe Name → Name → Bool
buildMatcher n nothing  x = n == x
buildMatcher n (just m) x = n == x ∨ m == x

findMonoidNames : Term → TC MonoidNames
findMonoidNames mon = do
  ∙-altName ← normalise (def (quote Monoid._∙_) (2 ⋯⟅∷⟆ mon ⟨∷⟩ []))
  ε-altName ← normalise (def (quote Monoid.ε)   (2 ⋯⟅∷⟆ mon ⟨∷⟩ []))
  returnTC record
    { is-∙ = buildMatcher (quote Monoid._∙_) (getName ∙-altName)
    ; is-ε = buildMatcher (quote Monoid.ε)   (getName ε-altName)
    }

----------------------------------------------------------------------
-- Building Expr
----------------------------------------------------------------------

-- We now define a function that takes an AST representing the LHS
-- or RHS of the equation to solve and converts it into an AST
-- respresenting the corresponding Expr.

″ε″ : Term
″ε″ = quote ε′ ⟨ con ⟩ []

[_↑]′ : Term → Term
[ t ↑]′ = quote [_↑] ⟨ con ⟩ (t ⟨∷⟩ [])

module _ (names : MonoidNames) where

 open MonoidNames names

 mutual
  ″∙″ : List (Arg Term) → Term
  ″∙″ (x ⟨∷⟩ y ⟨∷⟩ []) = quote _∙′_ ⟨ con ⟩ buildExpr x ⟨∷⟩ buildExpr y ⟨∷⟩ []
  ″∙″ (x ∷ xs)         = ″∙″ xs
  ″∙″ _                = unknown

  buildExpr : Term → Term
  buildExpr t@(def n xs) =
    if is-∙ n
      then ″∙″ xs
    else if is-ε n
      then ″ε″
    else
      [ t ↑]′
  buildExpr t@(con n xs) =
    if is-∙ n
      then ″∙″ xs
    else if is-ε n
      then ″ε″
    else [ t ↑]′
  buildExpr t = quote [_↑] ⟨ con ⟩ (t ⟨∷⟩ [])

----------------------------------------------------------------------
-- Constructing the solution
----------------------------------------------------------------------

-- This function joins up the two homomorphism proofs. It constructs
-- a proof of the following form:
--
--   trans (sym (homo x)) (homo y)
--
-- where x and y are the Expr representations of each side of the
-- goal equation.

constructSoln : Term → MonoidNames → Term → Term → Term
constructSoln mon names lhs rhs =
  quote Monoid.trans ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩
    (quote Monoid.sym ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩
       (quote homo ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩ buildExpr names lhs ⟨∷⟩ []) ⟨∷⟩ [])
    ⟨∷⟩
    (quote homo ⟨ def ⟩ 2 ⋯⟅∷⟆ mon ⟨∷⟩ buildExpr names rhs ⟨∷⟩ []) ⟨∷⟩
    []

----------------------------------------------------------------------
-- Macro
----------------------------------------------------------------------

solve-macro : Term → Term → TC _
solve-macro mon hole = do
  hole′ ← inferType hole >>= normalise
  names ← findMonoidNames mon
  just (lhs , rhs) ← returnTC (getArgs hole′)
    where nothing → typeError (termErr hole′ ∷ [])
  let soln = constructSoln mon names lhs rhs
  unify hole soln

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


{-

Inductive eliminators to establish properties of all finite sets directly

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

module Cubical.Data.FinSet.Induction where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Equiv renaming (_∙ₑ_ to _⋆_)
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence

open import Cubical.HITs.PropositionalTruncation as Prop
open import Cubical.HITs.SetTruncation as Set

open import Cubical.Data.Nat
  renaming (_+_ to _+ℕ_) hiding (elim)
open import Cubical.Data.Unit
open import Cubical.Data.Empty as Empty
open import Cubical.Data.Sum

open import Cubical.Data.Fin renaming (Fin to Finℕ)
open import Cubical.Data.SumFin
open import Cubical.Data.FinSet.Base
open import Cubical.Data.FinSet.Properties
open import Cubical.Data.FinSet.Constructors

private
  variable
    ℓ ℓ' : Level

-- definitions mimicking that of natural numbers

module _
  {ℓ : Level} where

  𝟘 : FinSet ℓ
  𝟘 = ⊥* , 0 , ∣ uninhabEquiv Empty.rec* Empty.rec ∣

  𝟙 : FinSet ℓ
  𝟙 = Unit* , isContr→isFinSet (isContrUnit*)

  _+_ : FinSet ℓ → FinSet ℓ → FinSet ℓ
  X + Y = X .fst ⊎ Y .fst , isFinSet⊎ X Y

  -- 𝔽in can be seen as a universe polymorphic version of SumFin
  𝔽in : ℕ → FinSet ℓ
  𝔽in 0 = 𝟘
  𝔽in (suc n) = 𝟙 + 𝔽in n

  -- useful properties

  𝟘≃Empty : 𝟘 .fst ≃ ⊥
  𝟘≃Empty = uninhabEquiv rec* (λ x → x)

  𝟙≃Unit : 𝟙 .fst ≃ Unit
  𝟙≃Unit = isContr→≃Unit (isContrUnit*)

  * : {n : ℕ} → 𝔽in (suc n) .fst
  * = inl tt*

  𝔽in≃Fin : (n : ℕ) → 𝔽in n .fst ≃ Fin n
  𝔽in≃Fin 0 = 𝟘≃Empty
  𝔽in≃Fin (suc n) = ⊎-equiv 𝟙≃Unit (𝔽in≃Fin n)

  𝔽in≃Finℕ : (n : ℕ) → 𝔽in n .fst ≃ Finℕ n
  𝔽in≃Finℕ n = 𝔽in≃Fin n ⋆ SumFin≃Fin n

  -- 𝔽in preserves addition

  𝟘+X≡X : {X : FinSet ℓ} → 𝟘 + X ≡ X
  𝟘+X≡X {X = X} i .fst = ua (⊎-swap-≃ ⋆ ⊎-equiv (idEquiv (X .fst)) 𝟘≃Empty ⋆ ⊎-⊥-≃) i
  𝟘+X≡X {X = X} i .snd =
    isProp→PathP {B = λ i → isFinSet (𝟘+X≡X {X = X} i .fst)}
                 (λ _ → isPropIsFinSet) ((𝟘 + X) .snd) (X .snd) i

  𝔽in1≡𝟙 : 𝔽in 1 ≡ 𝟙
  𝔽in1≡𝟙 i .fst = ua (⊎-equiv (idEquiv (𝟙 .fst)) 𝟘≃Empty ⋆ ⊎-⊥-≃) i
  𝔽in1≡𝟙 i .snd =
    isProp→PathP {B = λ i → isFinSet (𝔽in1≡𝟙 i .fst)}
                 (λ _ → isPropIsFinSet) (𝔽in 1 .snd) (𝟙 .snd) i

  𝔽in+ : (m n : ℕ) → 𝔽in m + 𝔽in n ≡ 𝔽in (m +ℕ n)
  𝔽in+ 0 n = 𝟘+X≡X
  𝔽in+ (suc m) n i .fst = (ua (⊎-assoc-≃) ∙ (λ i → (𝟙 + 𝔽in+ m n i) .fst)) i
  𝔽in+ (suc m) n i .snd =
    isProp→PathP {B = λ i → isFinSet (𝔽in+ (suc m) n i .fst)}
                 (λ _ → isPropIsFinSet) ((𝔽in (suc m) + 𝔽in n) .snd) (𝔽in (suc m +ℕ n) .snd) i

-- every finite sets are merely equal to some 𝔽in

∣≡𝔽in∣ : (X : FinSet ℓ) → ∥ Σ[ n ∈ ℕ ] X ≡ 𝔽in n ∥
∣≡𝔽in∣ X = Prop.map (λ (n , p) → n , path X (n , p)) (isFinSet→isFinSet' (X .snd))
  where
    path : (X : FinSet ℓ) → ((n , _) : isFinOrd (X .fst)) → X ≡ 𝔽in n
    path X (n , p) i .fst = ua (p ⋆ invEquiv (𝔽in≃Fin n)) i
    path X (n , p) i .snd =
      isProp→PathP {B = λ i → isFinSet (path X (n , p) i .fst)}
                   (λ _ → isPropIsFinSet) (X .snd) (𝔽in n .snd) i

-- the eliminators

module _
  (P : FinSet ℓ → Type ℓ')
  (h : (X : FinSet ℓ) → isProp (P X)) where

  module _
    (p : (n : ℕ) → P (𝔽in n)) where

    elimProp : (X : FinSet ℓ) → P X
    elimProp X = Prop.rec (h X) (λ (n , q) → transport (λ i → P (q (~ i))) (p n)) (∣≡𝔽in∣ X)

  module _
    (p0 : P 𝟘)
    (p1 : {X : FinSet ℓ} → P X → P (𝟙 + X)) where

    elimProp𝔽in : (n : ℕ) → P (𝔽in n)
    elimProp𝔽in 0 = p0
    elimProp𝔽in (suc n) = p1 (elimProp𝔽in n)

    elimProp𝟙+ : (X : FinSet ℓ) → P X
    elimProp𝟙+ = elimProp elimProp𝔽in

  module _
    (p0 : P 𝟘)(p1 : P 𝟙)
    (p+ : {X Y : FinSet ℓ} → P X → P Y → P (X + Y)) where

    elimProp+ : (X : FinSet ℓ) → P X
    elimProp+ = elimProp𝟙+ p0 (λ p → p+ p1 p)


------------------------------------------------------------------------
-- Some results/examples related to CCS, implemented using the
-- classical definition of bisimilarity
------------------------------------------------------------------------

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

open import Prelude

module Bisimilarity.CCS.Examples.Classical {ℓ} {Name : Type ℓ} where

open import Equality.Propositional
open import Prelude.Size

open import Bisimilarity.CCS.Classical
import Bisimilarity.Classical.Equational-reasoning-instances
open import Equational-reasoning
open import Labelled-transition-system.CCS Name
open import Relation

open import Bisimilarity.Classical CCS

------------------------------------------------------------------------
-- Exercise 6.2.4 from "Enhancements of the bisimulation proof method"
-- by Pous and Sangiorgi

6-2-4 : ∀ {a} → ! ! a ∙ ∼ ! a ∙
6-2-4 {a} = bisimulation-up-to-∼⊆∼ R-is base
  where
  data R : Rel₂ ℓ (Proc ∞) where
    base : R (! ! a ∙ , ! a ∙)

  impossible : ∀ {μ P q} {Q : Type q} →
               ! ! a ∙ [ μ ]⟶ P → μ ≡ τ → Q
  impossible {μ} !!a⟶P μ≡τ = ⊥-elim $ name≢τ
    (name a  ≡⟨ !-only (!-only ·-only) !!a⟶P ⟩
     μ       ≡⟨ μ≡τ ⟩∎
     τ       ∎)

  R-is : Bisimulation-up-to-bisimilarity R
  R-is = ⟪ lr , rl ⟫
    where
    lemma = λ {P : Proc ∞} P∼!a∣∅ →
      ! ! a ∙ ∣ P            ∼⟨ reflexive ∣-cong P∼!a∣∅ ⟩
      ! ! a ∙ ∣ (! a ∙ ∣ ∅)  ∼⟨ reflexive ∣-cong ∣-right-identity ⟩
      ! ! a ∙ ∣ ! a ∙        ∼⟨ 6-1-2 ⟩■
      ! ! a ∙

    lr : ∀ {P P′ Q μ} →
         R (P , Q) → P [ μ ]⟶ P′ →
         ∃ λ Q′ → Q [ μ ]⟶ Q′ ×
                  (Bisimilarity ⊙ R ⊙ Bisimilarity) (P′ , Q′)
    lr {P′ = P′} base !!a⟶P′ = case 6-1-3-2 !!a⟶P′ of λ where
      (inj₂ (μ≡τ , _)) → impossible !!a⟶P′ μ≡τ
      (inj₁ (P″ , !a⟶P″ , P′∼!!a∣P″)) → case 6-1-3-2 !a⟶P″ of λ where
        (inj₂ (μ≡τ , _)) → impossible !!a⟶P′ μ≡τ
        (inj₁ (.∅ , action , P″∼!a∣∅)) →
            _
          , (! a ∙      [ name a ]⟶⟨ replication (par-right action) ⟩
             ! a ∙ ∣ ∅)
          , _
          , (P′            ∼⟨ P′∼!!a∣P″ ⟩
             ! ! a ∙ ∣ P″  ∼⟨ ∼: lemma P″∼!a∣∅ ⟩■
             ! ! a ∙)
          , _
          , base
          , (! a ∙      ∼⟨ symmetric ∣-right-identity ⟩■
             ! a ∙ ∣ ∅)

    rl : ∀ {P Q Q′ μ} →
         R (P , Q) → Q [ μ ]⟶ Q′ →
         ∃ λ P′ → P [ μ ]⟶ P′ ×
                  (Bisimilarity ⊙ R ⊙ Bisimilarity) (P′ , Q′)
    rl {Q′ = Q′} base !a⟶Q′ = case 6-1-3-2 !a⟶Q′ of λ where
      (inj₂ (refl , .∅ , Q″ , .a , action , a⟶Q″ , _)) →
        ⊥-elim (names-are-not-inverted a⟶Q″)
      (inj₁ (.∅ , action , Q′∼!a∣∅)) →
          _
        , (! ! a ∙       [ name a ]⟶⟨ replication (par-right !a⟶Q′) ⟩
           ! ! a ∙ ∣ Q′)
        , _
        , (! ! a ∙ ∣ Q′  ∼⟨ lemma Q′∼!a∣∅ ⟩■
           ! ! a ∙)
        , _
        , base
        , (! a ∙      ∼⟨ symmetric ∣-right-identity ⟩
           ! a ∙ ∣ ∅  ∼⟨ symmetric Q′∼!a∣∅ ⟩■
           Q′)

------------------------------------------------------------------------
-- A result mentioned in "Enhancements of the bisimulation proof
-- method" by Pous and Sangiorgi

∙∣∙∼∙∙ : ∀ {a} → a ∙ ∣ a ∙ ∼ name a ∙ (a ∙)
∙∣∙∼∙∙ {a} = bisimulation-up-to-∪⊆∼ R-is base
  where
  data R : Rel₂ ℓ (Proc ∞) where
    base : R (a ∙ ∣ a ∙ , name a ∙ (a ∙))

  R-is : Bisimulation-up-to-∪ R
  R-is = ⟪ lr , rl ⟫
    where
    lr : ∀ {P P′ Q μ} →
         R (P , Q) → P [ μ ]⟶ P′ →
         ∃ λ Q′ → Q [ μ ]⟶ Q′ × (R ∪ Bisimilarity) (P′ , Q′)
    lr base (par-left action) =
        _
      , (name a ∙ (a ∙)  [ name a ]⟶⟨ action ⟩
         a ∙)
      , inj₂ (∅ ∣ a ∙  ∼⟨ ∣-left-identity ⟩■
              a ∙)

    lr base (par-right action) =
        _
      , (name a ∙ (a ∙)  [ name a ]⟶⟨ action ⟩
         a ∙)
      , inj₂ (a ∙ ∣ ∅  ∼⟨ ∣-right-identity ⟩■
              a ∙)

    lr base (par-τ action tr) = ⊥-elim (names-are-not-inverted tr)

    rl : ∀ {P Q Q′ μ} →
         R (P , Q) → Q [ μ ]⟶ Q′ →
         ∃ λ P′ → P [ μ ]⟶ P′ × (R ∪ Bisimilarity) (P′ , Q′)
    rl base action =
        _
      , (a ∙ ∣ a ∙  [ name a ]⟶⟨ par-right action ⟩
         a ∙ ∣ ∅)
      , inj₂ (a ∙ ∣ ∅  ∼⟨ ∣-right-identity ⟩■
              a ∙)


{-
This second-order term syntax was created from the following second-order syntax description:

syntax CommGroup | CG

type
  * : 0-ary

term
  unit : * | ε
  add  : *  *  ->  * | _⊕_ l20
  neg  : *  ->  * | ⊖_ r40

theory
  (εU⊕ᴸ) a |> add (unit, a) = a
  (εU⊕ᴿ) a |> add (a, unit) = a
  (⊕A) a b c |> add (add(a, b), c) = add (a, add(b, c))
  (⊖N⊕ᴸ) a |> add (neg (a), a) = unit
  (⊖N⊕ᴿ) a |> add (a, neg (a)) = unit
  (⊕C) a b |> add(a, b) = add(b, a)
-}

module CommGroup.Syntax where

open import SOAS.Common
open import SOAS.Context
open import SOAS.Variable
open import SOAS.Families.Core
open import SOAS.Construction.Structure
open import SOAS.ContextMaps.Inductive

open import SOAS.Metatheory.Syntax

open import CommGroup.Signature

private
  variable
    Γ Δ Π : Ctx
    α : *T
    𝔛 : Familyₛ

-- Inductive term declaration
module CG:Terms (𝔛 : Familyₛ) where

  data CG : Familyₛ where
    var  : ℐ ⇾̣ CG
    mvar : 𝔛 α Π → Sub CG Π Γ → CG α Γ

    ε   : CG * Γ
    _⊕_ : CG * Γ → CG * Γ → CG * Γ
    ⊖_  : CG * Γ → CG * Γ

  infixl 20 _⊕_
  infixr 40 ⊖_

  open import SOAS.Metatheory.MetaAlgebra ⅀F 𝔛

  CGᵃ : MetaAlg CG
  CGᵃ = record
    { 𝑎𝑙𝑔 = λ where
      (unitₒ ⋮ _)     → ε
      (addₒ  ⋮ a , b) → _⊕_ a b
      (negₒ  ⋮ a)     → ⊖_  a
    ; 𝑣𝑎𝑟 = var ; 𝑚𝑣𝑎𝑟 = λ 𝔪 mε → mvar 𝔪 (tabulate mε) }

  module CGᵃ = MetaAlg CGᵃ

  module _ {𝒜 : Familyₛ}(𝒜ᵃ : MetaAlg 𝒜) where

    open MetaAlg 𝒜ᵃ

    𝕤𝕖𝕞 : CG ⇾̣ 𝒜
    𝕊 : Sub CG Π Γ → Π ~[ 𝒜 ]↝ Γ
    𝕊 (t ◂ σ) new = 𝕤𝕖𝕞 t
    𝕊 (t ◂ σ) (old v) = 𝕊 σ v
    𝕤𝕖𝕞 (mvar 𝔪 mε) = 𝑚𝑣𝑎𝑟 𝔪 (𝕊 mε)
    𝕤𝕖𝕞 (var v) = 𝑣𝑎𝑟 v

    𝕤𝕖𝕞  ε        = 𝑎𝑙𝑔 (unitₒ ⋮ tt)
    𝕤𝕖𝕞 (_⊕_ a b) = 𝑎𝑙𝑔 (addₒ  ⋮ 𝕤𝕖𝕞 a , 𝕤𝕖𝕞 b)
    𝕤𝕖𝕞 (⊖_  a)   = 𝑎𝑙𝑔 (negₒ  ⋮ 𝕤𝕖𝕞 a)

    𝕤𝕖𝕞ᵃ⇒ : MetaAlg⇒ CGᵃ 𝒜ᵃ 𝕤𝕖𝕞
    𝕤𝕖𝕞ᵃ⇒ = record
      { ⟨𝑎𝑙𝑔⟩ = λ{ {t = t} → ⟨𝑎𝑙𝑔⟩ t }
      ; ⟨𝑣𝑎𝑟⟩ = refl
      ; ⟨𝑚𝑣𝑎𝑟⟩ = λ{ {𝔪 = 𝔪}{mε} → cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-tab mε)) }  }
      where
      open ≡-Reasoning
      ⟨𝑎𝑙𝑔⟩ : (t : ⅀ CG α Γ) → 𝕤𝕖𝕞 (CGᵃ.𝑎𝑙𝑔 t) ≡ 𝑎𝑙𝑔 (⅀₁ 𝕤𝕖𝕞 t)
      ⟨𝑎𝑙𝑔⟩ (unitₒ ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (addₒ  ⋮ _) = refl
      ⟨𝑎𝑙𝑔⟩ (negₒ  ⋮ _) = refl

      𝕊-tab : (mε : Π ~[ CG ]↝ Γ)(v : ℐ α Π) → 𝕊 (tabulate mε) v ≡ 𝕤𝕖𝕞 (mε v)
      𝕊-tab mε new = refl
      𝕊-tab mε (old v) = 𝕊-tab (mε ∘ old) v

    module _ (g : CG ⇾̣ 𝒜)(gᵃ⇒ : MetaAlg⇒ CGᵃ 𝒜ᵃ g) where

      open MetaAlg⇒ gᵃ⇒

      𝕤𝕖𝕞! : (t : CG α Γ) → 𝕤𝕖𝕞 t ≡ g t
      𝕊-ix : (mε : Sub CG Π Γ)(v : ℐ α Π) → 𝕊 mε v ≡ g (index mε v)
      𝕊-ix (x ◂ mε) new = 𝕤𝕖𝕞! x
      𝕊-ix (x ◂ mε) (old v) = 𝕊-ix mε v
      𝕤𝕖𝕞! (mvar 𝔪 mε) rewrite cong (𝑚𝑣𝑎𝑟 𝔪) (dext (𝕊-ix mε))
        = trans (sym ⟨𝑚𝑣𝑎𝑟⟩) (cong (g ∘ mvar 𝔪) (tab∘ix≈id mε))
      𝕤𝕖𝕞! (var v) = sym ⟨𝑣𝑎𝑟⟩

      𝕤𝕖𝕞! ε = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (_⊕_ a b) rewrite 𝕤𝕖𝕞! a | 𝕤𝕖𝕞! b = sym ⟨𝑎𝑙𝑔⟩
      𝕤𝕖𝕞! (⊖_ a) rewrite 𝕤𝕖𝕞! a = sym ⟨𝑎𝑙𝑔⟩

-- Syntax instance for the signature
CG:Syn : Syntax
CG:Syn = record
  { ⅀F = ⅀F
  ; ⅀:CS = ⅀:CompatStr
  ; mvarᵢ = CG:Terms.mvar
  ; 𝕋:Init = λ 𝔛 → let open CG:Terms 𝔛 in record
    { ⊥ = CG ⋉ CGᵃ
    ; ⊥-is-initial = record { ! = λ{ {𝒜 ⋉ 𝒜ᵃ} → 𝕤𝕖𝕞 𝒜ᵃ ⋉ 𝕤𝕖𝕞ᵃ⇒ 𝒜ᵃ }
    ; !-unique = λ{ {𝒜 ⋉ 𝒜ᵃ} (f ⋉ fᵃ⇒) {x = t} → 𝕤𝕖𝕞! 𝒜ᵃ f fᵃ⇒ t } } } }

-- Instantiation of the syntax and metatheory
open Syntax CG:Syn public
open CG:Terms public
open import SOAS.Families.Build public
open import SOAS.Syntax.Shorthands CGᵃ public
open import SOAS.Metatheory CG:Syn public


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

module hott.types where

open import hott.types.nat public
open import hott.types.coproduct public


module test.Negation where

open import Type
open import Declarative
open import Builtin
open import Builtin.Constant.Type
open import Builtin.Constant.Term Ctx⋆ Kind * # _⊢⋆_ con size⋆

-- zerepoch/zerepoch-core/test/data/negation.plc

open import Declarative.StdLib.Bool

negate : ∀{Γ} → Γ ⊢ boolean ⇒ boolean
negate {Γ} = ƛ (if ·⋆ boolean · ` Z · false · true)


module Oscar.Category.Monoid where

open import Oscar.Level

record Monoid 𝔬 𝔪 𝔮 : Set (lsuc (𝔬 ⊔ 𝔪 ⊔ 𝔮)) where


module Prelude.Function where

id : ∀ {a} {A : Set a} → A → A
id x = x
{-# INLINE id #-}

infixl -10 id
syntax id {A = A} x = x ofType A

const : ∀ {a b} {A : Set a} {B : Set b} → A → B → A
const x _ = x
{-# INLINE const #-}

flip : ∀ {a b c} {A : Set a} {B : Set b} {C : A → B → Set c} → (∀ x y → C x y) → ∀ y x → C x y
flip f x y = f y x
{-# INLINE flip #-}

infixr 9 _∘_
_∘_ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x → B x → Set c}
        (f : ∀ {x} (y : B x) → C x y) (g : ∀ x → B x) →
        ∀ x → C x (g x)
(f ∘ g) x = f (g x)
{-# INLINE _∘_ #-}

infixr 9 _∘′_
_∘′_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} →
         (B → C) → (A → B) → (A → C)
f ∘′ g = f ∘ g
{-# INLINE _∘′_ #-}

infixr -20 _$_ _$′_
infixr 0 case_of_ case_return_of_
_$_ : ∀ {a b} {A : Set a} {B : A → Set b} → (∀ x → B x) → ∀ x → B x
f $ x = f x

_$′_ : ∀ {a b}{A : Set a} {B : Set b} → (A → B) → A → B
f $′ x = f x

case_of_ : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
case x of f = f x

case₂_,_of_ : ∀ {a b c} {A : Set a} {B : Set b} {C : Set c} → A → B → (A → B → C) → C
case₂ x , y of f = f x y

case₃_,_,_of_ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d} → A → B → C → (A → B → C → D) → D
case₃ x , y , z of f = f x y z

case₄_,_,_,_of_ : ∀ {a b c d e} {A : Set a} {B : Set b} {C : Set c} {D : Set d} {E : Set e} →
                A → B → C → D → (A → B → C → D → E) → E
case₄ x , y , z , w of f = f x y z w

case_return_of_ : ∀ {a b} {A : Set a} (x : A) (B : A → Set b) → (∀ x → B x) → B x
case x return B of f = f x

infixr 0 letSyntax
syntax letSyntax e (λ x → b) = let[ x := e ] b
letSyntax : ∀ {a b} {A : Set a} {B : Set b} → A → (A → B) → B
letSyntax x f = f x

{-# INLINE _$_ #-}
{-# INLINE _$′_ #-}
{-# INLINE case_of_ #-}
{-# INLINE case₂_,_of_ #-}
{-# INLINE case_return_of_ #-}

infixl 8 _on_
_on_ : ∀ {a b c} {A : Set a} {B : A → Set b} {C : ∀ x y → B x → B y → Set c} →
         (∀ {x y} (z : B x) (w : B y) → C x y z w) → (f : ∀ x → B x) → ∀ x y →
         C x y (f x) (f y)
h on f = λ x y → h (f x) (f y)
{-# INLINE _on_ #-}

it : ∀ {a} {A : Set a} {{x : A}} → A
it {{x}} = x
{-# INLINE it #-}

asInstance : ∀ {a b} {A : Set a} {B : A → Set b} (x : A) → (∀ {{x}} → B x) → B x
asInstance x f = f {{x}}
{-# INLINE asInstance #-}

record Instance {a} (A : Set a) : Set a where
  constructor !
  field {{x}} : A

mkInstance : ∀ {a} {A : Set a} → A → Instance A
mkInstance x = ! {{x}}
{-# INLINE mkInstance #-}

-- Can be used to force normalisation at compile time.
static : ∀ {a} {A : Set a} → A → A
static x = x
{-# STATIC static #-}