open import Agda.Builtin.Nat

data Sing : Nat → Set where
  i : (k : Nat) → Sing k

toSing : (n : Nat) → Sing n
toSing n = i n

fun : (n : Nat) → Nat
fun n with toSing n
fun .n       | i n with toSing n
fun .(n + n) | i .n | i n = {!!}


------------------------------------------------------------------------------
-- Distributive laws on a binary operation: Lemma 6
------------------------------------------------------------------------------

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

module DistributiveLaws.Lemma6-ATP where

open import DistributiveLaws.Base

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

postulate
  lemma₆ : ∀ u x y z →
           (((x · y) · (z · u)) · ((x · y) · (z · u))) ≡ (x · y) · (z · u)
{-# ATP prove lemma₆ #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- A pointwise lifting of a relation to incorporate an additional point.
------------------------------------------------------------------------

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

-- This module is designed to be used with
-- Relation.Nullary.Construct.Add.Point

open import Relation.Binary

module Relation.Binary.Construct.Add.Point.Equality
  {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) where

open import Level using (_⊔_)
open import Function
import Relation.Binary.PropositionalEquality as P
open import Relation.Nullary
open import Relation.Nullary.Construct.Add.Point
import Relation.Nullary.Decidable as Dec

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

data _≈∙_ : Rel (Pointed A) (a ⊔ ℓ) where
  ∙≈∙ :                     ∙     ≈∙ ∙
  [_] : {k l : A} → k ≈ l → [ k ] ≈∙ [ l ]

------------------------------------------------------------------------
-- Relational properties

[≈]-injective : ∀ {k l} → [ k ] ≈∙ [ l ] → k ≈ l
[≈]-injective [ k≈l ] = k≈l

≈∙-refl : Reflexive _≈_ → Reflexive _≈∙_
≈∙-refl ≈-refl {∙}     = ∙≈∙
≈∙-refl ≈-refl {[ k ]} = [ ≈-refl ]

≈∙-sym : Symmetric _≈_ → Symmetric _≈∙_
≈∙-sym ≈-sym ∙≈∙     = ∙≈∙
≈∙-sym ≈-sym [ x≈y ] = [ ≈-sym x≈y ]

≈∙-trans : Transitive _≈_ → Transitive _≈∙_
≈∙-trans ≈-trans ∙≈∙     ∙≈z     = ∙≈z
≈∙-trans ≈-trans [ x≈y ] [ y≈z ] = [ ≈-trans x≈y y≈z ]

≈∙-dec : Decidable _≈_ → Decidable _≈∙_
≈∙-dec _≟_ ∙     ∙     = yes ∙≈∙
≈∙-dec _≟_ ∙     [ l ] = no (λ ())
≈∙-dec _≟_ [ k ] ∙     = no (λ ())
≈∙-dec _≟_ [ k ] [ l ] = Dec.map′ [_] [≈]-injective (k ≟ l)

≈∙-irrelevant : Irrelevant _≈_ → Irrelevant _≈∙_
≈∙-irrelevant ≈-irr ∙≈∙   ∙≈∙   = P.refl
≈∙-irrelevant ≈-irr [ p ] [ q ] = P.cong _ (≈-irr p q)

≈∙-substitutive : ∀ {ℓ} → Substitutive _≈_ ℓ → Substitutive _≈∙_ ℓ
≈∙-substitutive ≈-subst P ∙≈∙   = id
≈∙-substitutive ≈-subst P [ p ] = ≈-subst (P ∘′ [_]) p

------------------------------------------------------------------------
-- Structures

≈∙-isEquivalence : IsEquivalence _≈_ → IsEquivalence _≈∙_
≈∙-isEquivalence ≈-isEquivalence = record
  { refl  = ≈∙-refl refl
  ; sym   = ≈∙-sym sym
  ; trans = ≈∙-trans trans
  } where open IsEquivalence ≈-isEquivalence

≈∙-isDecEquivalence : IsDecEquivalence _≈_ → IsDecEquivalence _≈∙_
≈∙-isDecEquivalence ≈-isDecEquivalence = record
  { isEquivalence = ≈∙-isEquivalence isEquivalence
  ; _≟_           = ≈∙-dec _≟_
  } where open IsDecEquivalence ≈-isDecEquivalence


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

module Data.Sum where

open import Level
open import Cubical.Data.Sum using (_⊎_; inl; inr) public
open import Data.Bool using (Bool; true; false)
open import Function using (const)

either : ∀ {ℓ} {C : A ⊎ B → Type ℓ} →  ((a : A) → C (inl a)) → ((b : B) → C (inr b))
        → (x : A ⊎ B) → C x
either f _ (inl x) = f x
either _ g (inr y) = g y

⟦l_,r_⟧ = either

either′ : (A → C) → (B → C) → (A ⊎ B) → C
either′ = either

is-l : A ⊎ B → Bool
is-l = either′ (const true) (const false)

map-⊎ : ∀ {a₁ a₂ b₁ b₂} {A₁ : Type a₁} {A₂ : Type a₂} {B₁ : Type b₁} {B₂ : Type b₂} →
      (A₁ → A₂) →
      (B₁ → B₂) →
      (A₁ ⊎ B₁) →
      (A₂ ⊎ B₂)
map-⊎ f g (inl x) = inl (f x)
map-⊎ f g (inr x) = inr (g x)

mapˡ : (A → B) → A ⊎ C → B ⊎ C
mapˡ f (inl x) = inl (f x)
mapˡ f (inr x) = inr x

mapʳ : (A → B) → C ⊎ A → C ⊎ B
mapʳ f (inl x) = inl x
mapʳ f (inr x) = inr (f x)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.ListedFiniteSet.Base where

open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Empty as ⊥
open import Cubical.Data.Sum as ⊎ using (_⊎_; inl; inr)

open import Cubical.Functions.Logic

private
  variable
    ℓ : Level
    A B : Type ℓ

infixr 20 _∷_
-- infix 30 _∈_
infixr 5 _++_

data LFSet (A : Type ℓ) : Type ℓ where
  []    : LFSet A
  _∷_   : (x : A) → (xs : LFSet A) → LFSet A
  dup   : ∀ x xs   → x ∷ x ∷ xs ≡ x ∷ xs
  comm  : ∀ x y xs → x ∷ y ∷ xs ≡ y ∷ x ∷ xs
  trunc : isSet (LFSet A)

-- Membership.
--
-- Doing some proofs with equational reasoning adds an extra "_∙ refl"
-- at the end.
-- We might want to avoid it, or come up with a more clever equational reasoning.
_∈_ : {A : Type ℓ} → A → LFSet A → hProp ℓ
z ∈ []                  = Lift ⊥.⊥ , isOfHLevelLift 1 isProp⊥
z ∈ (y ∷ xs)            = (z ≡ₚ y) ⊔ (z ∈ xs)
z ∈ dup x xs i          = proof i
  where
    -- proof : z ∈ (x ∷ x ∷ xs) ≡ z ∈ (x ∷ xs)
    proof = z ≡ₚ x  ⊔ (z ≡ₚ x ⊔ z ∈ xs) ≡⟨ ⊔-assoc (z ≡ₚ x) (z ≡ₚ x) (z ∈ xs) ⟩
            (z ≡ₚ x ⊔ z ≡ₚ x) ⊔ z ∈ xs  ≡⟨ cong (_⊔ (z ∈ xs)) (⊔-idem (z ≡ₚ x)) ⟩
            z ≡ₚ x            ⊔ z ∈ xs  ∎
z ∈ comm x y xs i       = proof i
  where
    -- proof : z ∈ (x ∷ y ∷ xs) ≡ z ∈ (y ∷ x ∷ xs)
    proof = z ≡ₚ x  ⊔ (z ≡ₚ y ⊔ z ∈ xs) ≡⟨ ⊔-assoc (z ≡ₚ x) (z ≡ₚ y) (z ∈ xs) ⟩
            (z ≡ₚ x ⊔ z ≡ₚ y) ⊔ z ∈ xs  ≡⟨ cong (_⊔ (z ∈ xs)) (⊔-comm (z ≡ₚ x) (z ≡ₚ y)) ⟩
            (z ≡ₚ y ⊔ z ≡ₚ x) ⊔ z ∈ xs  ≡⟨ sym (⊔-assoc (z ≡ₚ y) (z ≡ₚ x) (z ∈ xs)) ⟩
            z ≡ₚ y  ⊔ (z ≡ₚ x ⊔ z ∈ xs) ∎
x ∈ trunc xs ys p q i j = isSetHProp (x ∈ xs) (x ∈ ys) (cong (x ∈_) p) (cong (x ∈_) q) i j

module Elim {ℓ}
  {B : LFSet A → Type ℓ}
  ([]* : B [])
  (_∷*_ : (x : A) {xs : LFSet A} → B xs → B (x ∷ xs))
  (comm* : (x y : A) {xs : LFSet A} (b : B xs)
    → PathP (λ i → B (comm x y xs i)) (x ∷* (y ∷* b)) (y ∷* (x ∷* b)))
  (dup* : (x : A) {xs : LFSet A} (b : B xs)
    → PathP (λ i → B (dup x xs i)) (x ∷* (x ∷* b)) (x ∷* b))
  (trunc* : (xs : LFSet A) → isSet (B xs)) where

  f : ∀ x → B x
  f [] = []*
  f (x ∷ xs) = x ∷* f xs
  f (dup x xs i) = dup* x (f xs) i
  f (comm x y xs i) = comm* x y (f xs) i
  f (trunc x y p q i j) =
    isOfHLevel→isOfHLevelDep 2 trunc*
      (f x) (f y)
      (λ i → f (p i)) (λ i → f (q i))
      (trunc x y p q) i j

module Rec {ℓ} {B : Type ℓ}
  ([]* : B)
  (_∷*_ : (x : A) → B → B)
  (comm* : (x y : A) (xs : B) → (x ∷* (y ∷* xs)) ≡ (y ∷* (x ∷* xs)))
  (dup* : (x : A) (b : B) → (x ∷* (x ∷* b)) ≡ (x ∷* b))
  (trunc* : isSet B) where

  f : LFSet A → B
  f =
    Elim.f
      []* (λ x xs → x ∷* xs)
      (λ x y b → comm* x y b) (λ x b → dup* x b)
      λ _ → trunc*

module PropElim {ℓ}
  {B : LFSet A → Type ℓ}
  ([]* : B []) (_∷*_ : (x : A) {xs : LFSet A} → B xs → B (x ∷ xs))
  (trunc* : (xs : LFSet A) → isProp (B xs)) where

  f : ∀ x → B x
  f =
    Elim.f
      []* _∷*_
      (λ _ _ _ → isOfHLevel→isOfHLevelDep 1 trunc* _ _ _)
      (λ _ _ → isOfHLevel→isOfHLevelDep 1 trunc* _ _ _)
      λ xs → isProp→isSet (trunc* xs)

_++_ : ∀ (xs ys : LFSet A) → LFSet A
[]                  ++ ys = ys
(x ∷ xs)            ++ ys = x ∷ (xs ++ ys)
dup x xs i          ++ ys = dup x (xs ++ ys) i
comm x y xs i       ++ ys = comm x y (xs ++ ys) i
trunc xs zs p q i j ++ ys =
  trunc (xs ++ ys) (zs ++ ys) (cong (_++ ys) p) (cong (_++ ys) q) i j

map : (A → B) → LFSet A → LFSet B
map f [] = []
map f (x ∷ xs) = f x ∷ map f xs
map f (dup x xs i) = dup (f x) (map f xs) i
map f (comm x y xs i) = comm (f x) (f y) (map f xs) i
map f (trunc xs ys p q i j) =
  trunc (map f xs) (map f ys) (cong (map f) p) (cong (map f) q) i j

disj-union : LFSet A → LFSet B → LFSet (A ⊎ B)
disj-union xs ys = map ⊎.inl xs ++ map ⊎.inr ys


module Structure.Operator where

import Lvl
open import Functional using (_$_)
open import Lang.Instance
open import Logic.Predicate
open import Logic
open import Structure.Setoid
open import Structure.Function.Names
open import Structure.Function
open import Structure.Relator.Properties
open import Syntax.Function
open import Syntax.Transitivity
open import Type

private variable ℓ ℓₒ ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₒ₄ ℓₗ ℓₗ₁ ℓₗ₂ ℓₗ₃ ℓₗ₄ : Lvl.Level
private variable A₁ A₂ A₃ B : Type{ℓ}

module _
  ⦃ equiv-A₁ : Equiv{ℓₗ₁}(A₁) ⦄
  ⦃ equiv-A₂ : Equiv{ℓₗ₂}(A₂) ⦄
  ⦃ equiv-B : Equiv{ℓₗ₃}(B) ⦄
  (_▫_ : A₁ → A₂ → B)
  where

  -- The operator `_▫_` "(behaves like)/is a function" in the context of `_≡_` from the Equiv instance.
  -- `congruence` is the defining property of a binary operation.
  record BinaryOperator : Type{Lvl.of(A₁) Lvl.⊔ Lvl.of(A₂) Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂ Lvl.⊔ ℓₗ₃} where
    constructor intro
    field congruence : Congruence₂(_▫_)

    instance
      left : ∀{x} → Function(_▫ x)
      left = intro(proof ↦ congruence proof (reflexivity(_≡_)))

    instance
      right : ∀{x} → Function(x ▫_)
      right = intro(proof ↦ congruence (reflexivity(_≡_)) proof)

    congruenceₗ : ∀{x₁ x₂}{y} → (x₁ ≡ x₂) → (x₁ ▫ y ≡ x₂ ▫ y)
    congruenceₗ = Function.congruence(left)

    congruenceᵣ : ∀{x}{y₁ y₂} → (y₁ ≡ y₂) → (x ▫ y₁ ≡ x ▫ y₂)
    congruenceᵣ = Function.congruence(right)

  [≡]-congruence2-left : ⦃ inst : BinaryOperator ⦄ → (x : _) → Function(_▫ x)
  [≡]-congruence2-left = x ↦ inst-fn(BinaryOperator.left) {x}

  [≡]-congruence2-right : ⦃ inst : BinaryOperator ⦄ → (x : _) → Function(x ▫_)
  [≡]-congruence2-right = x ↦ inst-fn(BinaryOperator.right) {x}

  congruence₂ = inst-fn BinaryOperator.congruence

  congruence₂ₗ : ⦃ inst : BinaryOperator ⦄ → (a : A₂) → ∀{x y : A₁} → (x ≡ y) → (x ▫ a ≡ y ▫ a)
  congruence₂ₗ _ = inst-fn BinaryOperator.congruenceₗ -- (congruence₁(_▫ a) ⦃ [≡]-congruence2-left ⦃ inst ⦄ a ⦄)

  congruence₂ᵣ : ⦃ inst : BinaryOperator ⦄ → (a : A₁) → ∀{x y : A₂} → (x ≡ y) → (a ▫ x ≡ a ▫ y)
  congruence₂ᵣ _ = inst-fn BinaryOperator.congruenceᵣ

  functions-to-binaryOperator : ⦃ l : ∀{y} → Function(_▫ y) ⦄ ⦃ r : ∀{x} → Function(x ▫_) ⦄ → BinaryOperator
  BinaryOperator.congruence functions-to-binaryOperator {x₁} {y₁} {x₂} {y₂} leq req =
    (x₁ ▫ x₂) 🝖[ _≡_ ]-[ congruence₁(_▫ x₂) leq ]
    (y₁ ▫ x₂) 🝖[ _≡_ ]-[ congruence₁(y₁ ▫_) req ]
    (y₁ ▫ y₂) 🝖-end

module _
  ⦃ equiv-A₁ : Equiv{ℓₗ₁}(A₁) ⦄
  ⦃ equiv-A₂ : Equiv{ℓₗ₂}(A₂) ⦄
  ⦃ equiv-A₃ : Equiv{ℓₗ₃}(A₃) ⦄
  ⦃ equiv-B : Equiv{ℓₗ₄}(B) ⦄
  (_▫_▫_ : A₁ → A₂ → A₃ → B)
  where

  record TrinaryOperator : Type{Lvl.of(A₁) Lvl.⊔ Lvl.of(A₂) Lvl.⊔ Lvl.of(A₃) Lvl.⊔ ℓₗ₁ Lvl.⊔ ℓₗ₂ Lvl.⊔ ℓₗ₃ Lvl.⊔ ℓₗ₄} where
    constructor intro
    field congruence : Congruence₃(_▫_▫_)

  congruence₃ = inst-fn TrinaryOperator.congruence


open import Prelude

module Implicits.Syntax.Context where

open import Implicits.Syntax.Type
open import Data.List.All
open import Data.Vec
open import Data.List

Ctx : ℕ → ℕ → Set
Ctx ν n = Vec (Type ν) n

ICtx : ℕ → Set
ICtx ν = List (Type ν)

-- wellformed implicit contexts
_⊢OK : ∀ {ν} → ICtx ν → Set
Δ ⊢OK = All (λ a → List.[] ⊢unamb a) Δ

Ktx : ℕ → ℕ → Set
Ktx ν n = Ctx ν n × ICtx ν

_∷Γ_ : ∀ {ν n} → Type ν → Ktx ν n → Ktx ν (suc n)
a ∷Γ (Γ , Δ) = (a ∷ Γ) , Δ

_∷Δ_ : ∀ {ν n} → Type ν → Ktx ν n → Ktx ν n
a ∷Δ (Γ , Δ) = Γ , a List.∷ Δ

_∷K_ : ∀ {ν n} → Type ν → Ktx ν n → Ktx ν (suc n)
a ∷K (Γ , Δ) = a ∷ Γ , a List.∷ Δ

nil : ∀ {ν} → Ktx ν 0
nil = [] , List.[]


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties satisfied by bounded meet semilattices
------------------------------------------------------------------------

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

open import Relation.Binary.Lattice

module Relation.Binary.Properties.BoundedMeetSemilattice
  {c ℓ₁ ℓ₂} (M : BoundedMeetSemilattice c ℓ₁ ℓ₂) where

open BoundedMeetSemilattice M

import Algebra.FunctionProperties as P; open P _≈_
open import Data.Product
open import Function using (_∘_; flip)
open import Relation.Binary
open import Relation.Binary.Properties.Poset poset
import Relation.Binary.Properties.BoundedJoinSemilattice as J

-- The dual construction is a bounded join semilattice.

dualIsBoundedJoinSemilattice : IsBoundedJoinSemilattice _≈_ (flip _≤_) _∧_ ⊤
dualIsBoundedJoinSemilattice = record
  { isJoinSemilattice = record
    { isPartialOrder  = invIsPartialOrder
    ; supremum        = infimum
    }
  ; minimum           = maximum
  }

dualBoundedJoinSemilattice : BoundedJoinSemilattice c ℓ₁ ℓ₂
dualBoundedJoinSemilattice = record
  { ⊥                        = ⊤
  ; isBoundedJoinSemilattice = dualIsBoundedJoinSemilattice
  }

open J dualBoundedJoinSemilattice
  hiding (dualIsBoundedMeetSemilattice; dualBoundedMeetSemilattice) public


------------------------------------------------------------------------
-- The Agda standard library
--
-- Properties of These
------------------------------------------------------------------------

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

module Data.These.Properties where

open import Data.These
open import Function using (_∘_)
open import Relation.Binary using (Decidable)
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary using (yes; no)

------------------------------------------------------------------------
-- Equality

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

  this-injective : ∀ {x y : A} → this {B = B} x ≡ this y → x ≡ y
  this-injective refl = refl

  that-injective : ∀ {a b : B} → that {A = A} a ≡ that b → a ≡ b
  that-injective refl = refl

  these-injectiveˡ : ∀ {x y : A} {a b : B} → these x a ≡ these y b → x ≡ y
  these-injectiveˡ refl = refl

  these-injectiveʳ : ∀ {x y : A} {a b : B} → these x a ≡ these y b → a ≡ b
  these-injectiveʳ refl = refl

  ≡-dec : Decidable _≡_ → Decidable _≡_ → Decidable {A = These A B} _≡_
  ≡-dec dec₁ dec₂ (this x)    (this y)    with dec₁ x y
  ... | yes refl = yes refl
  ... | no  x≢y  = no (x≢y ∘ this-injective)
  ≡-dec dec₁ dec₂ (this x)    (that y)    = no λ()
  ≡-dec dec₁ dec₂ (this x)    (these y b) = no λ()
  ≡-dec dec₁ dec₂ (that x)    (this y)    = no λ()
  ≡-dec dec₁ dec₂ (that x)    (that y)    with dec₂ x y
  ... | yes refl = yes refl
  ... | no  x≢y  = no (x≢y ∘ that-injective)
  ≡-dec dec₁ dec₂ (that x)    (these y b) = no λ()
  ≡-dec dec₁ dec₂ (these x a) (this y)    = no λ()
  ≡-dec dec₁ dec₂ (these x a) (that y)    = no λ()
  ≡-dec dec₁ dec₂ (these x a) (these y b) with dec₁ x y | dec₂ a b
  ... | yes refl | yes refl = yes refl
  ... | no  x≢y  | _        = no (x≢y ∘ these-injectiveˡ)
  ... | yes _    | no  a≢b  = no (a≢b ∘ these-injectiveʳ)


{-# OPTIONS --cubical #-}
module TranspComputing where

open import Agda.Builtin.Cubical.Path
open import Agda.Primitive.Cubical
open import Agda.Builtin.List

transpList : ∀ (φ : I) (A : Set) x xs → primTransp (λ _ → List A) φ (x ∷ xs) ≡ (primTransp (λ i → A) φ x ∷ primTransp (λ i → List A) φ xs)
transpList φ A x xs = \ _ → primTransp (λ _ → List A) φ (x ∷ xs)

data S¹ : Set where
  base : S¹
  loop : base ≡ base

-- This should be refl.
transpS¹ : ∀ (φ : I) (u0 : S¹) → primTransp (λ _ → S¹) φ u0 ≡ u0
transpS¹ φ u0 = \ _ →  u0


{-# OPTIONS --enable-prop #-}

data Squash {ℓ} (A : Set ℓ) : Prop ℓ where
  squash : A → Squash A

squash-elim : ∀ {ℓ₁ ℓ₂} (A : Set ℓ₁) (P : Prop ℓ₂)
            → (A → P) → Squash A → P
squash-elim A P f (squash x) = f x


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

postulate
  A : Set
  a : A

record Eq (a : A) : Set where
  constructor mkEq
  field
    v : A
    p : a ≡ v
open Eq

record S : Set1 where
  constructor mkS
  field
    u : A
    e : Eq u
  open Eq e public
open S

test : ∀ (b : A) → S
u (test b) = b
v (e (test b)) = a
p (e (test b)) = refl


{-# OPTIONS --type-in-type #-}
module Record where

open import Prelude

record Sigma (A : Set)(B : A -> Set) : Set
record Sigma A B where
  constructor pair
  field
    fst : A
    snd : B fst

open Sigma

data Unit : Set
data Unit where
  tt : Unit

Cat : Set
Cat =
  Sigma Set                                                  (\ Obj ->
  Sigma (Obj -> Obj -> Set)                                  (\ Hom ->
  Sigma ((X : _) -> Hom X X)                                 (\ id ->
  Sigma ((X Y Z : _) -> Hom Y Z -> Hom X Y -> Hom X Z)       (\ comp ->
  Sigma ((X Y : _)(f : Hom X Y) -> comp _ _ _ (id Y) f == f) (\ idl ->
  Sigma ((X Y : _)(f : Hom X Y) -> comp _ _ _ f (id X) == f) (\ idr ->
  Sigma ((W X Y Z : _)
         (f : Hom W X)(g : Hom X Y)(h : Hom Y Z) ->
           comp _ _ _ (comp _ _ _ h g) f ==
           comp _ _ _ h (comp _ _ _ g f))                    (\ assoc ->
  Unit)))))))

Obj : (C : Cat) -> Set
Obj C = fst C

Hom : (C : Cat) -> Obj C -> Obj C -> Set
Hom C = fst (snd C)

id : (C : Cat) -> (X : _) -> Hom C X X
id C = fst (snd (snd C))

comp : (C : Cat) -> (X Y Z : _) -> Hom C Y Z -> Hom C X Y -> Hom C X Z
comp C = fst (snd (snd (snd C)))

idl : (C : Cat) -> (X Y : _)(f : Hom C X Y) ->
      comp C _ _ _ (id C Y) f == f
idl C = fst (snd (snd (snd (snd C))))

idr : (C : Cat) -> (X Y : _)(f : Hom C X Y) ->
      comp C _ _ _ f (id C X) == f
idr C = fst (snd (snd (snd (snd (snd C)))))

assoc : (C : Cat) ->
        (W X Y Z : _) (f : Hom C W X)(g : Hom C X Y)(h : Hom C Y Z) ->
        comp C _ _ _ (comp C _ _ _ h g) f ==
        comp C _ _ _ h (comp C _ _ _ g f)
assoc C = fst (snd (snd (snd (snd (snd (snd C))))))


-- There was a problem with reordering telescopes.
module Issue234 where

postulate
  A : Set
  P : A → Set

data List : Set where
  _∷ : A → List

data _≅_ {x : A}(p : P x) : ∀ {y} → P y → Set where
  refl : p ≅ p

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

data Any (x : A) : Set where
  here : P x → Any x

it : ∀ {x : A} → Any x → A
it {x} (here _) = x

prf : ∀ {x : A}(p : Any x) → P (it p)
prf (here px) = px

foo : (x : A) (p : Any x) →
      (f : ∀ {y} → it p ≡ y → P y) →
      f refl ≅ prf p →
      Set₁
foo x (here ._) f refl = Set


open import Oscar.Prelude
open import Oscar.Class.Reflexivity
open import Oscar.Class.Transitivity
open import Oscar.Class.Transextensionality
open import Oscar.Class.Transassociativity

module Oscar.Class.IsPrecategory where

module _
  {𝔬} {𝔒 : Ø 𝔬}
  {𝔯} (_∼_ : 𝔒 → 𝔒 → Ø 𝔯)
  {ℓ} (_∼̇_ : ∀ {x y} → x ∼ y → x ∼ y → Ø ℓ) (let infix 4 _∼̇_ ; _∼̇_ = _∼̇_)
  (_↦_ : Transitivity.type _∼_)
  where
  record IsPrecategory : Ø 𝔬 ∙̂ 𝔯 ∙̂ ℓ where
    constructor ∁
    field
      ⦃ `𝓣ransextensionality ⦄ : Transextensionality.class _∼_ _∼̇_ _↦_
      ⦃ `𝓣ransassociativity ⦄ : Transassociativity.class _∼_ _∼̇_ _↦_


{-# OPTIONS --without-K #-}
module Util.HoTT.Univalence.Beta where

open import Util.HoTT.Equiv
open import Util.HoTT.Equiv.Induction
open import Util.HoTT.Univalence.Axiom
open import Util.Prelude
open import Util.Relation.Binary.PropositionalEquality using
  ( Σ-≡⁻ ; cast )

private
  variable
    α β γ : Level
    A B C : Set α

≃→≡-β : ≃→≡ (≃-refl {A = A}) ≡ refl
≃→≡-β = ≃→≡∘≡→≃ refl

cast-≃→≡ : ∀ (A≃B : A ≃ B) {x}
  → cast (≃→≡ A≃B) x ≡ A≃B .forth x
cast-≃→≡ A≃B {x}
  = J-≃ (λ A B A≃B → ∀ x → cast (≃→≡ A≃B) x ≡ A≃B .forth x)
      (λ A x → subst (λ p → cast p x ≡ x) (sym ≃→≡-β) refl) A≃B x

cast-≅→≡ : ∀ (A≅B : A ≅ B) {x}
  → cast (≅→≡ A≅B) x ≡ A≅B .forth x
cast-≅→≡ = cast-≃→≡ ∘ ≅→≃


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

module HLevels where

open import Path
open import Cubical.Foundations.Everything
  using (isProp
        ;isSet
        ;isContr
        ;isPropIsContr
        ;isProp→isSet
        ;isOfHLevel→isOfHLevelDep
        ;hProp
        ;isSetHProp
        ;isPropIsProp
        )
  public

open import Level
open import Data.Sigma

hSet : ∀ ℓ → Type (ℓsuc ℓ)
hSet ℓ = Σ (Type ℓ) isSet


open import Functional
open import Logic
open import Logic.Propositional
open import Type

module Relator.Ordering where

module From-[<][≡] {ℓ₁}{ℓ₂}{ℓ₃} {T : Type{ℓ₁}} (_<_ : T → T → Stmt{ℓ₂}) (_≡_ : T → T → Stmt{ℓ₃}) where
  -- Greater than
  _>_ : T → T → Stmt
  _>_ = swap(_<_)

  -- Lesser than or equals
  _≤_ : T → T → Stmt
  x ≤ y = (x < y) ∨ (x ≡ y)

  -- Greater than or equals
  _≥_ : T → T → Stmt
  x ≥ y = (x > y) ∨ (x ≡ y)

  -- In an open interval
  _<_<_ : T → T → T → Stmt
  x < y < z = (x < y) ∧ (y < z)

  -- In an closed interval
  _≤_≤_ : T → T → T → Stmt
  x ≤ y ≤ z = (x ≤ y) ∧ (y ≤ z)

  _≮_ : T → T → Stmt
  _≮_ = (¬_) ∘₂ (_<_)

  _≯_ : T → T → Stmt
  _≯_ = (¬_) ∘₂ (_>_)

  _≰_ : T → T → Stmt
  _≰_ = (¬_) ∘₂ (_≤_)

  _≱_ : T → T → Stmt
  _≱_ = (¬_) ∘₂ (_≥_)

module From-[≤] {ℓ₁}{ℓ₂} {T : Type{ℓ₁}} (_≤_ : T → T → Stmt{ℓ₂}) where
  -- Greater than or equals
  _≥_ : T → T → Stmt
  _≥_ = swap(_≤_)

  _≰_ : T → T → Stmt
  _≰_ = (¬_) ∘₂ (_≤_)

  _≱_ : T → T → Stmt
  _≱_ = swap(_≰_)

  -- Greater than
  _>_ : T → T → Stmt
  _>_ = _≰_

  -- Lesser than or equals
  _<_ : T → T → Stmt
  _<_ = swap(_>_)

  -- In an open interval
  _<_<_ : T → T → T → Stmt
  x < y < z = (x < y) ∧ (y < z)

  -- In an closed interval
  _≤_≤_ : T → T → T → Stmt
  x ≤ y ≤ z = (x ≤ y) ∧ (y ≤ z)

  _≮_ : T → T → Stmt
  _≮_ = (¬_) ∘₂ (_<_)

  _≯_ : T → T → Stmt
  _≯_ = (¬_) ∘₂ (_>_)

module From-[≤][<] {ℓ₁}{ℓ₂}{ℓ₃} {T : Type{ℓ₁}} (_≤_ : T → T → Stmt{ℓ₂}) (_<_ : T → T → Stmt{ℓ₃}) where
  -- Greater than
  _>_ : T → T → Stmt
  _>_ = swap(_<_)

  -- Greater than or equals
  _≥_ : T → T → Stmt
  _≥_ = swap(_≤_)

  -- In an open interval
  _<_<_ : T → T → T → Stmt
  x < y < z = (x < y) ∧ (y < z)

  -- In an closed interval
  _≤_≤_ : T → T → T → Stmt
  x ≤ y ≤ z = (x ≤ y) ∧ (y ≤ z)

  _≮_ : T → T → Stmt
  _≮_ = (¬_) ∘₂ (_<_)

  _≯_ : T → T → Stmt
  _≯_ = (¬_) ∘₂ (_>_)

  _≰_ : T → T → Stmt
  _≰_ = (¬_) ∘₂ (_≤_)

  _≱_ : T → T → Stmt
  _≱_ = (¬_) ∘₂ (_≥_)

module From-[≤][≢] {ℓ₁}{ℓ₂}{ℓ₃} {T : Type{ℓ₁}} (_≤_ : T → T → Stmt{ℓ₂}) (_≢_ : T → T → Stmt{ℓ₃}) where
  -- Lesser than or equals
  _<_ : T → T → Stmt
  x < y = (x ≤ y) ∧ (x ≢ y)

  -- Greater than
  _>_ : T → T → Stmt
  _>_ = swap(_<_)

  -- Greater than or equals
  _≥_ : T → T → Stmt
  _≥_ = swap(_≤_)

  -- In an open interval
  _<_<_ : T → T → T → Stmt
  x < y < z = (x < y) ∧ (y < z)

  -- In an closed interval
  _≤_≤_ : T → T → T → Stmt
  x ≤ y ≤ z = (x ≤ y) ∧ (y ≤ z)

  _≮_ : T → T → Stmt
  _≮_ = (¬_) ∘₂ (_<_)

  _≯_ : T → T → Stmt
  _≯_ = (¬_) ∘₂ (_>_)

  _≰_ : T → T → Stmt
  _≰_ = (¬_) ∘₂ (_≤_)

  _≱_ : T → T → Stmt
  _≱_ = (¬_) ∘₂ (_≥_)


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

open import Sets.EquivalenceRelations
open import Functions.Definition
open import Agda.Primitive using (Level; lzero; lsuc; _⊔_; Setω)
open import Setoids.Setoids
open import Groups.Definition
open import LogicalFormulae
open import Orders.WellFounded.Definition
open import Numbers.Naturals.Semiring
open import Groups.Lemmas

module Groups.FreeProduct.Definition {i : _} {I : Set i} (decidableIndex : (x y : I) → ((x ≡ y) || ((x ≡ y) → False))) {a b : _} {A : I → Set a} {S : (i : I) → Setoid {a} {b} (A i)} {_+_ : (i : I) → (A i) → (A i) → A i} (decidableGroups : (i : I) → (x y : A i) → ((Setoid._∼_ (S i) x y)) || ((Setoid._∼_ (S i) x y) → False)) (G : (i : I) → Group (S i) (_+_ i)) where

data ReducedSequenceBeginningWith : I → Set (a ⊔ b ⊔ i) where
  ofEmpty : (i : I) → (g : A i) → .(nonZero : (Setoid._∼_ (S i) g (Group.0G (G i))) → False) → ReducedSequenceBeginningWith i
  prependLetter : (i : I) → (g : A i) → .(nonZero : Setoid._∼_ (S i) g (Group.0G (G i)) → False) → {j : I} → ReducedSequenceBeginningWith j → ((i ≡ j) → False) → ReducedSequenceBeginningWith i

data ReducedSequence : Set (a ⊔ b ⊔ i) where
  empty : ReducedSequence
  nonempty : (i : I) → ReducedSequenceBeginningWith i → ReducedSequence

injection : {i : I} (x : A i) .(nonzero : (Setoid._∼_ (S i) x (Group.0G (G i))) → False) → ReducedSequence
injection {i} x nonzero = nonempty i (ofEmpty i x nonzero)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Maybes where one of the elements satisfies a given property
------------------------------------------------------------------------

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

module Data.Maybe.Relation.Unary.Any where

open import Data.Maybe.Base using (Maybe; just; nothing)
open import Data.Product as Prod using (∃; _,_; -,_)
open import Function using (id)
open import Function.Equivalence using (_⇔_; equivalence)
open import Level
open import Relation.Binary.PropositionalEquality as P using (_≡_; cong)
open import Relation.Unary
open import Relation.Nullary
import Relation.Nullary.Decidable as Dec

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

data Any {a p} {A : Set a} (P : Pred A p) : Pred (Maybe A) (a ⊔ p) where
  just : ∀ {x} → P x → Any P (just x)

------------------------------------------------------------------------
-- Basic operations

module _ {a p} {A : Set a} {P : Pred A p} where

  drop-just : ∀ {x} → Any P (just x) → P x
  drop-just (just px) = px

  just-equivalence : ∀ {x} → P x ⇔ Any P (just x)
  just-equivalence = equivalence just drop-just

  map : ∀ {q} {Q : Pred A q} → P ⊆ Q → Any P ⊆ Any Q
  map f (just px) = just (f px)

  satisfied : ∀ {x} → Any P x → ∃ P
  satisfied (just p) = -, p

------------------------------------------------------------------------
-- (un/)zip(/With)

module _ {a p q r} {A : Set a} {P : Pred A p} {Q : Pred A q} {R : Pred A r} where

  zipWith : P ∩ Q ⊆ R → Any P ∩ Any Q ⊆ Any R
  zipWith f (just px , just qx) = just (f (px , qx))

  unzipWith : P ⊆ Q ∩ R → Any P ⊆ Any Q ∩ Any R
  unzipWith f (just px) = Prod.map just just (f px)

module _ {a p q} {A : Set a} {P : Pred A p} {Q : Pred A q} where

  zip : Any P ∩ Any Q ⊆ Any (P ∩ Q)
  zip = zipWith id

  unzip : Any (P ∩ Q) ⊆ Any P ∩ Any Q
  unzip = unzipWith id

------------------------------------------------------------------------
-- Seeing Any as a predicate transformer

module _ {a p} {A : Set a} {P : Pred A p} where

  dec : Decidable P → Decidable (Any P)
  dec P-dec nothing  = no λ ()
  dec P-dec (just x) = Dec.map just-equivalence (P-dec x)

  irrelevant : Irrelevant P → Irrelevant (Any P)
  irrelevant P-irrelevant (just p) (just q) = cong just (P-irrelevant p q)

  satisfiable : Satisfiable P → Satisfiable (Any P)
  satisfiable P-satisfiable = Prod.map just just P-satisfiable


module Haskell.RangedSetsProp.BoundariesProperties where

open import Haskell.RangedSetsProp.library

open import Agda.Builtin.Equality
open import Agda.Builtin.Bool

open import Haskell.Prim
open import Haskell.Prim.Ord
open import Haskell.Prim.Bool
open import Haskell.Prim.Maybe
open import Haskell.Prim.Enum
open import Haskell.Prim.Eq
open import Haskell.Prim.List
open import Haskell.Prim.Integer
open import Haskell.Prim.Double

open import Haskell.RangedSets.Boundaries

prop_no_boundary_smaller : {{ o : Ord a }} -> {{ dio : DiscreteOrdered a}} -> (r1 : Boundary a) -> (r1 < BoundaryBelowAll) ≡ false
prop_no_boundary_smaller BoundaryBelowAll = refl
prop_no_boundary_smaller BoundaryAboveAll = refl
prop_no_boundary_smaller (BoundaryAbove x) = refl
prop_no_boundary_smaller (BoundaryBelow x) = refl

prop_no_boundary_greater : {{ o : Ord a }} -> {{ dio : DiscreteOrdered a}} -> (r1 : Boundary a) -> (r1 > BoundaryAboveAll) ≡ false
prop_no_boundary_greater BoundaryBelowAll = refl
prop_no_boundary_greater BoundaryAboveAll = refl
prop_no_boundary_greater (BoundaryAbove x) = refl
prop_no_boundary_greater (BoundaryBelow x) = refl

BoundaryBelowAllSmaller :  ⦃ o : Ord a ⦄ → ⦃ dio : DiscreteOrdered a ⦄ → (b : Boundary a)
      → (BoundaryBelowAll <= b) ≡ true
BoundaryBelowAllSmaller BoundaryBelowAll = refl
BoundaryBelowAllSmaller BoundaryAboveAll = refl
BoundaryBelowAllSmaller (BoundaryBelow _) = refl
BoundaryBelowAllSmaller (BoundaryAbove _)  = refl

postulate
  prop_max_sym : {{ o : Ord a }} -> {{ dio : DiscreteOrdered a}} -> (r1 : Boundary a) -> (r2 : Boundary a) -> max r1 r2 ≡ max r2 r1
  prop_min_sym : {{ o : Ord a }} -> {{ dio : DiscreteOrdered a}} -> (r1 : Boundary a) -> (r2 : Boundary a) -> min r1 r2 ≡ min r2 r1

-- prop_max_sym : {{ o : Ord a }} -> {{ dio : DiscreteOrdered a}} -> (r1 : Boundary a) -> (r2 : Boundary a) -> max r1 r2 ≡ max r2 r1
-- prop_max_sym {{o}} {{dio}} r1 r2 =
--     begin
--         max r1 r2
--     =⟨⟩
--         if (compare x y == GT) then x else y
--     =⟨⟩
--         if (compare y x == GT) then y else x
--     =⟨⟩
--         max r2 r1
--     end


module Issue152 where

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

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

f : ℕ → ℕ
f 0 with zero
f 0 | n = n
f 1 with zero
f 1 | n = n
f n = n

g : ℕ → ℕ
g 0    with zero
g zero | n = n
g 1    with zero
g (suc zero) | n = n
g n = n

h : ℕ → ℕ
h zero with zero
h 0    | n = n
h (suc zero) with zero
h 1 | n = n
h n = n


module Esterel.Variable.Shared where

open import Data.Nat
  using (ℕ) renaming (_≟_ to _≟ℕ_)
open import Function
  using (_∘_)
open import Relation.Nullary
  using (Dec ; yes ; no ; ¬_)
open import Relation.Binary
  using (Decidable)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; cong ; trans ; sym)

data SharedVar : Set where
  _ₛₕ : ℕ → SharedVar

unwrap : SharedVar → ℕ
unwrap (n ₛₕ) = n

unwrap-inverse : ∀ {s} → (unwrap s) ₛₕ ≡ s
unwrap-inverse {_ ₛₕ} = refl

unwrap-injective : ∀ {s t} → unwrap s ≡ unwrap t → s ≡ t
unwrap-injective s'≡t' = trans (sym unwrap-inverse) (trans (cong _ₛₕ s'≡t') unwrap-inverse)

-- for backward compatibility
unwrap-neq : ∀{k1 : SharedVar} → ∀{k2 : SharedVar} → ¬ k1 ≡ k2 → ¬ (unwrap k1) ≡ (unwrap k2)
unwrap-neq = (_∘ unwrap-injective)

wrap : ℕ → SharedVar
wrap = _ₛₕ

bijective : ∀{x} → unwrap (wrap x) ≡ x
bijective = refl

_≟_ : Decidable {A = SharedVar} _≡_
(s ₛₕ) ≟ (t ₛₕ) with s ≟ℕ t
... | yes p = yes (cong _ₛₕ p)
... | no ¬p = no (¬p ∘ cong unwrap)

data Status : Set where
  ready : Status
  new  : Status
  old : Status

_≟ₛₜ_ : Decidable {A = Status} _≡_
ready ≟ₛₜ ready = yes refl
ready ≟ₛₜ new   = no λ()
ready ≟ₛₜ old   = no λ()
new   ≟ₛₜ ready = no λ()
new   ≟ₛₜ new   = yes refl
new   ≟ₛₜ old   = no λ()
old   ≟ₛₜ ready = no λ()
old   ≟ₛₜ new   = no λ()
old   ≟ₛₜ old   = yes refl


module Esterel.Variable.Signal where

open import Data.Nat
  using (ℕ) renaming (_≟_ to _≟ℕ_)
open import Function
  using (_∘_)
open import Relation.Nullary
  using (Dec ; yes ; no ; ¬_)
open import Relation.Binary
  using (Decidable)
open import Relation.Binary.PropositionalEquality
  using (_≡_ ; refl ; cong ; trans ; sym)

data Signal : Set where
  _ₛ : (S : ℕ) → Signal

unwrap : Signal → ℕ
unwrap (n ₛ) = n

unwrap-inverse : ∀ {s} → (unwrap s) ₛ ≡ s
unwrap-inverse {_ ₛ} = refl

unwrap-injective : ∀ {s t} → unwrap s ≡ unwrap t → s ≡ t
unwrap-injective s'≡t' = trans (sym unwrap-inverse) (trans (cong _ₛ s'≡t') unwrap-inverse)

wrap : ℕ → Signal
wrap = _ₛ

bijective : ∀{x} → unwrap (wrap x) ≡ x
bijective = refl

-- for backward compatibility
unwrap-neq : ∀{k1 : Signal} → ∀{k2 : Signal} → ¬ k1 ≡ k2 → ¬ (unwrap k1) ≡ (unwrap k2)
unwrap-neq = (_∘ unwrap-injective)

_≟_ : Decidable {A = Signal} _≡_
(s ₛ) ≟ (t ₛ) with s ≟ℕ t
... | yes p = yes (cong _ₛ p)
... | no ¬p = no (¬p ∘ cong unwrap)

data Status : Set where
  present : Status
  absent  : Status
  unknown : Status

_≟ₛₜ_ : Decidable {A = Status} _≡_
present ≟ₛₜ present = yes refl
present ≟ₛₜ absent  = no λ()
present ≟ₛₜ unknown = no λ()
absent  ≟ₛₜ present = no λ()
absent  ≟ₛₜ absent  = yes refl
absent  ≟ₛₜ unknown = no λ()
unknown ≟ₛₜ present = no λ()
unknown ≟ₛₜ absent  = no λ()
unknown ≟ₛₜ unknown = yes refl


------------------------------------------------------------------------
-- The Agda standard library
--
-- Some derivable properties
------------------------------------------------------------------------

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

open import Algebra.Bundles

module Algebra.Properties.Group {g₁ g₂} (G : Group g₁ g₂) where

open Group G
open import Algebra.Definitions _≈_
open import Relation.Binary.Reasoning.Setoid setoid
open import Function
open import Data.Product

ε⁻¹≈ε : ε ⁻¹ ≈ ε
ε⁻¹≈ε = begin
  ε ⁻¹      ≈⟨ sym $ identityʳ (ε ⁻¹) ⟩
  ε ⁻¹ ∙ ε  ≈⟨ inverseˡ ε ⟩
  ε         ∎

private

  left-helper : ∀ x y → x ≈ (x ∙ y) ∙ y ⁻¹
  left-helper x y = begin
    x              ≈⟨ sym (identityʳ x) ⟩
    x ∙ ε          ≈⟨ ∙-congˡ $ sym (inverseʳ y) ⟩
    x ∙ (y ∙ y ⁻¹) ≈⟨ sym (assoc x y (y ⁻¹)) ⟩
    (x ∙ y) ∙ y ⁻¹ ∎

  right-helper : ∀ x y → y ≈ x ⁻¹ ∙ (x ∙ y)
  right-helper x y = begin
    y              ≈⟨ sym (identityˡ y) ⟩
    ε          ∙ y ≈⟨ ∙-congʳ $ sym (inverseˡ x) ⟩
    (x ⁻¹ ∙ x) ∙ y ≈⟨ assoc (x ⁻¹) x y ⟩
    x ⁻¹ ∙ (x ∙ y) ∎

∙-cancelˡ : LeftCancellative _∙_
∙-cancelˡ x {y} {z} eq = begin
              y  ≈⟨ right-helper x y ⟩
  x ⁻¹ ∙ (x ∙ y) ≈⟨ ∙-congˡ eq ⟩
  x ⁻¹ ∙ (x ∙ z) ≈˘⟨ right-helper x z ⟩
              z  ∎

∙-cancelʳ : RightCancellative _∙_
∙-cancelʳ {x} y z eq = begin
  y            ≈⟨ left-helper y x ⟩
  y ∙ x ∙ x ⁻¹ ≈⟨ ∙-congʳ eq ⟩
  z ∙ x ∙ x ⁻¹ ≈˘⟨ left-helper z x ⟩
  z            ∎

∙-cancel : Cancellative _∙_
∙-cancel = ∙-cancelˡ , ∙-cancelʳ

⁻¹-involutive : ∀ x → x ⁻¹ ⁻¹ ≈ x
⁻¹-involutive x = begin
  x ⁻¹ ⁻¹              ≈˘⟨ identityʳ _ ⟩
  x ⁻¹ ⁻¹ ∙ ε          ≈˘⟨ ∙-congˡ $ inverseˡ _ ⟩
  x ⁻¹ ⁻¹ ∙ (x ⁻¹ ∙ x) ≈˘⟨ right-helper (x ⁻¹) x ⟩
  x                    ∎

⁻¹-injective : ∀ {x y} → x ⁻¹ ≈ y ⁻¹ → x ≈ y
⁻¹-injective {x} {y} eq = ∙-cancelʳ x y ( begin
  x ∙ x ⁻¹ ≈⟨ inverseʳ x ⟩
  ε        ≈˘⟨ inverseʳ y ⟩
  y ∙ y ⁻¹ ≈˘⟨ ∙-congˡ eq ⟩
  y ∙ x ⁻¹ ∎ )

⁻¹-anti-homo-∙ : ∀ x y → (x ∙ y) ⁻¹ ≈ y ⁻¹ ∙ x ⁻¹
⁻¹-anti-homo-∙ x y = ∙-cancelˡ _ ( begin
  x ∙ y ∙ (x ∙ y) ⁻¹    ≈⟨ inverseʳ _ ⟩
  ε                     ≈˘⟨ inverseʳ _ ⟩
  x ∙ x ⁻¹              ≈⟨ ∙-congʳ (left-helper x y) ⟩
  (x ∙ y) ∙ y ⁻¹ ∙ x ⁻¹ ≈⟨ assoc (x ∙ y) (y ⁻¹) (x ⁻¹) ⟩
  x ∙ y ∙ (y ⁻¹ ∙ x ⁻¹) ∎ )

identityˡ-unique : ∀ x y → x ∙ y ≈ y → x ≈ ε
identityˡ-unique x y eq = begin
  x              ≈⟨ left-helper x y ⟩
  (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩
       y  ∙ y ⁻¹ ≈⟨ inverseʳ y ⟩
  ε              ∎

identityʳ-unique : ∀ x y → x ∙ y ≈ x → y ≈ ε
identityʳ-unique x y eq = begin
  y              ≈⟨ right-helper x y ⟩
  x ⁻¹ ∙ (x ∙ y) ≈⟨ refl ⟨ ∙-cong ⟩ eq ⟩
  x ⁻¹ ∙  x      ≈⟨ inverseˡ x ⟩
  ε              ∎

identity-unique : ∀ {x} → Identity x _∙_ → x ≈ ε
identity-unique {x} id = identityˡ-unique x x (proj₂ id x)

inverseˡ-unique : ∀ x y → x ∙ y ≈ ε → x ≈ y ⁻¹
inverseˡ-unique x y eq = begin
  x              ≈⟨ left-helper x y ⟩
  (x ∙ y) ∙ y ⁻¹ ≈⟨ ∙-congʳ eq ⟩
       ε  ∙ y ⁻¹ ≈⟨ identityˡ (y ⁻¹) ⟩
            y ⁻¹ ∎

inverseʳ-unique : ∀ x y → x ∙ y ≈ ε → y ≈ x ⁻¹
inverseʳ-unique x y eq = begin
  y       ≈⟨ sym (⁻¹-involutive y) ⟩
  y ⁻¹ ⁻¹ ≈⟨ ⁻¹-cong (sym (inverseˡ-unique x y eq)) ⟩
  x ⁻¹    ∎

------------------------------------------------------------------------
-- DEPRECATED NAMES
------------------------------------------------------------------------
-- Please use the new names as continuing support for the old names is
-- not guaranteed.

-- Version 1.1

left-identity-unique = identityˡ-unique
{-# WARNING_ON_USAGE left-identity-unique
"Warning: left-identity-unique was deprecated in v1.1.
Please use identityˡ-unique instead."
#-}
right-identity-unique = identityʳ-unique
{-# WARNING_ON_USAGE right-identity-unique
"Warning: right-identity-unique was deprecated in v1.1.
Please use identityʳ-unique instead."
#-}
left-inverse-unique = inverseˡ-unique
{-# WARNING_ON_USAGE left-inverse-unique
"Warning: left-inverse-unique was deprecated in v1.1.
Please use inverseˡ-unique instead."
#-}
right-inverse-unique = inverseʳ-unique
{-# WARNING_ON_USAGE right-inverse-unique
"Warning: right-inverse-unique was deprecated in v1.1.
Please use inverseʳ-unique instead."
#-}


{-# OPTIONS --without-K --safe #-}
module Categories.Category.Instance.Groupoids where

-- The category of groupoids.
--
-- This category should maybe be called "Ho(Groupoids)" or "Ho(Gpd)"
-- instead.  The "homsets" are not the "usual" ones consisting of
-- functors, but consist instead of equivalence classes of functors up
-- to natural isomorphism.  This is because homsets here are really
-- hom-setoids and we pick natural isomorphism as the equivalence
-- relation for these setoids.
--
-- See https://ncatlab.org/nlab/show/Ho%28Cat%29

open import Level
open import Categories.Category
open import Categories.Category.Groupoid
open import Categories.Functor as Fctr using (Functor; _∘F_)
open import Categories.Functor.Properties using ([_]-resp-Iso)
import Categories.Morphism.IsoEquiv as IsoEquiv
open import Categories.NaturalTransformation.NaturalIsomorphism
  using (NaturalIsomorphism; associator; unitorˡ; unitorʳ; unitor²; isEquivalence; _ⓘₕ_; sym)
private
  variable
    o ℓ e : Level

open Groupoid using (category)

-- The category of groupoids.

Groupoids : ∀ o ℓ e → Category (suc (o ⊔ ℓ ⊔  e)) (o ⊔ ℓ ⊔ e) (o ⊔ ℓ ⊔ e)
Groupoids o ℓ e = record
  { Obj       = Groupoid o ℓ e
  ; _⇒_       = λ G H → Functor (category G) (category H)
  ; _≈_       = NaturalIsomorphism
  ; id        = Fctr.id
  ; _∘_       = _∘F_
  ; assoc     = λ {_ _ _ _ F G H} → associator F G H
  ; sym-assoc = λ {_ _ _ _ F G H} → sym (associator F G H)
  ; identityˡ = unitorˡ
  ; identityʳ = unitorʳ
  ; identity² = unitor²
  ; equiv     = isEquivalence
  ; ∘-resp-≈  = _ⓘₕ_
  }

module _ {o ℓ e o′ ℓ′ e′} {G : Groupoid o ℓ e} {H : Groupoid o′ ℓ′ e′}
         (F : Functor (category G) (category H))
         where

  private
    module G = Groupoid G
    module H = Groupoid H
  open Functor F
  open IsoEquiv (category H) using (to-unique)

  -- Functors preserve inverses

  F-resp-⁻¹ : ∀ {A B} (f : A G.⇒ B) → F₁ (f G.⁻¹) H.≈ (F₁ f) H.⁻¹
  F-resp-⁻¹ f = to-unique ([ F ]-resp-Iso G.iso) H.iso H.Equiv.refl


module Extensions.ListFirstFunctional where

open import Prelude hiding (_⊔_)
open import Level

private
    lemma : ∀ {a b} {A : Set a} {P : A → Set b} (decP : ∀ a → (Dec $ P a)) v {x y} →
            any decP (x List.∷ v) ≡ yes (there {x = x} y) → ¬ P x
    lemma decP v {x} {y} eq p with decP x
    lemma decP v () p         | yes _
    lemma decP v eq p         | no ¬p = ¬p p

-- first is functionally defined as the element matched by 'any'
First : ∀ {a b} {A : Set a} {P : A → Set b} (decP : ∀ a → (Dec $ P a)) → List A → Set (a ⊔ b)
First f v = ∃ λ m → any f v ≡ yes m

private
    There : ∀ {a b} {A : Set a} {P : A → Set b} {f v} → (f : First {P = P} f v) → Set
    There (here px , _) = ⊥
    There (there _ , _) = ⊤

    head-first : ∀ {a b} {A : Set a} {P : A → Set b} {f v} → First {P = P} f v → A
    head-first (here {x} _ , _) = x
    head-first (there {x} _ , _) = x

-- we can recover the negative evidence even though Any does not "save it" for there-instances
there⟶¬x' : ∀ {a b} {A : Set a} {P : A → Set b} {decP v} →
            (f : First {P = P} decP v) → {x : There f} → ¬ P (head-first f)
there⟶¬x' (here px , proj₂) {x = ()}
there⟶¬x' {P = P} {decP = decP} (there {x = x'} {xs = xs} tail , proj₂) px with lemma decP xs
there⟶¬x' {P = P} {decP = decP} (there {x = x'} {xs = xs} tail , proj₂) px | ¬px = ¬px proj₂ px


open import Level using (0ℓ)
open import Function using (_$_; _∘_)

open import Relation.Nullary using (yes; no)
open import Relation.Nullary.Decidable using (False; True)
open import Relation.Nullary.Negation using (contradiction)
open import Relation.Binary
  using (Reflexive; Transitive; Trans; Antisymmetric; Asymmetric; Irreflexive; Decidable; Total; IsPreorder; IsPartialOrder; IsTotalOrder; TotalOrder; _Preserves₂_⟶_⟶_; Trichotomous; Tri; Irrelevant; Connex)
open Tri
open import Relation.Binary.PropositionalEquality
  using (_≡_; _≢_; refl; sym; trans; cong; resp₂; module ≡-Reasoning)
  renaming (isEquivalence to ≡-isEquivalence)
open import Relation.Binary.PropositionalEquality.WithK using (≡-erase)

open import Data.Bool using (T)
open import Data.Bool.Properties using (T?)
open import Data.Unit using (tt)

open import Data.List using (List)
open List
open import Data.Sum using (_⊎_)
open _⊎_

module AKS.Nat.Properties where

open import Data.Nat.Properties using (+-assoc; +-suc; +-comm; *-identityʳ; +-identityʳ; m+n≡0⇒m≡0; +-cancelʳ-≡; +-cancelˡ-≡; 1+n≢0; suc-injective) public
open import Data.Nat.Properties using (n∸n≡0; ∸-+-assoc) public
open import Data.Nat.Properties using (*-comm; *-1-commutativeMonoid) public

open import Polynomial.Simple.AlmostCommutativeRing using (AlmostCommutativeRing)
open import Polynomial.Simple.AlmostCommutativeRing.Instances using (module Nat)
open import Polynomial.Simple.Reflection using (solveOver)
open Nat.Reflection using (∀⟨_⟩)

open import AKS.Nat.Base using (ℕ; _+_; _*_; _∸_; lte; _≤_; _≥_; _≰_; _≱_; _<_; _≮_; _>_; _≯_; _<ᵇ_; _≟_; ℕ⁺; ℕ+; ⟅_⇓⟆; ⟅_⇑⟆; pred)
open ℕ
open import Algebra.Definitions {A = ℕ} _≡_ using (_DistributesOverˡ_)

≢⇒¬≟ : ∀ {n m} → n ≢ m → False (n ≟ m)
≢⇒¬≟ {n} {m} n≢m with n ≟ m
... | yes n≡m = contradiction n≡m n≢m
... | no _ = tt

¬≟⇒≢ : ∀ {n m} → False (n ≟ m) → n ≢ m
¬≟⇒≢ {n} {m} ¬n≟m n≡m with n ≟ m
... | no n≢m = contradiction n≡m n≢m

ℕ→ℕ⁺→ℕ : ∀ n {n≢0} → ⟅ ⟅ n ⇑⟆ {n≢0} ⇓⟆ ≡ n
ℕ→ℕ⁺→ℕ (suc n) {n≢0} = refl

⟅⇓⟆-injective : ∀ {n m} → pred ⟅ n ⇓⟆ ≡ pred ⟅ m ⇓⟆ → n ≡ m
⟅⇓⟆-injective {ℕ+ n} {ℕ+ m} refl = refl

n≢0∧m≢0⇒n*m≢0 : ∀ {n m} → n ≢ 0 → m ≢ 0 → n * m ≢ 0
n≢0∧m≢0⇒n*m≢0 {zero} {m} n≢0 m≢0 = contradiction refl n≢0
n≢0∧m≢0⇒n*m≢0 {suc n} {zero} n≢0 m≢0 = contradiction refl m≢0
n≢0∧m≢0⇒n*m≢0 {suc n} {suc m} n≢0 m≢0 ()

suc-injective-≡ : ∀ {n m} → suc n ≡ suc m → n ≡ m
suc-injective-≡ refl = refl

------------ _≤_ --------------

0≤n : ∀ {n} → 0 ≤ n
0≤n {n} = lte n refl

≤-refl : Reflexive _≤_
≤-refl {x} = lte 0 (≡-erase ∀⟨ x ∷ [] ⟩)

≤-reflexive : ∀ {n m} → n ≡ m → n ≤ m
≤-reflexive refl = ≤-refl

≤-trans : Transitive _≤_
≤-trans {x} (lte k₁ refl) (lte k₂ refl) = lte (k₁ + k₂) (≡-erase ∀⟨ x ∷ k₁ ∷ k₂ ∷ [] ⟩)

n+m≡n⇒m≡0 : ∀ {n m} → n + m ≡ n → m ≡ 0
n+m≡n⇒m≡0 {n} {m} n+m≡n = m≡0
  where
  open ≡-Reasoning
  m≡0 : m ≡ 0
  m≡0 = +-cancelˡ-≡ n $ begin
    n + m ≡⟨ n+m≡n ⟩
    n ≡⟨ sym (+-identityʳ n) ⟩
    n + 0 ∎

≤-antisym : Antisymmetric _≡_ _≤_
≤-antisym {x} {y} (lte k₁ x+k₁≡y) (lte k₂ y+k₂≡x) = ≡-erase (+-cancelʳ-≡ x y x+k₁≡y+k₁)
  where
  open ≡-Reasoning

  k₁+k₂≡0 : k₁ + k₂ ≡ 0
  k₁+k₂≡0 = n+m≡n⇒m≡0 $ begin
    x + (k₁ + k₂) ≡⟨ sym (+-assoc x k₁ k₂) ⟩
    (x + k₁) + k₂ ≡⟨ cong (λ t → t + k₂) x+k₁≡y ⟩
    y + k₂ ≡⟨ y+k₂≡x ⟩
    x ∎

  x+k₁≡y+k₁ : x + k₁ ≡ y + k₁
  x+k₁≡y+k₁ = begin
    x + k₁ ≡⟨ x+k₁≡y ⟩
    y      ≡⟨ sym (+-identityʳ y) ⟩
    y + 0  ≡⟨ cong (λ t → y + t) (sym (m+n≡0⇒m≡0 k₁ k₁+k₂≡0)) ⟩
    y + k₁ ∎

suc-mono-≤ : ∀ {n m} → n ≤ m → suc n ≤ suc m
suc-mono-≤ (lte k₁ refl) = lte k₁ refl

suc-injective-≤ : ∀ {n m} → suc n ≤ suc m → n ≤ m
suc-injective-≤ (lte k refl) = lte k refl

m≤m+n : ∀ {m n} → m ≤ m + n
m≤m+n {m} {n} = lte n refl

m≤n+m : ∀ {m n} → m ≤ n + m
m≤n+m {m} {n} = lte n (+-comm m n)

≤-erase : ∀ {n m} → n ≤ m → n ≤ m
≤-erase (lte k ≤-proof) = lte k (≡-erase ≤-proof)

≤-isPreorder : IsPreorder _≡_ _≤_
≤-isPreorder = record
 { isEquivalence = ≡-isEquivalence
 ; reflexive = ≤-reflexive
 ; trans = ≤-trans
 }

≤-isPartialOrder : IsPartialOrder _≡_ _≤_
≤-isPartialOrder = record
  { isPreorder = ≤-isPreorder
  ; antisym    = ≤-antisym
  }

------------ _<_ --------------

<-trans : Transitive _<_
<-trans {x} (lte k₁ refl) (lte k₂ refl) = lte (suc (k₁ + k₂)) (≡-erase ∀⟨ x ∷ k₁ ∷ k₂ ∷ [] ⟩)

<-≤-trans : Trans _<_ _≤_ _<_
<-≤-trans x<y y≤z = ≤-trans x<y y≤z

≤-<-trans : Trans _≤_ _<_ _<_
≤-<-trans {x} (lte k₁ refl) (lte k₂ refl) = lte (k₁ + k₂) (≡-erase ∀⟨ x ∷ k₁ ∷ k₂ ∷ [] ⟩)

n≮n : ∀ {n} → n ≮ n
n≮n {n} (lte k n+1+k≡n) rewrite sym (+-suc n k) = 1+n≢0 (n+m≡n⇒m≡0 n+1+k≡n)

<-irrefl : Irreflexive _≡_ _<_
<-irrefl refl x<x = n≮n x<x

<-asym : Asymmetric _<_
<-asym x<y y<x = n≮n (<-trans x<y y<x)

<⇒≯ : ∀ {n m} → n < m → n ≯ m
<⇒≯ n<m n>m = <-asym n<m n>m

n<1+n : ∀ {n} → n < 1 + n
n<1+n = ≤-refl

0<1+n : ∀ {n} → 0 < 1 + n
0<1+n {n} = lte n refl

n≮0 : ∀ {n} → n ≮ 0
n≮0 ()

suc-mono-< : ∀ {n m} → n < m → suc n < suc m
suc-mono-< (lte k₁ refl) = lte k₁ refl

+-mono-≤ : _+_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
+-mono-≤ {x} {_} {u} (lte k refl) (lte m refl) = lte (k + m) (≡-erase (solveOver (x ∷ u ∷ k ∷ m ∷ []) Nat.ring))

+-mono-< : _+_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
+-mono-< {x} {_} {u} (lte k refl) (lte m refl) = lte (suc (k + m)) (≡-erase (solveOver (x ∷ u ∷ k ∷ m ∷ []) Nat.ring))

private
  a+b∸a≡b+[a∸a] : ∀ a b → a + b ∸ a ≡ b + (a ∸ a)
  a+b∸a≡b+[a∸a] zero b = sym (+-identityʳ b)
  a+b∸a≡b+[a∸a] (suc a) b = a+b∸a≡b+[a∸a] a b

m+[n∸m]≡n : ∀ {m n} → m ≤ n → m + (n ∸ m) ≡ n
m+[n∸m]≡n {m} {n} (lte k refl) = begin
  m + (m + k ∸ m)   ≡⟨ cong (λ x → m + x) (a+b∸a≡b+[a∸a] m k) ⟩
  m + (k + (m ∸ m)) ≡⟨ cong (λ x → m + (k + x)) (n∸n≡0 m) ⟩
  m + (k + 0)       ≡⟨ cong (λ x → m + x) (+-identityʳ k) ⟩
  m + k ∎
  where
  open ≡-Reasoning

[n∸m]+m≡n : ∀ {m n} → m ≤ n → (n ∸ m) + m ≡ n
[n∸m]+m≡n {m} {n} rewrite +-comm (n ∸ m) m = m+[n∸m]≡n

m<n⇒n∸m≢0 : ∀ {m n} → m < n → n ∸ m ≢ 0
m<n⇒n∸m≢0 {zero} {n} m<n n∸m≡0 = <-irrefl (sym n∸m≡0) m<n
m<n⇒n∸m≢0 {suc m} {suc n} m<n n∸m≡0 = m<n⇒n∸m≢0 (suc-injective-≤ m<n) n∸m≡0

∸-mono-<ˡ : ∀ {x b t} → x ≤ b → b < t → b ∸ x < t ∸ x
∸-mono-<ˡ {x} (lte k₁ refl) (lte k₂ refl) = lte k₂ (≡-erase ≤-proof)
  where
  open ≡-Reasoning
  lemma₁ : ∀ a → 1 + (k₁ + a) + k₂ ≡ 1 + k₁ + k₂ + a
  lemma₁ a = ∀⟨ a ∷ k₁ ∷ k₂ ∷ [] ⟩
  lemma₂ : x + (1 + k₁ + k₂) ≡ 1 + (x + k₁ + k₂)
  lemma₂ = ∀⟨ x ∷ k₁ ∷ k₂ ∷ [] ⟩
  ≤-proof : suc (x + k₁ ∸ x) + k₂ ≡ suc (x + k₁) + k₂ ∸ x
  ≤-proof = begin
    suc (x + k₁ ∸ x) + k₂ ≡⟨ cong (λ t → suc t + k₂) (a+b∸a≡b+[a∸a] x k₁) ⟩
    suc (k₁ + (x ∸ x)) + k₂ ≡⟨ lemma₁ (x ∸ x) ⟩
    suc k₁ + k₂ + (x ∸ x) ≡⟨ sym (a+b∸a≡b+[a∸a] x (suc k₁ + k₂)) ⟩
    x + (suc k₁ + k₂) ∸ x ≡⟨ cong (λ t → t ∸ x) lemma₂ ⟩
    suc (x + k₁) + k₂ ∸ x ∎

∸-mono-<ʳ : ∀ {x b t} → t ≤ x → b < t → x ∸ t < x ∸ b
∸-mono-<ʳ {b = b} (lte k₁ refl) (lte k₂ refl) = lte k₂ (≡-erase ≤-proof)
  where
  open ≡-Reasoning
  LHS : suc (suc b + k₂ + k₁ ∸ (suc b + k₂) + k₂) ≡ suc (k₂ + k₁)
  LHS = cong suc $ begin
    suc b + k₂ + k₁ ∸ (suc b + k₂) + k₂ ≡⟨ cong (λ t → t + k₂) (sym (∸-+-assoc (b + k₂ + k₁) b k₂)) ⟩
    suc b + k₂ + k₁ ∸ suc b ∸ k₂ + k₂ ≡⟨ cong (λ t → t ∸ suc b ∸ k₂ + k₂) (+-assoc (suc b) k₂ k₁) ⟩
    suc b + (k₂ + k₁) ∸ suc b ∸ k₂ + k₂ ≡⟨ cong (λ t →  t ∸ k₂ + k₂) (a+b∸a≡b+[a∸a] (suc b) (k₂ + k₁)) ⟩
    k₂ + k₁ + (suc b ∸ suc b) ∸ k₂ + k₂ ≡⟨ cong (λ t → k₂ + k₁ + t ∸ k₂ + k₂) (n∸n≡0 (suc b)) ⟩
    k₂ + k₁ + 0 ∸ k₂ + k₂ ≡⟨  cong (λ t → t ∸ k₂ + k₂) (+-identityʳ (k₂ + k₁)) ⟩
    k₂ + k₁ ∸ k₂ + k₂ ≡⟨ cong (λ t → t + k₂) (a+b∸a≡b+[a∸a] k₂ k₁) ⟩
    k₁ + (k₂ ∸ k₂) + k₂ ≡⟨ cong (λ t → k₁ + t + k₂) (n∸n≡0 k₂) ⟩
    k₁ + 0 + k₂ ≡⟨ cong (λ t → t + k₂) (+-identityʳ k₁) ⟩
    k₁ + k₂ ≡⟨ +-comm k₁ k₂ ⟩
    k₂ + k₁ ∎
  lemma₁ : 1 + (b + k₂ + k₁) ≡ b + (1 + (k₂ + k₁))
  lemma₁ = ∀⟨ b ∷ k₂ ∷ k₁ ∷ [] ⟩
  RHS : suc (b + k₂ + k₁) ∸ b ≡ suc (k₂ + k₁)
  RHS = begin
    suc (b + k₂ + k₁) ∸ b ≡⟨ cong (λ t → t ∸ b) lemma₁ ⟩
    b + suc (k₂ + k₁) ∸ b ≡⟨ a+b∸a≡b+[a∸a] b (suc (k₂ + k₁)) ⟩
    suc (k₂ + k₁) + (b ∸ b) ≡⟨ cong (λ t → suc (k₂ + k₁) + t) (n∸n≡0 b) ⟩
    suc (k₂ + k₁) + 0 ≡⟨ +-identityʳ (suc (k₂ + k₁)) ⟩
    suc (k₂ + k₁) ∎
  ≤-proof : suc (suc b + k₂ + k₁ ∸ (suc b + k₂) + k₂) ≡ suc (b + k₂ + k₁) ∸ b
  ≤-proof = trans LHS (sym RHS)

∸-mono-≤ˡ : ∀ {x b t} → x ≤ b → b ≤ t → b ∸ x ≤ t ∸ x
∸-mono-≤ˡ {x} {b} {t} (lte k₁ refl) (lte k₂ refl) = lte k₂ ≤-proof
  where
  open ≡-Reasoning
  lemma₁ : ∀ a → k₁ + a + k₂ ≡ k₁ + k₂ + a
  lemma₁ a = ∀⟨ a ∷ k₁ ∷ k₂ ∷ [] ⟩
  ≤-proof : x + k₁ ∸ x + k₂ ≡ x + k₁ + k₂ ∸ x
  ≤-proof = begin
    x + k₁ ∸ x + k₂   ≡⟨ cong (λ t → t + k₂) (a+b∸a≡b+[a∸a] x k₁) ⟩
    k₁ + (x ∸ x) + k₂ ≡⟨ lemma₁ (x ∸ x) ⟩
    k₁ + k₂ + (x ∸ x) ≡⟨ sym (a+b∸a≡b+[a∸a] x (k₁ + k₂)) ⟩
    x + (k₁ + k₂) ∸ x ≡⟨ cong (λ t → t ∸ x) (sym (+-assoc x k₁ k₂)) ⟩
    x + k₁ + k₂ ∸ x   ∎

*-mono-< : _*_ Preserves₂ _<_ ⟶ _<_ ⟶ _<_
*-mono-< {x} {_} {u} (lte k refl) (lte m refl) =
  lte (k * m + k * u + k + m * x + m + u + x) (≡-erase ∀⟨ x ∷ u ∷ k ∷ m ∷ [] ⟩)

*-mono-≤ : _*_ Preserves₂ _≤_ ⟶ _≤_ ⟶ _≤_
*-mono-≤ {x} {_} {u} (lte k refl) (lte m refl) = lte (k * m + k * u + m * x) (≡-erase ∀⟨ x ∷ u ∷ k ∷ m ∷ [] ⟩)

+-lower-≤ : ∀ x {n m} → n + x ≤ m → n ≤ m
+-lower-≤ x {n} {m} (lte q refl) = lte (x + q) (sym (+-assoc n x q))

<⇒≤ : ∀ {n m} → n < m → n ≤ m
<⇒≤ {n} (lte k refl) = lte (suc k) (≡-erase (+-suc n k))

module ≤-Reasoning where
   open import Relation.Binary.Reasoning.Base.Triple
     ≤-isPreorder <-trans (resp₂ _<_) <⇒≤ <-≤-trans ≤-<-trans
     public

n≤m⇒n<m⊎n≡m : ∀ {n m} → n ≤ m → n < m ⊎ n ≡ m
n≤m⇒n<m⊎n≡m {n} (lte zero ≤-proof) rewrite ≡-erase (+-identityʳ n) = inj₂ ≤-proof
n≤m⇒n<m⊎n≡m {n} (lte (suc k) ≤-proof) rewrite ≡-erase (+-suc n k) = inj₁ (lte k ≤-proof)

≤∧≢⇒< : ∀ {m n} → m ≤ n → m ≢ n → m < n
≤∧≢⇒< m≤n m≢n with n≤m⇒n<m⊎n≡m m≤n
... | inj₁ m<n = m<n
... | inj₂ m≡n = contradiction m≡n m≢n

≮⇒≥ : ∀ {m n} → m ≮ n → m ≥ n
≮⇒≥ {_} {zero} m≮n = 0≤n
≮⇒≥ {zero} {suc n} m≮n = contradiction 0<1+n m≮n
≮⇒≥ {suc m} {suc n} m≮n = suc-mono-≤ (≮⇒≥ (m≮n ∘ suc-mono-<))

<⇒≱ : ∀ {m n} → m < n → m ≱ n
<⇒≱ {m} {n} m<n m≥n with n≤m⇒n<m⊎n≡m m≥n
... | inj₁ m>n = <-asym m<n m>n
... | inj₂ m≡n = <-irrefl (sym m≡n) m<n

<ᵇ⇒< : ∀ m n → T (m <ᵇ n) → m < n
<ᵇ⇒< zero    (suc n) m<n = 0<1+n
<ᵇ⇒< (suc m) (suc n) m<n = suc-mono-< (<ᵇ⇒< m n m<n)

<⇒<ᵇ : ∀ m n → m < n → T (m <ᵇ n)
<⇒<ᵇ zero (suc n) m<n = tt
<⇒<ᵇ (suc m) (suc n) m<n = <⇒<ᵇ m n (suc-injective-≤ m<n)

0≢⇒0< : ∀ {n} → 0 ≢ n → 0 < n
0≢⇒0< {zero} 0≢n = contradiction refl 0≢n
0≢⇒0< {suc n} 0≢n = 0<1+n

-- TODO change to does/proof
<-cmp : Trichotomous _≡_ _<_
<-cmp m n with m ≟ n | T? (m <ᵇ n)
... | yes m≡n | _       = tri≈ (<-irrefl m≡n) m≡n (<-irrefl (sym m≡n))
... | no  m≢n | yes m<n = tri< (<ᵇ⇒< m n m<n) m≢n (<⇒≯ (<ᵇ⇒< m n m<n))
... | no  m≢n | no  m≮n = tri> (m≮n ∘ <⇒<ᵇ m n) m≢n (≤∧≢⇒< (≮⇒≥ (m≮n ∘ <⇒<ᵇ m n)) (m≢n ∘ sym))

_<?_ : Decidable _<_
a <? b with <-cmp a b
... | tri< a<b _ _ = yes a<b
... | tri≈ _ refl _ = no λ a<b → n≮n a<b
... | tri> _ _ a>b = no λ a<b → <-asym a>b a<b

<-≤-connex : Connex _<_ _≤_
<-≤-connex m n with <-cmp m n
... | tri< n<m _ _  = inj₁ n<m
... | tri≈ _ refl _ = inj₂ ≤-refl
... | tri> _ _ n>m  = inj₂ (<⇒≤ n>m)

<-irrelevant : Irrelevant _<_
<-irrelevant {x} (lte k₁ 1+x+k₁≡y) (lte k₂ 1+x+k₂≡y) with +-cancelˡ-≡ (1 + x) (trans 1+x+k₁≡y (sym 1+x+k₂≡y))
<-irrelevant {x} (lte k₁ refl) (lte .k₁ refl) | refl = refl

≤-total : Total _≤_
≤-total n m with <-cmp n m
... | tri< n<m _ _  = inj₁ (<⇒≤ n<m)
... | tri≈ _ refl _ = inj₁ ≤-refl
... | tri> _ _ n>m  = inj₂ (<⇒≤ n>m)

≤-isTotalOrder : IsTotalOrder _≡_ _≤_
≤-isTotalOrder = record
  { isPartialOrder = ≤-isPartialOrder
  ; total          = ≤-total
  }

≤-totalOrder : TotalOrder 0ℓ 0ℓ 0ℓ
≤-totalOrder = record { isTotalOrder = ≤-isTotalOrder }

open import Algebra.Construct.NaturalChoice.Max ≤-totalOrder public

+-distribˡ-⊔ : _+_ DistributesOverˡ _⊔_
+-distribˡ-⊔ x y z with ≤-total z y
+-distribˡ-⊔ x y z | inj₁ z≤y with ≤-total (x + z) (x + y)
+-distribˡ-⊔ x y z | inj₁ z≤y | inj₁ x+z≤x+y = refl
+-distribˡ-⊔ x y z | inj₁ z≤y | inj₂ x+y≤x+z = ≤-antisym x+y≤x+z (+-mono-≤ ≤-refl z≤y)
+-distribˡ-⊔ x y z | inj₂ y≤z with ≤-total (x + z) (x + y)
+-distribˡ-⊔ x y z | inj₂ y≤z | inj₁ x+z≤x+y = ≤-antisym x+z≤x+y (+-mono-≤ ≤-refl y≤z)
+-distribˡ-⊔ x y z | inj₂ y≤z | inj₂ x+y≤x+z = refl

⊔-least-≤ : ∀ n m o → n ≤ o → m ≤ o → n ⊔ m ≤ o
⊔-least-≤ n m o n≤o m≤o with ≤-total m n
... | inj₁ _ = n≤o
... | inj₂ _ = m≤o

⊔-least-< : ∀ n m o → n < o → m < o → n ⊔ m < o
⊔-least-< n m o n<o m<o with ≤-total m n
... | inj₁ _ = n<o
... | inj₂ _ = m<o

m≤n⇒m⊔n≡n : ∀ {m n} → m ≤ n → m ⊔ n ≡ n
m≤n⇒m⊔n≡n {m} {n} m≤n with ≤-total n m
... | inj₁ n≤m = ≤-antisym m≤n n≤m
... | inj₂ _   = refl

auto-≤ : ∀ {n m} {{ pf : True (n + (m ∸ n) ≟ m) }} → n ≤ m
auto-≤ {n} {m} with n + (m ∸ n) ≟ m
... | yes pf = lte (m ∸ n) pf


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

postulate
  M   : Set → Set
  _>>=_ : ∀{A B : Set} → M A → (A → M B) → M B

infixr 1 bind
bind : _
bind = _>>=_

infix 0 id
id : ∀{A : Set} → A → A
id = λ x → x

syntax id  x             = do x
syntax bind ma (λ x → f) = x ← ma , f

swapM′ : ∀ {A B} → M (A × B) → M (B × A)
swapM′ mAB =
  do
     (a , b) ← mAB
   , return $ b , a

-- Was:
-- An internal error has occurred. Please report this as a bug.
-- Location of the error:
-- src/full/Agda/TypeChecking/Monad/Base.hs:1793


{-# OPTIONS -v tc.lhs.unify:80 #-}
data _≡_ {A : Set} (x : A) : A → Set where
  refl : x ≡ x

postulate
  A : Set
  a : A

record Foo : Set where
  constructor foo
  field anA : A

test : (f : A → A) (x : Foo) → foo (f a) ≡ x → A
test f .(foo (f a)) refl = a


{-# OPTIONS --without-K #-}
infixr 1 _‘→’_

record ⊤ : Set where
  constructor tt

data ⊥ : Set where

mutual
  data Type : Set where
    _‘→’_ : Type → Type → Type
    ‘□’ : Type → Type
    ‘⊤’ : Type
    ‘⊥’ : Type

  data □ : Type → Set where
    Lӧb : ∀ {X} → □ (‘□’ X ‘→’ X) → □ X
    ‘tt’ : □ ‘⊤’

mutual
  ⌞_⌟ : Type → Set
  ⌞ A ‘→’ B ⌟ = ⌞ A ⌟ → ⌞ B ⌟
  ⌞ ‘□’ T ⌟   = □ T
  ⌞ ‘⊤’ ⌟     = ⊤
  ⌞ ‘⊥’ ⌟     = ⊥

  ⌞_⌟t : ∀ {T : Type} → □ T → ⌞ T ⌟
  ⌞ (Lӧb □‘X’→X) ⌟t = ⌞ □‘X’→X ⌟t (Lӧb □‘X’→X)
  ⌞ ‘tt’ ⌟t = tt

¬_ : Set → Set
¬ T = T → ⊥

‘¬’_ : Type → Type
‘¬’ T = T ‘→’ ‘⊥’

lӧb : ∀ {‘X’} → □ (‘□’ ‘X’ ‘→’ ‘X’) → ⌞ ‘X’ ⌟
lӧb f = ⌞ Lӧb f ⌟t

incompleteness : ¬ □ (‘¬’ (‘□’ ‘⊥’))
incompleteness = lӧb

soundness : ¬ □ ‘⊥’
soundness x = ⌞ x ⌟t

non-emptyness : □ ‘⊤’
non-emptyness = ‘tt’


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

module Definition.Typed.Consequences.Inversion where

open import Definition.Untyped
open import Definition.Typed
open import Definition.Typed.Properties

open import Definition.Typed.Consequences.Syntactic
open import Definition.Typed.Consequences.Substitution

open import Tools.Product

-- Inversion of natural number type.
inversion-ℕ : ∀ {Γ C} → Γ ⊢ ℕ ∷ C → Γ ⊢ C ≡ U
inversion-ℕ (ℕⱼ x) = refl (Uⱼ x)
inversion-ℕ (conv x x₁) = trans (sym x₁) (inversion-ℕ x)

-- Inversion of Π-types.
inversion-Π : ∀ {F G Γ C}
            → Γ ⊢ Π F ▹ G ∷ C → Γ ⊢ F ∷ U × Γ ∙ F ⊢ G ∷ U × Γ ⊢ C ≡ U
inversion-Π (Πⱼ x ▹ x₁) = x , x₁ , refl (Uⱼ (wfTerm x))
inversion-Π (conv x x₁) = let a , b , c = inversion-Π x
                          in  a , b , trans (sym x₁) c

-- Inversion of zero.
inversion-zero : ∀ {Γ C} → Γ ⊢ zero ∷ C → Γ ⊢ C ≡ ℕ
inversion-zero (zeroⱼ x) = refl (ℕⱼ x)
inversion-zero (conv x x₁) = trans (sym x₁) (inversion-zero x)

-- Inversion of successor.
inversion-suc : ∀ {Γ t C} → Γ ⊢ suc t ∷ C → Γ ⊢ t ∷ ℕ × Γ ⊢ C ≡ ℕ
inversion-suc (sucⱼ x) = x , refl (ℕⱼ (wfTerm x))
inversion-suc (conv x x₁) =
  let a , b = inversion-suc x
  in  a , trans (sym x₁) b

-- Inversion of natural recursion.
inversion-natrec : ∀ {Γ c g n A C} → Γ ⊢ natrec C c g n ∷ A
  → (Γ ∙ ℕ ⊢ C)
  × Γ ⊢ c ∷ C [ zero ]
  × Γ ⊢ g ∷ Π ℕ ▹ (C ▹▹ C [ suc (var 0) ]↑)
  × Γ ⊢ n ∷ ℕ
  × Γ ⊢ A ≡ C [ n ]
inversion-natrec (natrecⱼ x d d₁ n) = x , d , d₁ , n , refl (substType x n)
inversion-natrec (conv d x) = let a , b , c , d , e = inversion-natrec d
                              in  a , b , c , d , trans (sym x) e

-- Inversion of application.
inversion-app :  ∀ {Γ f a A} → Γ ⊢ (f ∘ a) ∷ A →
  ∃₂ λ F G → Γ ⊢ f ∷ Π F ▹ G × Γ ⊢ a ∷ F × Γ ⊢ A ≡ G [ a ]
inversion-app (d ∘ⱼ d₁) = _ , _ , d , d₁ , refl (substTypeΠ (syntacticTerm d) d₁)
inversion-app (conv d x) = let a , b , c , d , e = inversion-app d
                           in  a , b , c , d , trans (sym x) e

-- Inversion of lambda.
inversion-lam : ∀ {t A Γ} → Γ ⊢ lam t ∷ A →
  ∃₂ λ F G → Γ ⊢ F × (Γ ∙ F ⊢ t ∷ G × Γ ⊢ A ≡ Π F ▹ G)
inversion-lam (lamⱼ x x₁) = _ , _ , x , x₁ , refl (Πⱼ x ▹ (syntacticTerm x₁))
inversion-lam (conv x x₁) = let a , b , c , d , e = inversion-lam x
                            in  a , b , c , d , trans (sym x₁) e


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

data D (A : Set) : Set → Set₁ where
  c₁ : {B : Set} → D A B
  c₂ : D A A

record P {A B : Set} (p : D A B) : Set₁ where
  constructor c
  field
    d : D A B

Q : {A B₁ B₂ C : Set} {x : D A (B₁ → C)} {y : D A B₂} →
    P x → P y → B₁ ≡ B₂ → Nat
Q (c c₁) _      refl = 0
Q _      (c c₁) refl = 1
Q _      _      _    = 2

module _ {A B C : Set} where

  checkQ₀ : {x : D A (B → C)} {y : D A B} (px : P x) (py : P y) →
              Q {x = x} {y = y} (c c₁) py refl ≡ 0
  checkQ₀ _ _ = refl

  checkQ₁ : {x : D (A → B) (A → B)} {y : D (A → B) A} (px : P x) (py : P y) →
              Q {x = x} {y = y} (c c₂) (c c₁) refl ≡ 1
  checkQ₁ _ _ = refl

  checkQ₂ : {x : D (A → B) (A → B)} {y : D (A → B) (A → B)} (px : P x) (py : P y) (eq : A ≡ (A → B)) →
              Q {x = x} {y = y} (c c₂) (c c₂) eq ≡ 2
  checkQ₂ _ _ _ = refl

R : {A B₁ B₂ C : Set} {x : D A (B₁ → C)} {y : D A B₂} →
    P x → P y → B₁ ≡ B₂ → Nat
R (c c₂) _      refl = 0
R _      (c c₂) refl = 1
R _      _      _    = 2

module _ {A B C : Set} where

  checkR₀ : ∀ {B C} {x : D (B → C) (B → C)} {y : D (B → C) B} (px : P x) (py : P y) →
             R {x = x} {y = y} (c c₂) py refl ≡ 0
  checkR₀ _ _ = refl

  checkR₁ : ∀ {A B} {x : D A (A → B)} {y : D A A} (px : P x) (py : P y) →
             R {x = x} {y = y} (c c₁) (c c₂) refl ≡ 1
  checkR₁ _ _ = refl

  checkR₂ : ∀ {A B C} {x : D A (B → C)} {y : D A B} (px : P x) (py : P y) →
             R {x = x} {y = y} (c c₁) (c c₁) refl ≡ 2
  checkR₂ _ _ = refl


------------------------------------------------------------------------------
-- Group theory
------------------------------------------------------------------------------

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

module GroupTheory.README where

------------------------------------------------------------------------------
-- Description

-- Theory of groups using Agda postulates for the group axioms.

------------------------------------------------------------------------------
-- The axioms
open import GroupTheory.Base

-- Basic properties
open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI

-- Commutator properties
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

-- Abelian groups
open import GroupTheory.AbelianGroup.PropertiesATP


open import Data.List    using (List; _∷_; [])
open import Data.Product using (_×_; _,_; Σ)
open import Data.Unit    using (⊤; tt)
open import Relation.Binary.PropositionalEquality using (_≡_)

module SystemT where

  {- de Bruijn indices are represented as proofs that
     an element is in a list -}
  data _∈_ {A : Set} : (x : A) (l : List A) → Set where -- type \in
    i0 : {x : A} {xs : List A} → x ∈ (x ∷ xs)
    iS : {x y : A} {xs : List A} → x ∈ xs → x ∈ (y ∷ xs)

  {- types of the STLC -}
  data TType : Set where
    b : TType             -- uninterpreted base type
    _⇒_ : TType → TType → TType -- type \=>

  {- contexts are lists of TType's -}
  Ctx = List
  _,,_ : ∀ {A} → Ctx A → TType → Ctx A
  Γ ,, τ = τ ∷ Γ

  infixr 10 _⇒_
  infixr 9 _,,_
  infixr 8 _⊢_ -- type \entails

  {- Γ ⊢ τ represents a term of type τ in context Γ -}
  data _⊢_ (Γ : Ctx) : TType → Set where
    c   : Γ ⊢ b -- some constant of the base type
    v   : {τ : TType} → τ ∈ Γ → Γ ⊢ τ
    lam : {τ1 τ2 : TType} → Γ ,, τ1 ⊢ τ2 → Γ ⊢ τ1 ⇒ τ2
    app : {τ1 τ2 : TType} → Γ ⊢ τ1 ⇒ τ2 → Γ ⊢ τ1 → Γ ⊢ τ2

  module Examples where
    i : [] ⊢ b ⇒ b
    i = lam (v i0) -- \ x -> x

    k : [] ⊢ b ⇒ b ⇒ b
    k = lam (lam (v (iS i0))) -- \ x -> \ y -> x

    {- TASK 1: Define a term representing  \ x -> \ y -> y -}
    k' : [] ⊢ b ⇒ b ⇒ b
    k' = {!!}

  {- The following proof is like a "0-ary" logical relation.
     It gives a semantics of the STLC in Agda.
     This shows that the STLC is sound, relative to Agda.
  -}
  module Semantics (B : Set) (elB : B) where
    -- works for any interpretation of the base type b

    -- function mapping STLC types to Agda types
    ⟦_⟧t : TType → Set  -- type \(0 and \)0
    ⟦ b ⟧t = B
    ⟦ τ1 ⇒ τ2 ⟧t = ⟦ τ1 ⟧t → ⟦ τ2 ⟧t

    -- function mapping STLC contexts to Agda types
    ⟦_⟧c : Ctx → Set
    ⟦ [] ⟧c = ⊤
    ⟦ τ ∷ Γ ⟧c = ⟦ Γ ⟧c × ⟦ τ ⟧t

    {- TASK 2 : Define the interpretation of terms -}
    ⟦_⟧ : {Γ : Ctx} {τ : TType} → Γ ⊢ τ → ⟦ Γ ⟧c → ⟦ τ ⟧t
    ⟦ e ⟧ γ = {!!}

    {- the following test should pass
    test : ⟦ Examples.k ⟧ == \ γ x y → x
    test = Refl
    -}

  {- you can ignore the implementation of this module.
     the interface for the components you need is listed below
  -}
  module RenamingAndSubstitution where

    -- renamings = variable for variable substitutions

    infix 9 _⊇_

    _⊇_ : Ctx → Ctx → Set -- type \sup=
    Γ' ⊇ [] = ⊤
    Γ' ⊇ (τ ∷ Γ) = (Γ' ⊇ Γ) × (τ ∈ Γ')

    extend⊇ : {Γ : Ctx} (Γ' : Ctx) {τ : TType} → Γ ⊇ Γ' → (Γ ,, τ) ⊇ Γ'
    extend⊇ [] ren = tt
    extend⊇ (τ ∷ Γ') (ρ , x) = extend⊇ Γ' ρ , iS x

    open import Data.List using (_++_)
    extend⊇* : {Γ : Ctx} (Γ' : Ctx) (Γ'' : Ctx) → Γ ⊇ Γ' → (Γ'' ++ Γ) ⊇ Γ'
    extend⊇* Γ' [] ρ = ρ
    extend⊇* Γ' (x ∷ Γ'') ρ = extend⊇ _ (extend⊇* Γ' Γ'' ρ)

    shift : {Γ : Ctx} {τ : TType} (Γ' : Ctx) (i : τ ∈ Γ) → τ ∈ (Γ' ++ Γ)
    shift [] i = i
    shift (τ ∷ Γ) i = iS (shift Γ i)

    ⊇-id : (Γ : Ctx) → Γ ⊇ Γ
    ⊇-id [] = tt
    ⊇-id (τ ∷ Γ) = extend⊇ Γ (⊇-id Γ) , i0

    ⊇-single : {Γ : Ctx} {τ : TType} → (Γ ,, (τ ⊇ Γ))
    ⊇-single = extend⊇ _ (⊇-id _)

    -- you can rename a term

    rename : {Γ Γ' : Ctx} {τ : TType} → Γ' ⊇ Γ → Γ ⊢ τ → Γ' ⊢ τ
    rename ρ c = c
    rename (_ , x') (v i0) = v x'
    rename (ρ , _) (v (iS x)) = rename ρ (v x)
    rename ρ (lam e) = lam (rename (extend⊇ _ ρ , i0) e)
    rename ρ (app e e') = app (rename ρ e) (rename ρ e')

    -- expression-for-variable substitutions

    _⊢c_ : Ctx → Ctx → Set
    Γ' ⊢c [] = tt
    Γ' ⊢c (τ ∷ Γ) = (Γ' ⊢c Γ) × (Γ' ⊢ τ)

    rename-subst : {Γ1 Γ2 Γ3 : Ctx} →  Γ1 ⊇ Γ2 → Γ2 ⊢c Γ3 → Γ1 ⊢c Γ3
    rename-subst {Γ1} {Γ2} {[]} ρ θ = tt
    rename-subst {Γ1} {Γ2} {τ3 ∷ Γ3} ρ (θ , e) = rename-subst ρ θ , rename ρ e

    addvar : {Γ Γ' : Ctx} {τ : TType} → Γ ⊢c Γ' → (Γ ,, τ) ⊢c (Γ' ,, τ)
    addvar θ = rename-subst ⊇-single θ , v i0

    id-subst : {Γ : Ctx} → Γ ⊢c Γ
    id-subst {[]} = tt
    id-subst {τ ∷ Γ} = rename-subst ⊇-single (id-subst {Γ}) , v i0

    subst : {Γ Γ' : Ctx}{τ : TType} → Γ ⊢c Γ' → Γ' ⊢ τ  → Γ ⊢ τ
    subst θ c = c
    subst (θ , e) (v i0) = e
    subst (θ , e) (v (iS x)) = subst θ (v x)
    subst θ (lam e) = lam (subst (addvar θ) e)
    subst θ (app e e') = app (subst θ e) (subst θ e')

    subst1 : {τ τ0 : TType} → [] ⊢ τ0 → ([] ,, τ0) ⊢ τ → [] ⊢ τ
    subst1 e0 e = subst (tt , e0) e

    -- these are not tasks (unless you really want); I didn't get to prove them; sorry!
    compose : {τ1 τ2 : TType} {Γ : Ctx} (θ : [] ⊢c Γ) (e' : [] ⊢ τ1) (e : Γ ,, τ1 ⊢ τ2)
            → subst (θ , e') e ≡ subst1 e' (subst (addvar θ) e)
    compose = {!!}

    ident : {Γ : Ctx} {τ : TType} {e : Γ ⊢ τ} → e ≡ subst (id-subst) e
    ident = {!!}

  open RenamingAndSubstitution using (subst1 ; _⊢c_ ; subst ; ident ; compose)
  {- θ : Γ ⊢c Γ' means θ is a substitution for Γ' in terms of Γ.  It is defined as follows:

    _⊢c_ : Ctx → Ctx → Set
    Γ' ⊢c [] = Unit
    Γ' ⊢c (τ ∷ Γ) = (Γ' ⊢c Γ) × (Γ' ⊢ τ)

    -- apply a substitution to a term
    subst : {Γ Γ' : Ctx}{τ : TType} → Γ ⊢c Γ' → Γ' ⊢ τ  → Γ ⊢ τ

    -- substitution for a single variable
    subst1 : {τ τ0 : TType} → [] ⊢ τ0 → ([] ,, τ0) ⊢ τ → [] ⊢ τ

    -- you will need these two properties:
    compose : {τ1 τ2 : TType} {Γ : Ctx} (θ : [] ⊢c Γ) (e' : [] ⊢ τ1) (e : Γ ,, τ1 ⊢ τ2)
            → subst (θ , e') e == subst1 e' (subst (addvar θ) e)

    ident : {Γ : Ctx} {τ : TType} {e : Γ ⊢ τ} → e == subst (id-subst) e
  -}

  module OpSem where
    -- step relation
    data _↦_ : {τ : TType} → [] ⊢ τ → [] ⊢ τ → Set where
      Step/app  :{τ1 τ2 : TType} {e e' : [] ⊢ τ1 ⇒ τ2} {e1 : [] ⊢ τ1}
             → e ↦ e'
             → (app e e1) ↦ (app e' e1)
      Step/β : {τ1 τ2 : TType} {e : [] ,, τ1 ⊢ τ2} {e1 : [] ⊢ τ1}
             → (app (lam e) e1) ↦ subst1 e1 e

    -- reflexive/transitive closure
    data _↦*_ : {τ : TType} → [] ⊢ τ → [] ⊢ τ → Set where
      Done : {τ : TType} {e : [] ⊢ τ} → e ↦* e
      Step : {τ : TType} {e1 e2 e3 : [] ⊢ τ}
           → e1 ↦ e2  →  e2 ↦* e3
           → e1 ↦* e3
  open OpSem

  {- Next, you will prove "very weak normalization".  The theorem is
     that any closed term *of base type b* evaluates to the constant c.
     No claims are made about terms of function type.
  -}
  module VeryWeakNormalization where

    WN : (τ : TType) → [] ⊢ τ → Set
    -- WN_τ(e) iff e ↦* c
    WN b e = e ↦* c
    -- WN_τ(e) iff for all e1 : τ1, if WN_τ1(e1) then WN_τ2(e e1)
    WN (τ1 ⇒ τ2) e = (e1 : [] ⊢ τ1) → WN τ1 e1 → WN τ2 (app e e1)

    -- extend WN to contexts and substitutions
    WNc : (Γ : Ctx) → [] ⊢c Γ → Set
    WNc [] θ = tt
    WNc (τ ∷ Γ) (θ , e) = WNc Γ θ × WN τ e

    {- TASK 3 : show that the relation is closed under head expansion: -}
    head-expand : (τ : TType) {e e' : [] ⊢ τ} → e ↦ e' → WN τ e' → WN τ e
    head-expand = {!!}

    {- TASK 4 : prove the fundamental theorem

    Hint: you may find it helpful to use
      transport : {A : Set} (B : A → Set) {a1 a2 : A} → a1 == a2 → (B a1 → B a2)
    to coerce by a propositional equality.
    -}
    fund : {Γ : Ctx} {τ : TType} {θ : [] ⊢c Γ}
         → (e : Γ ⊢ τ)
         → WNc Γ θ
         → WN τ (subst θ e)
    fund = {!!}

    {- TASK 5 : conclude weak normalization at base type -}
    corollary : (e : [] ⊢ b) → e ↦* c
    corollary = {!!}

  {- TASK 6 : change the definition of the logical relation so that you also can conclude normalization
              at function type.
  -}
  module WeakNormalization where

    open RenamingAndSubstitution using (addvar)
    --- you will want to use
    --    addvar : {Γ Γ' : Ctx} {τ : TType} → Γ ⊢c Γ' → (Γ ,, τ) ⊢c (Γ' ,, τ)

    -- Hint: you will need a couple of lemmas about ↦* that we didn't need above
    -- (I used three of them)

    {- TASK 6a -}
    corollary1 : (e : [] ⊢ b) → e ↦* c
    corollary1 e = {!!}

    {- TASK 6b -}
    corollary2 : {τ1 τ2 : TType} (e : [] ⊢ τ1 ⇒ τ2) → Σ \(e' : _) → e ↦* (lam e')
    corollary2 e = {!!}


{-

  Functions building UARels and DUARels on propositions / propositional families

-}
{-# OPTIONS --no-exact-split --safe #-}
module Cubical.Displayed.Prop where

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

open import Cubical.Data.Sigma
open import Cubical.Data.Unit

open import Cubical.Displayed.Base

private
  variable
    ℓA ℓ≅A ℓB ℓ≅B ℓP : Level

𝒮-prop : (P : hProp ℓP) → UARel (P .fst) ℓ-zero
𝒮-prop P .UARel._≅_ _ _ = Unit
𝒮-prop P .UARel.ua _ _ =
  invEquiv (isContr→≃Unit (isOfHLevelPath' 0 (P .snd) _ _))

𝒮ᴰ-prop : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) (P : A → hProp ℓP)
  → DUARel 𝒮-A (λ a → P a .fst) ℓ-zero
𝒮ᴰ-prop 𝒮-A P .DUARel._≅ᴰ⟨_⟩_ _ _ _ = Unit
𝒮ᴰ-prop 𝒮-A P .DUARel.uaᴰ _ _ _ =
  invEquiv (isContr→≃Unit (isOfHLevelPathP' 0 (P _ .snd) _ _))

𝒮-subtype : {A : Type ℓA} (𝒮-A : UARel A ℓ≅A) {P : A → Type ℓP}
  → (∀ a → isProp (P a))
  → UARel (Σ A P) ℓ≅A
𝒮-subtype 𝒮-A propP .UARel._≅_ (a , _) (a' , _) = 𝒮-A .UARel._≅_ a a'
𝒮-subtype 𝒮-A propP .UARel.ua (a , _) (a' , _) =
  compEquiv (𝒮-A .UARel.ua a a') (Σ≡PropEquiv propP)

𝒮ᴰ-subtype : {A : Type ℓA} {𝒮-A : UARel A ℓ≅A}
  {B : A → Type ℓB} (𝒮ᴰ-B : DUARel 𝒮-A B ℓ≅B)
  {P : (a : A) → B a → Type ℓP}
  → (∀ a b → isProp (P a b))
  → DUARel 𝒮-A (λ a → Σ[ b ∈ B a ] (P a b)) ℓ≅B
𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel._≅ᴰ⟨_⟩_ (b , _) p (b' , _) = 𝒮ᴰ-B .DUARel._≅ᴰ⟨_⟩_ b p b'
𝒮ᴰ-subtype 𝒮ᴰ-B propP .DUARel.uaᴰ (b , _) p (b' , _) =
  compEquiv
    (𝒮ᴰ-B .DUARel.uaᴰ b p b')
    (compEquiv
      (invEquiv (Σ-contractSnd λ _ → isOfHLevelPathP' 0 (propP _ b') _ _))
      ΣPath≃PathΣ)


module RAdjunctions.RAdj2RMon where

open import Function
open import Relation.Binary.HeterogeneousEquality
open import Categories
open import Functors
open import RMonads
open import RAdjunctions

open Cat
open Fun
open RAdj

Adj2Mon : ∀{a b c d e f}{C : Cat {a}{b}}{D : Cat {c}{d}}{E : Cat {e}{f}}
          {J : Fun C D} → RAdj J E → RMonad J
Adj2Mon {C = C}{D}{E}{J} A = record{
  T    = OMap (R A) ∘ OMap (L A);
  η    = left A (iden E);
  bind = HMap (R A) ∘ right A;
  law1 = trans (cong (HMap (R A)) (lawa A (iden E))) (fid (R A));
  law2 = λ {_ _ f} →
    trans (cong (comp D (HMap (R A) (right A f)))
                (trans (sym (idr D))
                       (cong (comp D (left A (iden E))) (sym (fid J)))))
          (trans (natleft A (iden C) (right A f) (iden E))
                 (trans (cong (left A)
                              (trans (cong (comp E (right A f))
                                           (trans (idl E) (fid (L A))))
                                     (idr E)))
                        (lawb A f)));
  law3 = λ{_ _ _ f g} →
    trans (cong (HMap (R A))
                (trans (trans (cong (right A)
                                    (cong (comp D (HMap (R A) (right A g)))
                                          (trans (sym (idr D))
                                                 (cong (comp D f)
                                                       (sym (fid J))))))
                              (trans (natright A (iden C) (right A g) f)
                                     (trans (sym (ass E))
                                            (cong (comp E (comp E (right A g)
                                                                  (right A f)))
                                                  (fid (L A))))))
                       (idr E)))
          (fcomp (R A))}


module Subset where

data Subset (A : Set) (P : A -> Set) : Set where
  inn : (a : A) -> .(P a) -> Subset A P

out : forall {A P} -> Subset A P -> A
out (inn a p) = a


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

open import HoTT
open import homotopy.SphereEndomorphism
open import groups.Pointed
open import groups.SphereEndomorphism
open import groups.FromSusp
open import cohomology.Theory

module cohomology.SphereEndomorphism (CT : CohomologyTheory lzero) (n : ℤ) (m : ℕ) where

  open CohomologyTheory CT
  open import cohomology.Cogroup CT n
    (Susp-cogroup-structure (⊙Sphere m))
    (⊙Sphere (S m))

  private
    C-fmap' : Trunc-⊙Sphere-endo (S m) → (C n (⊙Sphere (S m)) →ᴳ C n (⊙Sphere (S m)))
    C-fmap' = Trunc-rec λ f → C-fmap n f

    CEl-fmap' : Trunc-⊙Sphere-endo (S m) → (CEl n (⊙Sphere (S m)) → CEl n (⊙Sphere (S m)))
    CEl-fmap' f = GroupHom.f (C-fmap' f)

    C-fmap'-hom : Trunc-⊙SphereS-endo-group m →ᴳ
      (hom-group (C n (⊙Sphere (S m))) (C-abgroup n (⊙Sphere (S m))))
    C-fmap'-hom = group-hom C-fmap'
      (Trunc-elim λ f → Trunc-elim λ g → C-fmap-preserves-comp f g)

    CEl-fmap'-η : ∀ (f : Trunc-⊙Sphere-endo (S m)) (g : CEl n (⊙Sphere (S m)))
      → CEl-fmap' f g == Group.exp (C n (⊙Sphere (S m))) g (Trunc-⊙SphereS-endo-degree m f)
    CEl-fmap'-η f g =
      CEl-fmap' f g
        =⟨ ! $ ap (λ f → CEl-fmap' f g) $ is-equiv.f-g (Trunc-⊙SphereS-endo-⊙group-is-infinite-cyclic m) f ⟩
      CEl-fmap' (Group.exp (Trunc-⊙SphereS-endo-group m) [ ⊙idf _ ] (Trunc-⊙SphereS-endo-degree m f)) g
        =⟨ GroupHom.pres-exp
            (app-hom g ∘ᴳ C-fmap'-hom)
            [ ⊙idf _ ]
            (Trunc-⊙SphereS-endo-degree m f) ⟩
      Group.exp
        (C n (⊙Sphere (S m)))
        (CEl-fmap' [ ⊙idf _ ] g)
        (Trunc-⊙SphereS-endo-degree m f)
        =⟨ ap (λ g → Group.exp (C n (⊙Sphere (S m))) g (Trunc-⊙SphereS-endo-degree m f)) $
              CEl-fmap-idf n g  ⟩
      Group.exp
        (C n (⊙Sphere (S m))) g
        (Trunc-⊙SphereS-endo-degree m f)
        =∎
  abstract
    CEl-fmap-⊙Sphere-endo-η : ∀ (f : ⊙Sphere-endo (S m)) (g : CEl n (⊙Sphere (S m)))
      → CEl-fmap n f g == Group.exp (C n (⊙Sphere (S m))) g (⊙SphereS-endo-degree m f)
    CEl-fmap-⊙Sphere-endo-η f = CEl-fmap'-η [ f ]


------------------------------------------------------------------------
-- Properties related to negation
------------------------------------------------------------------------

module Relation.Nullary.Negation where

open import Relation.Nullary
open import Relation.Unary
open import Data.Empty
open import Data.Function
open import Data.Product as Prod
open import Data.Fin
open import Data.Fin.Dec
open import Category.Monad

contradiction : ∀ {P whatever} → P → ¬ P → whatever
contradiction p ¬p = ⊥-elim (¬p p)

contraposition : ∀ {P Q} → (P → Q) → ¬ Q → ¬ P
contraposition f ¬q p = contradiction (f p) ¬q

-- Note also the following use of flip:

private
  note : ∀ {P Q} → (P → ¬ Q) → Q → ¬ P
  note = flip

------------------------------------------------------------------------
-- Quantifier juggling

∃⟶¬∀¬ : ∀ {A} {P : Pred A} → ∃ P → ¬ (∀ x → ¬ P x)
∃⟶¬∀¬ = flip uncurry

∀⟶¬∃¬ : ∀ {A} {P : Pred A} → (∀ x → P x) → ¬ ∃ λ x → ¬ P x
∀⟶¬∃¬ ∀xPx (x , ¬Px) = ¬Px (∀xPx x)

¬∃⟶∀¬ : ∀ {A} {P : Pred A} → ¬ ∃ (λ x → P x) → ∀ x → ¬ P x
¬∃⟶∀¬ = curry

∀¬⟶¬∃ : ∀ {A} {P : Pred A} → (∀ x → ¬ P x) → ¬ ∃ (λ x → P x)
∀¬⟶¬∃ = uncurry

∃¬⟶¬∀ : ∀ {A} {P : Pred A} → ∃ (λ x → ¬ P x) → ¬ (∀ x → P x)
∃¬⟶¬∀ = flip ∀⟶¬∃¬

-- When P is a decidable predicate over a finite set the following
-- lemma can be proved.

¬∀⟶∃¬ : ∀ n (P : Pred (Fin n)) → (∀ i → Dec (P i)) →
        ¬ (∀ i → P i) → ∃ λ i → ¬ P i
¬∀⟶∃¬ n P dec ¬P = Prod.map id proj₁ $ ¬∀⟶∃¬-smallest n P dec ¬P

------------------------------------------------------------------------
-- Double-negation

¬¬-map : ∀ {P Q} → (P → Q) → ¬ ¬ P → ¬ ¬ Q
¬¬-map f = contraposition (contraposition f)

¬¬-drop : {P : Set} → ¬ ¬ ¬ P → ¬ P
¬¬-drop ¬¬¬P P = ¬¬¬P (λ ¬P → ¬P P)

¬¬-drop-Dec : {P : Set} → Dec P → ¬ ¬ P → P
¬¬-drop-Dec (yes p) ¬¬p = p
¬¬-drop-Dec (no ¬p) ¬¬p = ⊥-elim (¬¬p ¬p)

¬-drop-Dec : {P : Set} → Dec (¬ ¬ P) → Dec (¬ P)
¬-drop-Dec (yes ¬¬p) = no ¬¬p
¬-drop-Dec (no ¬¬¬p) = yes (¬¬-drop ¬¬¬p)

-- Double-negation is a monad (if we assume that all elements of ¬ ¬ P
-- are equal).

¬¬-Monad : RawMonad (λ P → ¬ ¬ P)
¬¬-Monad = record
  { return = contradiction
  ; _>>=_  = λ x f → ¬¬-drop (¬¬-map f x)
  }

¬¬-push : {P : Set} {Q : P → Set} →
          ¬ ¬ ((x : P) → Q x) → (x : P) → ¬ ¬ Q x
¬¬-push ¬¬P⟶Q P ¬Q = ¬¬P⟶Q (λ P⟶Q → ¬Q (P⟶Q P))

-- A double-negation-translated variant of excluded middle (or: every
-- nullary relation is decidable in the double-negation monad).

excluded-middle : {P : Set} → ¬ ¬ Dec P
excluded-middle ¬h = ¬h (no (λ p → ¬h (yes p)))

-- If whatever is instantiated with ¬ ¬ something, then this function
-- is call with current continuation in the double-negation monad, or,
-- if you will, a double-negation translation of Peirce's law.
--
-- In order to prove ¬ ¬ P one can assume ¬ P and prove ⊥. However, it
-- is sometimes nice to avoid leaving the double-negation monad; in
-- that case this function can be used (with whatever instantiated to
-- ⊥).

call/cc : ∀ {whatever P : Set} → ((P → whatever) → ¬ ¬ P) → ¬ ¬ P
call/cc hyp ¬p = hyp (λ p → ⊥-elim (¬p p)) ¬p


------------------------------------------------------------------------
-- The Agda standard library
--
-- Decidable semi-heterogeneous vector equality over setoids
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.Vec.Relation.Binary.Equality.DecSetoid
  {a ℓ} (DS : DecSetoid a ℓ) where

open import Data.Nat using (ℕ)
import Data.Vec.Relation.Binary.Equality.Setoid as Equality
import Data.Vec.Relation.Binary.Pointwise.Inductive as PW
open import Level using (_⊔_)
open import Relation.Binary using (Decidable)

open DecSetoid DS

------------------------------------------------------------------------
-- Make all definitions from equality available

open Equality setoid public

------------------------------------------------------------------------
-- Additional properties

infix 4 _≋?_

_≋?_ : ∀ {m n} → Decidable (_≋_ {m} {n})
_≋?_ = PW.decidable _≟_

≋-isDecEquivalence : ∀ n → IsDecEquivalence (_≋_ {n})
≋-isDecEquivalence = PW.isDecEquivalence isDecEquivalence

≋-decSetoid : ℕ → DecSetoid a (a ⊔ ℓ)
≋-decSetoid = PW.decSetoid DS