{-# OPTIONS --cubical --safe #-}
module Cubical.HITs.Colimit.Examples where

open import Cubical.Core.Glue
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Isomorphism
open import Cubical.Data.SumFin

open import Cubical.Data.Graph
open import Cubical.HITs.Colimit.Base

open import Cubical.HITs.Pushout

-- Pushouts are colimits over the graph ⇐⇒

module _ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} where

  PushoutDiag : (A → B) → (A → C) → Diag (ℓ-max ℓ (ℓ-max ℓ' ℓ'')) ⇐⇒
  (PushoutDiag f g) $ fzero             = Lift {j = ℓ-max ℓ  ℓ'' } B
  (PushoutDiag f g) $ fsuc fzero        = Lift {j = ℓ-max ℓ' ℓ'' } A
  (PushoutDiag f g) $ fsuc (fsuc fzero) = Lift {j = ℓ-max ℓ  ℓ'  } C
  _<$>_ (PushoutDiag f g) {fsuc fzero} {fzero}             tt (lift a) = lift (f a)
  _<$>_ (PushoutDiag f g) {fsuc fzero} {fsuc (fsuc fzero)} tt (lift a) = lift (g a)

module _ {ℓ ℓ' ℓ''} {A : Type ℓ} {B : Type ℓ'} {C : Type ℓ''} {f : A → B} {g : A → C} where

  PushoutCocone : Cocone _ (PushoutDiag f g) (Pushout f g)
  leg PushoutCocone fzero               (lift b) = inl b
  leg PushoutCocone (fsuc fzero)        (lift a) = inr (g a)
  leg PushoutCocone (fsuc (fsuc fzero)) (lift c) = inr c
  com PushoutCocone {fsuc fzero} {fzero}             tt i (lift a) = push a i
  com PushoutCocone {fsuc fzero} {fsuc (fsuc fzero)} tt i (lift a) = inr (g a)

  private
    module _ ℓq (Y : Type ℓq) where

      fwd : (Pushout f g → Y) → Cocone ℓq (PushoutDiag f g) Y
      fwd = postcomp PushoutCocone

      module _ (C : Cocone ℓq (PushoutDiag f g) Y) where
        coml : ∀ a → leg C fzero               (lift (f a)) ≡ leg C (fsuc fzero) (lift a)
        comr : ∀ a → leg C (fsuc (fsuc fzero)) (lift (g a)) ≡ leg C (fsuc fzero) (lift a)
        coml a i = com C {j = fsuc fzero} {k = fzero}             tt i (lift a)
        comr a i = com C {j = fsuc fzero} {k = fsuc (fsuc fzero)} tt i (lift a)

      bwd : Cocone ℓq (PushoutDiag f g) Y → (Pushout f g → Y)
      bwd C (inl b)    = leg C fzero (lift b)
      bwd C (inr c)    = leg C (fsuc (fsuc fzero)) (lift c)
      bwd C (push a i) = (coml C a ∙ sym (comr C a)) i

      bwd-fwd : ∀ F → bwd (fwd F) ≡ F
      bwd-fwd F i (inl b) = F (inl b)
      bwd-fwd F i (inr c) = F (inr c)
      bwd-fwd F i (push a j) = compPath-filler (coml (fwd F) a) (sym (comr (fwd F) a)) (~ i) j

      fwd-bwd : ∀ C → fwd (bwd C) ≡ C
      leg (fwd-bwd C i) fzero               (lift b) = leg C fzero (lift b)
      leg (fwd-bwd C i) (fsuc fzero)        (lift a) = comr C a i
      leg (fwd-bwd C i) (fsuc (fsuc fzero)) (lift c) = leg C (fsuc (fsuc fzero)) (lift c)
      com (fwd-bwd C i) {fsuc fzero} {fzero}             tt j (lift a) -- coml (fwd-bwd C i) = ...
        = compPath-filler (coml C a) (sym (comr C a)) (~ i) j
      com (fwd-bwd C i) {fsuc fzero} {fsuc (fsuc fzero)} tt j (lift a) -- comr (fwd-bwd C i) = ...
        = comr C a (i ∧ j)

      eqv : isEquiv {A = (Pushout f g → Y)} {B = Cocone ℓq (PushoutDiag f g) Y} (postcomp PushoutCocone)
      eqv = isoToIsEquiv (iso fwd bwd fwd-bwd bwd-fwd)

  isColimPushout : isColimit (PushoutDiag f g) (Pushout f g)
  cone isColimPushout = PushoutCocone
  univ isColimPushout = eqv

  colim≃Pushout : colim (PushoutDiag f g) ≃ Pushout f g
  colim≃Pushout = uniqColimit colimIsColimit isColimPushout


module UniDB.Morph.Shift where

open import UniDB.Spec
open import UniDB.Morph.Depth
open import UniDB.Morph.Weaken

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

data Shift : MOR where
  shift : {γ₁ γ₂ : Dom} (ξ : Depth Weaken γ₁ γ₂) → Shift γ₁ γ₂

instance
  iUpShift : Up Shift
  _↑₁ {{iUpShift}} (shift ζ) = shift (ζ ↑₁)
  _↑_ {{iUpShift}} ξ 0 = ξ
  _↑_ {{iUpShift}} ξ (suc δ⁺) = ξ ↑ δ⁺ ↑₁
  ↑-zero {{iUpShift}} ξ = refl
  ↑-suc {{iUpShift}} ξ δ⁺ = refl

  iWkmShift : Wkm Shift
  wkm {{iWkmShift}} δ = shift (depth (weaken δ) 0)

  iIdmShift : Idm Shift
  idm {{iIdmShift}} _ = wkm {Shift} 0

module _ {T : STX} {{vrT : Vr T}} where

  instance
    iLkShift : Lk T Shift
    lk {{iLkShift}} (shift ζ) i = vr {T} (lk {Ix} {Depth Weaken} ζ i)

    iLkUpShift : {{wkT : Wk T}} {{wkVrT : WkVr T}} → LkUp T Shift
    lk-↑₁-zero {{iLkUpShift}} (shift ξ) = cong (vr {T}) (lk-↑₁-zero {Ix} {_} ξ )
    lk-↑₁-suc {{iLkUpShift}} (shift ξ) i = begin
      vr {T} (lk {Ix} (ξ ↑₁) (suc i)) ≡⟨ cong (vr {T}) (lk-↑₁-suc ξ i) ⟩
      vr {T} (wk₁ {Ix} (lk {Ix} ξ i)) ≡⟨ sym (wk₁-vr {T} (lk {Ix} ξ i)) ⟩
      wk₁ {T} (vr {T} (lk {Ix} ξ i))  ∎

    iLkWkmShift : LkWkm T Shift
    lk-wkm {{iLkWkmShift}} δ i = refl

    iLkIdmShift : LkIdm T Shift
    lk-idm {{iLkIdmShift}} i = refl

module _ {T : STX} {{vrT : Vr T}} where

  instance
    iLkRenShift : LkRen T Shift
    lk-ren {{iLkRenShift}} (shift ξ) i = refl

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


open import Prelude
open import Nat
open import List
open import Int
open import Bij
open import delta-lemmas
open import Delta
open import NatDelta


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

module Cubical.Categories.Instances.Functors where

open import Cubical.Categories.Category
open import Cubical.Categories.Functor.Base
open import Cubical.Categories.NaturalTransformation.Base
open import Cubical.Categories.NaturalTransformation.Properties
open import Cubical.Categories.Morphism renaming (isIso to isIsoC)
open import Cubical.Foundations.Prelude

private
  variable
    ℓC ℓC' ℓD ℓD' : Level

module _ (C : Precategory ℓC ℓC') (D : Precategory ℓD ℓD') ⦃ isCatD : isCategory D ⦄ where
  open Precategory
  open NatTrans
  open Functor

  FUNCTOR : Precategory (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) (ℓ-max (ℓ-max ℓC ℓC') ℓD')
  FUNCTOR .ob = Functor C D
  FUNCTOR .Hom[_,_] = NatTrans
  FUNCTOR .id = idTrans
  FUNCTOR ._⋆_ = seqTrans
  FUNCTOR .⋆IdL α = makeNatTransPath λ i x → D .⋆IdL (α .N-ob x) i
  FUNCTOR .⋆IdR α = makeNatTransPath λ i x → D .⋆IdR (α .N-ob x) i
  FUNCTOR .⋆Assoc α β γ = makeNatTransPath λ i x → D .⋆Assoc (α .N-ob x) (β .N-ob x) (γ .N-ob x) i

  isCatFUNCTOR : isCategory FUNCTOR
  isCatFUNCTOR .isSetHom = isSetNat

  open isIsoC renaming (inv to invC)
  -- component wise iso is an iso in Functor
  FUNCTORIso : ∀ {F G : Functor C D} (α : F ⇒ G)
             → (∀ (c : C .ob) → isIsoC {C = D} (α ⟦ c ⟧))
             → isIsoC {C = FUNCTOR} α
  FUNCTORIso α is .invC .N-ob c = (is c) .invC
  FUNCTORIso {F} {G} α is .invC .N-hom {c} {d} f
    = invMoveL areInv-αc
               ( α ⟦ c ⟧ ⋆⟨ D ⟩ (G ⟪ f ⟫ ⋆⟨ D ⟩ is d .invC)
               ≡⟨ sym (D .⋆Assoc _ _ _) ⟩
                 (α ⟦ c ⟧ ⋆⟨ D ⟩ G ⟪ f ⟫) ⋆⟨ D ⟩ is d .invC
               ≡⟨ sym (invMoveR areInv-αd (α .N-hom f)) ⟩
                 F ⟪ f ⟫
               ∎ )
    where
      areInv-αc : areInv (α ⟦ c ⟧) ((is c) .invC)
      areInv-αc = isIso→areInv (is c)

      areInv-αd : areInv (α ⟦ d ⟧) ((is d) .invC)
      areInv-αd = isIso→areInv (is d)
  FUNCTORIso α is .sec = makeNatTransPath (funExt (λ c → (is c) .sec))
  FUNCTORIso α is .ret = makeNatTransPath (funExt (λ c → (is c) .ret))

instance
  ⦃isCatFUNCTOR⦄ : {C : Precategory ℓC ℓC'} {D : Precategory ℓD ℓD'} ⦃ isCatD : isCategory D ⦄
    → isCategory (FUNCTOR C D)
  ⦃isCatFUNCTOR⦄ {C = C} {D} = isCatFUNCTOR C D


module All where

open import Basics
open import Ix

All : {X : Set} -> (X -> Set) -> (List X -> Set)
All P []        = One
All P (x ,- xs) = P x * All P xs

allPu : forall {X}{T : X -> Set} -> [ T ] -> [ All T ]
allPu t [] = <>
allPu t (x ,- xs) = t x , allPu t xs

allAp : forall {X}{S T : X -> Set} -> [ All (S -:> T) -:> All S -:> All T ]
allAp [] <> <> = <>
allAp (x ,- xs) (f , fs) (s , ss) = f s , allAp xs fs ss

all : {X : Set}{S T : X -> Set} ->
      [ S -:> T ] -> [ All S -:> All T ]
all f xs = allAp xs (allPu f xs)

allRe : forall {X Y}(f : X -> Y){P : Y -> Set}
        (xs : List X) -> All (\ x -> P (f x)) xs -> All P (list f xs)
allRe f [] <> = <>
allRe f (x ,- xs) (p , ps) = p , allRe f xs ps

collect : {I J : Set}(is : List I) -> All (\ i -> List J) is -> List J
collect [] <> = []
collect (i ,- is) (js , jss) = js +L collect is jss


data N : Set where
  suc : N → N

data Val : N → Set where
  valSuc : ∀ n → Val (suc n)

record R : Set where
  constructor wrap
  field unwrap : N

data W (ft : R) : Set where
  immed : (v : Val (R.unwrap ft)) → W ft

test : (fa : R) → W fa → R
test fa (immed (valSuc a)) = fa

postulate
  Evaluate : ∀ (ft : R) (P : (w : W ft) → Set) → Set

test₂ : ∀ (fa : R) → Set
test₂ fa = Evaluate fa testw
  where
  testw : W fa → Set
  testw (immed (valSuc a)) = W fa


module Oscar.Data.Proposequality where

open import Agda.Builtin.Equality public using (_≡_) renaming (refl to ∅) public
open import Relation.Binary.PropositionalEquality public using (_≢_) public

open import Oscar.Category.Setoid

open import Relation.Binary.PropositionalEquality using (sym; trans)

open import Oscar.Level
open import Oscar.Relation

instance

  IsSetoidProposequality : ∀ {a} {A : Set a} → IsSetoid (_≡_ {A = A})
  IsSetoid.reflexivity IsSetoidProposequality _ = ∅
  IsSetoid.symmetry IsSetoidProposequality = sym
  IsSetoid.transitivity IsSetoidProposequality = λ ‵ → trans ‵

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

  setoid : Setoid a a
  setoid = ↑ _≡_ {A = A}

{-
  private

    infixl 7 _∙_
    _∙_ : Transitive (_≡_ {A = A})
    _∙_ = (λ y≡z x≡y → transitivity x≡y y≡z)
-}

  open import Oscar.Category.Morphism
  open import Oscar.Function

  module _ {b} (B : A → A → Set b) where

{-
    private

      infix 4 _≞_
      _≞_ = λ {x} {y} → _≡_ {A = B x y}
-}
    morphism : Morphism a b b
    morphism = -- ↑ λ {x} {y} → _≞_ {x} {y} -- _≡_ {A = B x y}
               ↑ λ {x} {y} → _≡_ {A = B x y}

    open Morphism morphism

    open import Oscar.Category.Semigroupoid

    module _ (_∙_ : Transitive _↦_) (associativity : Associative _∙_ _≞_) where

      instance

        IsSemigroupoidProposequality : IsSemigroupoid morphism _∙_
        IsSemigroupoid.extensionality IsSemigroupoidProposequality ∅ ∅ = ∅
        IsSemigroupoid.associativity IsSemigroupoidProposequality = associativity

-- instance

--   IsSemigroupoidProposequality : ∀ {a} {A : Set a} {b} {B : A → A → Set b}
--     → IsSemigroupoid (morphism B) {!!} -- (transitivity ⦃ setoid A ⦄)
--   IsSemigroupoidProposequality = {!!}

--   IsSemigroupoidProposequality' : ∀ {a} {A : Set a}
--     → IsSemigroupoid (morphism (_≡_ {A = A})) (λ y≡z x≡y → transitivity x≡y y≡z) -- (transitivity ⦃ setoid A ⦄)
--   IsSemigroupoid.extensionality IsSemigroupoidProposequality' = {!!} -- ∅ ∅ = ∅
--   IsSemigroupoid.associativity IsSemigroupoidProposequality' ∅ _ _ = ∅

-- -- semigroupoid : Semigroupoid

-- -- setoid : ∀ {a} (A : Set a) → Setoid a a
-- -- setoid A = ↑ _≡_ {A = A}

-- -- open import Oscar.Category.Morphism
-- -- open import Oscar.Function

-- -- morphism : ∀ {a} {A : Set a} {b} (B : A → A → Set b) → Morphism a b b
-- -- morphism B = ↑ λ {x} {y} → _≡_ {A = B x y}

-- -- open import Oscar.Category.Semigroupoid

-- -- infixl 7 _∙_
-- -- _∙_ : ∀ {y z} → y ↦ z → ∀ {x} → x ↦ y → x ↦ z

-- -- instance

-- --   IsSemigroupoidProposequality : ∀ {a} {A : Set a} {b} {B : A → A → Set b}
-- --     → IsSemigroupoid (morphism B) {!!} -- (transitivity ⦃ setoid A ⦄)
-- --   IsSemigroupoidProposequality = {!!}

-- --   IsSemigroupoidProposequality' : ∀ {a} {A : Set a}
-- --     → IsSemigroupoid (morphism (_≡_ {A = A})) (λ y≡z x≡y → transitivity x≡y y≡z) -- (transitivity ⦃ setoid A ⦄)
-- --   IsSemigroupoid.extensionality IsSemigroupoidProposequality' = {!!} -- ∅ ∅ = ∅
-- --   IsSemigroupoid.associativity IsSemigroupoidProposequality' ∅ _ _ = ∅

-- -- -- semigroupoid : Semigroupoid


module Data.Fin.Subset.Properties.Cardinality where

open import Data.Nat as ℕ using (ℕ)
open import Data.Nat.Properties as NP
open import Data.Empty using (⊥-elim)
open import Data.Fin
open import Data.Fin.Subset
open import Data.Fin.Subset.Properties
open import Data.Vec using (_∷_; [])
open import Data.Vec.Any  using (here ; there)
open import Data.Vec.Properties as VP
open import Data.Product
open import Data.Sum
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as Eq
open import Relation.Nullary.Negation

open import Function
-- some trivial lemma

∣p∣≡0→≡⊥  : ∀ {n}(p : Subset n) → ∣ p ∣ ≡ 0 → p ≡ ⊥
∣p∣≡0→≡⊥ {ℕ.zero} [] refl = refl
∣p∣≡0→≡⊥ {ℕ.suc n} (outside ∷ p) eq = cong (outside ∷_) (∣p∣≡0→≡⊥ p eq)
∣p∣≡0→≡⊥ {ℕ.suc n} (inside ∷ p) ()

∣p∣≡n→≡⊤  : ∀ {n}(p : Subset n) → ∣ p ∣ ≡ n → p ≡ ⊤
∣p∣≡n→≡⊤ {ℕ.zero} [] refl = refl
∣p∣≡n→≡⊤ {ℕ.suc n} (outside ∷ p) eq = ⊥-elim (1+n≰n (≤-respˡ-≈ eq (∣p∣≤n p)))
  where
    open IsPartialOrder NP.≤-isPartialOrder using (≤-respˡ-≈)
∣p∣≡n→≡⊤ {ℕ.suc n} (inside ∷ p) eq = cong (inside ∷_) (∣p∣≡n→≡⊤ p (NP.suc-injective eq))

∣p∣≡1→≡⁅x⁆ : ∀ {n}(p : Subset n) → ∣ p ∣ ≡ 1 → ∃ λ x → p ≡ ⁅ x ⁆
∣p∣≡1→≡⁅x⁆ {ℕ.zero} [] ()
∣p∣≡1→≡⁅x⁆ {ℕ.suc n} (outside ∷ p) eq with ∣p∣≡1→≡⁅x⁆ p eq
... | x , q = suc x , cong (outside ∷_) q
∣p∣≡1→≡⁅x⁆ {ℕ.suc n} (inside ∷ p) eq rewrite ∣p∣≡0→≡⊥ p (NP.suc-injective eq) = zero , refl

-- union

≤∪ˡ : ∀ {n} {p} (q : Subset n) → ∣ p ∣ ℕ.≤  ∣ p ∪ q ∣
≤∪ˡ {n}{p} q = p⊆q⇒∣p∣<∣q∣ (p⊆p∪q {p = p} q)
≤∪ʳ : ∀ {n} (p q : Subset n) → ∣ q ∣ ℕ.≤  ∣ p ∪ q ∣
≤∪ʳ p q =  p⊆q⇒∣p∣<∣q∣ (q⊆p∪q p q)

∪≤ : ∀ {n} (p q : Subset n) → ∣ p ∪ q ∣ ℕ.≤ ∣ p ∣ ℕ.+ ∣ q ∣
∪≤ {ℕ.zero} [] [] = ℕ.z≤n
∪≤ {ℕ.suc n} (outside ∷ p) (outside ∷ q) = ∪≤ p q
∪≤ {ℕ.suc n} (outside ∷ p) (inside ∷ q) rewrite +-suc ∣ p ∣ ∣ q ∣ = ℕ.s≤s (∪≤ p q)
∪≤ {ℕ.suc n} (inside ∷ p) (outside ∷ q) = ℕ.s≤s (∪≤ p q)
∪≤ {ℕ.suc n} (inside ∷ p) (inside ∷ q) = ℕ.s≤s (NP.≤-trans (∪≤ p q) (NP.+-mono-≤ (≤-refl {∣ p ∣}) (n≤1+n _)))

disjoint-∪≡+ : ∀ {n} (p q : Subset n) → p ∩ q ≡ ⊥ → ∣ p ∪ q ∣ ≡ ∣ p ∣ ℕ.+ ∣ q ∣
disjoint-∪≡+ {ℕ.zero} [] [] refl = refl
disjoint-∪≡+ {ℕ.suc n} (outside ∷ p) (outside ∷ q) dis = disjoint-∪≡+ p q (VP.∷-injectiveʳ dis)
disjoint-∪≡+ {ℕ.suc n} (outside ∷ p) (inside ∷ q) dis =
  Eq.trans (Eq.cong ℕ.suc (disjoint-∪≡+ p q (VP.∷-injectiveʳ dis))) (Eq.sym (NP.+-suc _ _))
disjoint-∪≡+ {ℕ.suc n} (inside ∷ p) (outside ∷ q) dis = Eq.cong ℕ.suc (disjoint-∪≡+ p q (VP.∷-injectiveʳ dis))
disjoint-∪≡+ {ℕ.suc n} (inside ∷ p) (inside ∷ q) ()

x∈p⇒⁅x⁆∪p≡p : ∀ {n} (x : Fin n)(p : Subset n) → x ∈ p → ⁅ x ⁆ ∪ p ≡ p
x∈p⇒⁅x⁆∪p≡p x p x∈p = ⊆-antisym from to
  where
    from : ∀ {y} → y ∈ ⁅ x ⁆ ∪ p → y ∈ p
    from h with x∈p∪q⁻ ⁅ x ⁆ p h
    from h | inj₁ y∈⁅x⁆ rewrite x∈⁅y⁆⇒x≡y _ y∈⁅x⁆ = x∈p
    from h | inj₂ y∈p = y∈p

    to : ∀ {y}  → y ∈ p → y ∈ ⁅ x ⁆ ∪ p
    to h = x∈p∪q⁺ (inj₂ h)

∣⁅x⁆∪p∣≡1+∣p∣⇒x∉p : ∀ {n}(x : Fin n)(p : Subset n) → ∣ ⁅ x ⁆ ∪ p  ∣ ≡ 1 ℕ.+ ∣ p ∣ →  x ∉ p
∣⁅x⁆∪p∣≡1+∣p∣⇒x∉p x p h x∈p rewrite x∈p⇒⁅x⁆∪p≡p x p x∈p = contradiction h lemma
  where
    lemma : ∀ {n} → n ≢ ℕ.suc n
    lemma ()

∣⁅x⁆∪⁅y⁆∣≡2⇒x≢y : ∀ {n}(x y : Fin n) → ∣ ⁅ x ⁆ ∪ ⁅ y ⁆  ∣ ≡ 2 →  x ≢ y
∣⁅x⁆∪⁅y⁆∣≡2⇒x≢y x .x h refl with ∣⁅x⁆∪p∣≡1+∣p∣⇒x∉p x ⁅ x ⁆ (trans h (cong ℕ.suc (sym (∣⁅x⁆∣≡1 x))))
... | x∉⁅y⁆ = contradiction (x∈⁅x⁆ _) x∉⁅y⁆

module _ {n : ℕ} where
  open import Algebra.Structures {A = Subset n} _≡_
  open IsBooleanAlgebra (∪-∩-isBooleanAlgebra n) renaming (∧-complementʳ to ∩-complementʳ; ∨-complementʳ to ∪-complementʳ)
  ∣p∣+∣∁p∣≡n : ∀ (p : Subset n) → ∣ p ∣  ℕ.+ ∣ ∁ p ∣ ≡ n
  ∣p∣+∣∁p∣≡n p = ∣ p ∣  ℕ.+ ∣ ∁ p ∣
                     ≡⟨ Eq.sym (disjoint-∪≡+ _ _ (∩-complementʳ p)) ⟩ _
                     ≡⟨ Eq.cong ∣_∣ (∪-complementʳ p) ⟩ _
                     ≡⟨ ∣⊤∣≡n _ ⟩ n ∎
    where
      open Eq.≡-Reasoning

∩≤ˡ : ∀ {n} (a b : Subset n) → ∣ a ∩ b ∣  ℕ.≤  ∣ a ∣
∩≤ˡ {n} a b = p⊆q⇒∣p∣<∣q∣ (p∩q⊆p a b)

∩≤ʳ : ∀ {n} (a b : Subset n) → ∣ a ∩ b ∣  ℕ.≤  ∣ b ∣
∩≤ʳ {n} a b = p⊆q⇒∣p∣<∣q∣ (p∩q⊆q a b)

∣p∣<∣q∣⇒∣∁q∣<∣∁p∣ : ∀ {n} (p q : Subset n) → ∣ p ∣ ℕ.< ∣ q ∣ → ∣ ∁ q ∣ ℕ.< ∣ ∁ p ∣
∣p∣<∣q∣⇒∣∁q∣<∣∁p∣ p q p<q = NP.+-cancelˡ-< ∣ q ∣
  (begin-strict ∣ q ∣ ℕ.+ ∣ ∁ q ∣ ≡⟨ ∣p∣+∣∁p∣≡n q ⟩ _ ≡⟨ sym (∣p∣+∣∁p∣≡n p) ⟩ ∣ p ∣ ℕ.+ ∣ ∁ p ∣ <⟨ NP.+-monoˡ-< _ p<q ⟩  ∣ q ∣ ℕ.+ ∣ ∁ p ∣ ∎)
  where
    open NP.≤-Reasoning
-- intersection
{-

private
  open import Relation.Nullary.Negation using (contraposition)
  p∩∁q≡⊥→p⊆q :  ∀ {n} {p q : Subset n} → p ∩ ∁ q ≡ ⊥ → p ⊆ q
  p∩∁q≡⊥→p⊆q {zero} {[]} {[]} refl ()
  p∩∁q≡⊥→p⊆q {suc n} {true ∷ p} {outside ∷ q} () here
  p∩∁q≡⊥→p⊆q {suc n} {inside ∷ p} {inside ∷ q} eq here = here
  p∩∁q≡⊥→p⊆q {suc n} {true ∷ p} {_ ∷ q} eq (there x∈p) with ∷-injective eq
  ... | _ , teq = there (p∩∁q≡⊥→p⊆q teq x∈p)
  p∩∁q≡⊥→p⊆q {suc n} {outside ∷ p} {_ ∷ q} eq (there x∈p) with ∷-injective eq
  ... | _ , teq = there (p∩∁q≡⊥→p⊆q teq x∈p)

  p∩q≡p→p⊆q : ∀ {n} {p q : Subset n} → p ∩ q ≡ p → p ⊆ q
  p∩q≡p→p⊆q {zero} {[]} {[]} refl ()
  p∩q≡p→p⊆q {suc n} {inside ∷ p} {x ∷ q} eq here with ∷-injective eq
  p∩q≡p→p⊆q {suc n} {inside ∷ p} {.inside ∷ q} eq here | refl , _ = here
  p∩q≡p→p⊆q {suc n} {inside ∷ p} {_ ∷ q} eq (there x∈p) with ∷-injective eq
  ... | _ , teq = there (p∩q≡p→p⊆q teq x∈p)
  p∩q≡p→p⊆q {suc n} {outside ∷ p} {_ ∷ q} eq (there x∈p) with ∷-injective eq
  ... | _ , teq = there (p∩q≡p→p⊆q teq x∈p)
  p⊈q→p∩q≢p : ∀ {n} {p q : Subset n} → p ⊈ q → p ∩ q ≢ p
  p⊈q→p∩q≢p = contraposition p∩q≡p→p⊆q

  split-size : ∀ {n} {a} (b : Subset n) → ∣ a ∣ ≡ ∣ a ∩ b ∣ ℕ.+ ∣ a ∩ ∁ b ∣
  split-size {n}{a} b = ∣a∣≡∣a∩b∣+∣a∩∁b∣
    where
      open P.≡-Reasoning
      a∩b∩a∩∁b≡⊥ : (a ∩ b) ∩ (a ∩ ∁ b) ≡ ⊥
      a∩b∩a∩∁b≡⊥ = begin
                   (a ∩ b) ∩ (a ∩ ∁ b) ≡⟨ ∩-assoc _ _ _ ⟩ _
                                       ≡⟨ cong (a ∩_ ) (sym (∩-assoc _ _ _)) ⟩ _
                                       ≡⟨ cong (a ∩_ ) (cong (_∩ _) (∩-comm _ _)) ⟩ _
                                       ≡⟨ cong (a ∩_ ) (∩-assoc _ _ _) ⟩ _
                                       ≡⟨ cong (a ∩_ ) (cong (a ∩_) (∩-complementʳ _)) ⟩ _
                                       ≡⟨ cong (a ∩_ ) (∩-zeroʳ _) ⟩ _
                                       ≡⟨ ∩-zeroʳ _ ⟩ ⊥
                   ∎
      a≡a∩b∪a∩∁b : a ≡ (a ∩ b) ∪ (a ∩ ∁ b)
      a≡a∩b∪a∩∁b = begin
                     a ≡⟨ sym (∩-identityʳ _) ⟩ a ∩ ⊤
                       ≡⟨ cong (_ ∩_) (sym (∪-complementʳ _)) ⟩ a ∩ (b ∪ ∁ b)
                       ≡⟨ (proj₁ ∪-∩-distrib) _ _ _  ⟩ (a ∩ b) ∪ (a ∩ ∁ b)
                   ∎
      ∣a∣≡∣a∩b∣+∣a∩∁b∣ : ∣ a ∣ ≡ ∣ a ∩ b ∣ ℕ.+ ∣ a ∩ ∁ b ∣
      ∣a∣≡∣a∩b∣+∣a∩∁b∣ = begin
                         ∣ a ∣ ≡⟨ cong size a≡a∩b∪a∩∁b ⟩ ∣ (a ∩ b) ∪ (a ∩ ∁ b) ∣
                              ≡⟨ disjoint-∪≡ a∩b∩a∩∁b≡⊥ ⟩  ∣ a ∩ b ∣ ℕ.+ ∣ a ∩ ∁ b ∣
                      ∎

  ⊈→∩<ˡ : ∀ {n} {a b : Subset n} → a ⊈ b → ∣ a ∩ b ∣ ℕ.< ∣ a ∣
  ⊈→∩<ˡ {n}{a}{b} a⊈b = ≤+≢⇒< (∩≤ˡ a b) lemma
    where
      open P.≡-Reasoning

      n+m≡n→m≡0 : ∀ {n m} → n ℕ.+ m ≡ n → m ≡ 0
      n+m≡n→m≡0 {n}{m} eq = +-cancelˡ-≡ n (P.trans eq (sym (+-identityʳ n)))

      lemma : ∣ a ∩ b ∣ ≢ ∣ a ∣
      lemma eq = (contraposition p∩∁q≡⊥→p⊆q a⊈b) (size0 (n+m≡n→m≡0 (sym (P.trans eq (split-size b)))))
-}


module _ where

open import Agda.Primitive
open import Agda.Builtin.Equality
open import Agda.Builtin.Nat

variable
  ℓ : Level
  A B C : Set ℓ

infixr 1 _×_ _,_
record _×_ {ℓ₁ ℓ₂} (A : Set ℓ₁) (B : Set ℓ₂) : Set (ℓ₁ ⊔ ℓ₂) where
  constructor _,_
  field
    fst : A
    snd : B

module _ (x : A) (y : B) where
  f : C → A × B × C
  f z = x , y , z

check : (x : B) (y : C) (z : A) → f x y z ≡ (x , y , z)
check x y z = refl


module Data where

import      Lvl
open import Type

-- An empty type which cannot be constructed.
-- By default, this should be used to represent _the_ empty type.
data Empty {ℓ} : Type{ℓ} where
{-# FOREIGN GHC data Empty ℓ #-}
{-# COMPILE GHC Empty = data Empty () #-}

-- Empty functions.
-- The empty type eliminator.
-- Any type can be constructed from the empty type.
empty : ∀{ℓ₁ ℓ₂}{T : Type{ℓ₁}} → Empty{ℓ₂} → T
empty ()
{-# COMPILE GHC empty = \_ _ _ e -> case e of{} #-}

-- An unit type which can only be constructed in one way.
-- By default, this should be used to represent _the_ unit type.
record Unit {ℓ} : Type{ℓ} where
  instance constructor <>
open Unit public

{-# BUILTIN UNIT Unit #-}
{-# FOREIGN GHC type Unit ℓ = () #-}
{-# COMPILE GHC Unit = data Unit (()) #-}


{-# OPTIONS --without-K --safe #-}
module Cats.Category.Setoids.Facts.Terminal where

open import Level
open import Relation.Binary using (Setoid)

open import Cats.Category
open import Cats.Category.Setoids using (Setoids)

import Data.Unit as Unit

⊤ : ∀ {l l′} → Setoid l l′
⊤ = record
  { Carrier = Lift _ Unit.⊤
  ; _≈_ = λ _ _ → Lift _ Unit.⊤
  }

instance
  hasTerminal : ∀ {l l≈} → HasTerminal (Setoids l l≈)
  hasTerminal = record { ⊤ = ⊤ }


data Nat : Set where
  zero : Nat
  suc : Nat → Nat

test : ∀{N M : Nat} → Nat → Nat → Nat
test N M = {!.N N .M!}


module Container.List where

open import Prelude

infixr 5 _∷_
data All {a b} {A : Set a} (P : A → Set b) : List A → Set (a ⊔ b) where
  []  : All P []
  _∷_ : ∀ {x xs} (p : P x) (ps : All P xs) → All P (x ∷ xs)

data Any {a b} {A : Set a} (P : A → Set b) : List A → Set (a ⊔ b) where
  instance
    zero : ∀ {x xs} (p : P x) → Any P (x ∷ xs)
    suc  : ∀ {x xs} (i : Any P xs) → Any P (x ∷ xs)

pattern zero! = zero refl

-- Literal overloading for Any
module _ {a b} {A : Set a} {P : A → Set b} where
  private
    AnyConstraint : List A → Nat → Set (a ⊔ b)
    AnyConstraint []        _      = ⊥′
    AnyConstraint (x ∷  _)  zero   = ⊤′ {a} × P x   -- hack to line up levels
    AnyConstraint (_ ∷ xs) (suc i) = AnyConstraint xs i

    natToIx : ∀ (xs : List A) n → {{_ : AnyConstraint xs n}} → Any P xs
    natToIx [] n {{}}
    natToIx (x ∷ xs)  zero {{_ , px}} = zero px
    natToIx (x ∷ xs) (suc n) = suc (natToIx xs n)

  instance
    NumberAny : ∀ {xs} → Number (Any P xs)
    Number.Constraint (NumberAny {xs}) = AnyConstraint xs
    fromNat {{NumberAny {xs}}} = natToIx xs

infix 3 _∈_
_∈_ : ∀ {a} {A : Set a} → A → List A → Set a
x ∈ xs = Any (_≡_ x) xs

forgetAny : ∀ {a p} {A : Set a} {P : A → Set p} {xs : List A} → Any P xs → Nat
forgetAny (zero _) = zero
forgetAny (suc  i) = suc (forgetAny i)

lookupAny : ∀ {a b} {A : Set a} {P Q : A → Set b} {xs} → All P xs → Any Q xs → Σ A (λ x → P x × Q x)
lookupAny (p ∷ ps) (zero q) = _ , p , q
lookupAny (p ∷ ps) (suc  i) = lookupAny ps i

lookup∈ : ∀ {a b} {A : Set a} {P : A → Set b} {xs x} → All P xs → x ∈ xs → P x
lookup∈ (p ∷ ps) (zero refl) = p
lookup∈ (p ∷ ps) (suc i)     = lookup∈ ps i

module _ {a b} {A : Set a} {P Q : A → Set b} (f : ∀ {x} → P x → Q x) where
  mapAll : ∀ {xs} → All P xs → All Q xs
  mapAll [] = []
  mapAll (x ∷ xs) = f x ∷ mapAll xs

  mapAny : ∀ {xs} → Any P xs → Any Q xs
  mapAny (zero x) = zero (f x)
  mapAny (suc i)  = suc (mapAny i)

traverseAll : ∀ {a b} {A : Set a} {B : A → Set a} {F : Set a → Set b}
                {{AppF : Applicative F}} →
                (∀ x → F (B x)) → (xs : List A) → F (All B xs)
traverseAll f []       = pure []
traverseAll f (x ∷ xs) = ⦇ f x ∷ traverseAll f xs ⦈

module _ {a b} {A : Set a} {P : A → Set b} where

  -- Append

  infixr 5 _++All_
  _++All_ : ∀ {xs ys} → All P xs → All P ys → All P (xs ++ ys)
  []       ++All qs = qs
  (p ∷ ps) ++All qs = p ∷ ps ++All qs

  -- Delete

  deleteIx : ∀ xs → Any P xs → List A
  deleteIx (_ ∷ xs) (zero _) = xs
  deleteIx (x ∷ xs) (suc  i) = x ∷ deleteIx xs i

  deleteAllIx : ∀ {c} {Q : A → Set c} {xs} → All Q xs → (i : Any P xs) → All Q (deleteIx xs i)
  deleteAllIx (q ∷ qs) (zero _) = qs
  deleteAllIx (q ∷ qs) (suc i)  = q ∷ deleteAllIx qs i

-- Equality --

module _ {a b} {A : Set a} {P : A → Set b} {{EqP : ∀ {x} → Eq (P x)}} where

  private
    z : ∀ {x xs} → P x → Any P (x ∷ xs)
    z = zero

    zero-inj : ∀ {x} {xs : List A} {p q : P x} → Any.zero {xs = xs} p ≡ z q → p ≡ q
    zero-inj refl = refl

    sucAny-inj : ∀ {x xs} {i j : Any P xs} → Any.suc {x = x} i ≡ Any.suc {x = x} j → i ≡ j
    sucAny-inj refl = refl

    cons-inj₁ : ∀ {x xs} {p q : P x} {ps qs : All P xs} → p All.∷ ps ≡ q ∷ qs → p ≡ q
    cons-inj₁ refl = refl

    cons-inj₂ : ∀ {x xs} {p q : P x} {ps qs : All P xs} → p All.∷ ps ≡ q ∷ qs → ps ≡ qs
    cons-inj₂ refl = refl

  instance
    EqAny : ∀ {xs} → Eq (Any P xs)
    _==_ {{EqAny}} (zero p) (zero q) = decEq₁ zero-inj   (p == q)
    _==_ {{EqAny}} (suc i)  (suc j)  = decEq₁ sucAny-inj (i == j)
    _==_ {{EqAny}} (zero _) (suc _)  = no λ ()
    _==_ {{EqAny}} (suc _)  (zero _) = no λ ()

    EqAll : ∀ {xs} → Eq (All P xs)
    _==_ {{EqAll}} []       []       = yes refl
    _==_ {{EqAll}} (x ∷ xs) (y ∷ ys) = decEq₂ cons-inj₁ cons-inj₂ (x == y) (xs == ys)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Sparse polynomials in a commutative ring, encoded in Horner normal
-- form.
--
-- Horner normal form encodes a polynomial as a list of coefficients.
-- As an example take the polynomial:
--
--   3 + 2x² + 4x⁵ + 2x⁷
--
-- Then expand it out, filling in the missing coefficients:
--
--   3x⁰ + 0x¹ + 2x² + 0x³ + 0x⁴ + 4x⁵ + 0x⁶ + 2x⁷
--
-- And then encode that as a list:
--
--   [3, 0, 2, 0, 0, 4, 0, 2]
--
-- The representation we use here is optimised from the above. First,
-- we remove the zero terms, and add a "gap" index next to every
-- coefficient:
--
--   [(3,0),(2,1),(4,2),(2,1)]
--
-- Which can be thought of as a representation of the expression:
--
--   x⁰ * (3 + x * x¹ * (2 + x * x² * (4 + x * x¹ * (2 + x * 0))))
--
-- This is "sparse" Horner normal form.
--
-- The second optimisation deals with representing multiple variables
-- in a polynomial. The standard trick is to encode a polynomial in n
-- variables as a polynomial with coefficients in n-1 variables,
-- recursing until you hit 0 which is simply the type of the coefficient
-- itself.
--
-- We again encode "gaps" here, with the injection index. Since the
-- number of variables in a polynomial is contained in its type,
-- however, operations on this gap are type-relevant, so it's not
-- convenient to simply use ℕ. We use _≤′_ instead.
------------------------------------------------------------------------

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

open import Tactic.RingSolver.Core.Polynomial.Parameters

module Tactic.RingSolver.Core.Polynomial.Base
  {ℓ₁ ℓ₂} (coeffs : RawCoeff ℓ₁ ℓ₂) where

open RawCoeff coeffs

open import Data.Bool              using (Bool; true; false; T)
open import Data.Empty             using (⊥)
open import Data.Fin.Base as Fin        using (Fin; zero; suc)
open import Data.List.Kleene
open import Data.Nat.Base as ℕ          using (ℕ; suc; zero; _≤′_; compare; ≤′-refl; ≤′-step; _<′_)
open import Data.Nat.Properties    using (z≤′n; ≤′-trans)
open import Data.Nat.Induction
open import Data.Product           using (_×_; _,_; map₁; curry; uncurry)
open import Data.Unit              using (⊤; tt)
open import Function.Base
open import Relation.Nullary       using (¬_; Dec; yes; no)

open import Algebra.Operations.Ring rawRing

------------------------------------------------------------------------
-- Injection indices.
------------------------------------------------------------------------

-- First, we define comparisons on _≤′_.
-- The following is analagous to Ordering and compare from
-- Data.Nat.Base.
data InjectionOrdering {n : ℕ} : ∀ {i j} (i≤n : i ≤′ n) (j≤n : j ≤′ n) → Set
                      where
  inj-lt : ∀ {i j-1} (i≤j-1 : i ≤′ j-1) (j≤n : suc j-1 ≤′ n) →
           InjectionOrdering (≤′-step i≤j-1 ⟨ ≤′-trans ⟩ j≤n) j≤n

  inj-gt : ∀ {i-1 j} (i≤n : suc i-1 ≤′ n) (j≤i-1 : j ≤′ i-1) →
           InjectionOrdering i≤n (≤′-step j≤i-1 ⟨ ≤′-trans ⟩ i≤n)

  inj-eq : ∀ {i} (i≤n : i ≤′ n) →
           InjectionOrdering i≤n i≤n

inj-compare : ∀ {i j n} (x : i ≤′ n) (y : j ≤′ n) → InjectionOrdering x y
inj-compare ≤′-refl     ≤′-refl     = inj-eq ≤′-refl
inj-compare ≤′-refl     (≤′-step y) = inj-gt ≤′-refl y
inj-compare (≤′-step x) ≤′-refl     = inj-lt x ≤′-refl
inj-compare (≤′-step x) (≤′-step y) = case inj-compare x y of
    λ { (inj-lt i≤j-1 y) → inj-lt i≤j-1 (≤′-step y)
      ; (inj-gt x j≤i-1) → inj-gt (≤′-step x) j≤i-1
      ; (inj-eq x)       → inj-eq (≤′-step x)
      }

-- The "space" above a Fin n is the number of unique "Fin n"s greater
-- than or equal to it.
space : ∀ {n} → Fin n → ℕ
space f = suc (go f)
  where
  go : ∀ {n} → Fin n → ℕ
  go {suc n} Fin.zero = n
  go (Fin.suc x) = go x

space≤′n : ∀ {n} (x : Fin n) → space x ≤′ n
space≤′n zero    = ≤′-refl
space≤′n (suc x) = ≤′-step (space≤′n x)

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

infixl 6 _Δ_
record PowInd {c} (C : Set c) : Set c where
  constructor _Δ_
  field
    coeff : C
    pow   : ℕ
open PowInd public

record Poly (n : ℕ) : Set ℓ₁
data FlatPoly : ℕ → Set ℓ₁
Coeff : ℕ → Set ℓ₁
record NonZero (i : ℕ) : Set ℓ₁
Zero : ∀ {n} → Poly n → Set
Normalised : ∀ {i} → Coeff i + → Set

-- A Polynomial is indexed by the number of variables it contains.
infixl 6 _⊐_
record Poly n where
  inductive
  constructor _⊐_
  field
    {i}  : ℕ
    flat : FlatPoly i
    i≤n  : i ≤′ n

data FlatPoly where
  Κ : Carrier → FlatPoly zero
  ⅀ : ∀ {n} (xs : Coeff n +) {xn : Normalised xs} → FlatPoly (suc n)

Coeff n = PowInd (NonZero n)

-- We disallow zeroes in the coefficient list. This condition alone
-- is enough to ensure a unique representation for any polynomial.
infixl 6 _≠0
record NonZero i where
  inductive
  constructor _≠0
  field
    poly      : Poly i
    .{poly≠0} : ¬ Zero poly

-- This predicate is used (in its negation) to ensure that no
-- coefficient is zero, preventing any trailing zeroes.
Zero (Κ x ⊐ _) = T (isZero x)
Zero (⅀ _ ⊐ _) = ⊥

-- This predicate is used to ensure that all polynomials are in
-- normal form: if a particular level is constant, then it can
-- be collapsed into the level below it.
Normalised (_ Δ zero  & [])  = ⊥
Normalised (_ Δ zero  & ∹ _) = ⊤
Normalised (_ Δ suc _ & _)   = ⊤
open NonZero public
open Poly public

----------------------------------------------------------------------
-- Special operations

-- Decision procedure for Zero
zero? : ∀ {n} → (p : Poly n) → Dec (Zero p)
zero? (⅀ _ ⊐ _) = no id
zero? (Κ x ⊐ _) with isZero x
... | true  = yes tt
... | false = no  id
{-# INLINE zero? #-}

-- Exponentiate the first variable of a polynomial
infixr 8 _⍓*_ _⍓+_
_⍓*_ : ∀ {n} → Coeff n * → ℕ → Coeff n *
_⍓+_ : ∀ {n} → Coeff n + → ℕ → Coeff n +

[] ⍓* _ = []
(∹ xs) ⍓* i = ∹ xs ⍓+ i

coeff (head (xs ⍓+ i)) = coeff (head xs)
pow   (head (xs ⍓+ i)) = pow (head xs) ℕ.+ i
tail  (xs ⍓+ i)        = tail xs

infixr 5 _∷↓_
_∷↓_ : ∀ {n} → PowInd (Poly n) → Coeff n * → Coeff n *
x Δ i ∷↓ xs = case zero? x of
  λ { (yes p) → xs ⍓* suc i
    ; (no ¬p) → ∹ _≠0 x {¬p} Δ i & xs
    }
{-# INLINE _∷↓_ #-}

-- Inject a polynomial into a larger polynomial with more variables
_⊐↑_ : ∀ {n m} → Poly n → (suc n ≤′ m) → Poly m
(xs ⊐ i≤n) ⊐↑ n≤m = xs ⊐ (≤′-step i≤n ⟨ ≤′-trans ⟩ n≤m)
{-# INLINE _⊐↑_ #-}

infixr 4 _⊐↓_
_⊐↓_ : ∀ {i n} → Coeff i * → suc i ≤′ n → Poly n
[]                        ⊐↓ i≤n = Κ 0# ⊐ z≤′n
(∹ (x ≠0 Δ zero  & []  )) ⊐↓ i≤n = x ⊐↑ i≤n
(∹ (x    Δ zero  & ∹ xs)) ⊐↓ i≤n = ⅀ (x Δ zero  & ∹ xs) ⊐ i≤n
(∹ (x    Δ suc j & xs  )) ⊐↓ i≤n = ⅀ (x Δ suc j & xs)   ⊐ i≤n
{-# INLINE _⊐↓_ #-}

----------------------------------------------------------------------
-- Standard operations
----------------------------------------------------------------------

----------------------------------------------------------------------
-- Folds

-- These folds allow us to abstract over the proofs later: we try to avoid
-- using ∷↓ and ⊐↓ directly anywhere except here, so if we prove that this fold
-- acts the same on a normalised or non-normalised polynomial, we can prove th
-- same about any operation which uses it.

PolyF : ℕ → Set ℓ₁
PolyF i = Poly i × Coeff i *

Fold : ℕ → Set ℓ₁
Fold i = PolyF i → PolyF i

para : ∀ {i} → Fold i → Coeff i + → Coeff i *
para f (x ≠0 Δ i & [])   = case f (x , [])        of λ {(y , ys) → y Δ i ∷↓ ys}
para f (x ≠0 Δ i & ∹ xs) = case f (x , para f xs) of λ {(y , ys) → y Δ i ∷↓ ys}

poly-map : ∀ {i} → (Poly i → Poly i) → Coeff i + → Coeff i *
poly-map f = para (map₁ f)
{-# INLINE poly-map #-}

----------------------------------------------------------------------
-- Addition

-- The reason the following code is so verbose is termination
-- checking. For instance, in the third case for ⊞-coeffs, we call a
-- helper function. Instead, you could conceivably use a with-block
-- (on ℕ.compare p q):
--
-- ⊞-coeffs ((x , p) ∷ xs) ((y , q) ∷ ys) with (ℕ.compare p q)
-- ... | ℕ.less    p k = (x , p) ∷ ⊞-coeffs xs ((y , k) ∷ ys)
-- ... | ℕ.equal   p   = (fst~ x ⊞ fst~ y , p) ∷↓ ⊞-coeffs xs ys
-- ... | ℕ.greater q k = (y , q) ∷ ⊞-coeffs ((x , k) ∷ xs) ys
--
-- However, because the first and third recursive calls each rewrap
-- a list that was already pattern-matched on, the recursive call
-- does not strictly decrease the size of its argument.
--
-- Interestingly, if --without-K is turned off, we don't need the
-- helper function ⊞-coeffs; we could pattern match on _⊞_ directly.
--
-- _⊞_ {zero} (lift x) (lift y) = lift (x + y)
-- _⊞_ {suc n} [] ys = ys
-- _⊞_ {suc n} (x ∷ xs) [] = x ∷ xs
-- _⊞_ {suc n} ((x , p) ∷ xs) ((y , q) ∷ ys) = ⊞-zip (ℕ.compare p q) x xs y ys

mutual
  infixl 6 _⊞_
  _⊞_ : ∀ {n} → Poly n → Poly n → Poly n
  (xs ⊐ i≤n) ⊞ (ys ⊐ j≤n) = ⊞-match (inj-compare i≤n j≤n) xs ys

  ⊞-match : ∀ {i j n}
        → {i≤n : i ≤′ n}
        → {j≤n : j ≤′ n}
        → InjectionOrdering i≤n j≤n
        → FlatPoly i
        → FlatPoly j
        → Poly n
  ⊞-match (inj-eq i&j≤n)     (Κ x)  (Κ y)  = Κ (x + y)         ⊐  i&j≤n
  ⊞-match (inj-eq i&j≤n)     (⅀ (x Δ i & xs)) (⅀ (y Δ j & ys)) = ⊞-zip (compare i j) x xs y ys ⊐↓ i&j≤n
  ⊞-match (inj-lt i≤j-1 j≤n)  xs    (⅀ ys) = ⊞-inj i≤j-1 xs ys ⊐↓ j≤n
  ⊞-match (inj-gt i≤n j≤i-1) (⅀ xs)  ys    = ⊞-inj j≤i-1 ys xs ⊐↓ i≤n

  ⊞-inj : ∀ {i k}
        → (i ≤′ k)
        → FlatPoly i
        → Coeff k +
        → Coeff k *
  ⊞-inj i≤k xs (y ⊐ j≤k ≠0 Δ zero  & ys) = ⊞-match (inj-compare j≤k i≤k) y xs Δ zero ∷↓ ys
  ⊞-inj i≤k xs (y          Δ suc j & ys) = xs ⊐ i≤k Δ zero ∷↓ ∹ y Δ j & ys

  ⊞-coeffs : ∀ {n} → Coeff n * → Coeff n * → Coeff n *
  ⊞-coeffs (∹ x Δ i & xs) ys = ⊞-zip-r x i xs ys
  ⊞-coeffs []             ys = ys

  ⊞-zip : ∀ {p q n}
        → ℕ.Ordering p q
        → NonZero n
        → Coeff n *
        → NonZero n
        → Coeff n *
        → Coeff n *
  ⊞-zip (ℕ.less    i k) x xs y ys = ∹ x Δ i & ⊞-zip-r y k ys xs
  ⊞-zip (ℕ.greater j k) x xs y ys = ∹ y Δ j & ⊞-zip-r x k xs ys
  ⊞-zip (ℕ.equal   i  ) x xs y ys = (x .poly ⊞ y .poly) Δ i ∷↓ ⊞-coeffs xs ys
  {-# INLINE ⊞-zip #-}

  ⊞-zip-r : ∀ {n} → NonZero n → ℕ → Coeff n * → Coeff n * → Coeff n *
  ⊞-zip-r x i xs [] = ∹ x Δ i & xs
  ⊞-zip-r x i xs (∹ y Δ j & ys) = ⊞-zip (compare i j) x xs y ys

----------------------------------------------------------------------
-- Negation

-- recurse on acc directly
-- https://github.com/agda/agda/issues/3190#issuecomment-416900716

⊟-step : ∀ {n} → Acc _<′_ n → Poly n → Poly n
⊟-step (acc wf) (Κ x  ⊐ i≤n) = Κ (- x) ⊐ i≤n
⊟-step (acc wf) (⅀ xs ⊐ i≤n) = poly-map (⊟-step (wf _ i≤n)) xs ⊐↓ i≤n

⊟_ : ∀ {n} → Poly n → Poly n
⊟_ = ⊟-step (<′-wellFounded _)
{-# INLINE ⊟_ #-}

----------------------------------------------------------------------
-- Multiplication

mutual
  ⊠-step′ : ∀ {n} → Acc _<′_ n → Poly n → Poly n → Poly n
  ⊠-step′ a (x ⊐ i≤n) = ⊠-step a x i≤n

  ⊠-step : ∀ {i n} → Acc _<′_ n → FlatPoly i → i ≤′ n → Poly n → Poly n
  ⊠-step a (Κ x) _ = ⊠-Κ a x
  ⊠-step a (⅀ xs)  = ⊠-⅀ a xs

  ⊠-Κ : ∀ {n} → Acc _<′_ n → Carrier → Poly n → Poly n
  ⊠-Κ (acc _ ) x (Κ y  ⊐ i≤n) = Κ (x * y) ⊐ i≤n
  ⊠-Κ (acc wf) x (⅀ xs ⊐ i≤n) = ⊠-Κ-inj (wf _ i≤n) x xs ⊐↓ i≤n
  {-# INLINE ⊠-Κ #-}

  ⊠-⅀ : ∀ {i n} → Acc _<′_ n → Coeff i + → i <′ n → Poly n → Poly n
  ⊠-⅀ (acc wf) xs i≤n (⅀ ys ⊐ j≤n) = ⊠-match  (acc wf) (inj-compare i≤n j≤n) xs ys
  ⊠-⅀ (acc wf) xs i≤n (Κ y ⊐ _)    = ⊠-Κ-inj (wf _ i≤n) y xs ⊐↓ i≤n

  ⊠-Κ-inj : ∀ {i}  → Acc _<′_ i → Carrier → Coeff i + → Coeff i *
  ⊠-Κ-inj a x xs = poly-map (⊠-Κ a x) (xs)

  ⊠-⅀-inj : ∀ {i k}
          → Acc _<′_ k
          → i <′ k
          → Coeff i +
          → Poly k
          → Poly k
  ⊠-⅀-inj (acc wf) i≤k x (⅀ y ⊐ j≤k) = ⊠-match (acc wf) (inj-compare i≤k j≤k) x y
  ⊠-⅀-inj (acc wf) i≤k x (Κ y ⊐ j≤k) = ⊠-Κ-inj (wf _ i≤k) y x ⊐↓ i≤k

  ⊠-match : ∀ {i j n}
          → Acc _<′_ n
          → {i≤n : i <′ n}
          → {j≤n : j <′ n}
          → InjectionOrdering i≤n j≤n
          → Coeff i +
          → Coeff j +
          → Poly n
  ⊠-match (acc wf) (inj-eq i&j≤n)     xs ys = ⊠-coeffs (wf _ i&j≤n) xs ys               ⊐↓ i&j≤n
  ⊠-match (acc wf) (inj-lt i≤j-1 j≤n) xs ys = poly-map (⊠-⅀-inj (wf _ j≤n) i≤j-1 xs) (ys) ⊐↓ j≤n
  ⊠-match (acc wf) (inj-gt i≤n j≤i-1) xs ys = poly-map (⊠-⅀-inj (wf _ i≤n) j≤i-1 ys) (xs) ⊐↓ i≤n

  ⊠-coeffs : ∀ {n} → Acc _<′_ n → Coeff n + → Coeff n + → Coeff n *
  ⊠-coeffs a (xs) (y ≠0 Δ j & [])   = poly-map (⊠-step′ a y) (xs) ⍓* j
  ⊠-coeffs a (xs) (y ≠0 Δ j & ∹ ys) = para (⊠-cons a y ys) (xs) ⍓* j
  {-# INLINE ⊠-coeffs #-}

  ⊠-cons : ∀ {n}
          → Acc _<′_ n
          → Poly n
          → Coeff n +
          → Fold n
  ⊠-cons a y ys (x ⊐ j≤n , xs) =
    ⊠-step a x j≤n y , ⊞-coeffs (poly-map (⊠-step a x j≤n) ys) xs
  {-# INLINE ⊠-cons #-}

infixl 7 _⊠_
_⊠_ : ∀ {n} → Poly n → Poly n → Poly n
_⊠_ = ⊠-step′ (<′-wellFounded _)
{-# INLINE _⊠_ #-}

----------------------------------------------------------------------
-- Constants and variables

-- The constant polynomial
κ : ∀ {n} → Carrier → Poly n
κ x = Κ x ⊐ z≤′n
{-# INLINE κ #-}

-- A variable
ι : ∀ {n} → Fin n → Poly n
ι i = (κ 1# Δ 1 ∷↓ []) ⊐↓ space≤′n i
{-# INLINE ι #-}

----------------------------------------------------------------------
-- Exponentiation

-- We try very hard to never do things like multiply by 1
-- unnecessarily. That's what all the weirdness here is for.

⊡-mult : ∀ {n} → ℕ → Poly n → Poly n
⊡-mult zero    xs = xs
⊡-mult (suc n) xs = ⊡-mult n xs ⊠ xs

_⊡_+1 : ∀ {n} → Poly n → ℕ → Poly n
(Κ x  ⊐ i≤n)           ⊡ i +1  = Κ (x ^ i +1) ⊐ i≤n
(⅀ (x Δ j & []) ⊐ i≤n) ⊡ i +1  = x .poly ⊡ i +1 Δ (j ℕ.+ i ℕ.* j) ∷↓ [] ⊐↓ i≤n
xs@(⅀ (_ & ∹ _) ⊐ i≤n) ⊡ i +1  = ⊡-mult i xs

infixr 8 _⊡_
_⊡_ : ∀ {n} → Poly n → ℕ → Poly n
_  ⊡ zero  = κ 1#
xs ⊡ suc i = xs ⊡ i +1
{-# INLINE _⊡_ #-}


------------------------------------------------------------------------------
-- Example of a nested recursive function using the Agda standard
-- library
------------------------------------------------------------------------------

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

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. vol 2152 LNCS. 2001.

module FOT.FOTC.Program.Nest.NestSL where

open import Data.Nat renaming (suc to succ)
open import Relation.Binary.PropositionalEquality

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

{-# TERMINATING #-}
nest : ℕ → ℕ
nest 0        = 0
nest (succ n) = nest (nest n)

{-# TERMINATING #-}
nest-x≡0 : ∀ n → nest n ≡ zero
nest-x≡0 zero     = refl
nest-x≡0 (succ n) = nest-x≡0 (nest n)


-- define ∑ and ∏ as the bigOps of a Ring when interpreted
-- as an additive/multiplicative monoid

{-# OPTIONS --safe #-}
module Cubical.Algebra.Ring.BigOps where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Function

open import Cubical.Data.Bool
open import Cubical.Data.Nat using (ℕ ; zero ; suc)
open import Cubical.Data.Sigma
open import Cubical.Data.FinData

open import Cubical.Algebra.Monoid.BigOp
open import Cubical.Algebra.Ring.Base
open import Cubical.Algebra.Ring.Properties

private
  variable
    ℓ ℓ' : Level

module KroneckerDelta (R' : Ring ℓ) where
 private
  R = fst R'
 open RingStr (snd R')

 δ : {n : ℕ} (i j : Fin n) → R
 δ i j = if i == j then 1r else 0r

module Sum (R' : Ring ℓ) where
 private
  R = fst R'
 open RingStr (snd R')
 open MonoidBigOp (Ring→AddMonoid R')
 open RingTheory R'
 open KroneckerDelta R'

 ∑ = bigOp
 ∑Ext = bigOpExt
 ∑0r = bigOpε
 ∑Last = bigOpLast

 ∑Split : ∀ {n} → (V W : FinVec R n) → ∑ (λ i → V i + W i) ≡ ∑ V + ∑ W
 ∑Split = bigOpSplit +Comm

 ∑Split++ : ∀ {n m : ℕ} (V : FinVec R n) (W : FinVec R m)
          → ∑ (V ++Fin W) ≡ ∑ V + ∑ W
 ∑Split++ = bigOpSplit++ +Comm

 ∑Mulrdist : ∀ {n} → (x : R) → (V : FinVec R n)
                → x · ∑ V ≡ ∑ λ i → x · V i
 ∑Mulrdist {n = zero}  x _ = 0RightAnnihilates x
 ∑Mulrdist {n = suc n} x V =
   x · (V zero + ∑ (V ∘ suc))           ≡⟨ ·DistR+ _ _ _ ⟩
   x · V zero + x · ∑ (V ∘ suc)         ≡⟨ (λ i → x · V zero + ∑Mulrdist x (V ∘ suc) i) ⟩
   x · V zero + ∑ (λ i → x · V (suc i)) ∎

 ∑Mulldist : ∀ {n} → (x : R) → (V : FinVec R n)
                → (∑ V) · x ≡ ∑ λ i → V i · x
 ∑Mulldist {n = zero}  x _ = 0LeftAnnihilates x
 ∑Mulldist {n = suc n} x V =
   (V zero + ∑ (V ∘ suc)) · x           ≡⟨ ·DistL+ _ _ _ ⟩
   V zero · x + (∑ (V ∘ suc)) · x       ≡⟨ (λ i → V zero · x + ∑Mulldist x (V ∘ suc) i) ⟩
   V zero · x + ∑ (λ i → V (suc i) · x) ∎

 ∑Mulr0 : ∀ {n} → (V : FinVec R n) → ∑ (λ i → V i · 0r) ≡ 0r
 ∑Mulr0 V = sym (∑Mulldist 0r V) ∙ 0RightAnnihilates _

 ∑Mul0r : ∀ {n} → (V : FinVec R n) → ∑ (λ i → 0r · V i) ≡ 0r
 ∑Mul0r V = sym (∑Mulrdist 0r V) ∙ 0LeftAnnihilates _

 ∑Mulr1 : (n : ℕ) (V : FinVec R n) → (j : Fin n) → ∑ (λ i → V i · δ i j) ≡ V j
 ∑Mulr1 (suc n) V zero = (λ k → ·IdR (V zero) k + ∑Mulr0 (V ∘ suc) k) ∙ +IdR (V zero)
 ∑Mulr1 (suc n) V (suc j) =
    (λ i → 0RightAnnihilates (V zero) i + ∑ (λ x → V (suc x) · δ x j))
    ∙∙ +IdL _ ∙∙ ∑Mulr1 n (V ∘ suc) j

 ∑Mul1r : (n : ℕ) (V : FinVec R n) → (j : Fin n) → ∑ (λ i → (δ j i) · V i) ≡ V j
 ∑Mul1r (suc n) V zero = (λ k → ·IdL (V zero) k + ∑Mul0r (V ∘ suc) k) ∙ +IdR (V zero)
 ∑Mul1r (suc n) V (suc j) =
   (λ i → 0LeftAnnihilates (V zero) i + ∑ (λ i → (δ j i) · V (suc i)))
   ∙∙ +IdL _ ∙∙ ∑Mul1r n (V ∘ suc) j

 ∑Dist- : ∀ {n : ℕ} (V : FinVec R n) → ∑ (λ i → - V i) ≡ - ∑ V
 ∑Dist- V = ∑Ext (λ i → -IsMult-1 (V i)) ∙ sym (∑Mulrdist _ V) ∙ sym (-IsMult-1 _)

module SumMap
  (Ar@(A , Astr) : Ring ℓ)
  (Br@(B , Bstr) : Ring ℓ')
  (f'@(f , fstr) : RingHom Ar Br)
  where

  open IsRingHom fstr

  open RingStr Astr using ()
    renaming
    ( _+_ to _+A_ )

  open RingStr Bstr using ()
    renaming
    ( _+_ to _+B_ )

  ∑Map : {n : ℕ} → (V : FinVec A n) → f (Sum.∑ Ar V) ≡ Sum.∑ Br (λ k → f (V k))
  ∑Map {n = zero} V = pres0
  ∑Map {n = suc n} V =
                       f ((V zero) +A helper) ≡⟨ pres+ (V zero) helper ⟩
                       ((f (V zero)) +B (f helper)) ≡⟨ cong (λ X → f (V zero) +B X) (∑Map (λ k → (V ∘ suc) k)) ⟩
                       Sum.∑ Br (λ k → f (V k)) ∎
                     where
                     helper : _
                     helper = foldrFin _+A_ (RingStr.0r (snd Ar)) (λ x → V (suc x))

-- anything interesting to prove here?
module Product (R' : Ring ℓ) where
 private
  R = fst R'
 open RingStr (snd R')
 open RingTheory R'
 open MonoidBigOp (Ring→MultMonoid R')

 ∏ = bigOp
 ∏Ext = bigOpExt
 ∏0r = bigOpε
 ∏Last = bigOpLast

-- only holds in CommRings!
-- ∏Split : ∀ {n} → (V W : FinVec R n) → ∏ (λ i → V i · W i) ≡ ∏ V · ∏ W
-- ∏Split = bigOpSplit MultR' ·-comm


------------------------------------------------------------------------
-- The two big-step semantics given by Leroy and Grall in "Coinductive
-- big-step operational semantics"
------------------------------------------------------------------------

module Lambda.Substitution.TwoSemantics where

open import Codata.Musical.Notation

open import Lambda.Syntax
open WHNF
open import Lambda.Substitution

-- Big-step semantics for terminating computations.

infix 4 _⇓_

data _⇓_ {n} : Tm n → Value n → Set where
  val : ∀ {v} → ⌜ v ⌝ ⇓ v
  app : ∀ {t₁ t₂ t v v′}
        (t₁⇓   : t₁ ⇓ ƛ t)
        (t₂⇓   : t₂ ⇓ v)
        (t₁t₂⇓ : t / sub ⌜ v ⌝ ⇓ v′) →
        t₁ · t₂ ⇓ v′

-- Big-step semantics for non-terminating computations.

infix 4 _⇑

data _⇑ {n} : Tm n → Set where
  ·ˡ  : ∀ {t₁ t₂}
        (t₁⇑ : ∞ (t₁ ⇑)) →
        t₁ · t₂ ⇑
  ·ʳ  : ∀ {t₁ t₂ v}
        (t₁⇓ : t₁ ⇓ v)
        (t₂⇑ : ∞ (t₂ ⇑)) →
        t₁ · t₂ ⇑
  app : ∀ {t₁ t₂ t v}
        (t₁⇓   : t₁ ⇓ ƛ t)
        (t₂⇓   : t₂ ⇓ v)
        (t₁t₂⇓ : ∞ (t / sub ⌜ v ⌝ ⇑)) →
        t₁ · t₂ ⇑


-- Plump ordinals as presented by Shulman
-- https://homotopytypetheory.org/2014/02/22/surreals-plump-ordinals/
--
-- Implementation based on an implementation of Aczel sets by Andreas Abel.
module Ordinal.Shulman where

open import Data.Sum using ([_,_]′)
open import Induction.WellFounded as WfRec using (Acc ; acc ; WellFounded)
open import Level using (Lift ; lift ; lower)
open import Relation.Binary using (IsEquivalence)
open import Relation.Nullary using (¬_)

open import Ordinal.HoTT using (IsOrdinal ; IsExtensional ; _↔_ ; forth ; back)
open import Util.Prelude

-- Definition of ordinals, equality, orders
------------------------------------------------------------------------

-- Ordinals are infinitely branching well-founded trees.
-- The branching type is given at each node.

data Ord ℓ : Set (lsuc ℓ) where
  limSuc : (I : Set ℓ) (els : I → Ord ℓ) → Ord ℓ

-- Branching type

Br : ∀ {ℓ} (a : Ord ℓ) → Set ℓ
Br (limSuc I _) = I

-- Elements

els : ∀ {ℓ} (a : Ord ℓ) (i : Br a) → Ord ℓ
els (limSuc _ f) = f

syntax els a i = a ` i

lift-Ord : ∀ {a ℓ} → Ord ℓ → Ord (a ⊔ℓ ℓ)
lift-Ord {a} (limSuc I f) = limSuc (Lift a I) λ i → lift-Ord {a} (f (lower i))

-- Equality and orders

mutual
  _<_ : ∀ {ℓ} (a b : Ord ℓ) → Set ℓ
  a < limSuc _ f = ∃[ i ] (a ≤ f i)

  _≤_  : ∀ {ℓ} (a b : Ord ℓ) → Set ℓ
  limSuc _ f ≤ b = ∀ i → f i < b

_≅_ : ∀ {ℓ} (a b : Ord ℓ) → Set ℓ
a ≅ b = (a ≤ b) × (b ≤ a)

_≮_ : ∀ {ℓ} (a b : Ord ℓ) → Set ℓ
a ≮ b = ¬ (a < b)

_≇_ : ∀ {ℓ} (a b : Ord ℓ) → Set ℓ
a ≇ b = ¬ (a ≅ b)

-- Intro/Elim rules for </≤ (for nicer proofs below)

<-intro : ∀ {ℓ} {a b : Ord ℓ} → ∃[ i ] (a ≤ (b ` i)) → a < b
<-intro {b = limSuc I f} p = p

<-elim : ∀ {ℓ} {a b : Ord ℓ} → a < b → ∃[ i ] (a ≤ (b ` i))
<-elim {b = limSuc I f} p = p

≤-intro : ∀ {ℓ} {a b : Ord ℓ} → (∀ i → (a ` i) < b) → a ≤ b
≤-intro {a = limSuc I f} p = p

≤-elim : ∀ {ℓ} {a b : Ord ℓ} → a ≤ b → (∀ i → (a ` i) < b)
≤-elim {a = limSuc I f} p = p

-- Reflexivity

≤-refl : ∀ {ℓ} {a : Ord ℓ} → a ≤ a
≤-refl {a = limSuc _ f} i = i , ≤-refl

≅-refl : ∀ {ℓ} {a : Ord ℓ} → a ≅ a
≅-refl = ≤-refl , ≤-refl

-- < implies ≤

<→≤ : ∀ {ℓ} {a b : Ord ℓ} → a < b → a ≤ b
<→≤ {ℓ} {limSuc A fa} {limSuc B fb} (i , fa<fb) j = i , <→≤ (fa<fb j)

-- Transitivity

mutual
  <-trans-≤ : ∀ {ℓ} {a b c : Ord ℓ} → a < b → b ≤ c → a < c
  <-trans-≤ {b = limSuc _ f} (i , p) h = ≤-trans-< p (h i)

  ≤-trans-< : ∀ {ℓ} {a b c : Ord ℓ} → a ≤ b → b < c → a < c
  ≤-trans-< {c = limSuc _ f} p (i , q) = i , ≤-trans p q

  ≤-trans : ∀ {ℓ} {a b c : Ord ℓ} → a ≤ b → b ≤ c → a ≤ c
  ≤-trans {a = limSuc _ f} h q i = <-trans-≤ (h i) q

<-trans : ∀ {ℓ} {a b c : Ord ℓ} → a < b → b < c → a < c
<-trans {ℓ} {a} {b} {limSuc C fc} a<b (i , b≤fci) = i , <→≤ (<-trans-≤ a<b b≤fci)

≅-trans : ∀ {ℓ} {a b c : Ord ℓ} (d : a ≅ b) (e : b ≅ c) → a ≅ c
≅-trans (p , p′) (q , q′) = ≤-trans p q , ≤-trans q′ p′

-- Symmetry

≅-sym : ∀ {ℓ} {a b : Ord ℓ} (p : a ≅ b) → b ≅ a
≅-sym (p , p′) = p′ , p

-- ≅ is an equivalence relation.

≅-equiv : ∀ {ℓ} → IsEquivalence (_≅_ {ℓ})
≅-equiv = record
  { refl = ≅-refl
  ; sym = ≅-sym
  ; trans = ≅-trans
  }

-- < is 'extensional'.

<-ext-≤ : ∀ {ℓ} {a b : Ord ℓ} → (∀ c → c < a → c < b) → a ≤ b
<-ext-≤ {a = limSuc I els} p i = p (els i) (i , ≤-refl)

<-ext : ∀ {ℓ} → IsExtensional {ℓ} _≅_ _<_
<-ext p = <-ext-≤ (λ c → forth (p c)) , <-ext-≤ (λ c → back (p c))

-- Alternative interpretation of ≤ in terms of <

≤-intro′ : ∀ {ℓ} {b c : Ord ℓ} → (∀ {a} → a < b → a < c) → b ≤ c
≤-intro′ {b = limSuc _ f} cast i = cast (i , ≤-refl)

≤-elim′ : ∀ {ℓ} {b c : Ord ℓ} → b ≤ c → ∀ {a} → a < b → a < c
≤-elim′ b≤c a<b = <-trans-≤ a<b b≤c

-- Compatibility of ≤ with ≅

≤-congˡ : ∀ {ℓ} {a b c : Ord ℓ} → a ≅ b → a ≤ c → b ≤ c
≤-congˡ {ℓ}  (a≤b , b≤a) a≤c = ≤-trans b≤a a≤c

≤-congʳ : ∀ {ℓ} {a b c : Ord ℓ} → b ≅ c → a ≤ b → a ≤ c
≤-congʳ (b≤c , c≤b) a≤b = ≤-trans a≤b b≤c

-- Compatibility of < with ≅

<-congʳ : ∀ {ℓ} {a b c : Ord ℓ} → b ≅ c → a < b → a < c
<-congʳ (b≤c , c≤b) a<b = <-trans-≤ a<b b≤c

<-congˡ : ∀ {ℓ} {a b c : Ord ℓ} → a ≅ b → a < c → b < c
<-congˡ (a≤b , b≤a) a<c = ≤-trans-< b≤a a<c

-- Foundation: a ≤ b implies b ≮ a

≤-found : ∀ {ℓ} {a b : Ord ℓ} → a ≤ b → b ≮ a
≤-found {ℓ} {limSuc A fa} {b} a≤b (i , b≤fai) = ≤-found b≤fai (a≤b i)

-- Thus, a ≮ a.

<-irr : ∀ {ℓ} {a : Ord ℓ} → a ≮ a
<-irr = ≤-found ≤-refl

-- Predicates over ordinals (need to respect equality)

IsPred : ∀ {ℓ} (P : Ord ℓ → Set ℓ) → Set (lsuc ℓ)
IsPred {ℓ} P = {a b : Ord ℓ} → a ≅ b → P a → P b

record Pred ℓ : Set (lsuc ℓ) where
  constructor pred
  field
    _!_  : Ord ℓ → Set ℓ
    resp : IsPred _!_

open Pred

-- <-induction.

<-acc-≤ : ∀ {ℓ} {a b : Ord ℓ} → a ≤ b → Acc _<_ b → Acc _<_ a
<-acc-≤ {ℓ} {limSuc A fa} {b} fai<b (acc rs) = acc λ where
  x (i , x≤fai) → rs x (≤-trans-< x≤fai (fai<b i))

<-wf : ∀ {ℓ} → WellFounded (_<_ {ℓ})
<-wf (limSuc I f) = acc λ { x (i , x≤fi) → <-acc-≤ x≤fi (<-wf (f i)) }

<-ind : ∀ {ℓ ℓ′} (P : Ord ℓ → Set ℓ′)
  → (∀ a → (∀ b → b < a → P b) → P a)
  → ∀ a → P a
<-ind = WfRec.All.wfRec <-wf _

-- Ordinals are ordinals (in the sense of the HoTT book).

isOrdinal : ∀ {ℓ} → IsOrdinal (Ord ℓ) ℓ ℓ
isOrdinal = record
  { _≈_ = _≅_
  ; ≈-equiv = ≅-equiv
  ; _<_ = _<_
  ; <-wf = <-wf
  ; <-ext = <-ext
  ; <-trans = <-trans
  }

-- Constructions on ordinals
------------------------------------------------------------------------

-- Zero

ozero : ∀ {ℓ} → Ord ℓ
ozero {ℓ} = limSuc (Lift ℓ ⊥) λ()

-- Successor?

osuc : ∀ {ℓ} → Ord ℓ → Ord ℓ
osuc {ℓ} a = limSuc (Lift ℓ ⊤) λ _ → a

-- Lo and behold!
osuc-mon-< : ∀ {ℓ} {a b : Ord ℓ} → a < b → osuc a < osuc b
osuc-mon-< a<b = _ , λ _ → a<b

osuc-mon-≤ : ∀ {ℓ} {a b : Ord ℓ} → a ≤ b → osuc a ≤ osuc b
osuc-mon-≤ a≤b _ = _ , a≤b

osuc-cong : ∀ {ℓ} {a b : Ord ℓ} → a ≅ b → osuc a ≅ osuc b
osuc-cong (a≤b , b≤a) = osuc-mon-≤ a≤b , osuc-mon-≤ b≤a

-- Maximum/Supremum

_⊔_ : ∀ {ℓ} (a b : Ord ℓ) → Ord ℓ
a ⊔ b = limSuc (_ ⊎ _) λ where
  (inj₁ i) → a ` i
  (inj₂ j) → b ` j

⊔-introˡ : ∀ {ℓ} a {b c : Ord ℓ} → a < b → a < (b ⊔ c)
⊔-introˡ a {limSuc _ f} (i , e) = inj₁ i , e

⊔-introʳ : ∀ {ℓ} a {b c : Ord ℓ} → a < c → a < (b ⊔ c)
⊔-introʳ a {c = limSuc _ g} (i , e) = inj₂ i , e

⊔-≤-introˡ : ∀ {ℓ} a {b c : Ord ℓ} → a ≤ b → a ≤ (b ⊔ c)
⊔-≤-introˡ a a≤b = ≤-intro λ i → ⊔-introˡ _ (≤-elim a≤b i)

⊔-≤-introˡ′ : ∀ {ℓ} {a : Ord ℓ} b → a ≤ (a ⊔ b)
⊔-≤-introˡ′ b = ⊔-≤-introˡ _ ≤-refl

⊔-≤-introʳ : ∀ {ℓ} a {b c : Ord ℓ} → a ≤ c → a ≤ (b ⊔ c)
⊔-≤-introʳ a a≤c = ≤-intro λ i → ⊔-introʳ _ (≤-elim a≤c i)

⊔-≤-introʳ′ : ∀ {ℓ} a {b : Ord ℓ} → b ≤ (a ⊔ b)
⊔-≤-introʳ′ a = ⊔-≤-introʳ _ ≤-refl

⊔-elim : ∀ {ℓ} {a b c : Ord ℓ} → c < (a ⊔ b) → (c < a) ⊎ (c < b)
⊔-elim {a = limSuc _ f}                  (inj₁ i , e) = inj₁ (i , e)
⊔-elim {a = limSuc _ _} {b = limSuc _ g} (inj₂ i , e) = inj₂ (i , e)

⊔-case : ∀ {ℓ} {a b c : Ord ℓ}
  → c < (a ⊔ b)
  → ∀ {q} {Q : Set q}
  → (c < a → Q)
  → (c < b → Q) → Q
⊔-case p left right = [ left , right ]′ (⊔-elim p)

⊔-split : ∀ {ℓ q} {Q : Set q} {a b c : Ord ℓ}
  → (c < a → Q)
  → (c < b → Q)
  → c < (a ⊔ b) → Q
⊔-split left right p = ⊔-case p left right

⊔-mon : ∀ {ℓ} {a a′ b b′ : Ord ℓ} → a ≤ a′ → b ≤ b′ → (a ⊔ b) ≤ (a′ ⊔ b′)
⊔-mon a≤a′ b≤b′ = ≤-intro′
  (⊔-split
    (λ c<a → ⊔-introˡ _ (≤-elim′ a≤a′ c<a))
    (λ c<b → ⊔-introʳ _ (≤-elim′ b≤b′ c<b)))

⊔-cong : ∀ {ℓ} {a a′ b b′ : Ord ℓ} → a ≅ a′ → b ≅ b′ → (a ⊔ b) ≅ (a′ ⊔ b′)
⊔-cong (a≤a′ , a′≤a) (b≤b′ , b′≤b) = ⊔-mon a≤a′ b≤b′ , ⊔-mon a′≤a b′≤b

⊔-<→LEM : ∀ {ℓ}
  → ({α α′ β : Ord ℓ} → α < β → α′ < β → (α ⊔ α′) < β)
  → (A : Set ℓ) → A ⊎ ¬ A
⊔-<→LEM {ℓ} p A
  = let α<β : α < β
        α<β = lift true , ≤-refl
        α′<β : α′ < β
        α′<β = lift false , ≤-refl in
    go (p α<β α′<β)
  where
    oone = osuc ozero
    α = limSuc A λ _ → oone
    α′ = oone
    β = limSuc (Lift ℓ Bool) λ { (lift true) → α ; (lift false) → α′ }

    go : (α ⊔ α′) < β → A ⊎ ¬ A
    go (lift true , α⊔α′≤α) = inj₁ (proj₁ (α⊔α′≤α (inj₂ _)))
    go (lift false , α⊔α′≤α′) = inj₂ λ a → lower (proj₁ (proj₂ (α⊔α′≤α′ (inj₁ a)) _))

-- Supremum of a family of ordinals

⨆ᶠ : ∀ {ℓ} {I : Set ℓ} (f : I → Ord ℓ) → Ord ℓ
⨆ᶠ {ℓ} {I} f = limSuc (∃[ i ] Br (f i)) λ { (i , j) → f i ` j }

⨆ᶠ-intro : ∀ {ℓ} {I : Set ℓ} (f : I → Ord ℓ) {c : Ord ℓ} {i : I}
  → c < f i → c < ⨆ᶠ f
⨆ᶠ-intro f {c} {i} c<fi
  = let j , c≤ = <-elim c<fi in
    (i , j) , c≤

⨆ᶠ-elim : ∀ {ℓ} {I : Set ℓ} (f : I → Ord ℓ) {c : Ord ℓ}
  → c < ⨆ᶠ f → ∃[ i ] (c < f i)
⨆ᶠ-elim _ ((i , j) , e) = i , <-intro (j , e)

⨆ᶠ-mon : ∀ {ℓ} {I : Set ℓ} {f f′ : I → Ord ℓ}
  → (∀ i → f i ≤ f′ i) → ⨆ᶠ f ≤ ⨆ᶠ f′
⨆ᶠ-mon {f = f} {f′} p = ≤-intro′ λ c<⨆ᶠf →
  let i , q = ⨆ᶠ-elim f c<⨆ᶠf in
  ⨆ᶠ-intro f′ (≤-elim′ (p i) q)

⨆ᶠ-cong : ∀ {ℓ} {I : Set ℓ} {f f′ : I → Ord ℓ}
  → (∀ i → f i ≅ f′ i) → ⨆ᶠ f ≅ ⨆ᶠ f′
⨆ᶠ-cong p = ⨆ᶠ-mon (λ i → proj₁ (p i))
          , ⨆ᶠ-mon (λ i → proj₂ (p i))

-- Supremum of all ordinals smaller than some given ordinal

⨆ : ∀ {ℓ} (a : Ord ℓ) → Ord ℓ
⨆ (limSuc _ f) = ⨆ᶠ f

⨆-intro : ∀ {ℓ} {a b : Ord ℓ} → b < a → b ≤ ⨆ a
⨆-intro {a = limSuc A fa} {b = limSuc B fb} (i , b≤fi) = ≤-intro λ j →
  let k , p = <-elim (b≤fi j) in _ , p

⨆-elim : ∀ {ℓ} {a c : Ord ℓ} → c < ⨆ a → ∃[ b ] ((b < a) × (c < b))
⨆-elim {a = limSuc _ f} ((i , j) , c≤) = f i , (i , ≤-refl) , <-intro (_ , c≤)


------------------------------------------------------------------------
-- An implementation of tree sort, formally proved to return a
-- permutation of the input
------------------------------------------------------------------------

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

open import Equality
open import Prelude hiding (id; _∘_; List; module List; []; _∷_)

module Container.Tree-sort
  {c⁺}
  (eq : ∀ {a p} → Equality-with-J a p c⁺)
  {A : Type}
  (_≤_ : A → A → Bool) -- A comparison function.
  where

open Derived-definitions-and-properties eq

open import Logical-equivalence using (module _⇔_)

open import Bijection eq using (_↔_; module _↔_)
open import Container eq
open import Container.List eq as List
open import Container.Tree eq as Tree
open import Function-universe eq

------------------------------------------------------------------------
-- Boring lemmas

private

  -- The following lemma is easy to prove automatically (for
  -- instance by using a ring solver).

  lemma₁ : (A B C D : Type) → A ⊎ B ⊎ C ⊎ D ↔ C ⊎ A ⊎ B ⊎ D
  lemma₁ A B C D =
    A ⊎ B ⊎ C ⊎ D      ↔⟨ id ⊎-cong ⊎-assoc ⟩
    A ⊎ (B ⊎ C) ⊎ D    ↔⟨ id ⊎-cong ⊎-comm ⊎-cong id ⟩
    A ⊎ (C ⊎ B) ⊎ D    ↔⟨ ⊎-assoc ⟩
    (A ⊎ C ⊎ B) ⊎ D    ↔⟨ ⊎-assoc ⊎-cong id ⟩
    ((A ⊎ C) ⊎ B) ⊎ D  ↔⟨ (⊎-comm ⊎-cong id) ⊎-cong id ⟩
    ((C ⊎ A) ⊎ B) ⊎ D  ↔⟨ inverse ⊎-assoc ⊎-cong id ⟩
    (C ⊎ A ⊎ B) ⊎ D    ↔⟨ inverse ⊎-assoc ⟩
    C ⊎ (A ⊎ B) ⊎ D    ↔⟨ id ⊎-cong inverse ⊎-assoc ⟩
    C ⊎ A ⊎ B ⊎ D      □

  lemma₂ : {A B C D : Type} (b : Bool) →
           T b × ((A ⊎ B) ⊎ C ⊎ D) ⊎ T (not b) × (B ⊎ C ⊎ A ⊎ D) ↔
           A ⊎ B ⊎ C ⊎ D
  lemma₂ = if-lemma (λ _ → _) (inverse ⊎-assoc) (lemma₁ _ _ _ _)

------------------------------------------------------------------------
-- Insertion into trees

-- Inserts an element into the tree.

insert : A → ⟦ Tree ⟧ A → ⟦ Tree ⟧ A
insert x = Tree.fold
  (singleton x)
  (λ l y r x+l x+r →
     if x ≤ y then node x+l y r
              else node l y x+r)

-- The insert function inserts.

Any-insert : ∀ (P : A → Type) x t →
             Any P (insert x t) ↔ P x ⊎ Any P t
Any-insert P x = Tree.fold-lemma
  (λ t t′ → Any P t′ ↔ P x ⊎ Any P t)

  (λ t₁ t₂ t₁≈t₂ t hyp →
     Any P t         ↔⟨ hyp ⟩
     P x ⊎ Any P t₁  ↔⟨ id ⊎-cong _⇔_.to (∼⇔∼″ t₁ t₂) t₁≈t₂ P ⟩
     P x ⊎ Any P t₂  □)

  (Any P (singleton x)  ↔⟨ Any-singleton P ⟩
   P x                  ↔⟨ inverse ⊎-right-identity ⟩
   P x ⊎ ⊥              ↔⟨ id ⊎-cong inverse (Any-leaf P) ⟩
   P x ⊎ Any P leaf     □)

  (λ l y r l′ r′ ih-l ih-r →
     Any P (if x ≤ y then node l′ y r else node l y r′)   ↔⟨ Any-if P (node l′ y r) (node l y r′) (x ≤ y) ⟩

     T (x ≤ y) × Any P (node l′ y r) ⊎
       T (not (x ≤ y)) × Any P (node l y r′)              ↔⟨ id ×-cong Any-node P ⊎-cong
                                                             id ×-cong Any-node P ⟩
     T (x ≤ y) × (Any P l′ ⊎ P y ⊎ Any P r) ⊎
       T (not (x ≤ y)) × (Any P l ⊎ P y ⊎ Any P r′)       ↔⟨ id ×-cong (ih-l ⊎-cong id) ⊎-cong
                                                             id ×-cong (id ⊎-cong id ⊎-cong ih-r) ⟩
     T (x ≤ y) × ((P x ⊎ Any P l) ⊎ P y ⊎ Any P r) ⊎
       T (not (x ≤ y)) × (Any P l ⊎ P y ⊎ P x ⊎ Any P r)  ↔⟨ lemma₂ (x ≤ y) ⟩

     P x ⊎ Any P l ⊎ P y ⊎ Any P r                        ↔⟨ id ⊎-cong inverse (Any-node P) ⟩

     P x ⊎ Any P (node l y r)                             □)

------------------------------------------------------------------------
-- Turning a list into a search tree

-- Converts the list to a search tree.

to-search-tree : ⟦ List ⟧ A → ⟦ Tree ⟧ A
to-search-tree = List.fold leaf (λ x _ t → insert x t)

-- No elements are added or removed.

to-search-tree≈ : ∀ xs → to-search-tree xs ≈-bag xs
to-search-tree≈ = List.fold-lemma
  (λ xs t → t ≈-bag xs)

  (λ xs ys xs≈ys t t≈xs z →
     z ∈ t   ↔⟨ t≈xs z ⟩
     z ∈ xs  ↔⟨ xs≈ys z ⟩
     z ∈ ys  □)

  (λ z →
     z ∈ leaf  ↔⟨ Any-leaf (λ x → z ≡ x) ⟩
     ⊥         ↔⟨ inverse $ Any-[] (λ x → z ≡ x) ⟩
     z ∈ []    □)

  (λ x xs t t≈xs z →
     z ∈ insert x t  ↔⟨ Any-insert (λ x → z ≡ x) _ _ ⟩
     z ≡ x ⊎ z ∈ t   ↔⟨ id ⊎-cong t≈xs z ⟩
     z ≡ x ⊎ z ∈ xs  ↔⟨ inverse $ Any-∷ (λ x → z ≡ x) ⟩
     z ∈ x ∷ xs      □)

------------------------------------------------------------------------
-- Sorting

-- Sorts a list.

sort : ⟦ List ⟧ A → ⟦ List ⟧ A
sort = flatten ∘ to-search-tree

-- The result is a permutation of the input.

sort≈ : ∀ xs → sort xs ≈-bag xs
sort≈ xs = λ z →
  z ∈ sort xs                      ↔⟨⟩
  z ∈ flatten (to-search-tree xs)  ↔⟨ flatten≈ (to-search-tree xs) _ ⟩
  z ∈ to-search-tree xs            ↔⟨ to-search-tree≈ xs _ ⟩
  z ∈ xs                           □


{-# OPTIONS --cubical-compatible #-}
module Common.Bool where

open import Agda.Builtin.Bool public

not : Bool -> Bool
not true  = false
not false = true

notnot : Bool -> Bool
notnot true  = not (not true)
notnot false = not (not false)

if_then_else_ : ∀ {a} {A : Set a} → Bool → A → A → A
if true  then t else f = t
if false then t else f = f


open import Oscar.Prelude
open import Oscar.Class
open import Oscar.Class.Reflexivity
open import Oscar.Class.Smap
open import Oscar.Class.Surjextensionality
open import Oscar.Class.Surjidentity
open import Oscar.Class.Surjtranscommutativity
open import Oscar.Class.HasEquivalence
open import Oscar.Class.Transitivity
open import Oscar.Class.Thickandthin
open import Oscar.Class.IsPrefunctor
open import Oscar.Class.IsFunctor
open import Oscar.Data.Maybe
open import Oscar.Data.¶
open import Oscar.Data.Fin
open import Oscar.Data.Proposequality
open import Oscar.Data.Substitunction
open import Oscar.Data.Term
open import Oscar.Data.Substitist
open import Oscar.Data.Descender
import Oscar.Property.Setoid.Proposextensequality
import Oscar.Property.Functor.SubstitunctionExtensionTerm
import Oscar.Property.Category.AListProposequality
import Oscar.Property.Category.ExtensionProposextensequality
import Oscar.Property.Thickandthin.FinFinProposequalityMaybeProposequality
import Oscar.Class.HasEquivalence.Substitunction
import Oscar.Class.Surjection.⋆

module Oscar.Property.Functor.SubstitistProposequalitySubstitunctionProposextensequality where

module _ {𝔭} {𝔓 : Ø 𝔭} where

  open Substitunction 𝔓
  open Term 𝔓
  open Substitist 𝔓

  _for_ : ∀ {n} (t' : Term n) (x : Fin (↑ n)) → Fin (↑ n) → Term n
  (t for x) y = maybe′ ε t (check[ Maybe ] x y)

  instance

    𝓢urjectivitySubstitist,Substitunction : Smap.class Substitist Substitunction ¡ ¡
    𝓢urjectivitySubstitist,Substitunction .⋆ _ _ ∅ = i
    𝓢urjectivitySubstitist,Substitunction .⋆ _ _ ((x , t) , σ) = 𝓢urjectivitySubstitist,Substitunction .⋆ _ _ σ ∙ (t for x)

    𝓢urjextensionalitySubstitist,Substitunction : Surjextensionality.class Substitist Proposequality Substitunction _≈_ ¡ smap
    𝓢urjextensionalitySubstitist,Substitunction .⋆ _ _ _ _ ∅ _ = ∅

    𝓢urjtranscommutativitySubstitist,Substitunction : Surjtranscommutativity.class Substitist Substitunction _≈_ smap transitivity transitivity
    𝓢urjtranscommutativitySubstitist,Substitunction .⋆ ∅ _ _ = ∅
    𝓢urjtranscommutativitySubstitist,Substitunction .⋆ ((π₀ , π₁) , f) g =
      let _⟪∙⟫′_ = flip (𝓢urjtranscommutativitySubstitist,Substitunction .⋆) in -- kludge for Agda's termination checker

        (
            § g ⟪∙⟫ §[ Substitunction ] f
          ∙
            ⟪ g ⟪∙⟫′ f ⟫[ Proposextensequality ]
        )
      ∘
        π₁ for π₀

    IsPrefunctorSubstitist,Substitunction : IsPrefunctor Substitist Proposequality transitivity Substitunction _≈_ transitivity smap
    IsPrefunctorSubstitist,Substitunction = ∁

    𝓢urjidentitySubstitist,Substitunction : Surjidentity.class Substitist Substitunction _≈_ smap ε ε
    𝓢urjidentitySubstitist,Substitunction .⋆ _ = ∅

    IsFunctorSubstitist,Substitunction : IsFunctor Substitist Proposequality ε transitivity Substitunction _≈_ ε transitivity smap
    IsFunctorSubstitist,Substitunction = ∁


module Curry5 where

open import Relation.Binary.PropositionalEquality as PropEq using (_≡_; subst)
open import Function using (id)

lemma1 : {X Y : Set} → (X ≡ (X → Y)) → X
lemma1 p rewrite p = (λ x → let f = subst id p x in f x)

curry : {X Y : Set} → (X ≡ (X → Y)) → Y
curry p = (let f = subst id p (lemma1 p) in f (lemma1 p))


module Data.QuadTree.Implementation.PropDepthRelation where

open import Haskell.Prelude
open import Data.Logic

---- Properties of depth

lteTransitiveWeird : (x y d : Nat) -> IsTrue (x < y) -> (y <= d) ≡ ((x <= d) && (y <= d))
lteTransitiveWeird zero zero zero xlty = refl
lteTransitiveWeird zero zero (suc d) xlty = refl
lteTransitiveWeird zero (suc y) zero xlty = refl
lteTransitiveWeird zero (suc y) (suc d) xlty = refl
lteTransitiveWeird (suc x) (suc y) zero xlty = refl
lteTransitiveWeird (suc x) (suc y) (suc d) xlty = lteTransitiveWeird x y d xlty

lteTransitiveWeirdInv : (x y d : Nat) -> IsFalse (x < y) -> (x <= d) ≡ ((x <= d) && (y <= d))
lteTransitiveWeirdInv zero zero zero xnlty = refl
lteTransitiveWeirdInv zero zero (suc d) xnlty = refl
lteTransitiveWeirdInv (suc x) zero zero xnlty = refl
lteTransitiveWeirdInv (suc x) zero (suc d) xnlty =
  begin
    (suc x <= suc d)
  =⟨ sym $ boolAndTrue (suc x <= suc d) ⟩
    (suc x <= suc d) && true
  =⟨⟩
    ((suc x <= suc d) && (zero <= suc d))
  end
lteTransitiveWeirdInv (suc x) (suc y) zero xnlty = refl
lteTransitiveWeirdInv (suc x) (suc y) (suc d) xnlty = lteTransitiveWeirdInv x y d xnlty

ifComparisonMap : (x y d : Nat) -> ((x <= d) && (y <= d)) ≡ (if x < y then (y <= d) else (x <= d))
ifComparisonMap x y d = ifc x < y
  then (λ {{xlty}} ->
    begin
      (x <= d) && (y <= d)
    =⟨ sym $ lteTransitiveWeird x y d xlty ⟩
      y <= d
    =⟨ sym $ ifTrue (x < y) xlty ⟩
      (if x < y then (y <= d) else (x <= d))
    end
  )
  else (λ {{xnlty}} ->
    begin
      (x <= d) && (y <= d)
    =⟨ sym $ lteTransitiveWeirdInv x y d xnlty ⟩
      x <= d
    =⟨ sym $ ifFalse (x < y) xnlty ⟩
      (if x < y then (y <= d) else (x <= d))
    end
  )

propMaxLte : (x y d : Nat) -> ((x <= d) && (y <= d)) ≡ (max x y <= d)
propMaxLte x y d =
  begin
    (x <= d) && (y <= d)
  =⟨ ifComparisonMap x y d ⟩
    (if x < y then (y <= d) else (x <= d))
  =⟨ propFnIf (λ v -> v <= d) ⟩
    (if x < y then y else x) <= d
  =⟨⟩
    max x y <= d
  end

propAndMap : (a b c d : Bool) -> a ≡ c -> b ≡ d -> (a && b) ≡ (c && d)
propAndMap false false false false ac bd = refl
propAndMap false true false true ac bd = refl
propAndMap true false true false ac bd = refl
propAndMap true true true true ac bd = refl

propMaxLte4 : (w x y z d : Nat) -> (((w <= d) && (x <= d)) && ((y <= d) && (z <= d))) ≡ (max (max w x) (max y z) <= d)
propMaxLte4 w x y z d =
  begin
    ((w <= d) && (x <= d)) && ((y <= d) && (z <= d))
  =⟨ propAndMap ((w <= d) && (x <= d)) ((y <= d) && (z <= d)) (max w x <= d) (max y z <= d) (propMaxLte w x d) (propMaxLte y z d) ⟩
    (max w x <= d) && (max y z <= d)
  =⟨ propMaxLte (if w < x then x else w) (if y < z then z else y) d ⟩
    (max (max w x) (max y z) <= d)
  end


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

open import HoTT
open import cohomology.Exactness
open import cohomology.Theory

module cohomology.Unit {i} (CT : CohomologyTheory i) where

open CohomologyTheory CT

module _ (n : ℤ) where

  private
    ⊙LU = ⊙Lift {j = i} ⊙Unit

  Cof-Unit-is-Unit : ⊙Cof (⊙idf ⊙LU) == ⊙LU
  Cof-Unit-is-Unit = ⊙ua (⊙≃-in {X = _ , cfbase} e idp)
    where
    e : Cofiber (idf (Lift {j = i} Unit)) ≃ Lift Unit
    e = equiv (λ _ → lift unit)
              (λ _ → cfbase)
              (λ _ → idp)
              (Cofiber-elim {f = idf _}
                 {P = λ c → cfbase == c}
                 idp
                 (λ _ → cfglue (lift unit))
                 (λ _ → ↓-cst=idf-in idp))

  C-Unit-is-contr : is-contr (CEl n ⊙LU)
  C-Unit-is-contr =
    (Cid n ⊙LU , λ x → lemma₂ x ∙ app= (ap GroupHom.f (CF-ident n)) x)
    where
    lemma₁ : (x : CEl n (⊙Cof (⊙idf _)))
      → Cid n ⊙LU == CF n (⊙cfcod' (⊙idf _)) x
    lemma₁ x = ! (itok (C-exact n (⊙idf _)) _ [ x , idp ])
               ∙ app= (ap GroupHom.f (CF-ident n))
                      (CF n (⊙cfcod' (⊙idf _)) x)

    lemma₂ : (x : CEl n ⊙LU) → Cid n ⊙LU == CF n (⊙idf _) x
    lemma₂ = transport
      {A = Σ (Ptd i) (λ X → fst (⊙LU ⊙→ X))}
      (λ {(X , H) → (c : CEl n X) → Cid n ⊙LU == CF n H c})
      (pair= Cof-Unit-is-Unit
             (prop-has-all-paths-↓ (⊙→-level (Lift-level Unit-is-prop))))
      lemma₁

  C-Unit : C n ⊙LU == 0ᴳ
  C-Unit = contr-is-0ᴳ _ C-Unit-is-contr


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

open import LogicalFormulae
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)
open import Functions.Definition
open import Numbers.Naturals.Semiring
open import Numbers.Naturals.Order

module Numbers.Naturals.WithK where

<NRefl : {a b : ℕ} → (p1 p2 : a <N b) → (p1 ≡ p2)
<NRefl {a} {.(succ (p1 +N a))} (le p1 refl) (le p2 proof2) = help p1=p2 proof2
  where
    p1=p2 : p1 ≡ p2
    p1=p2 = equalityCommutative (canSubtractFromEqualityRight {p2} {a} {p1} (succInjective proof2))
    help : (p1 ≡ p2) → (pr2 : succ (p2 +N a) ≡ succ (p1 +N a)) → le p1 refl ≡ le p2 pr2
    help refl refl = refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by decidable total orders
------------------------------------------------------------------------

open import Relation.Binary

module Relation.Binary.Properties.DecTotalOrder
         {d₁ d₂ d₃} (DT : DecTotalOrder d₁ d₂ d₃) where

open Relation.Binary.DecTotalOrder DT hiding (trans)
import Relation.Binary.NonStrictToStrict as Conv
open Conv _≈_ _≤_

strictTotalOrder : StrictTotalOrder _ _ _
strictTotalOrder = record
  { isStrictTotalOrder = record
      { isEquivalence = isEquivalence
      ; trans         = trans isPartialOrder
      ; compare       = trichotomous Eq.sym _≟_ antisym total
      ; <-resp-≈      = <-resp-≈ isEquivalence ≤-resp-≈
      }
  }

open StrictTotalOrder strictTotalOrder public


module Structure.Relator.Properties.Proofs where

import      Lvl
open import Data.Tuple as Tuple using (_⨯_ ; _,_)
open import Functional
open import Logic
-- open import Logic.Classical
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Structure.Relator.Properties
open import Structure.Relator
open import Structure.Setoid
open import Type

private variable ℓ ℓ₁ ℓ₂ ℓₑ : Lvl.Level
private variable T A B : Type{ℓ}
private variable _<_ _▫_ _▫₁_ _▫₂_ : T → T → Stmt{ℓ}
private variable f : T → T

[asymmetry]-to-irreflexivity : ⦃ _ : Asymmetry(_<_) ⦄ → Irreflexivity(_<_)
Irreflexivity.proof([asymmetry]-to-irreflexivity {_<_ = _<_}) = [→]-redundancy(asymmetry(_<_))

[irreflexivity,transitivity]-to-asymmetry : ⦃ irrefl : Irreflexivity(_<_) ⦄ ⦃ trans : Transitivity(_<_) ⦄ → Asymmetry(_<_)
Asymmetry.proof([irreflexivity,transitivity]-to-asymmetry {_<_ = _<_}) = Tuple.curry(irreflexivity(_<_) ∘ (Tuple.uncurry(transitivity(_<_))))

converseTotal-to-reflexivity : ⦃ convTotal : ConverseTotal(_<_) ⦄ → Reflexivity(_<_)
Reflexivity.proof(converseTotal-to-reflexivity {_<_ = _<_}) = [∨]-elim id id (converseTotal(_<_))

reflexivity-to-negated-irreflexivity : ⦃ refl : Reflexivity(_<_) ⦄ → Irreflexivity((¬_) ∘₂ (_<_))
Irreflexivity.proof (reflexivity-to-negated-irreflexivity {_<_ = _<_}) irrefl = irrefl(reflexivity(_<_))

negated-symmetry : ⦃ sym : Symmetry(_<_) ⦄ → Symmetry((¬_) ∘₂ (_<_))
Symmetry.proof (negated-symmetry {_<_ = _<_}) nxy yx = nxy(symmetry(_<_) yx)

antisymmetry-irreflexivity-to-asymmetry : ⦃ equiv : Equiv{ℓₑ}(T) ⦄ ⦃ rel : BinaryRelator{A = T}(_<_) ⦄ ⦃ antisym : Antisymmetry(_<_)(_≡_) ⦄ ⦃ irrefl : Irreflexivity(_<_) ⦄ → Asymmetry(_<_)
Asymmetry.proof (antisymmetry-irreflexivity-to-asymmetry {_<_ = _<_}) xy yx = irreflexivity(_<_) (substitute₂ᵣ(_<_) (antisymmetry(_<_)(_≡_) xy yx) yx)

asymmetry-to-antisymmetry : ⦃ asym : Asymmetry(_<_) ⦄ → Antisymmetry(_<_)(_▫_)
Antisymmetry.proof (asymmetry-to-antisymmetry {_<_ = _<_}) ab ba = [⊥]-elim(asymmetry(_<_) ab ba)

subrelation-transitivity-to-subtransitivityₗ : ⦃ sub : (_▫₁_) ⊆₂ (_▫₂_) ⦄ ⦃ trans : Transitivity(_▫₂_) ⦄ → Subtransitivityₗ(_▫₂_)(_▫₁_)
Subtransitivityₗ.proof (subrelation-transitivity-to-subtransitivityₗ {_▫₁_ = _▫₁_} {_▫₂_ = _▫₂_}) xy yz = transitivity(_▫₂_) (sub₂(_▫₁_)(_▫₂_) xy) yz

subrelation-transitivity-to-subtransitivityᵣ : ⦃ sub : (_▫₁_) ⊆₂ (_▫₂_) ⦄ ⦃ trans : Transitivity(_▫₂_) ⦄ → Subtransitivityᵣ(_▫₂_)(_▫₁_)
Subtransitivityᵣ.proof (subrelation-transitivity-to-subtransitivityᵣ {_▫₁_ = _▫₁_} {_▫₂_ = _▫₂_}) xy yz = transitivity(_▫₂_) xy (sub₂(_▫₁_)(_▫₂_) yz)

-- TODO: https://proofwiki.org/wiki/Definition%3aRelation_Compatible_with_Operation and substitution. Special case for (≡) and function application: ∀(x∊T)∀(y∊T). (x ≡ y) → (∀(f: T→T). f(x) ≡ f(y))

instance
  -- A subrelation of a reflexive relation is reflexive.
  -- ∀{_□_ _△_ : T → T → Type} → ((_□_) ⊆₂ (_△_)) → (Reflexivity(_□_) → Reflexivity(_△_))
  subrelation-reflexivity : (_⊆₂_) ⊆₂ ((_→ᶠ_) on₂ Reflexivity{ℓ₂ = ℓ}{T = T})
  _⊆₂_.proof subrelation-reflexivity (intro ab) (intro ra) = intro (ab ra)

instance
  -- The negation of a subrelation is a superrelation.
  -- ∀{_□_ _△_ : T → T → Type} → ((_□_) ⊆₂ (_△_)) → (((¬_) ∘₂ (_△_)) ⊆₂ ((¬_) ∘₂ (_□_)))
  swapped-negated-subrelation : (_⊆₂_ {A = A}{B = B}{ℓ₁ = ℓ}) ⊆₂ ((_⊇₂_) on₂ ((¬_) ∘₂_))
  _⊆₂_.proof (_⊆₂_.proof swapped-negated-subrelation (intro sub)) = _∘ sub

swap-reflexivity : ⦃ refl : Reflexivity(_▫_) ⦄ → Reflexivity(swap(_▫_))
swap-reflexivity {_▫_ = _▫_} = intro(reflexivity(_▫_))

on₂-reflexivity : ∀{_▫_ : B → B → Stmt{ℓ}}{f : A → B} → ⦃ refl : Reflexivity(_▫_) ⦄ → Reflexivity((_▫_) on₂ f)
on₂-reflexivity {_▫_ = _▫_} = intro(reflexivity(_▫_))

on₂-symmetry : ∀{_▫_ : B → B → Stmt{ℓ}}{f : A → B} → ⦃ sym : Symmetry(_▫_) ⦄ → Symmetry((_▫_) on₂ f)
on₂-symmetry {_▫_ = _▫_} = intro(symmetry(_▫_))

on₂-transitivity : ∀{_▫_ : B → B → Stmt{ℓ}}{f : A → B} → ⦃ trans : Transitivity(_▫_) ⦄ → Transitivity((_▫_) on₂ f)
on₂-transitivity {_▫_ = _▫_} = intro(transitivity(_▫_))


------------------------------------------------------------------------------
-- Parametrized preorder reasoning
------------------------------------------------------------------------------

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

module Common.Relation.Binary.PreorderReasoning
  {D     : Set}
  (_∼_   : D → D → Set)
  (refl  : ∀ {x} → x ∼ x)
  (trans : ∀ {x y z} → x ∼ y → y ∼ z → x ∼ z)
  where

infix  3 _∎
infixr 2 _∼⟨_⟩_

------------------------------------------------------------------------------
-- From (Mu, S.-C., Ko, H.-S. and Jansson, P. (2009)).
--
-- N.B. Unlike Ulf's thesis (and the Agda standard library 0.8.1) this
-- set of combinators do not use a wrapper data type.

_∼⟨_⟩_ : ∀ x {y z} → x ∼ y → y ∼ z → x ∼ z
_ ∼⟨ x∼y ⟩ y∼z = trans x∼y y∼z

_∎ : ∀ x → x ∼ x
_∎ _ = refl

------------------------------------------------------------------------------
-- References
--
-- Mu, S.-C., Ko, H.-S. and Jansson, P. (2009). Algebra of programming
-- in Agda: Dependent types for relational program derivation. Journal
-- of Functional Programming 19.5, pp. 545–579.


open import bool
open import level
open import eq
open import product
open import product-thms
open import relations

-- module closures where

--   module basics {ℓ ℓ' : level}{A : Set ℓ} (_>A_ : A → A → Set ℓ') where

--     data tc : A → A → Set (ℓ ⊔ ℓ') where
--       tc-step : ∀{a b : A} → a >A b → tc a b
--       tc-trans : ∀{a b c : A} → tc a b → tc b c → tc a c

--     data rc : A → A → Set (ℓ ⊔ ℓ') where
--       rc-step : ∀{a b : A} → a >A b → rc a b
--       rc-refl : ∀{a : A} → rc a a

--     tc-transitive : transitive tc
--     tc-transitive = tc-trans

--   module combinations {ℓ ℓ' : level}{A : Set ℓ} (_>A_ : A → A → Set ℓ') where
--      open basics public

--      rtc : A → A → Set (ℓ ⊔ ℓ')
--      rtc = rc (tc _>A_)

--      rtc-refl : reflexive rtc
--      rtc-refl = rc-refl

--      rtc-trans : transitive rtc
--      rtc-trans (rc-step{a}{b} x) (rc-step{.b}{c} x') = rc-step (tc-trans x x')
--      rtc-trans (rc-step x) rc-refl = rc-step x
--      rtc-trans rc-refl (rc-step x) = rc-step x
--      rtc-trans rc-refl rc-refl = rc-refl


{-# OPTIONS --safe #-}
module Cubical.Algebra.CommMonoid.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.Equiv.HalfAdjoint
open import Cubical.Foundations.Function
open import Cubical.Foundations.HLevels
open import Cubical.Foundations.Isomorphism
open import Cubical.Foundations.Univalence
open import Cubical.Foundations.Transport
open import Cubical.Foundations.SIP

open import Cubical.Data.Sigma

open import Cubical.Algebra.Semigroup
open import Cubical.Algebra.Monoid.Base

open import Cubical.Displayed.Base
open import Cubical.Displayed.Auto
open import Cubical.Displayed.Record
open import Cubical.Displayed.Universe

open import Cubical.Reflection.RecordEquiv

open Iso

private
  variable
    ℓ ℓ' : Level

record IsCommMonoid {A : Type ℓ} (ε : A) (_·_ : A → A → A) : Type ℓ where
  constructor iscommmonoid

  field
   isMonoid : IsMonoid ε _·_
   comm :  (x y : A) → x · y ≡ y · x

  open IsMonoid isMonoid public

unquoteDecl IsCommMonoidIsoΣ = declareRecordIsoΣ IsCommMonoidIsoΣ (quote IsCommMonoid)

record CommMonoidStr (A : Type ℓ) : Type ℓ where
  constructor commmonoidstr

  field
    ε        : A
    _·_      : A → A → A
    isCommMonoid : IsCommMonoid ε _·_

  infixl 7 _·_

  open IsCommMonoid isCommMonoid public

CommMonoid : ∀ ℓ → Type (ℓ-suc ℓ)
CommMonoid ℓ = TypeWithStr ℓ CommMonoidStr

commmonoid : (A : Type ℓ) (ε : A) (_·_ : A → A → A) (h : IsCommMonoid ε _·_) → CommMonoid ℓ
commmonoid A ε _·_ h = A , commmonoidstr ε _·_ h

-- Easier to use constructors
makeIsCommMonoid : {M : Type ℓ} {ε : M} {_·_ : M → M → M}
               (is-setM : isSet M)
               (assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
               (rid : (x : M) → x · ε ≡ x)
               (lid : (x : M) → ε · x ≡ x)
               (comm : (x y : M) → x · y ≡ y · x)
             → IsCommMonoid ε _·_
IsCommMonoid.isMonoid (makeIsCommMonoid is-setM assoc rid lid comm) =
                                        makeIsMonoid is-setM assoc rid lid
IsCommMonoid.comm (makeIsCommMonoid is-setM assoc rid lid comm) = comm

makeCommMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M)
             (is-setM : isSet M)
             (assoc : (x y z : M) → x · (y · z) ≡ (x · y) · z)
             (rid : (x : M) → x · ε ≡ x)
             (lid : (x : M) → ε · x ≡ x)
             (comm : (x y : M) → x · y ≡ y · x)
           → CommMonoid ℓ
makeCommMonoid ε _·_ is-setM assoc rid lid comm =
  commmonoid _ ε _·_ (makeIsCommMonoid is-setM assoc rid lid comm)

CommMonoidStr→MonoidStr : {A : Type ℓ} → CommMonoidStr A → MonoidStr A
CommMonoidStr→MonoidStr (commmonoidstr _ _ H) = monoidstr _ _ (IsCommMonoid.isMonoid H)

CommMonoid→Monoid : CommMonoid ℓ → Monoid ℓ
CommMonoid→Monoid (_ , commmonoidstr _ _ H) = _ , monoidstr _ _ (IsCommMonoid.isMonoid H)

CommMonoidHom : (L : CommMonoid ℓ) (M : CommMonoid ℓ') → Type (ℓ-max ℓ ℓ')
CommMonoidHom L M = MonoidHom (CommMonoid→Monoid L) (CommMonoid→Monoid M)

IsCommMonoidEquiv : {A : Type ℓ} {B : Type ℓ'}
  (M : CommMonoidStr A) (e : A ≃ B) (N : CommMonoidStr B) → Type (ℓ-max ℓ ℓ')
IsCommMonoidEquiv M e N = IsMonoidHom (CommMonoidStr→MonoidStr M) (e .fst) (CommMonoidStr→MonoidStr N)

CommMonoidEquiv : (M : CommMonoid ℓ) (N : CommMonoid ℓ') → Type (ℓ-max ℓ ℓ')
CommMonoidEquiv M N = Σ[ e ∈ (M .fst ≃ N .fst) ] IsCommMonoidEquiv (M .snd) e (N .snd)

isPropIsCommMonoid : {M : Type ℓ} (ε : M) (_·_ : M → M → M)
             → isProp (IsCommMonoid ε _·_)
isPropIsCommMonoid ε _·_ (iscommmonoid MM MC) (iscommmonoid SM SC) =
  λ i → iscommmonoid (isPropIsMonoid _ _ MM SM i) (isPropComm MC SC i)
  where
  isSetM : isSet _
  isSetM = MM .IsMonoid.isSemigroup .IsSemigroup.is-set

  isPropComm : isProp ((x y : _) → x · y ≡ y · x)
  isPropComm = isPropΠ2 λ _ _ → isSetM _ _

𝒮ᴰ-CommMonoid : DUARel (𝒮-Univ ℓ) CommMonoidStr ℓ
𝒮ᴰ-CommMonoid =
  𝒮ᴰ-Record (𝒮-Univ _) IsCommMonoidEquiv
    (fields:
      data[ ε ∣ autoDUARel _ _ ∣ presε ]
      data[ _·_ ∣ autoDUARel _ _ ∣ isHom ]
      prop[ isCommMonoid ∣ (λ _ _ → isPropIsCommMonoid _ _) ])
  where
  open CommMonoidStr
  open IsMonoidHom

CommMonoidPath : (M N : CommMonoid ℓ) → CommMonoidEquiv M N ≃ (M ≡ N)
CommMonoidPath = ∫ 𝒮ᴰ-CommMonoid .UARel.ua


module Category.Functor.Lawful where
open import Agda.Primitive using (lsuc; _⊔_)
open import Category.Functor
open import Category.Applicative
open import Function using (id; _∘_)
open import Relation.Binary.PropositionalEquality using (_≡_; module ≡-Reasoning; sym; cong)

record LawfulFunctorImp {l₁ l₂} {F : Set l₁ → Set l₂} (FFunc : RawFunctor F) : Set (lsuc l₁ ⊔ l₂) where
  open RawFunctor FFunc
  field
    <$>-identity : ∀ {a} {x : F a} → (id <$> x) ≡ x
    <$>-compose  : ∀ {a b c} {f : a → b} {g : b → c} {x : F a} → ((g ∘ f) <$> x) ≡ (g <$> (f <$> x))

module LawfulFunctor {l₁ l₂} {F : Set l₁ → Set l₂} {FFunc : RawFunctor F} (FLawful : LawfulFunctorImp FFunc) where
  open RawFunctor FFunc public
  open LawfulFunctorImp FLawful public

record LawfulApplicativeImp {l} {F : Set l → Set l} (FAppl : RawApplicative F) : Set (lsuc l) where
  open RawApplicative FAppl
  field
    ⊛-identity     : ∀ {A}     {u : F A}                                 → (pure id ⊛ u) ≡ u
    ⊛-homomorphism : ∀ {A B}   {u :    A → B } {v : A}                   → (pure u ⊛ pure v) ≡ pure (u v)
    ⊛-interchange  : ∀ {A B}   {u : F (A → B)} {v : A}                   → (u ⊛ pure v) ≡ (pure (λ uᵢ → uᵢ v) ⊛ u)
    ⊛-composition  : ∀ {A B C} {u : F (B → C)} {v : F (A → B)} {w : F A} → (pure (λ f g a → f (g a)) ⊛ u ⊛ v ⊛ w) ≡ (u ⊛ (v ⊛ w))
  open ≡-Reasoning
  private
    composelemma  : ∀ {a b c} {f : a → b} {g : b → c} {x : F a} → ((g ∘ f) <$> x) ≡ (g <$> (f <$> x))
    composelemma {_} {_} {_} {f} {g} {x} =
      pure (λ x₁ → g (f x₁)) ⊛ x ≡⟨ cong (_⊛ x) (sym ⊛-homomorphism) ⟩
      pure (λ f x → g (f x)) ⊛ pure f ⊛ x ≡⟨ cong ((_⊛ x) ∘ (_⊛ pure f)) (sym ⊛-homomorphism) ⟩
      pure (λ g f x → g (f x)) ⊛ pure g ⊛ pure f ⊛ x ≡⟨ ⊛-composition ⟩
      pure g ⊛ (pure f ⊛ x) ∎
  isLawfulFunctor : LawfulFunctorImp rawFunctor
  isLawfulFunctor = record
    { <$>-identity = ⊛-identity
    ; <$>-compose = composelemma
    }

module LawfulApplicative {l} {F : Set l → Set l} (FAppl : RawApplicative F) (FLawful : LawfulApplicativeImp FAppl) where
  open RawApplicative FAppl public
  open LawfulApplicativeImp FLawful public
  open LawfulFunctorImp isLawfulFunctor public


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

module hSet where

  open import lib.Basics
  open import lib.Funext
  open import lib.NType2
  open import lib.types.Truncation
  open import lib.types.Bool
  open import PropT

  _is-a-set : {i : ULevel} (A : Type i) → Type i
  A is-a-set = is-set A

  -- To get an element a of the set A is to give a : ∈ A.
  ∈ : {i : ULevel} (A : hSet i) → Type i
  ∈ = fst

  set-is-a-set : {i : ULevel} (A : hSet i) → (∈ A) is-a-set
  set-is-a-set A = snd A

  -- Equality for sets, landing in Prop
  _==ₚ_ : {i : ULevel} {A : hSet i}
          → (x y : ∈ A) → PropT i
  _==ₚ_ {_} {A} x y = (x == y) , has-level-apply (set-is-a-set A) x y

  _=bool=_ : {i : ULevel} {A : Type i} {p : has-dec-eq A}
             → (x y : A) → Bool
  _=bool=_ {p = p} x y  = case (p x y)
    where case : Dec (x == y) → Bool
          case (inl _) = true
          case (inr _) = false

  ∥_∥₀ : ∀ {i} (A : Type i) → Type i
  ∥_∥₀ = Trunc 0


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

module WellFounded where

open import Level

data Acc {a r} {A : Type a} (R : A → A → Type r) (x : A) : Type (a ℓ⊔ r) where
  acc : (∀ y → R y x → Acc R y) → Acc R x

-- record Acc {a r} {A : Type a} (R : A → A → Type r) (x : A) : Type (a ℓ⊔ r) where
--   inductive
--   constructor acc
--   field step : ∀ y → R y x → Acc R y
-- open Acc public

WellFounded : ∀ {r} → (A → A → Type r) → Type _
WellFounded R = ∀ x → Acc R x

open import HLevels
open import Path

isPropAcc : ∀ {r} {R : A → A → Type r} {x : A} → isProp (Acc R x)
isPropAcc (acc x) (acc y) = cong acc (funExt λ n → funExt λ p → isPropAcc (x n p) (y n p))


module Stack where

open import Data.Bool using (Bool; true; false)
open import Data.Nat using (ℕ; zero; suc)

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl; cong)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_; _∎; step-≡)

module V1 where
    {-
    This first version introduces the Stack abstract data type.
    -}

    data Stack (A : Set) : Set where
        ∅    : Stack A
        _>>_ : A → Stack A → Stack A

    infixr 50 _>>_

    push : ∀ {A} → A → Stack A → Stack A
    push a s = a >> s

    peek : ∀ {A} → (S : Stack A) → A
    -- May be absurd can be used here but how?
    peek (a >> _) = a

    pop : ∀ {A} → (S : Stack A) → Stack A
    -- May be absurd can be used here but how?
    pop (a >> s) = s

    module Example where
        _ : Stack Bool
        _ = true >> false >> ∅

    module Laws where
        law1 : ∀ {A} (a : A) (s : Stack A) -> peek (push a s) ≡ a
        law1 a s =
            begin
               peek (push a s)
               ≡⟨⟩
               peek (a >> s)
               ≡⟨⟩
               a
            ∎

        law2 : ∀ {A} {a : A} {s : Stack A} → pop (push a s) ≡ s
        law2 = refl

module V2 where
    {-
    This second version introduces the expression as constraint in the type definition.
    This prevents incomplete pattern matching for peek and pop.

    For this purpose we first design empty? predicate and then we use it in the type definition
    of peek and pop.
    -}

    data Stack (A : Set) : Set where
        ∅    : Stack A
        _>>_ : A → Stack A → Stack A

    infixr 50 _>>_

    empty? : ∀ {A} → Stack A → Bool
    empty? ∅ = true
    empty? _ = false

    push : ∀ {A} → A → Stack A → Stack A
    push a s = a >> s

    peek : ∀ {A} → (S : Stack A) -> {empty? S ≡ false} → A
    peek (a >> _) = a

    pop : ∀ {A} → (S : Stack A) -> {empty? S ≡ false} → Stack A
    pop (a >> s) = s

    module Example where
        _ : Stack Bool
        _ = pop (push true ∅) {refl}

    module Laws where
        law1 : ∀ {A} {a : A} {s : Stack A} → peek (push a s) {refl} ≡ a
        law1 = refl

        law2 : ∀ {A} {a : A} {s : Stack A} → pop (push a s) {refl} ≡ s
        law2 = refl

module V3 where
    {-
    In this third version we use a GADT for the Stack data representation.
    A Kind then is design on purpose and a phantom type is used for the
    association between the stack and the kind.
    -}

    data Kind : Set where
        Empty    : Kind
        NotEmpty : Kind

    data Stack (A : Set) : Kind → Set where
        ∅    : Stack A Empty
        _>>_ : ∀ {B} → A → Stack A B → Stack A NotEmpty

    infixr 50 _>>_

    push : ∀ {A B} → A → Stack A B → Stack A NotEmpty
    push a s = a >> s

    peek : ∀ {A} → Stack A NotEmpty → A
    peek (a >> _) = a

    {-
    B is in the ouput only! => No constraint with the input.
    Writing such pop function is impossible as is.

    pop : ∀ {A B} → Stack A NotEmpty → Stack A B
    pop (_ >> s) = s
    -}

    module Example where
        _ : Stack Bool NotEmpty
        _ = push true ∅

    module Laws where
        law1 : ∀ {A B} {a : A} {s : Stack A B} → peek (push a s) ≡ a
        law1 = refl

        -- law2 cannot be expressed ...

module V4 where
    {-
    In this fourth version we slightly review the NotEmpty construction.
    This opens the opportunity to express the pop function since a
    dependency can by modeled in the corresponding type definition.
    -}
    data Kind : Set where
        Empty    : Kind
        NotEmpty : Kind → Kind

    data Stack (A : Set) : Kind → Set where
        ∅  : Stack A Empty
        _>>_ : ∀ {B} → A → Stack A B → Stack A (NotEmpty B)

    infixr 50 _>>_

    push : ∀ {A B} → A → Stack A B → Stack A (NotEmpty B)
    push a s = a >> s

    peek : ∀ {A B} → Stack A (NotEmpty B) → A
    peek (a >> _) = a

    pop : ∀ {A B} → Stack A (NotEmpty B) → Stack A B
    pop (_ >> s) = s

    module Example where
        _ : Stack Bool (NotEmpty Empty)
        _ = push true ∅

    module Laws where
        law1 : ∀ {A B} {a : A} {s : Stack A B} → peek (push a s) ≡ a
        law1 = refl

        law2 : ∀ {A B} {a : A} {s : Stack A B} → pop (push a s) ≡ s
        law2 = refl

module V5 where
    {-
    In this last version we show that previous Kind definiton is isomorphic
    with the Natural.
    -}

    data Stack (A : Set) : ℕ → Set where
        ∅  : Stack A 0
        _>>_ : ∀ {B} → A → Stack A B → Stack A (suc B)

    infixr 50 _>>_

    push : ∀ {A B} → A → Stack A B → Stack A (suc B)
    push a s = a >> s

    peek : ∀ {A B} → Stack A (suc B) → A
    peek (a >> _) = a

    pop : ∀ {A B} → Stack A (suc B) → Stack A B
    pop (_ >> s) = s

    module Example where
        _ : Stack Bool 1
        _ = push true ∅

    module Laws where
        law1 : ∀ {A B} {a : A} {s : Stack A B} → peek (push a s) ≡ a
        law1 = refl

        law2 : ∀ {A B} {a : A} {s : Stack A B} → pop (push a s) ≡ s
        law2 = refl


module plfa-exercises.Practice4 where

open import Relation.Binary.PropositionalEquality using (_≡_; refl; sym; cong)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import Data.Product using (_×_ ; ∃-syntax; ∃; _,_) -- renaming (_,_ to ⟨_,_⟩)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_; _∸_; _≤_; _≤?_; _≟_; s≤s; z≤n)
open import Data.Nat.Binary.Properties using (≰⇒>)
open import Data.Nat.Properties using (≤-refl; ≤-trans; ≤-antisym; ≤-total)
open import Data.Maybe using (Maybe; just; nothing; maybe; _>>=_; from-just; From-just)
open import Data.Bool using (Bool; true; false; T; _∧_; _∨_; not)
open import Relation.Nullary.Decidable using (⌊_⌋; toWitness; fromWitness; from-yes; From-yes)
open import Relation.Nullary using (¬_; Dec; yes; no)
open import Data.Unit using (⊤; tt)

--data OrderedTree (A : Set) : (smallest middle biggest : ℕ) → Set where
--  leaf : ∀ (n : ℕ) → A → OrderedTree A n n
--  node : ∀ {s₁ m₁ b₁ s₂ m₂ b₂ : ℕ}
--       → (m : ℕ)
--       → b₁ ≤ m
--       → m ≤ s₂
--       → OrderedTree A s₁ m₁ b₁
--       → OrderedTree A s₂ m₂ b₂
--       → OrderedTree A s₁ m b₂
--
---- node 7 _ _ (leaf 5 300) (leaf 10 200)
----middle_values_in_node_are_smaller :
--
--insert_left : ∀ {s m b : ℕ} → (n : ℕ) → A → OrderedTree A s m b

data BST : ℕ → ℕ → Set where
  leaf : ∀ {l u : ℕ} → l ≤ u → BST l u
  node : ∀ {l l₀ u₁ u : ℕ} (d : ℕ)
       → BST l₀ d
       → BST d  u₁
       → l  ≤ l₀ -- This overcomplicates some stuff in later code. Better get rid off it
       → u₁ ≤ u
       → BST l u

-- node {l = 0} {u = 30} 5 (leaf {2} {5} _) (leaf {5} {6} _)

-- If we use the long definition of BST this function gets short, otherwise it's quite complicated
widen : ∀ {l l' u u' : ℕ}
      → BST l' u'
      → l ≤ l'
      → u' ≤ u
      → BST l u
widen (leaf l'≤u') l≤l' u'≤u = leaf (≤-trans l≤l' (≤-trans l'≤u' u'≤u))
widen (node d left right l'≤l₀ u₁≤u') l≤l' u'≤u = node d left right (≤-trans l≤l' l'≤l₀) (≤-trans u₁≤u' u'≤u)

-- node {l = 0} {u = 30} 5 (leaf {2} {5} _) (widen (leaf {23} {29} _) _ _) z≤n _

a-tree : BST 0 30 -- A tree with a single node!!
--a-tree = node 5 (leaf 2≤5) (leaf 5≤30) z≤n 30≤30
a-tree = node 5 (leaf 2≤5) (widen (leaf 23≤29) 5≤23 29≤30) z≤n 30≤30
--a-tree = node {l = 0} {u = 30} 5 (leaf {2} {5} 2≤5) (widen (leaf {23} {29} 23≤29) 5≤23 29≤30) z≤n 30≤30
  where
    --2≤5   = toWitness {Q =  2 ≤?  5} tt
    2≤5   = from-yes ( 2 ≤?  5)
    23≤29 = from-yes (23 ≤? 29)
    5≤23  = from-yes ( 5 ≤? 23)
    29≤30 = from-yes (29 ≤? 30)
    30≤30 = from-yes (30 ≤? 30)

binary-search : ∀ {l u : ℕ} → (n : ℕ) → l ≤ n → n ≤ u → BST l u → Maybe (∃[ l' ] (∃[ u' ] (BST l' u')))
binary-search _ _ _ (leaf _) = nothing
binary-search n l≤n n≤u (node {l'} {l₀} {u₁} {u'} d left right l'≤l₀ u₁≤u') with d ≟ n
--binary-search n _ _ (node {_} {l} {_} {u} d left right l≤l₀ u₁≤u) with d ≟ n
...             | yes d=n = just (l' , u' , node d left right l'≤l₀ u₁≤u')
...             | no  d≠n  with ≤-total n d | l₀ ≤? n | n ≤? u₁
...                           | inj₁ n≤d | yes l₀≤n | _         = binary-search n l₀≤n n≤d left
...                           | inj₁ n≤d | no ¬l₀≤n | _         = nothing -- This shouldn't exist if the definition of BST wasn't so overcomcomplicated
...                           | inj₂ d≤n | _        | yes n≤u₁  = binary-search n d≤n n≤u₁ right
...                           | inj₂ d≤n | _        | no ¬n≤u₁  = nothing

smaller : ℕ → ℕ → Bool
smaller m n with m ≤? n
...            | yes m≤n = true
...            | _       = false

_≤ℕ_ : ∀ (m n : ℕ) → From-yes (m ≤? n)
m ≤ℕ n = from-yes (m ≤? n)

--_ : Maybe (∃ (λ l' → ∃ (BST l')))
--_ = binary-search 5 _ _ a-tree ≡ nothing
  --where
    --5≤30 = from-yes (5 ≤? 30)
_ : binary-search 2 z≤n (2 ≤ℕ 30) a-tree ≡ nothing
_ = refl

_ : binary-search 5 z≤n (5 ≤ℕ 30) a-tree ≡ just (0 , 30 , node 5 _ _ _ _)
_ = refl

insert : ∀ {l u} (d : ℕ) → l ≤ d → d ≤ u → BST l u → BST l u
insert d l≤d d≤u (leaf _) = node d (leaf l≤d) (leaf d≤u) ≤-refl ≤-refl
insert d l≤d d≤u (node {_} {l₀} m left right l≤m m≤u) with ≤-total m d
...                | inj₁ m≤d = node m (insert d ? ? left) right l≤m m≤u -- This shouldn't exist if the definition of BST wasn't so overcomcomplicated
...                | inj₂ d≤m = ?

-- ≰⇒> ¬3≤4


-- Andreas, 2015-06-11

{-# OPTIONS --copatterns #-}

open import Common.Size

module _ {C : Set} {R : C → Set} where

mutual
  record IO (i : Size) (A : Set) : Set where
    coinductive
    constructor delay
    field
      force : {j : Size< i} → IO' j A

  data IO' (i : Size) (A : Set) : Set where
    do     : (c : C) (f : R c → IO i A) → IO' i A
    return : (a : A) → IO' i A

open IO

module Works where

  _>>=_ : ∀{i A B} (m : IO i A) (k : A → IO i B) → IO i B
  force (m >>= k) with force m
  force (m >>= k) {j} | do c f   = do c λ x → f x >>= k
  force (m >>= k) {j} | return a = force (k a)

_>>=_ : ∀{i A B} (m : IO i A) (k : A → IO i B) → IO i B
force (m >>= k) with force m
force (m >>= k) | do c f   = do c λ x → f x >>= k
force (m >>= k) | return a = force (k a)

-- Error WAS:
-- Too few arguments given in with-clause
-- when checking that the clause
-- force (m >>= k) with force m
-- force (m >>= k) | do c f = do c (λ x → f x >>= k)
-- force (m >>= k) | return a = force (k a)
-- has type {i : Size} {A B : Set} → IO i A → (A → IO i B) → IO i B


module ExtendedLambdaCase where

data Bool : Set where
  true false : Bool

data Void : Set where

foo : Bool -> Bool -> Bool -> Bool
foo = λ { x → λ { y z → {!!} } }

module parameterised {A : Set}(B : A -> Set) where

  data Bar : (Bool -> Bool) -> Set where
    baz : (t : Void) -> Bar λ { x → {!!} }

  -- with hidden argument
  data Bar' : (Bool -> Bool) -> Set where
    baz' : {t : Void} -> Bar' λ { x' → {!!} }

baz : Bool -> {w : Bool} -> Bool
baz = λ { z {w} → {!!} }


{-# OPTIONS --cubical --safe #-}
module Cubical.Structures.Monoid where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.Equiv
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma

open import Cubical.Foundations.SIP renaming (SNS-PathP to SNS)

open import Cubical.Structures.Pointed
open import Cubical.Structures.NAryOp

private
  variable
    ℓ : Level

-- Monoids
raw-monoid-structure : Type ℓ → Type ℓ
raw-monoid-structure X = X × (X → X → X)

-- If we ignore the axioms we get a "raw" monoid
raw-monoid-is-SNS : SNS {ℓ} raw-monoid-structure _
raw-monoid-is-SNS = join-SNS pointed-iso pointed-is-SNS (nAryFunIso 2) (nAryFunSNS 2)

-- Monoid axioms
monoid-axioms : (X : Type ℓ) → raw-monoid-structure X → Type ℓ
monoid-axioms X (e , _·_ ) = isSet X
                           × ((x y z : X) → x · (y · z) ≡ (x · y) · z)
                           × ((x : X) → x · e ≡ x)
                           × ((x : X) → e · x ≡ x)

monoid-structure : Type ℓ → Type ℓ
monoid-structure = add-to-structure raw-monoid-structure monoid-axioms

Monoid : Type (ℓ-suc ℓ)
Monoid {ℓ} = TypeWithStr ℓ monoid-structure

-- Monoid extractors

⟨_⟩ : Monoid {ℓ} → Type ℓ
⟨ G , _ ⟩ = G

monoid-id : (M : Monoid {ℓ}) → ⟨ M ⟩
monoid-id (_ , (e , _) , _) = e

monoid-operation : (M : Monoid {ℓ}) → ⟨ M ⟩ → ⟨ M ⟩ → ⟨ M ⟩
monoid-operation (_ , (_ , f) , _) = f

-- Monoid syntax with explicit monoid

module monoid-syntax where
  id : (M : Monoid {ℓ}) → ⟨ M ⟩
  id = monoid-id

  monoid-operation-syntax : (M : Monoid {ℓ}) → ⟨ M ⟩ → ⟨ M ⟩ → ⟨ M ⟩
  monoid-operation-syntax = monoid-operation

  infixr 18 monoid-operation-syntax
  syntax monoid-operation-syntax M x y = x ·⟨ M ⟩ y

open monoid-syntax

-- More Monoid extractors

monoid-is-set : (M : Monoid {ℓ}) → isSet (⟨ M ⟩)
monoid-is-set (_ , _ , P , _) = P

monoid-assoc : (M : Monoid {ℓ})
             → (x y z : ⟨ M ⟩) → x ·⟨ M ⟩ (y ·⟨ M ⟩ z) ≡ (x ·⟨ M ⟩ y) ·⟨ M ⟩ z
monoid-assoc (_ , _ , _ , P , _) = P

monoid-rid : (M : Monoid {ℓ})
           → (x : ⟨ M ⟩) → x ·⟨ M ⟩ (id M) ≡ x
monoid-rid (_ , _ , _ , _ , P , _) = P

monoid-lid : (M : Monoid {ℓ})
           → (x : ⟨ M ⟩) → (id M) ·⟨ M ⟩ x ≡ x
monoid-lid (_ , _ , _ , _ , _ , P) = P

-- Monoid equivalence
monoid-iso : StrIso monoid-structure ℓ
monoid-iso = add-to-iso (join-iso pointed-iso (nAryFunIso 2)) monoid-axioms

-- We have to show that the monoid axioms are indeed propositions
monoid-axioms-are-Props : (X : Type ℓ) (s : raw-monoid-structure X) → isProp (monoid-axioms X s)
monoid-axioms-are-Props X (e , _·_) s = β s
   where
   α = s .fst
   β = isProp× isPropIsSet
      (isProp× (isPropΠ3 (λ x y z → α (x · (y · z)) ((x · y) · z)))
      (isProp× (isPropΠ (λ x → α (x · e) x)) (isPropΠ (λ x → α (e · x) x))))

monoid-is-SNS : SNS {ℓ} monoid-structure monoid-iso
monoid-is-SNS = add-axioms-SNS _ monoid-axioms-are-Props raw-monoid-is-SNS

MonoidPath : (M N : Monoid {ℓ}) → (M ≃[ monoid-iso ] N) ≃ (M ≡ N)
MonoidPath = SIP monoid-is-SNS

-- Added for its use in groups
-- If there exists a inverse of an element it is unique

inv-lemma : (M : Monoid {ℓ})
          → (x y z : ⟨ M ⟩)
          → y ·⟨ M ⟩ x ≡ id M
          → x ·⟨ M ⟩ z ≡ id M
          → y ≡ z
inv-lemma M x y z left-inverse right-inverse =
  y                     ≡⟨ sym (monoid-rid M y) ⟩
  y ·⟨ M ⟩ id M         ≡⟨ cong (λ - → y ·⟨ M ⟩ -) (sym right-inverse) ⟩
  y ·⟨ M ⟩ (x ·⟨ M ⟩ z) ≡⟨ monoid-assoc M y x z ⟩
  (y ·⟨ M ⟩ x) ·⟨ M ⟩ z ≡⟨ cong (λ - → - ·⟨ M ⟩ z) left-inverse ⟩
  id M ·⟨ M ⟩ z         ≡⟨ monoid-lid M z ⟩
  z ∎

-- Monoid ·syntax

module monoid-·syntax (M : Monoid {ℓ}) where

  infixr 18 _·_

  _·_ : ⟨ M ⟩ → ⟨ M ⟩ → ⟨ M ⟩
  _·_ = monoid-operation M

  ₁ : ⟨ M ⟩
  ₁ = monoid-id M