module Metalogic.Classical.Propositional.ProofSystem {ℓₚ} (Proposition : Set(ℓₚ)) where

import      Lvl
open import Data hiding (empty)
import      Data.List
open        Data.List using (List ; ∅ ; _⊰_ ; _++_ ; [_ ; _])
open        Data.List.Notation
import      Data.List.Relation.Membership
import      Data.List.Relation.Membership.Proofs
open import Metalogic.Classical.Propositional.Syntax(Proposition)
open import Functional

open        Data.List.Relation.Membership{ℓₚ} {Formula}
open        Data.List.Relation.Membership.Proofs{ℓₚ} {Formula}

module Meta where
  data _⊢_ : List(Formula) → Formula → Set(ℓₚ) where -- TODO: Reduce the number of rules
    [⊤]-intro : ∀{Γ} → (Γ ⊢ ⊤)

    [⊥]-intro : ∀{Γ}{φ} → (φ ∈ Γ) → ((¬ φ) ∈ Γ) → (Γ ⊢ ⊥)
    [⊥]-elim  : ∀{Γ}{φ} → (⊥ ∈ Γ) → (Γ ⊢ φ)

    [¬]-intro : ∀{Γ}{φ} → ((φ ∈ Γ) → (Γ ⊢ ⊥)) → (Γ ⊢ (¬ φ))
    [¬]-elim  : ∀{Γ}{φ} → (((¬ φ) ∈ Γ) → (Γ ⊢ ⊥)) → (Γ ⊢ φ)

    [∧]-intro : ∀{Γ}{φ₁ φ₂} → (φ₁ ∈ Γ) → (φ₂ ∈ Γ) → (Γ ⊢ (φ₁ ∧ φ₂))
    [∧]-elimₗ  : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∧ φ₂) ∈ Γ) → (Γ ⊢ φ₁)
    [∧]-elimᵣ  : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∧ φ₂) ∈ Γ) → (Γ ⊢ φ₂)

    [∨]-introₗ : ∀{Γ}{φ₁ φ₂} → (φ₁ ∈ Γ) → (Γ ⊢ (φ₁ ∨ φ₂))
    [∨]-introᵣ : ∀{Γ}{φ₁ φ₂} → (φ₂ ∈ Γ) → (Γ ⊢ (φ₁ ∨ φ₂))
    [∨]-elim   : ∀{Γ}{φ₁ φ₂ φ₃} → ((φ₁ ∈ Γ) → (Γ ⊢ φ₃)) → ((φ₂ ∈ Γ) → (Γ ⊢ φ₃)) → ((φ₁ ∨ φ₂) ∈ Γ) → (Γ ⊢ φ₃)

    [⇒]-intro : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∈ Γ) → (Γ ⊢ φ₂)) → (Γ ⊢ (φ₁ ⇒ φ₂))
    [⇒]-elim  : ∀{Γ}{φ₁ φ₂} → ((φ₁ ⇒ φ₂) ∈ Γ) → (φ₁ ∈ Γ) → (Γ ⊢ φ₂)

  [¬¬]-elim : ∀{Γ}{φ} → ((¬ ¬ φ) ∈ Γ) → (Γ ⊢ φ)
  [¬¬]-elim{Γ}{φ} ([¬¬φ]-in) =
    ([¬]-elim{Γ}{φ} ([¬φ]-in ↦
      ([⊥]-intro{Γ}{¬ φ}
        ([¬φ]-in)
        ([¬¬φ]-in)
      )
    ))

  _⊬_ : List(Formula) → Formula → Set(ℓₚ)
  _⊬_ Γ φ = (_⊢_ Γ φ) → Empty{ℓₚ}

  -- Consistency
  Inconsistent : List(Formula) → Set(ℓₚ)
  Inconsistent Γ = (Γ ⊢ ⊥)

  Consistent : List(Formula) → Set(ℓₚ)
  Consistent Γ = (Γ ⊬ ⊥)

module TruthTables where
  open Meta

-- Natural deduction proof trees.
-- This is a proof system that should reflect the semantic truth of formulas.
module NaturalDeduction where
  -- A `Tree` is associated with a formula.
  -- [Proposition without assumptions (Axiom)]
  --   Represented by the type `Tree(φ)`.
  --   It means that a tree with the formula φ at the bottom exists (is constructable).
  --   This represents that the formula φ is provable in the natural deduction proof system.
  -- [Proposition with an assumption]
  --   Represented by the type `Tree(φ₁) → Tree(φ₂)`.
  --   It means that a tree with φ₁ as a leaf and φ₂ at the bottom exists (is constructable).
  --   This represents that the formula φ₂ is provable if one can assume the formula φ₁.
  -- The constructors of `Tree` are all the possible ways to construct a natural deduction proof tree.
  -- If a tree with a certain formula cannot be constructed, then it means that the formula is not provable.
  {-# NO_POSITIVITY_CHECK #-} -- TODO: Could this be a problem? Maybe not? Classical logic is supposed to be consistent, but maybe that does not have anything to do with this?
  data Tree : Formula → Set(ℓₚ) where
    [⊤]-intro : Tree(⊤)

    [⊥]-intro : ∀{φ} → Tree(φ) → Tree(¬ φ) → Tree(⊥)

    [¬]-intro : ∀{φ} → (Tree(φ) → Tree(⊥)) → Tree(¬ φ)
    [¬]-elim  : ∀{φ} → (Tree(¬ φ) → Tree(⊥)) → Tree(φ)

    [∧]-intro : ∀{φ₁ φ₂} → Tree(φ₁) → Tree(φ₂) → Tree(φ₁ ∧ φ₂)
    [∧]-elimₗ  : ∀{φ₁ φ₂} → Tree(φ₁ ∧ φ₂) → Tree(φ₁)
    [∧]-elimᵣ  : ∀{φ₁ φ₂} → Tree(φ₁ ∧ φ₂) → Tree(φ₂)

    [∨]-introₗ : ∀{φ₁ φ₂} → Tree(φ₁) → Tree(φ₁ ∨ φ₂)
    [∨]-introᵣ : ∀{φ₁ φ₂} → Tree(φ₂) → Tree(φ₁ ∨ φ₂)
    [∨]-elim  : ∀{φ₁ φ₂ φ₃} → (Tree(φ₁) → Tree(φ₃)) → (Tree(φ₂) → Tree(φ₃)) → Tree(φ₁ ∨ φ₂) → Tree(φ₃)

    [⇒]-intro : ∀{φ₁ φ₂} → (Tree(φ₁) → Tree(φ₂)) → Tree(φ₁ ⇒ φ₂)
    [⇒]-elim  : ∀{φ₁ φ₂} → Tree(φ₁ ⇒ φ₂) → Tree(φ₁) → Tree(φ₂)

  -- Double negated proposition is positive.
  [¬¬]-elim : ∀{φ} → Tree(¬ (¬ φ)) → Tree(φ)
  [¬¬]-elim nna = [¬]-elim(na ↦ [⊥]-intro na nna)

  -- A contradiction can derive every formula.
  [⊥]-elim : ∀{φ} → Tree(⊥) → Tree(φ)
  [⊥]-elim bottom = [¬]-elim(_ ↦ bottom)

  -- List of natural deduction proof trees.
  -- A `Trees` is associated with a list of formulas.
  -- If all formulas in the list can be constructed, then all the formulas in the list are provable.
  -- This is used to express (⊢) using the usual conventions in formal logic.
  -- Trees(Γ) is the statement that all formulas in Γ have proof trees.
  Trees : List(Formula) → Set(ℓₚ)
  Trees(Γ) = (∀{γ} → (γ ∈ Γ) → Tree(γ))

  module Trees where
    tree : ∀{Γ}{φ} → Trees(Γ) → (φ ∈ Γ) → Tree(φ)
    tree f(x) = f(x)

    empty : Trees(∅)
    empty ()

    singleton : ∀{φ} → Tree(φ) → Trees([ φ ])
    singleton (φ-tree) (use) = φ-tree
    singleton (φ-tree) (skip ())

    -- TODO: This could possibly be generalized to: ∀{Γ₁ Γ₂}{F : T → Set} → (∀{a} → (a ∈ Γ₁) → (a ∈ Γ₂)) → ((∀{γ} → (γ ∈ Γ₂) → F(γ)) → (∀{γ} → (γ ∈ Γ₁) → F(γ)))
    from-[∈] : ∀{Γ₁ Γ₂} → (∀{a} → (a ∈ Γ₁) → (a ∈ Γ₂)) → (Trees(Γ₂) → Trees(Γ₁))
    from-[∈] (f) (Γ₂-trees) {γ} = liftᵣ (f{γ}) (Γ₂-trees)

    push : ∀{Γ}{φ} → Tree(φ) → Trees(Γ) → Trees(φ ⊰ Γ)
    push (φ-tree) (Γ-tree) (use) = φ-tree
    push (φ-tree) (Γ-tree) (skip membership) = Γ-tree (membership)

    pop : ∀{Γ}{φ} → Trees(φ ⊰ Γ) → Trees(Γ)
    pop = from-[∈] (skip)

    first : ∀{Γ}{φ} → Trees(φ ⊰ Γ) → Tree(φ)
    first(f) = f(use)

    -- TODO: Could be removed because liftᵣ is easier to use. ALthough a note/tip should be written for these purposes.
    -- formula-weaken : ∀{ℓ}{T : Set(ℓ)}{Γ₁ Γ₂} → (Trees(Γ₁) → Trees(Γ₂)) → (Trees(Γ₂) → T) → (Trees(Γ₁) → T)
    -- formula-weaken = liftᵣ

    [++]-commute : ∀{Γ₁ Γ₂} → Trees(Γ₁ ++ Γ₂) → Trees(Γ₂ ++ Γ₁)
    [++]-commute {Γ₁}{Γ₂} (trees) = trees ∘ ([∈][++]-commute{_}{Γ₂}{Γ₁})

    [++]-left : ∀{Γ₁ Γ₂} → Trees(Γ₁ ++ Γ₂) → Trees(Γ₁)
    [++]-left {Γ₁}{Γ₂} (trees) ([∈]-[Γ₁]) = trees ([∈][++]-expandᵣ {_}{Γ₁}{Γ₂} [∈]-[Γ₁])

    [++]-right : ∀{Γ₁ Γ₂} → Trees(Γ₁ ++ Γ₂) → Trees(Γ₂)
    [++]-right {Γ₁}{Γ₂} (trees) ([∈]-[Γ₂]) = trees ([∈][++]-expandₗ {_}{Γ₁}{Γ₂} [∈]-[Γ₂])

    [++]-deduplicate : ∀{Γ} → Trees(Γ ++ Γ) → Trees(Γ)
    [++]-deduplicate {Γ} (trees) {γ} = liftᵣ([∈][++]-expandₗ {γ}{Γ}{Γ})(trees{γ})

    [⊰]-reorderₗ : ∀{Γ₁ Γ₂}{φ} → Trees(Γ₁ ++ (φ ⊰ Γ₂)) → Trees(φ ⊰ (Γ₁ ++ Γ₂))
    [⊰]-reorderₗ {Γ₁}{Γ₂}{φ} (Γ₁φΓ₂-trees) = push (φ-tree) ([++]-commute{Γ₂}{Γ₁} Γ₂Γ₁-trees) where
      φΓ₂Γ₁-trees : Trees(φ ⊰ (Γ₂ ++ Γ₁))
      φΓ₂Γ₁-trees = [++]-commute{Γ₁}{φ ⊰ Γ₂} (Γ₁φΓ₂-trees)

      φ-tree : Tree(φ)
      φ-tree = first{Γ₂ ++ Γ₁}{φ} (φΓ₂Γ₁-trees)

      Γ₂Γ₁-trees : Trees(Γ₂ ++ Γ₁)
      Γ₂Γ₁-trees = pop{Γ₂ ++ Γ₁}{φ} (φΓ₂Γ₁-trees)
    -- Γ₁ ++ (φ ⊰ Γ₂) //assumption
    -- (φ ⊰ Γ₂) ++ Γ₁ //Trees.[++]-commute
    -- φ ⊰ (Γ₂ ++ Γ₁) //Definition: (++)
    -- φ ⊰ (Γ₁ ++ Γ₂) //Trees.[++]-commute

    push-many : ∀{Γ₁ Γ₂} → Trees(Γ₁) → Trees(Γ₂) → Trees(Γ₁ ++ Γ₂)
    push-many{∅}     {Γ₂} ([∅]-trees)    ([Γ₂]-trees) = [Γ₂]-trees
    push-many{φ ⊰ Γ₁}{Γ₂} ([φ⊰Γ₁]-trees) ([Γ₂]-trees) = [⊰]-reorderₗ{Γ₁}{Γ₂}{φ} (push-many{Γ₁}{φ ⊰ Γ₂} (pop [φ⊰Γ₁]-trees) (push (first [φ⊰Γ₁]-trees) [Γ₂]-trees))

  -- Derivability
  -- Proof of: If there exists a tree for every formula in Γ, then there exists a tree for the formula φ.
  data _⊢_ (Γ : List(Formula)) (φ : Formula) : Set(ℓₚ) where
    [⊢]-construct : (Trees(Γ) → Tree(φ)) → (Γ ⊢ φ)

  module Theorems where
    [⊢]-from-trees : ∀{Γ₁ Γ₂}{φ} → (Trees(Γ₂) → Trees(Γ₁)) → (Γ₁ ⊢ φ) → (Γ₂ ⊢ φ)
    [⊢]-from-trees (trees-fn) ([⊢]-construct (Γ₁⊢φ)) = [⊢]-construct ((Γ₁⊢φ) ∘ (trees-fn))

    [⊢]-formula-weaken : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ φ₁) → ((φ₂ ⊰ Γ) ⊢ φ₁)
    [⊢]-formula-weaken {_}{_}{φ₂} = [⊢]-from-trees (Trees.pop {_}{φ₂})

    [⊢]-weakenₗ : ∀{Γ₂}{φ} → (Γ₂ ⊢ φ) → ∀{Γ₁} → ((Γ₁ ++ Γ₂) ⊢ φ)
    [⊢]-weakenₗ {_} {_} (Γ₂⊢φ) {∅}       = (Γ₂⊢φ)
    [⊢]-weakenₗ {Γ₂}{φ} (Γ₂⊢φ) {φ₂ ⊰ Γ₁} = [⊢]-formula-weaken {Γ₁ ++ Γ₂} ([⊢]-weakenₗ (Γ₂⊢φ) {Γ₁})

    [⊢]-reorder-[++] : ∀{Γ₁ Γ₂}{φ} → ((Γ₁ ++ Γ₂) ⊢ φ) → ((Γ₂ ++ Γ₁) ⊢ φ)
    [⊢]-reorder-[++] {Γ₁}{Γ₂} = [⊢]-from-trees (Trees.[++]-commute {Γ₂}{Γ₁})

    [⊢]-apply : ∀{Γ}{φ} → (Γ ⊢ φ) → Trees(Γ) → Tree(φ)
    [⊢]-apply ([⊢]-construct [Γ]⊢[φ]) (Γ-trees) = ([Γ]⊢[φ]) (Γ-trees)

    [⊢]-apply-first : ∀{Γ}{φ₁ φ₂} → Tree(φ₁) → ((φ₁ ⊰ Γ) ⊢ φ₂) → (Γ ⊢ φ₂)
    [⊢]-apply-first ([φ₁]-tree) ([⊢]-construct ([φ₁⊰Γ]⊢[φ₂])) =
      [⊢]-construct([Γ]⊢[φ₂] ↦
        ([φ₁⊰Γ]⊢[φ₂]) (Trees.push ([φ₁]-tree) (\{γ} → [Γ]⊢[φ₂] {γ}))
      )

    [⊢]-apply-many : ∀{Γ₁ Γ₂}{φ} → Trees(Γ₁) → ((Γ₁ ++ Γ₂) ⊢ φ) → (Γ₂ ⊢ φ)
    [⊢]-apply-many ([Γ₁]-trees) ([⊢]-construct ([Γ₁++Γ₂]⊢[φ])) =
      [⊢]-construct([Γ₂]⊢[φ] ↦
        ([Γ₁++Γ₂]⊢[φ]) (Trees.push-many ([Γ₁]-trees) (\{γ} → [Γ₂]⊢[φ] {γ}))
      )

    [⊢]-reorderᵣ-[⊰] : ∀{Γ₁ Γ₂}{φ₁ φ₂} → ((Γ₁ ++ (φ₁ ⊰ Γ₂)) ⊢ φ₂) ← ((φ₁ ⊰ (Γ₁ ++ Γ₂)) ⊢ φ₂)
    [⊢]-reorderᵣ-[⊰] {Γ₁}{Γ₂}{φ₁} = [⊢]-from-trees (Trees.[⊰]-reorderₗ {Γ₁}{Γ₂}{φ₁})

    [⊢]-id : ∀{Γ}{φ} → (φ ∈ Γ) → (Γ ⊢ φ)
    [⊢]-id (φ-in) = [⊢]-construct ([∈]-proof ↦ [∈]-proof (φ-in))
    -- ((A → B) → B) → C
    -- f(g ↦ g(x))

    -- Almost like that cut rule.
    [⊢]-compose : ∀{Γ}{φ₁ φ₂} → (Γ ⊢ φ₁) → ((φ₁ ⊰ Γ) ⊢ φ₂) → (Γ ⊢ φ₂)
    [⊢]-compose ([Γ]⊢[φ₁]) ([φ₁Γ]⊢[φ₂]) =
      [⊢]-construct ([Γ]-trees ↦
        let [φ₁]-tree = [⊢]-apply ([Γ]⊢[φ₁]) (\{γ} → [Γ]-trees {γ})
            [Γ]⊢[φ₂]  = [⊢]-apply-first ([φ₁]-tree) ([φ₁Γ]⊢[φ₂])
        in [⊢]-apply ([Γ]⊢[φ₂]) (\{γ} → [Γ]-trees {γ})
      )
    -- TODO: ∀{Γ}{φ₁ φ₂} → (Γ ⊢ φ₁) → ((φ₁ ∈ Γ) → (Γ ⊢ φ₂)) → (Γ ⊢ φ₂) Provable?

    [⊢]-membership-precedingₗ : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∈ Γ) → (Γ ⊢ φ₂)) ← ((φ₁ ⊰ Γ) ⊢ φ₂)
    [⊢]-membership-precedingₗ{Γ}{φ₁}{φ₂} ([φ₁Γ]⊢[φ₂]) ([φ₁]-in) =
      [⊢]-construct([Γ]-trees ↦
        [⊢]-apply ([φ₁Γ]⊢[φ₂]) (Trees.push ([Γ]-trees [φ₁]-in) (\{γ} → [Γ]-trees {γ}))
      )

    {- TODO: Maybe this is unprovable? And also false?
    postulate a : ∀{b : Set(ℓₚ)} → b
    [⊢]-membership-precedingᵣ : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∈ Γ) → (Γ ⊢ φ₂)) → ((φ₁ ⊰ Γ) ⊢ φ₂)
    [⊢]-membership-precedingᵣ{Γ}{φ₁}{φ₂} (incl) =
      [⊢]-construct ([φ₁Γ]-trees ↦
        let [Γ]-trees = Trees.pop (\{γ} → [φ₁Γ]-trees {γ})
            [φ₁]-in = a
            [Γ]⊢[φ₂] = incl([φ₁]-in)
        in [⊢]-apply ([Γ]⊢[φ₂]) ([Γ]-trees)
      )
    -}

    [⊢][⊤]-intro : ∀{Γ} → (Γ ⊢ ⊤)
    [⊢][⊤]-intro =
      [⊢]-construct(const [⊤]-intro)

    [⊢][⊥]-intro : ∀{Γ}{φ} → (φ ∈ Γ) → ((¬ φ) ∈ Γ) → (Γ ⊢ ⊥)
    [⊢][⊥]-intro ([φ]-in) ([¬φ]-in) =
      [⊢]-construct(assumption-trees ↦
        ([⊥]-intro
          (assumption-trees ([φ]-in))
          (assumption-trees ([¬φ]-in))
        )
      )

    [⊢][⊥]-elim : ∀{Γ}{φ} → (⊥ ∈ Γ) → (Γ ⊢ φ)
    [⊢][⊥]-elim ([⊥]-in) =
      [⊢]-construct(assumption-trees ↦
        ([⊥]-elim
          (assumption-trees ([⊥]-in))
        )
      )

    [⊢][¬]-intro : ∀{Γ}{φ} → ((φ ⊰ Γ) ⊢ ⊥) → (Γ ⊢ (¬ φ))
    [⊢][¬]-intro ([⊢]-construct φΓ⊢⊥) =
      [⊢]-construct(assumption-trees ↦
        ([¬]-intro (φ-tree ↦
          (φΓ⊢⊥) (Trees.push (φ-tree) (\{γ} → assumption-trees {γ}))
        ))
      )

    [⊢][¬]-elim : ∀{Γ}{φ} → (((¬ φ) ⊰ Γ) ⊢ ⊥) → (Γ ⊢ φ)
    [⊢][¬]-elim ([⊢]-construct ¬φΓ⊢⊥) =
      [⊢]-construct(assumption-trees ↦
        ([¬]-elim (φ-tree ↦
          (¬φΓ⊢⊥) (Trees.push (φ-tree) (\{γ} → assumption-trees {γ}))
        ))
      )

    [⊢][∧]-intro : ∀{Γ}{φ₁ φ₂} → (φ₁ ∈ Γ) → (φ₂ ∈ Γ) → (Γ ⊢ (φ₁ ∧ φ₂))
    [⊢][∧]-intro ([φ₁]-in) ([φ₂]-in) =
      [⊢]-construct(assumption-trees ↦
        ([∧]-intro
          (assumption-trees ([φ₁]-in))
          (assumption-trees ([φ₂]-in))
        )
      )

    [⊢][∧]-elimₗ : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∧ φ₂) ∈ Γ) → (Γ ⊢ φ₁)
    [⊢][∧]-elimₗ ([φ₁∧φ₂]-in) =
      [⊢]-construct(assumption-trees ↦
        [∧]-elimₗ (assumption-trees ([φ₁∧φ₂]-in))
      )

    [⊢][∧]-elimᵣ : ∀{Γ}{φ₁ φ₂} → ((φ₁ ∧ φ₂) ∈ Γ) → (Γ ⊢ φ₂)
    [⊢][∧]-elimᵣ ([φ₁∧φ₂]-in) =
      [⊢]-construct(assumption-trees ↦
        [∧]-elimᵣ (assumption-trees ([φ₁∧φ₂]-in))
      )

    [⊢][∨]-introₗ : ∀{Γ}{φ₁ φ₂} → (φ₁ ∈ Γ) → (Γ ⊢ (φ₁ ∨ φ₂))
    [⊢][∨]-introₗ ([φ₁]-in) =
      [⊢]-construct(assumption-trees ↦
        [∨]-introₗ (assumption-trees ([φ₁]-in))
      )

    [⊢][∨]-introᵣ : ∀{Γ}{φ₁ φ₂} → (φ₂ ∈ Γ) → (Γ ⊢ (φ₁ ∨ φ₂))
    [⊢][∨]-introᵣ ([φ₂]-in) =
      [⊢]-construct(assumption-trees ↦
        [∨]-introᵣ (assumption-trees ([φ₂]-in))
      )

    [⊢][∨]-elim : ∀{Γ₁ Γ₂}{φ₁ φ₂ φ₃} → ((φ₁ ⊰ Γ₁) ⊢ φ₃) → ((φ₂ ⊰ Γ₂) ⊢ φ₃) → (((φ₁ ∨ φ₂) ⊰ (Γ₁ ++ Γ₂)) ⊢ φ₃)
    [⊢][∨]-elim {Γ₁}{Γ₂} ([⊢]-construct φ₁Γ⊢φ₃) ([⊢]-construct φ₂Γ⊢φ₃) = [⊢]-construct
      (assumption-trees ↦ [∨]-elim
        (φ₁-tree ↦ (φ₁Γ⊢φ₃) (Trees.push (φ₁-tree) (Trees.[++]-left  {Γ₁}{Γ₂} (Trees.pop (\{γ} → assumption-trees {γ})))))
        (φ₂-tree ↦ (φ₂Γ⊢φ₃) (Trees.push (φ₂-tree) (Trees.[++]-right {Γ₁}{Γ₂} (Trees.pop (\{γ} → assumption-trees {γ})))))
        (assumption-trees (use))
      )

    [⊢][⇒]-intro : ∀{Γ}{φ₁ φ₂} → ((φ₁ ⊰ Γ) ⊢ φ₂) → (Γ ⊢ (φ₁ ⇒ φ₂))
    [⊢][⇒]-intro ([⊢]-construct φ₁Γ⊢φ₂) = [⊢]-construct
      (assumption-trees ↦ [⇒]-intro
        (φ-tree ↦ (φ₁Γ⊢φ₂) (Trees.push (φ-tree) (\{γ} → assumption-trees {γ})))
      )

    [⊢][⇒]-elim : ∀{Γ}{φ₁ φ₂} → ((φ₁ ⇒ φ₂) ∈ Γ) → (φ₁ ∈ Γ) → (Γ ⊢ φ₂)
    [⊢][⇒]-elim ([φ₁⇒φ₂]-in) ([φ₁]-in) =
      [⊢]-construct(assumption-trees ↦
        [⇒]-elim
          (assumption-trees ([φ₁⇒φ₂]-in))
          (assumption-trees ([φ₁]-in))
      )

    -- [⊢]-metaᵣ : ∀{a}{b} → _⊢_ a b → Meta._⊢_ a b
    -- [⊢]-metaₗ : ∀{a}{b} → _⊢_ a b ← Meta._⊢_ a b

    {-[⊢]-rules : Meta.[⊢]-rules (_⊢_)
    [⊢]-rules =
      record{
        [⊤]-intro  = \{Γ} → [⊢][⊤]-intro {Γ} ;
        [⊥]-intro  = \{Γ}{φ} → [⊢][⊥]-intro {Γ}{φ} ;
        [⊥]-elim   = \{Γ}{φ} → [⊢][⊥]-elim {Γ}{φ} ;
        [¬]-intro  = \{Γ}{φ} → [⊢][¬]-intro {Γ}{φ} ;
        [¬]-elim   = \{Γ}{φ} → [⊢][¬]-elim {Γ}{φ} ;
        [∧]-intro  = \{Γ}{φ₁}{φ₂} → [⊢][∧]-intro {Γ}{φ₁}{φ₂} ;
        [∧]-elimₗ  = \{Γ}{φ₁}{φ₂} → [⊢][∧]-elimₗ {Γ}{φ₁}{φ₂} ;
        [∧]-elimᵣ  = \{Γ}{φ₁}{φ₂} → [⊢][∧]-elimᵣ {Γ}{φ₁}{φ₂} ;
        [∨]-introₗ = \{Γ}{φ₁}{φ₂} → [⊢][∨]-introₗ {Γ}{φ₁}{φ₂} ;
        [∨]-introᵣ = \{Γ}{φ₁}{φ₂} → [⊢][∨]-introᵣ {Γ}{φ₁}{φ₂} ;
        [∨]-elim   = \{Γ₁}{Γ₂}{φ₁ φ₂ φ₃} → [⊢][∨]-elim {Γ₁}{Γ₂}{φ₁}{φ₂}{φ₃} ;
        [⇒]-intro  = \{Γ}{φ₁}{φ₂} → [⊢][⇒]-intro {Γ}{φ₁}{φ₂} ;
        [⇒]-elim   = \{Γ}{φ₁}{φ₂} → [⊢][⇒]-elim {Γ}{φ₁}{φ₂}
      }
    -}


-- Andreas, 2011-04-11 adapted from Data.Nat.Properties

module FrozenMVar2 where

open import Common.Level
open import Common.Equality

Rel : ∀ {a} → Set a → (ℓ : Level) → Set (a ⊔ lsuc ℓ)
Rel A ℓ = A → A → Set ℓ

Op₂ : ∀ {ℓ} → Set ℓ → Set ℓ
Op₂ A = A → A → A

module FunctionProperties
         {a ℓ} {A : Set a} (_≈_ : Rel A ℓ) where

  Associative : Op₂ A → Set _
  Associative _∙_ = ∀ x y z → ((x ∙ y) ∙ z) ≈ (x ∙ (y ∙ z))

open FunctionProperties _≡_  -- THIS produces frozen metas

data ℕ : Set where
  zℕ : ℕ
  sℕ : (n : ℕ) → ℕ

infixl 6 _+_

_+_ : ℕ → ℕ → ℕ
zℕ   + n = n
sℕ m + n = sℕ (m + n)

+-assoc : Associative _+_
-- +-assoc : ∀ x y z -> ((x + y) + z) ≡ (x + (y + z)) -- this works
+-assoc zℕ     _ _ = refl
+-assoc (sℕ m) n o = cong sℕ (+-assoc m n o)
-- Due to a frozen meta we get:
-- Type mismatch when checking that the pattern zℕ has type _95


{-# OPTIONS --safe #-}
module Cubical.Categories.Functor.Base where

open import Cubical.Foundations.Prelude

open import Cubical.Data.Sigma

open import Cubical.Categories.Category

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

record Functor (C : Category ℓC ℓC') (D : Category ℓD ℓD') :
         Type (ℓ-max (ℓ-max ℓC ℓC') (ℓ-max ℓD ℓD')) where
  no-eta-equality

  open Category

  field
    F-ob  : C .ob → D .ob
    F-hom : {x y : C .ob} → C [ x , y ] → D [ F-ob x , F-ob y ]
    F-id  : {x : C .ob} → F-hom (C .id) ≡ D .id {x = F-ob x}
    F-seq : {x y z : C .ob} (f : C [ x , y ]) (g : C [ y , z ])
          → F-hom (f ⋆⟨ C ⟩ g) ≡ (F-hom f) ⋆⟨ D ⟩ (F-hom g)

  isFull = (x y : _) (F[f] : D [ F-ob x , F-ob y ]) → ∃[ f ∈ C [ x , y ] ] F-hom f ≡ F[f]
  isFaithful = (x y : _) (f g : C [ x , y ]) → F-hom f ≡ F-hom g → f ≡ g
  isEssentiallySurj = (d : D .ob) → Σ[ c ∈ C .ob ] CatIso D (F-ob c) d

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

open Category
open Functor

-- Helpful notation

-- action on objects
infix 30 _⟅_⟆
_⟅_⟆ : (F : Functor C D)
     → C .ob
     → D .ob
_⟅_⟆ = F-ob

-- action on morphisms
infix 30 _⟪_⟫ -- same infix level as on objects since these will never be used in the same context
_⟪_⟫ : (F : Functor C D)
     → ∀ {x y}
     → C [ x , y ]
     → D [(F ⟅ x ⟆) , (F ⟅ y ⟆)]
_⟪_⟫ = F-hom

-- Functor constructions

𝟙⟨_⟩ : ∀ (C : Category ℓ ℓ') → Functor C C
𝟙⟨ C ⟩ .F-ob x    = x
𝟙⟨ C ⟩ .F-hom f   = f
𝟙⟨ C ⟩ .F-id      = refl
𝟙⟨ C ⟩ .F-seq _ _ = refl

-- functor composition
funcComp : ∀ (G : Functor D E) (F : Functor C D) → Functor C E
(funcComp G F) .F-ob c    = G ⟅ F ⟅ c ⟆ ⟆
(funcComp G F) .F-hom f   = G ⟪ F ⟪ f ⟫ ⟫
(funcComp G F) .F-id      = cong (G ⟪_⟫) (F .F-id) ∙ G .F-id
(funcComp G F) .F-seq f g = cong (G ⟪_⟫) (F .F-seq _ _) ∙ G .F-seq _ _

infixr 30 funcComp
syntax funcComp G F = G ∘F F

_^opF : Functor C D → Functor (C ^op) (D ^op)
(F ^opF) .F-ob      = F .F-ob
(F ^opF) .F-hom     = F .F-hom
(F ^opF) .F-id      = F .F-id
(F ^opF) .F-seq f g = F .F-seq g f


module WithInParModule (A : Set) where

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

data Bool : Set where
  true : Bool
  false : Bool

isZero : Nat -> Bool
isZero zero = true
isZero (suc _) = false

f : Nat -> Nat
f n with isZero n
f n | true = zero
f n | false = suc zero

g : Nat -> Nat
g zero = zero
g (suc n) with g n
g (suc n) | zero  = n
g (suc n) | suc _ = n

data T : Set where
  tt : T

module A (x : T) where
  h : T
  h with x
  h | y = y

postulate
  C : T -> Set

test : C (A.h tt) -> C tt
test x = x


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

open import Data.Product using (proj₁ ; proj₂)
open import Level

open import Cats.Category.Base

import Cats.Category.Constructions.Iso as Iso
import Cats.Category.Constructions.Unique as Unique

module Build {lo la l≈} (Cat : Category lo la l≈) where

  open Category Cat
  open Iso.Build Cat
  open Unique.Build Cat

  IsTerminal : Obj → Set (lo ⊔ la ⊔ l≈)
  IsTerminal ⊤ = ∀ X → ∃! X ⊤

  record HasTerminal : Set (lo ⊔ la ⊔ l≈) where
    field
      ⊤ : Obj
      isTerminal : IsTerminal ⊤

    ! : ∀ X → X ⇒ ⊤
    ! X = ∃!′.arr (isTerminal X)

    !-unique : ∀ {X} (f : X ⇒ ⊤) → ! X ≈ f
    !-unique {X} f = ∃!′.unique (isTerminal X) _

    ⇒⊤-unique : ∀ {X} (f g : X ⇒ ⊤) → f ≈ g
    ⇒⊤-unique f g = ≈.trans (≈.sym (!-unique f)) (!-unique g)

    ⊤-unique : ∀ {X} → IsTerminal X → X ≅ ⊤
    ⊤-unique {X} term = record
      { forth = ! X
      ; back = term ⊤ .∃!′.arr
      ; back-forth = ≈.trans (≈.sym (term X .∃!′.unique _)) (term X .∃!′.unique _)
      ; forth-back = ⇒⊤-unique _ _
      }

  terminal-unique : ∀ {X Y} → IsTerminal X → IsTerminal Y → X ≅ Y
  terminal-unique X-term Y-term
    = HasTerminal.⊤-unique (record { isTerminal = Y-term }) X-term

open Build public using (HasTerminal)

private
  open module Build′ {lo la l≈} {C : Category lo la l≈}
    = Build C public using (IsTerminal ; terminal-unique)


module Relation.Ternary.Separation.Morphisms where

open import Level
open import Function
open import Relation.Unary
open import Relation.Binary.PropositionalEquality
open import Relation.Ternary.Separation
open import Data.Product
open import Function using (_∘_)

record Morphism {a b} (A : Set a) (B : Set b)
  {{r : RawSep A}} {u} {{s₁ : IsUnitalSep r u}}
  {{rb : RawSep B}} : Set (a ⊔ suc b) where

  field
    j    : A → B

    -- j "commutes" with _⊎_
    j-⊎  : ∀ {Φ₁ Φ₂ Φ} → Φ₁ ⊎ Φ₂ ≣ Φ → j Φ₁ ⊎ j Φ₂ ≣ j Φ
    j-⊎⁻ : ∀ {Φ₁ Φ₂ Φ} → j Φ₁ ⊎ j Φ₂ ≣ Φ → ∃ λ Φ' → Φ ≡ j Φ' × Φ₁ ⊎ Φ₂ ≣ Φ'

  instance _ = s₁

  infixr 8 _⇒ⱼ_
  _⇒ⱼ_ : ∀ {p q} → Pred A p → Pred B q → Pred A _
  P ⇒ⱼ Q = P ⇒ (Q ∘ j)

  infixr 8 _─✴ⱼ_
  _─✴ⱼ_ : ∀ {p q} → Pred A p → Pred B q → Pred B _
  P ─✴ⱼ Q = P ─✴[ j ] Q

  {- Such a morphism on SAs induces a functor on SA-predicates -}
  module _ where

    data J {p} (P : Pred A p) : Pred B (a ⊔ p) where
      inj : ∀ {Φ} → P Φ → J P (j Φ)

    jstar : ∀ {p q} {P : Pred A p} {Q : Pred A q} → ∀[ J (P ✴ Q) ⇒ J P ✴ J Q ]
    jstar (inj (p ×⟨ σ ⟩ q)) = inj p ×⟨ j-⊎ σ ⟩ inj q

    jmap : ∀ {p q} {P : Pred A p} {Q : Pred A q} → ∀[ (P ─✴ Q) ⇒ⱼ (J P ─✴ J Q) ]
    app (jmap f) (inj px) σ with j-⊎⁻ σ
    ... | _ , refl , σ' = inj (app f px σ')

  wanditⱼ : ∀ {p q} {P : Pred A p} {Q : Pred B q} → ∀[ P ⇒ⱼ Q ] → (P ─✴ⱼ Q) (j u)
  app (wanditⱼ f) px σ with j-⊎⁻ σ
  ... | _ , refl , σ' with ⊎-id⁻ˡ σ'
  ... | refl = f px

{- identity morphism -}
module _ {a} {A : Set a} {{r : RawSep A}} {u} {{s₁ : IsUnitalSep r u}} where

  instance id-morph : Morphism A A
  id-morph = record
    { j   = id
    ; j-⊎ = id
    ; j-⊎⁻ = λ x → -, refl , x
    }


module Oscar.Data.Term.ThickAndThin.internal {𝔣} (FunctionName : Set 𝔣) where

open import Oscar.Class.AlphaConversion
import Oscar.Class.ThickAndThin as ⋆
open import Oscar.Data.Term FunctionName
open import Oscar.Data.Term.Injectivity FunctionName
open import Oscar.Data.Term.AlphaConversion FunctionName
open import Oscar.Data.Equality
open import Oscar.Data.Equality.properties
open import Oscar.Data.Fin
open import Oscar.Data.Fin.ThickAndThin
open import Oscar.Data.Nat
open import Oscar.Data.Vec
open import Oscar.Data.Vec.Injectivity
open import Oscar.Function

private

  Fin⋆thin = ⋆.ThickAndThin.thin ThickAndThinFin
  Fin⋆thick = ⋆.ThickAndThin.thick ThickAndThinFin

thin : ∀ {m} → Fin (suc m) → Term m → Term (suc m)
thin = _◂_ ∘ Fin⋆thin

thins : ∀ {m} → Fin (suc m) → ∀ {N} → Vec (Term m) N → Vec (Term (suc m)) N
thins y = Fin⋆thin y ◂_ -- TODO: make point-free

mutual

  thin-injective : ∀ {m} (y : Fin (suc m)) {τ₁ τ₂ : Term m} → thin y τ₁ ≡ thin y τ₂ → τ₁ ≡ τ₂
  thin-injective y {i _} {i _} eq
    rewrite ⋆.thin-injective y (Term-i-inj eq)
    = refl
  thin-injective y {_ fork _} {_ fork _} eq
    rewrite thin-injective y (Term-forkLeft-inj eq)
          | thin-injective y (Term-forkRight-inj eq)
    = refl
  thin-injective _ {leaf} {leaf} _ = refl
  thin-injective y {function _ _} {function _ _} eq rewrite Term-functionName-inj eq with Term-functionArity-inj eq
  … | refl with Term-functionTerms-inj eq
  … | eq' rewrite (thins-injective y eq') = refl
  thin-injective _ {i _} {leaf} ()
  thin-injective _ {i _} {_ fork _} ()
  thin-injective _ {i _} {function _ _} ()
  thin-injective _ {leaf} {i _} ()
  thin-injective _ {leaf} {_ fork _} ()
  thin-injective _ {leaf} {function _ _} ()
  thin-injective _ {_ fork _} {i _} ()
  thin-injective _ {_ fork _} {leaf} ()
  thin-injective _ {_ fork _} {function _ _} ()
  thin-injective _ {function _ _} {i _} ()
  thin-injective _ {function _ _} {leaf} ()
  thin-injective _ {function _ _} {_ fork _} ()

  thins-injective : ∀ {m} (f : Fin (suc m)) → ∀ {N} {τs₁ τs₂ : Vec (Term m) N} → thins f τs₁ ≡ thins f τs₂ → τs₁ ≡ τs₂
  thins-injective y {_} {[]} {[]} x₁ = refl
  thins-injective y {_} {_ ∷ _} {_ ∷ _} eq
    rewrite thin-injective y (Vec-head-inj eq)
          | thins-injective y (Vec-tail-inj eq)
    = refl

thick : ∀ {m} → Term (suc m) → Fin m → Term m
thick τ = flip _◂_ τ ∘ flip Fin⋆thick

thicks : ∀ {m N} → Terms N (suc m) → Fin m → Terms N m
thicks τ = flip _◂_ τ ∘ flip Fin⋆thick


record category { ℓ₀ ℓ₁ } { k : Set ℓ₀ } (_⇒_ : k → k → Set ℓ₁) : Set (lsuc lzero ⊔ ℓ₀ ⊔ ℓ₁)
record groupoid { ℓ₀ ℓ₁ } { k : Set ℓ₀ } (_≈_ : k → k → Set ℓ₁) : Set (lsuc lzero ⊔ ℓ₀ ⊔ ℓ₁)
record groupoid { ℓ₀ ℓ₁ } { k } _≈_
  where
  coinductive
  field
    ⦃ cat ⦄ : category _≈_
  field
    symmetry : ∀ { x y } → x ≈ y → y ≈ x
record category { ℓ₀ ℓ₁ } { k } _⇒_
  where
  coinductive
  field
    id  : ∀ { a } → a ⇒ a
    _∘_ : ∀ { a b c } → b ⇒ c → a ⇒ b → a ⇒ c
  field
    _≈_ : { a b : k } → (f g : a ⇒ b) → Set
    ⦃ hom ⦄ : { a b : k } → groupoid { k = a ⇒ b } _≈_
  field
    lunit : ∀ { a b }     { x : a ⇒ b }                             → (id ∘ x) ≈ x
    runit : ∀ { a b }     { x : a ⇒ b }                             → (x ∘ id) ≈ x
    assoc : ∀ { a b c d } { x : c ⇒ d } { y : b ⇒ c } { z : a ⇒ b } → (x ∘ (y ∘ z)) ≈ ((x ∘ y) ∘ z)
open category ⦃ ... ⦄
open groupoid ⦃ ... ⦄


-- Mergesort

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

module Algorithms.List.Sort.Merge where

-- agda-stdlib
open import Level
open import Data.Bool using (true; false)
open import Data.List
import      Data.List.Properties as Listₚ
open import Data.Product as Prod
import      Data.Nat as ℕ
open import Data.Nat.Induction as Ind
open import Function.Base
open import Relation.Binary as B
open import Relation.Binary.PropositionalEquality as P using (_≡_)
open import Relation.Nullary
open import Relation.Unary as U
import      Relation.Unary.Properties as Uₚ
open import Induction.WellFounded

private
  variable
    a p r : Level

module Mergesort {A : Set a} {_≤_ : Rel A r} (_≤?_ : B.Decidable _≤_) where
  merge′ : A → A → List A → List A → List A
  merge′ x y xs ys with x ≤? y
  merge′ x y []        ys | true  because _ = x ∷ y ∷ ys
  merge′ x y (x₁ ∷ xs) ys | true  because _ = x ∷ merge′ x₁ y xs ys
  merge′ x y xs []        | false because _ = y ∷ x ∷ xs
  merge′ x y xs (y₁ ∷ ys) | false because _ = y ∷ merge′ x y₁ xs ys

  merge : List A → List A → List A
  merge []       ys       = ys
  merge (x ∷ xs) []       = x ∷ xs
  merge (x ∷ xs) (y ∷ ys) = merge′ x y xs ys

  _L<_ : Rel (List A) _
  _L<_ = ℕ._<_ on length

  L<-wf : WellFounded _L<_
  L<-wf = InverseImage.wellFounded length Ind.<-wellFounded

  split : List A → (List A × List A)
  split []           = [] , []
  split (x ∷ [])     = [ x ] , []
  split (x ∷ y ∷ xs) = Prod.map (x ∷_) (y ∷_) (split xs)
{-
  sort : List A → List A
  sort [] = []
  sort (x ∷ xs) = {!   !}
  sort xs = split xs
  ys , zs = merge (sort ys) (sort zs)
-}


{-# OPTIONS --without-K --safe #-}
module Categories.Functor.Limits where

open import Level

open import Categories.Category
open import Categories.Functor
open import Categories.Functor.Properties
open import Categories.Object.Terminal
open import Categories.Object.Initial

open import Categories.Diagram.Limit
open import Categories.Diagram.Colimit
open import Categories.Diagram.Cone.Properties
open import Categories.Diagram.Cocone.Properties

open import Categories.Category.Construction.Cones
open import Categories.Category.Construction.Cocones

private
  variable
    o ℓ e : Level
    𝒞 𝒟 ℐ : Category o ℓ e

module _ (F : Functor 𝒞 𝒟) {J : Functor ℐ 𝒞} where

  PreservesLimit : (L : Limit J) → Set _
  PreservesLimit L = IsTerminal (Cones (F ∘F J)) (F-map-Coneˡ F limit)
    where open Limit L

  PreservesColimit : (L : Colimit J) → Set _
  PreservesColimit L = IsInitial (Cocones (F ∘F J)) (F-map-Coconeˡ F colimit)
    where open Colimit L

  ReflectsLimits : Set _
  ReflectsLimits = ∀ (K : Cone J) → IsTerminal (Cones (F ∘F J)) (F-map-Coneˡ F K) → IsTerminal (Cones J) K

  ReflectsColimits : Set _
  ReflectsColimits = ∀ (K : Cocone J) → IsInitial (Cocones (F ∘F J)) (F-map-Coconeˡ F K) → IsInitial (Cocones J) K

--   record CreatesLimits : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′ ⊔ o″ ⊔ ℓ″) where
--     field
--       preserves-limits : PreservesLimit
--       reflects-limits  : ReflectsLimits

--   record CreatesColimits : Set (o ⊔ ℓ ⊔ e ⊔ o′ ⊔ ℓ′ ⊔ e′ ⊔ o″ ⊔ ℓ″) where
--     field
--       preserves-colimits : PreservesColimit
--       reflects-colimits  : ReflectsColimits

Continuous : ∀ o ℓ e → (F : Functor 𝒞 𝒟) → Set _
Continuous {𝒞 = 𝒞} o ℓ e F = ∀ {𝒥 : Category o ℓ e} {J : Functor 𝒥 𝒞} (L : Limit J) → PreservesLimit F L

Cocontinuous : ∀ o ℓ e → (F : Functor 𝒞 𝒟) → Set _
Cocontinuous {𝒞 = 𝒞} o ℓ e F = ∀ {𝒥 : Category o ℓ e} {J : Functor 𝒥 𝒞} (L : Colimit J) → PreservesColimit F L


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

-- Given a predicate on the objects of a Category C, build another category
-- with just those that satisfy a pr

module Categories.Category.Construction.ObjectRestriction where

open import Level
open import Data.Product using (Σ; proj₁)
open import Relation.Unary using (Pred)
open import Function using (_on_) renaming (id to id→)

open import Categories.Category.Core

private
  variable
    o ℓ e ℓ′ : Level

ObjectRestriction : (C : Category o ℓ e) → Pred (Category.Obj C) ℓ′ → Category (o ⊔ ℓ′) ℓ e
ObjectRestriction C R = record
  { Obj = Σ Obj R
  ; _⇒_ = _⇒_ on proj₁
  ; _≈_ = _≈_
  ; id = id
  ; _∘_ = _∘_
  ; assoc = assoc
  ; sym-assoc = sym-assoc
  ; identityˡ = identityˡ
  ; identityʳ = identityʳ
  ; identity² = identity²
  ; equiv = equiv
  ; ∘-resp-≈ = ∘-resp-≈
  }
  where open Category C


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

open import Level

-- ⊥ is Initial

module Categories.Category.Instance.Zero where

open import Data.Empty using (⊥; ⊥-elim)
open import Function renaming (id to idf)

open import Categories.Category
open import Categories.Functor
open import Categories.Category.Instance.Cats
import Categories.Object.Initial as Init

-- Unlike for ⊤ being Terminal, Agda can't deduce these, need to be explicit
module _ {o ℓ e : Level} where
  open Init (Cats o ℓ e)

  Zero : Category o ℓ e
  Zero = record
    { Obj       = Lift o ⊥
    ; _⇒_       = λ _ _ → Lift ℓ ⊥
    ; _≈_       = λ _ _ → Lift e ⊥
    ; id        = λ { { lift () } }
    ; _∘_       = λ a _ → a -- left-biased rather than strict
    ; assoc     = λ { {lift () } }
    ; sym-assoc = λ { {lift () } }
    ; identityˡ = λ { {()} }
    ; identityʳ = λ { {()} }
    ; identity² = λ { {()} }
    ; ∘-resp-≈  = λ { () }
    ; equiv     = record
      { refl = λ { {()} }
      ; sym = idf
      ; trans = λ a _ → a
      }
    }

  Zero-⊥ : Initial
  Zero-⊥ = record
    { ⊥ = Zero
    ; ! = record
      { F₀ = λ { (lift x) → ⊥-elim x }
      ; F₁ = λ { (lift ()) }
      ; identity = λ { {lift ()} }
      ; homomorphism = λ { {lift ()} }
      ; F-resp-≈ = λ { () }
      }
    ; !-unique = λ f → record
      { F⇒G = record { η = λ { () } ; commute = λ { () } ; sym-commute = λ { () } }
      ; F⇐G = record { η = λ { () } ; commute = λ { () } ; sym-commute = λ { () } }
      ; iso = λ { (lift ()) }
      }
    }


{-# OPTIONS --safe #-}
module Relation.Ternary.Separation.Construct.List {a} (A : Set a) where

open import Level
open import Data.Product
open import Data.List
open import Data.List.Properties using (++-isMonoid)
open import Data.List.Relation.Ternary.Interleaving.Propositional as I public
open import Data.List.Relation.Ternary.Interleaving.Properties
open import Data.List.Relation.Binary.Equality.Propositional
open import Data.List.Relation.Binary.Permutation.Inductive

open import Relation.Binary.PropositionalEquality as P hiding ([_])
open import Relation.Unary hiding (_∈_; _⊢_)
open import Relation.Ternary.Separation

private C = List A

instance separation : RawSep C
separation = record { _⊎_≣_ = Interleaving }

-- TODO add to stdlib
interleaving-assoc : ∀ {a b ab c abc : List A} →
          Interleaving a b ab → Interleaving ab c abc →
          ∃ λ bc → Interleaving a bc abc × Interleaving b c bc
interleaving-assoc l (consʳ r)         = let _ , p , q = interleaving-assoc l r in -, consʳ p , consʳ q
interleaving-assoc (consˡ l) (consˡ r) = let _ , p , q = interleaving-assoc l r in -, consˡ p , q
interleaving-assoc (consʳ l) (consˡ r) = let _ , p , q = interleaving-assoc l r in -, consʳ p , consˡ q
interleaving-assoc [] []               = [] , [] , []

instance list-has-sep : IsSep separation
list-has-sep = record
  { ⊎-comm = I.swap
  ; ⊎-assoc = interleaving-assoc
  }

instance list-is-unital : IsUnitalSep _ _
IsUnitalSep.isSep list-is-unital               = list-has-sep
IsUnitalSep.⊎-idˡ list-is-unital               = right (≡⇒≋ P.refl)
IsUnitalSep.⊎-id⁻ˡ list-is-unital []           = refl
IsUnitalSep.⊎-id⁻ˡ list-is-unital (refl ∷ʳ px) = cong (_ ∷_) (⊎-id⁻ˡ px)

instance list-has-concat : IsConcattative separation
IsConcattative._∙_ list-has-concat = _++_
IsConcattative.⊎-∙ₗ list-has-concat {Φₑ = []} ps = ps
IsConcattative.⊎-∙ₗ list-has-concat {Φₑ = x ∷ Φₑ} ps = consˡ (⊎-∙ₗ ps)

instance list-unitalsep : UnitalSep _
list-unitalsep = record
  { isUnitalSep = list-is-unital }

instance list-resource : MonoidalSep _
list-resource = record
  { sep = separation
  ; isSep = list-has-sep
  ; isUnitalSep   = list-is-unital
  ; isConcat      = list-has-concat
  ; monoid = ++-isMonoid }

instance list-positive : IsPositive separation
list-positive = record
  { ⊎-εˡ = λ where [] → refl }


module Dave.LeibnizEquality where
    open import Dave.Equality public

    _≐_ : ∀ {A : Set} (x y : A) → Set₁
    _≐_ {A} x y = ∀ (P : A → Set) → P x → P y

    refl-≐ : ∀ {A : Set} {x : A} → x ≐ x
    refl-≐ P Px = Px

    trans-≐ : ∀ {A : Set} {x y z : A} → x ≐ y → y ≐ z → x ≐ z
    trans-≐ x≐y y≐z P Px = y≐z P (x≐y P Px)

    sym-≐ : ∀ {A : Set} {x y : A} → x ≐ y → y ≐ x
    sym-≐ {A} {x} {y} x≐y P = Qy
        where
            Q : A → Set
            Q z = P z → P x
            Qx : Q x
            Qx = refl-≐ P
            Qy : Q y
            Qy = x≐y Q Qx

    ≡→≐ : ∀ {A : Set} {x y : A} → x ≡ y → x ≐ y
    ≡→≐ x≡y P = subst P x≡y

    ≐→≡ : ∀ {A : Set} {x y : A} → x ≐ y → x ≡ y
    ≐→≡ {A} {x} {y} x≐y = Qy
        where
            Q : A → Set
            Q z = x ≡ z
            Qx : Q x
            Qx = refl
            Qy : Q y
            Qy = x≐y Q Qx


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

-- Category where all arrows are inhabited by a single element
open import Level
open import Data.Unit

open import Categories.Category

open import Relation.Binary.PropositionalEquality as ≡

Indiscrete : ∀ {o ℓ} (A : Set o) → Category o ℓ ℓ
Indiscrete {_} {ℓ} A = record
  { Obj       = A
  ; _⇒_       = λ _ _ → Lift ℓ ⊤
  ; _≈_       = _≡_
  ; id        = _
  ; _∘_       = _
  ; assoc     = refl
  ; sym-assoc = refl
  ; identityˡ = refl
  ; identityʳ = refl
  ; identity² = refl
  ; equiv     = isEquivalence
  ; ∘-resp-≈  = λ where
    refl refl → refl
  }


module Integer.Difference where

open import Data.Product as Σ
open import Data.Product.Relation.Pointwise.NonDependent
open import Data.Unit
open import Equality
open import Natural as ℕ
open import Quotient as /
open import Relation.Binary
open import Syntax

infixl 6 _–_
pattern _–_ a b = _,_ a b

⟦ℤ⟧ = ℕ × ℕ
⟦ℤ²⟧ = ⟦ℤ⟧ × ⟦ℤ⟧

_≈_ : ⟦ℤ⟧ → ⟦ℤ⟧ → Set
(a – b) ≈ (c – d) = a + d ≡ c + b

≈-refl : ∀ {x} → x ≈ x
≈-refl = refl

ℤ = ⟦ℤ⟧ / _≈_
ℤ² = ⟦ℤ²⟧ / Pointwise _≈_ _≈_

instance
  ⟦ℤ⟧-Number : Number ⟦ℤ⟧
  ⟦ℤ⟧-Number = record { Constraint = λ _ → ⊤ ; fromNat = λ x → x – 0 }

  ℤ-Number : Number ℤ
  ℤ-Number = record { Constraint = λ _ → ⊤ ; fromNat = λ x → ⟦ fromNat x ⟧ }

  ⟦ℤ⟧-Negative : Negative ⟦ℤ⟧
  ⟦ℤ⟧-Negative = record { Constraint = λ _ → ⊤ ; fromNeg = λ x → 0 – x }

  ℤ-Negative : Negative ℤ
  ℤ-Negative = record { Constraint = λ _ → ⊤ ; fromNeg = λ x → ⟦ fromNeg x ⟧ }

suc–suc-injective : ∀ a b → Path ℤ ⟦ suc a – suc b ⟧ ⟦ a – b ⟧
suc–suc-injective a b = equiv (suc a – suc b) (a – b) (sym (+-suc a b ))

⟦negate⟧ : ⟦ℤ⟧ → ⟦ℤ⟧
⟦negate⟧ (a – b) = b – a

negate : ℤ → ℤ
negate =
  ⟦negate⟧ // λ where
    (a – b) (c – d) p →
      ⟨ +-comm b c ⟩ ≫ sym p ≫ ⟨ +-comm a d ⟩

⟦plus⟧ : ⟦ℤ²⟧ → ⟦ℤ⟧
⟦plus⟧ ((a – b) , (c – d)) = (a + c) – (d + b)

plus : ℤ² → ℤ
plus =
  ⟦plus⟧ // λ where
    ((a – b) , (c – d)) ((e – f) , (g – h)) (p , q) →
        (a + c) + (h + f)
      ≡⟨ sym (ℕ.+-assoc a _ _) ⟩
        a + (c + (h + f))
      ≡⟨ cong (a +_) (ℕ.+-assoc c _ _) ⟩
        a + ((c + h) + f)
      ≡⟨ cong (λ z → a + (z + f)) q ⟩
        a + ((g + d) + f)
      ≡⟨ cong (a +_) ⟨ ℕ.+-comm (g + d) _ ⟩ ⟩
        a + (f + (g + d))
      ≡⟨ ℕ.+-assoc a _ _ ⟩
        (a + f) + (g + d)
      ≡⟨ cong (_+ (g + d)) p ⟩
        (e + b) + (g + d)
      ≡⟨ ℕ.+-cross e _ _ _ ⟩
        (e + g) + (b + d)
      ≡⟨ cong ((e + g) +_) ⟨ ℕ.+-comm b _ ⟩ ⟩
        (e + g) + (d + b)
      ∎

instance
  ⟦ℤ⟧-plus-syntax : plus-syntax-simple ⟦ℤ⟧ ⟦ℤ⟧ ⟦ℤ⟧
  ⟦ℤ⟧-plus-syntax = λ where ._+_ x y → ⟦plus⟧ (x , y)

  ⟦ℤ⟧-minus-syntax : minus-syntax-simple ⟦ℤ⟧ ⟦ℤ⟧ ⟦ℤ⟧
  ⟦ℤ⟧-minus-syntax = λ where ._-_ x y → ⟦plus⟧ (x , ⟦negate⟧ y)

  ℕ-⟦ℤ⟧-minus-syntax : minus-syntax-simple ℕ ℕ ⟦ℤ⟧
  ℕ-⟦ℤ⟧-minus-syntax = λ where ._-_ → _–_

  ℤ-plus-syntax : plus-syntax-simple ℤ ℤ ℤ
  ℤ-plus-syntax = λ where ._+_ → /.uncurry refl refl plus

  ℤ-minus-syntax : minus-syntax-simple ℤ ℤ ℤ
  ℤ-minus-syntax = λ where ._-_ x y → x + negate y

  ℕ-ℤ-minus-syntax : minus-syntax-simple ℕ ℕ ℤ
  ℕ-ℤ-minus-syntax = λ where ._-_ x y → ⟦ x – y ⟧


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

module Data.Nat.PredExp2 where

open import Data.Nat
open import Data.Nat.Properties

open import Relation.Nullary
open import Relation.Nullary.Negation
open import Relation.Binary
open import Relation.Binary.PropositionalEquality as Eq using (_≡_; refl; _≢_; module ≡-Reasoning)

open import Data.Nat.Log2 using (⌈log₂_⌉)

pred[2^_] : ℕ → ℕ
pred[2^ n ] = pred (2 ^ n)

lemma/2^suc : ∀ n → 2 ^ n + 2 ^ n ≡ 2 ^ suc n
lemma/2^suc n =
  begin
    2 ^ n + 2 ^ n
  ≡˘⟨ Eq.cong ((2 ^ n) +_) (*-identityˡ (2 ^ n)) ⟩
    2 ^ n + (2 ^ n + 0)
  ≡⟨⟩
    2 ^ n + (2 ^ n + 0 * (2 ^ n))
  ≡⟨⟩
    2 * (2 ^ n)
  ≡⟨⟩
    2 ^ suc n
  ∎
    where open ≡-Reasoning

private
  lemma/1≤2^n : ∀ n → 1 ≤ 2 ^ n
  lemma/1≤2^n zero    = ≤-refl {1}
  lemma/1≤2^n (suc n) =
    begin
      1
    ≤⟨ s≤s z≤n ⟩
      1 + 1
    ≤⟨ +-mono-≤ (lemma/1≤2^n n) (lemma/1≤2^n n) ⟩
      2 ^ n + 2 ^ n
    ≡⟨ lemma/2^suc n ⟩
      2 ^ suc n
    ∎
      where open ≤-Reasoning

  lemma/2^n≢0 : ∀ n → 2 ^ n ≢ zero
  lemma/2^n≢0 n 2^n≡0 with 2 ^ n | lemma/1≤2^n n
  ... | zero | ()

pred[2^]-mono : pred[2^_] Preserves _≤_ ⟶ _≤_
pred[2^]-mono m≤n = pred-mono (2^-mono m≤n)
  where
    2^-mono : (2 ^_) Preserves _≤_ ⟶ _≤_
    2^-mono {y = y} z≤n = lemma/1≤2^n y
    2^-mono (s≤s m≤n) = *-monoʳ-≤ 2 (2^-mono m≤n)

pred[2^suc[n]] : (n : ℕ) → suc (pred[2^ n ] + pred[2^ n ]) ≡ pred[2^ suc n ]
pred[2^suc[n]] n =
  begin
    suc (pred[2^ n ] + pred[2^ n ])
  ≡⟨⟩
    suc (pred (2 ^ n) + pred (2 ^ n))
  ≡˘⟨ +-suc (pred (2 ^ n)) (pred (2 ^ n)) ⟩
    pred (2 ^ n) + suc (pred (2 ^ n))
  ≡⟨ Eq.cong (pred (2 ^ n) +_) (suc[pred[n]]≡n (lemma/2^n≢0 n)) ⟩
    pred (2 ^ n) + 2 ^ n
  ≡⟨ lemma/pred-+ (2 ^ n) (2 ^ n) (lemma/2^n≢0 n) ⟩
    pred (2 ^ n + 2 ^ n)
  ≡⟨ Eq.cong pred (lemma/2^suc n) ⟩
    pred (2 ^ suc n)
  ≡⟨⟩
    pred[2^ suc n ]
  ∎
    where
      open ≡-Reasoning

      lemma/pred-+ : ∀ m n → m ≢ zero → pred m + n ≡ pred (m + n)
      lemma/pred-+ zero    n m≢zero = contradiction refl m≢zero
      lemma/pred-+ (suc m) n m≢zero = refl

pred[2^log₂] : (n : ℕ) → pred[2^ ⌈log₂ suc ⌈ n /2⌉ ⌉ ] ≤ n
pred[2^log₂] n = strong-induction n n ≤-refl
  where
    strong-induction : (n m : ℕ) → m ≤ n → pred[2^ ⌈log₂ suc ⌈ m /2⌉ ⌉ ] ≤ m
    strong-induction n zero    h = z≤n
    strong-induction n (suc zero) h = s≤s z≤n
    strong-induction (suc (suc n)) (suc (suc m)) (s≤s (s≤s h)) =
      begin
        pred[2^ ⌈log₂ suc ⌈ suc (suc m) /2⌉ ⌉ ]
      ≡⟨⟩
        pred[2^ suc ⌈log₂ ⌈ suc ⌈ suc (suc m) /2⌉ /2⌉ ⌉ ]
      ≡˘⟨ pred[2^suc[n]] ⌈log₂ ⌈ suc ⌈ suc (suc m) /2⌉ /2⌉ ⌉ ⟩
        suc (pred[2^ ⌈log₂ ⌈ suc ⌈ suc (suc m) /2⌉ /2⌉ ⌉ ] + pred[2^ ⌈log₂ ⌈ suc ⌈ suc (suc m) /2⌉ /2⌉ ⌉ ])
      ≡⟨⟩
        suc (pred[2^ ⌈log₂ ⌈ suc (suc ⌈ m /2⌉) /2⌉ ⌉ ] + pred[2^ ⌈log₂ ⌈ suc (suc ⌈ m /2⌉) /2⌉ ⌉ ])
      ≡⟨⟩
        suc (pred[2^ ⌈log₂ suc ⌈ ⌈ m /2⌉ /2⌉ ⌉ ] + pred[2^ ⌈log₂ suc ⌈ ⌈ m /2⌉ /2⌉ ⌉ ])
      ≤⟨
        s≤s (
          +-mono-≤
            (strong-induction (suc n) ⌈ m /2⌉ (≤-trans (⌊n/2⌋≤n (suc m)) (s≤s h)))
            (strong-induction (suc n) ⌈ m /2⌉ (≤-trans (⌊n/2⌋≤n (suc m)) (s≤s h)))
        )
      ⟩
        suc (⌈ m /2⌉ + ⌈ m /2⌉)
      ≡⟨⟩
        suc (⌊ suc m /2⌋ + ⌈ m /2⌉)
      ≤⟨ s≤s (+-monoʳ-≤ ⌊ suc m /2⌋ (⌈n/2⌉-mono (n≤1+n m))) ⟩
        suc (⌊ suc m /2⌋ + ⌈ suc m /2⌉)
      ≡⟨ Eq.cong suc (⌊n/2⌋+⌈n/2⌉≡n (suc m)) ⟩
        suc (suc m)
      ∎
        where open ≤-Reasoning


module Relation.Equality.Extensionality where

open import Relation.Equality
open import Data.Inductive.Higher.Interval
open import Relation.Path.Operation

funext : ∀ {a b}{A : Set a}{B : A → Set b}{f g : (x : A) → B x} → (∀ x → f x ≡ g x) → f ≡ g
funext {A = A}{B = B} {f = f}{g = g} p = ap {f = h} path-seg
  where
    h : I → (x : A) → B x
    h i x = interval-rec (f x) (g x) (p x) i


module Extensions.Bool where

open import Data.Unit
open import Data.Bool
open import Relation.Nullary public using (yes; no; ¬_; Dec)

data All {p} (P : Set p) : Bool → Set p where
  true  : P → All P true
  false : All P false

data Any {p} (P : Set p) : Bool → Set p where
  true  : P → Any P true

all-map : ∀ {p} {P Q : Set p} {b} → All P b → (f : P → Q) → All Q b
all-map (true x) f = true (f x)
all-map false f = false

Is-true : Bool → Set
Is-true t = Any ⊤ t

is-yes : ∀ {a} {A : Set a} → Dec A → Bool
is-yes (yes p) = true
is-yes (no ¬p) = false


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

module Relation.Binary.Construct.Closure.SymmetricTransitive where

open import Level
open import Function
open import Relation.Binary

private
  variable
    a ℓ ℓ′ : Level
    A B    : Set a

module _ {A : Set a} (_≤_ : Rel A ℓ) where
  private
    variable
      x y z : A

  data Plus⇔ : Rel A (a ⊔ ℓ) where
    forth  : x ≤ y → Plus⇔ x y
    back   : y ≤ x → Plus⇔ x y
    forth⁺ : x ≤ y → Plus⇔ y z → Plus⇔ x z
    back⁺  : y ≤ x → Plus⇔ y z → Plus⇔ x z

module _ (_∼_ : Rel A ℓ) where

  trans : Transitive (Plus⇔ _∼_)
  trans (forth r) rel′      = forth⁺ r rel′
  trans (back r) rel′       = back⁺ r rel′
  trans (forth⁺ r rel) rel′ = forth⁺ r (trans rel rel′)
  trans (back⁺ r rel) rel′  = back⁺ r (trans rel rel′)

  sym : Symmetric (Plus⇔ _∼_)
  sym (forth r)      = back r
  sym (back r)       = forth r
  sym (forth⁺ r rel) = trans (sym rel) (back r)
  sym (back⁺ r rel)  = trans (sym rel) (forth r)

  isPartialEquivalence : IsPartialEquivalence (Plus⇔ _∼_)
  isPartialEquivalence = record
    { sym   = sym
    ; trans = trans
    }

  partialSetoid : PartialSetoid _ _
  partialSetoid = record
    { Carrier              = A
    ; _≈_                  = Plus⇔ _∼_
    ; isPartialEquivalence = isPartialEquivalence
    }

  module _ (refl : Reflexive _∼_) where

    isEquivalence : IsEquivalence (Plus⇔ _∼_)
    isEquivalence = record
      { refl  = forth refl
      ; sym   = sym
      ; trans = trans
      }

    setoid : Setoid _ _
    setoid = record
      { Carrier       = A
      ; _≈_           = Plus⇔ _∼_
      ; isEquivalence = isEquivalence
      }

  module _ {c e} (S : Setoid c e) where
    private
      module S = Setoid S

    minimal : (f : A → Setoid.Carrier S) →
              _∼_ =[ f ]⇒ Setoid._≈_ S →
              Plus⇔ _∼_ =[ f ]⇒ Setoid._≈_ S
    minimal f inj (forth r)      = inj r
    minimal f inj (back r)       = S.sym (inj r)
    minimal f inj (forth⁺ r rel) = S.trans (inj r) (minimal f inj rel)
    minimal f inj (back⁺ r rel)  = S.trans (S.sym (inj r)) (minimal f inj rel)

module Plus⇔Reasoning (_≤_ : Rel A ℓ) where
  infix  3 forth-syntax back-syntax
  infixr 2 forth⁺-syntax back⁺-syntax

  forth-syntax : ∀ x y → x ≤ y → Plus⇔ _≤_ x y
  forth-syntax _ _ = forth

  syntax forth-syntax x y x≤y = x ⇒⟨ x≤y ⟩∎ y ∎

  back-syntax : ∀ x y → y ≤ x → Plus⇔ _≤_ x y
  back-syntax _ _ = back

  syntax back-syntax x y y≤x = x ⇐⟨ y≤x ⟩∎ y ∎

  forth⁺-syntax : ∀ x {y z} → x ≤ y → Plus⇔ _≤_ y z → Plus⇔ _≤_ x z
  forth⁺-syntax _ = forth⁺

  syntax forth⁺-syntax x x≤y y⇔z = x ⇒⟨ x≤y ⟩ y⇔z

  back⁺-syntax : ∀ x {y z} → y ≤ x → Plus⇔ _≤_ y z → Plus⇔ _≤_ x z
  back⁺-syntax _ = back⁺

  syntax back⁺-syntax x y≤x y⇔z = x ⇐⟨ y≤x ⟩ y⇔z

module _ {_≤_ : Rel A ℓ} {_≼_ : Rel B ℓ′} (f : A → B) where

  module _ (inj : _≤_ =[ f ]⇒ _≼_) where

    gmap : Plus⇔ _≤_ =[ f ]⇒ Plus⇔ _≼_
    gmap (forth r)      = forth (inj r)
    gmap (back r)       = back (inj r)
    gmap (forth⁺ r rel) = forth⁺ (inj r) (gmap rel)
    gmap (back⁺ r rel)  = back⁺ (inj r) (gmap rel)

map : {_≤_ : Rel A ℓ} {_≼_ : Rel A ℓ′} (inj : _≤_ ⇒ _≼_) → Plus⇔ _≤_ ⇒ Plus⇔ _≼_
map = gmap id


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

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

single : {m n : Nat} → suc m ≡ suc n → n ≡ m
single p with refl ← p = refl

double : {m n p : Nat} → suc m ≡ n → suc n ≡ 2 + p → m ≡ p
double p q with refl ← p | refl ← q = refl

_∋_ : (A : Set) → A → A
A ∋ a = a

-- The second equality proof is only well-typed
-- after the first one has been used

tele : {m n : Nat} → suc m ≡ suc n → m ≡ n
tele {m} {n} p
  with refl ← p
  with refl ← (n ≡ m) ∋ refl
       = refl

tele' : {m n : Nat} → m ≡ n → m ≡ n
tele' {m} {n} p with refl ← p with (n ≡ m) ∋ refl
... | q = refl

-- Further splitting after a using & with

tele'' : {m n : Nat} → m ≡ n → Nat → Nat
tele'' {m} {n} p r with refl ← p | (n ≡ m) ∋ refl
tele'' {m} {m} p zero    | q = m
tele'' {m} {m} p (suc r) | q = r

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

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

  head : Vec A (suc n) → A
  head xs with (x ∷ _) ← xs = x

  tail : Vec A (suc n) → Vec A n
  tail xs with (_ ∷ xs) ← xs = xs -- pattern shadows variable with'd on

castVec : ∀ {m n} → m ≡ n → Vec Nat m → Vec Nat n
castVec eq ms with refl ← eq = ms

data All (P : Nat → Set) : ∀ {n} → Vec Nat n → Set where
  []  : All P []
  _∷_ : ∀ {n x xs} → P x → All P {n} xs → All P (x ∷ xs)

open import Agda.Builtin.Sigma

castAll : ∀ {P m n xs ys} → Σ (m ≡ n) (λ eq → castVec eq xs ≡ ys) →
          All P xs → All P ys
castAll (refl , refl) all = all

-- faking rewrite with the dependent irrefutable with
postulate +-comm : ∀ m n → m + n ≡ n + m

rew : ∀ m n p q → m + (p + q) + n ≡ m + (q + p) + n
rew m n p q with p+q ← p + q | refl ← +-comm p q {- : p + q ≡ q + p -} = refl

-- Note that the following does not work because
-- p+q is not abstracted over in `+-comm p q` which means
-- Agda gets stuck trying to unify `p + q` and `q + p`

-- Cf. test/Fail/UsingEq.agda

-- rew' : ∀ m n p q → m + (p + q) + n ≡ m + (q + p) + n
-- rew' m n p q with p+q ← p + q with refl ← +-comm p q = refl


{-# OPTIONS --universe-polymorphism #-}
module Categories.Support.PropositionalEquality where

open import Function using (flip; id)
open import Relation.Binary.PropositionalEquality public using () renaming (_≡_ to _≣_; refl to ≣-refl; trans to ≣-trans; sym to ≣-sym; cong to ≣-cong; cong₂ to ≣-cong₂; subst to ≣-subst; subst₂ to ≣-subst₂; isEquivalence to ≣-isEquivalence; setoid to ≣-setoid)

module ≣-reasoning = Relation.Binary.PropositionalEquality.≡-Reasoning renaming (_≡⟨_⟩_ to _≣⟨_⟩_)

≣-app : ∀ {a} {A : Set a} {b} {B : A → Set b} {f g : (x : A) → B x} → f ≣ g → (x : A) → f x ≣ g x
≣-app {f = f} {g} = flip (λ x → ≣-cong (flip id x))

≣-appʰ : ∀ {a} {A : Set a} {b} {B : A → Set b} {f g : ∀ {x} → B x} → (λ {x} → f) ≣ g → ∀ {x} → f {x} ≣ g {x}
≣-appʰ {f = f} {g} = λ pf {x} → ≣-cong (λ h → h {x}) pf

≣-subst₂-breakdown-lr : ∀ {a} {A : Set a} {b} {B : Set b} {ℓ} (f : A → B → Set ℓ) {a₁ a₂ : A} (a₁≣a₂ : a₁ ≣ a₂) {b₁ b₂ : B} (b₁≣b₂ : b₁ ≣ b₂) (x : f a₁ b₁) → ≣-subst₂ f a₁≣a₂ b₁≣b₂ x ≣ ≣-subst (f a₂) b₁≣b₂ (≣-subst (λ y → f y b₁) a₁≣a₂ x)
≣-subst₂-breakdown-lr f ≣-refl ≣-refl x = ≣-refl

≣-subst₂-breakdown-rl : ∀ {a} {A : Set a} {b} {B : Set b} {ℓ} (f : A → B → Set ℓ) {a₁ a₂ : A} (a₁≣a₂ : a₁ ≣ a₂) {b₁ b₂ : B} (b₁≣b₂ : b₁ ≣ b₂) (x : f a₁ b₁) → ≣-subst₂ f a₁≣a₂ b₁≣b₂ x ≣ ≣-subst (λ y → f y b₂) a₁≣a₂ (≣-subst (f a₁) b₁≣b₂ x)
≣-subst₂-breakdown-rl f ≣-refl ≣-refl x = ≣-refl

≣-subst-trans : ∀ {a} {A : Set a} {ℓ} (f : A → Set ℓ) {a₁ a₂ a₃ : A} (a₁≣a₂ : a₁ ≣ a₂) (a₂≣a₃ : a₂ ≣ a₃) (x : f a₁) → ≣-subst f (≣-trans a₁≣a₂ a₂≣a₃) x ≣ ≣-subst f a₂≣a₃ (≣-subst f a₁≣a₂ x)
≣-subst-trans f ≣-refl ≣-refl x = ≣-refl

≣-cong₂₊ : ∀ {a b c r} {A : Set a} {B : Set b} {C : A → B → Set c} {R : Set r} (f : (x : A) → (u : B) → .(z : C x u) → R) {x y : A} {u v : B} .(z : C x u) → (x≣y : x ≣ y) (u≣v : u ≣ v) → f x u z ≣ f y v (≣-subst₂ C x≣y u≣v z)
≣-cong₂₊ f z ≣-refl ≣-refl = ≣-refl


------------------------------------------------------------------------
-- Some properties about integers
------------------------------------------------------------------------

module Data.Integer.Properties where

open import Algebra
import Algebra.Morphism as Morphism
open import Data.Empty
open import Data.Function
open import Data.Integer hiding (suc)
open import Data.Nat as ℕ renaming (_*_ to _ℕ*_)
import Data.Nat.Properties as ℕ
open import Data.Sign as Sign using () renaming (_*_ to _S*_)
import Data.Sign.Properties as SignProp
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open Morphism.Definitions ℤ ℕ _≡_

-- Some properties relating sign and ∣_∣ to _◃_.

sign-◃ : ∀ s n → sign (s ◃ suc n) ≡ s
sign-◃ Sign.- _ = refl
sign-◃ Sign.+ _ = refl

sign-cong : ∀ {s₁ s₂ n₁ n₂} →
            s₁ ◃ suc n₁ ≡ s₂ ◃ suc n₂ → s₁ ≡ s₂
sign-cong {s₁} {s₂} {n₁} {n₂} eq = begin
  s₁                  ≡⟨ sym $ sign-◃ s₁ n₁ ⟩
  sign (s₁ ◃ suc n₁)  ≡⟨ cong sign eq ⟩
  sign (s₂ ◃ suc n₂)  ≡⟨ sign-◃ s₂ n₂ ⟩
  s₂                  ∎

abs-◃ : ∀ s n → ∣ s ◃ n ∣ ≡ n
abs-◃ _      zero    = refl
abs-◃ Sign.- (suc n) = refl
abs-◃ Sign.+ (suc n) = refl

abs-cong : ∀ {s₁ s₂ n₁ n₂} →
           s₁ ◃ n₁ ≡ s₂ ◃ n₂ → n₁ ≡ n₂
abs-cong {s₁} {s₂} {n₁} {n₂} eq = begin
  n₁           ≡⟨ sym $ abs-◃ s₁ n₁ ⟩
  ∣ s₁ ◃ n₁ ∣  ≡⟨ cong ∣_∣ eq ⟩
  ∣ s₂ ◃ n₂ ∣  ≡⟨ abs-◃ s₂ n₂ ⟩
  n₂           ∎

-- ∣_∣ commutes with multiplication.

abs-*-commute : Homomorphic₂ ∣_∣ _*_ _ℕ*_
abs-*-commute i j = abs-◃ _ _

-- Multiplication is right cancellative for non-zero integers.

cancel-*-right : ∀ i j k →
                 k ≢ + 0 → i * k ≡ j * k → i ≡ j
cancel-*-right i j k            ≢0 eq with signAbs k
cancel-*-right i j .(+ 0)       ≢0 eq | s ◂ zero  = ⊥-elim (≢0 refl)
cancel-*-right i j .(s ◃ suc n) ≢0 eq | s ◂ suc n
  with ∣ s ◃ suc n ∣ | abs-◃ s (suc n) | sign (s ◃ suc n) | sign-◃ s n
...  | .(suc n)      | refl            | .s               | refl =
  ◃-cong (sign-i≡sign-j i j eq) $
         ℕ.cancel-*-right ∣ i ∣ ∣ j ∣ $ abs-cong eq
  where
  sign-i≡sign-j : ∀ i j →
                  sign i S* s ◃ ∣ i ∣ ℕ* suc n ≡
                  sign j S* s ◃ ∣ j ∣ ℕ* suc n →
                  sign i ≡ sign j
  sign-i≡sign-j i              j              eq with signAbs i | signAbs j
  sign-i≡sign-j .(+ 0)         .(+ 0)         eq | s₁ ◂ zero   | s₂ ◂ zero   = refl
  sign-i≡sign-j .(+ 0)         .(s₂ ◃ suc n₂) eq | s₁ ◂ zero   | s₂ ◂ suc n₂
    with ∣ s₂ ◃ suc n₂ ∣ | abs-◃ s₂ (suc n₂)
  ... | .(suc n₂) | refl
    with abs-cong {s₁} {sign (s₂ ◃ suc n₂) S* s} {0} {suc n₂ ℕ* suc n} eq
  ...   | ()
  sign-i≡sign-j .(s₁ ◃ suc n₁) .(+ 0)         eq | s₁ ◂ suc n₁ | s₂ ◂ zero
    with ∣ s₁ ◃ suc n₁ ∣ | abs-◃ s₁ (suc n₁)
  ... | .(suc n₁) | refl
    with abs-cong {sign (s₁ ◃ suc n₁) S* s} {s₁} {suc n₁ ℕ* suc n} {0} eq
  ...   | ()
  sign-i≡sign-j .(s₁ ◃ suc n₁) .(s₂ ◃ suc n₂) eq | s₁ ◂ suc n₁ | s₂ ◂ suc n₂
    with ∣ s₁ ◃ suc n₁ ∣ | abs-◃ s₁ (suc n₁)
       | sign (s₁ ◃ suc n₁) | sign-◃ s₁ n₁
       | ∣ s₂ ◃ suc n₂ ∣ | abs-◃ s₂ (suc n₂)
       | sign (s₂ ◃ suc n₂) | sign-◃ s₂ n₂
  ... | .(suc n₁) | refl | .s₁ | refl | .(suc n₂) | refl | .s₂ | refl =
    SignProp.cancel-*-right s₁ s₂ (sign-cong eq)


------------------------------------------------------------------------
-- The Agda standard library
--
-- Pairs of lists that share no common elements (setoid equality)
------------------------------------------------------------------------

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

open import Relation.Binary

module Data.List.Relation.Binary.Disjoint.Setoid {c ℓ} (S : Setoid c ℓ) where

open import Level using (_⊔_)
open import Relation.Nullary using (¬_)
open import Function using (_∘_)
open import Data.List.Base using (List; []; [_]; _∷_)
open import Data.List.Relation.Unary.Any using (here; there)
open import Data.Product using (_×_; _,_)

open Setoid S renaming (Carrier to A)
open import Data.List.Membership.Setoid S using (_∈_; _∉_)

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

Disjoint : Rel (List A) (ℓ ⊔ c)
Disjoint xs ys = ∀ {v} → ¬ (v ∈ xs × v ∈ ys)

------------------------------------------------------------------------
-- Operations

contractₗ : ∀ {x xs ys} → Disjoint (x ∷ xs) ys → Disjoint xs ys
contractₗ x∷xs∩ys=∅ (v∈xs , v∈ys) = x∷xs∩ys=∅ (there v∈xs , v∈ys)

contractᵣ : ∀ {xs y ys} → Disjoint xs (y ∷ ys) → Disjoint xs ys
contractᵣ xs#y∷ys (v∈xs , v∈ys) = xs#y∷ys (v∈xs , there v∈ys)


------------------------------------------------------------------------------
-- Properties for the nest function
------------------------------------------------------------------------------

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

module FOTC.Program.Nest.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat.Type
open import FOTC.Program.Nest.Nest

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

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 nzero = prf
  where postulate prf : nest zero ≡ zero
        {-# ATP prove prf #-}
nest-x≡0 (nsucc {n} Nn) = prf (nest-x≡0 Nn)
  where postulate prf : nest n ≡ zero → nest (succ₁ n) ≡ zero
        {-# ATP prove prf #-}

postulate nest-N : ∀ {n} → N n → N (nest n)
{-# ATP prove nest-N nest-x≡0 #-}


-- notes-03-wednesday.agda

open import mylib

{-
  Classical vs intuitionistic logic
  In classical logica, we assume that each proposition is either true or false.
  Excluded middle, tertium non datur (the third is not given).
  To prove P, assume not P and derive a contradiction: indirect proof, reduction
  ad absurdum, reduction to the absurd.

-}

TND : prop → prop
TND P = P ∨ ¬ P

deMorgan' : TND P → ¬ (P ∧ Q) ⇔ ¬ P ∨ ¬ Q
proj₁ (deMorgan' (inj₁ p)) h = inj₂ (λ q → h (p , q))
proj₁ (deMorgan' (inj₂ np)) h = inj₁ np
proj₂ (deMorgan' tnd) (inj₁ np) (p , q) = np p
proj₂ (deMorgan' _)  (inj₂ nq) (p , q) = nq q

RAA : prop → prop
RAA P = ¬ ¬ P → P

tnd→raa : TND P → RAA P
tnd→raa (inj₁ p) nnp = p
tnd→raa (inj₂ np) nnp = case⊥ (nnp np)

{-
raa→tnd : RAA P → TND P
is not provable.
-}

nntnd : ¬ ¬ (P ∨ ¬ P)
nntnd h = h (inj₂ (λ p → h (inj₁ p)))

raa→tnd : ({P : prop} → RAA P) → {Q : prop} → TND Q
raa→tnd raa = raa nntnd

{-
  Datatypes, infinite types
  ℕ - natural numbers, Peano
  Every natural number is either 0 or a successor of a number.
  Peano arithmetic.
-}

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

one : ℕ
one = suc zero

two : ℕ
two = suc one

{-# BUILTIN NATURAL ℕ #-}

fifteen : ℕ
fifteen = 15

infixl 2 _+_
_+_ : ℕ → ℕ → ℕ -- structural recursive definition
zero + n = n
suc m + n = suc (m + n)

infixl 4 _*_
_*_ : ℕ → ℕ → ℕ
zero * n = 0
suc m * n = m * n + n

data List (A : Set) : Set where
  [] : List A -- nil
  _∷_ : A → List A → List A -- cons

-- ℕ = List ⊤

_++_ : List A → List A → List A -- append
[] ++ ys = ys
(x ∷ xs) ++ ys = x ∷ (xs ++ ys)

-- _++'_ : List A \to List B \to List (A \vee B)?

-- recursive but not inductive
{-# NO_POSITIVITY_CHECK #-}
data Λ : Set where
  lam : (Λ → Λ) → Λ

app : Λ → Λ → Λ
app (lam f) x = f x

self-apply : Λ
self-apply = lam λ x → app x x

Ω : Λ
Ω = app self-apply self-apply
-- normalisation doesn't terminate

data Ord : Set where
  zero : Ord
  suc : Ord → Ord
  lim : (ℕ → Ord) → Ord

-- strictly positive

{-# NO_POSITIVITY_CHECK #-}
data Reynolds : Set where
  inn : ((Reynolds → Bool) → Bool) → Reynolds

{-
  Inconsistent with classical logic
  It doesn't adhere to the intuitionistic explanation of inductive datatypes.
  Hence we reject types like this.
  - strictly positive = recursive type only appears on the right of an arrow
    type.
  - strictly positive = container / polynomial functors.
-}


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

open import Cubical.Core.Everything
open import Cubical.Foundations.Prelude
open import Cubical.Foundations.HLevels
open import Cubical.Data.Sigma

open import Cubical.Algebra
open import Cubical.Algebra.Semigroup.Morphism
open import Cubical.Algebra.Magma.Submagma

open import Cubical.Relation.Unary
open import Cubical.Relation.Unary.Subtype

record IsSubsemigroup {c ℓ} (S : Semigroup c) (Member : Pred ⟨ S ⟩ ℓ) : Type (ℓ-max c ℓ) where
  constructor issubsemigroup

  private module S = Semigroup S

  field
    closed : S._•_ Preserves₂ Member

  isSubmagma : IsSubmagma S.magma Member
  isSubmagma = record { closed = closed }

  open IsSubmagma isSubmagma hiding (closed) public

  assoc : Associative _•_
  assoc _ _ _ = ΣPathTransport→PathΣ _ _ (S.assoc _ _ _ , isProp[ Member ] _ _ _)

  isSemigroup : IsSemigroup Carrier _•_
  isSemigroup = record
    { isMagma = isMagma
    ; assoc = assoc
    }

  semigroup : Semigroup _
  semigroup = record { isSemigroup = isSemigroup }

  open Semigroup semigroup using (_^_) public

record Subsemigroup {c} (S : Semigroup c) ℓ : Type (ℓ-max c (ℓ-suc ℓ)) where
  constructor mksubsemigroup

  private module S = Semigroup S

  field
    Member : Pred ⟨ S ⟩ ℓ
    isSubsemigroup : IsSubsemigroup S Member

  open IsSubsemigroup isSubsemigroup public

  submagma : Submagma S.magma ℓ
  submagma = record { isSubmagma = isSubmagma }

instance
  SubsemigroupCarrier : ∀ {c ℓ} {S : Semigroup c} → HasCarrier (Subsemigroup S ℓ) _
  SubsemigroupCarrier = record { ⟨_⟩ = Subsemigroup.Carrier }

module _ {ℓ} (S : Semigroup ℓ) where
  open Semigroup S

  ∅-isSubsemigroup : IsSubsemigroup S ∅
  ∅-isSubsemigroup = record { closed = λ () }

  ∅-subsemigroup : Subsemigroup S _
  ∅-subsemigroup = record { isSubsemigroup = ∅-isSubsemigroup }

  U-isSubsemigroup : IsSubsemigroup S U
  U-isSubsemigroup = record {} -- trivial

  U-subsemigroup : Subsemigroup S _
  U-subsemigroup = record { isSubsemigroup = U-isSubsemigroup }


module eq where

open import level

----------------------------------------------------------------------
-- datatypes
----------------------------------------------------------------------

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

{-# BUILTIN EQUALITY _≡_ #-}

----------------------------------------------------------------------
-- syntax
----------------------------------------------------------------------

infix 4 _≡_

----------------------------------------------------------------------
-- operations
----------------------------------------------------------------------

sym : ∀ {ℓ}{A : Set ℓ}{x y : A} → x ≡ y → y ≡ x
sym refl = refl

trans : ∀ {ℓ}{A : Set ℓ}{x y z : A} → x ≡ y → y ≡ z → x ≡ z
trans refl refl = refl

cong : ∀ {ℓ ℓ'}{A : Set ℓ}{B : Set ℓ'}(p : A → B) {x y : A} → x ≡ y → p x ≡ p y
cong p refl = refl

congf : ∀{l l' : Level}{A : Set l}{B : Set l'}{f f' : A → B}{b c : A} → f ≡ f' → b ≡ c → (f b) ≡ (f' c)
congf refl refl = refl

congf2 : ∀{l l' l'' : Level}{A : Set l}{B : Set l'}{C : Set l''}{f f' : A → B → C}{b c : A}{d e : B} → f ≡ f' → b ≡ c → d ≡ e → (f b d) ≡ (f' c e)
congf2 refl refl refl = refl

cong2 : ∀{i j k}{A : Set i}{B : Set j}{C : Set k}{a a' : A}{b b' : B}
  → (f : A → B → C)
  → a ≡ a'
  → b ≡ b'
  → f a b ≡ f a' b'
cong2 f refl refl = refl

cong3 : ∀{i j k l}{A : Set i}{B : Set j}{C : Set k}{D : Set l}{a a' : A}{b b' : B}{c c' : C}
  → (f : A → B → C → D)
  → a ≡ a'
  → b ≡ b'
  → c ≡ c'
  → f a b c ≡ f a' b' c'
cong3 f refl refl refl = refl


------------------------------------------------------------------------------
-- Definition of the gcd of two natural numbers using the Euclid's algorithm
------------------------------------------------------------------------------

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

module FOTC.Program.GCD.Partial.GCD where

open import FOTC.Base
open import FOTC.Base.Loop
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities

------------------------------------------------------------------------------
-- In GHC ≤ 7.0.4 the gcd is a partial function, i.e. gcd 0 0 = undefined.

postulate
  gcd    : D → D → D
  gcd-eq : ∀ m n → gcd m n ≡
           (if (iszero₁ n)
              then (if (iszero₁ m)
                      then error
                      else m)
              else (if (iszero₁ m)
                      then n
                      else (if (gt m n)
                              then gcd (m ∸ n) n
                              else gcd m (n ∸ m))))
{-# ATP axiom gcd-eq #-}


------------------------------------------------------------------------
-- The Agda standard library
--
-- Indexed unary relations
------------------------------------------------------------------------

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

module Relation.Unary.Indexed  where

open import Data.Product using (∃; _×_)
open import Level
open import Relation.Nullary using (¬_)

IPred : ∀ {i a} {I : Set i} → (I → Set a) → (ℓ : Level) → Set _
IPred A ℓ = ∀ {i} → A i → Set ℓ

module _ {i a} {I : Set i} {A : I → Set a} where

  _∈_ : ∀ {ℓ} → (∀ i → A i) → IPred A ℓ → Set _
  x ∈ P = ∀ i → P (x i)

  _∉_ : ∀ {ℓ} → (∀ i → A i) → IPred A ℓ → Set _
  t ∉ P = ¬ (t ∈ P)


----------------------------------------------------------------
-- This file contains the definition of categories.           --
----------------------------------------------------------------
module Category.Category where

open import Level public renaming (suc to lsuc)
open import Data.Product

open import Setoid.Total public
open import Relation.Relation

open Setoid public

record Cat {l : Level} : Set (lsuc l) where
  field
    Obj     : Set l
    Hom     : Obj → Obj → Setoid {l}
    comp    : {A B C : Obj} → BinSetoidFun (Hom A B) (Hom B C) (Hom A C)
    id      : {A : Obj} → el (Hom A A)
    assocPf : ∀{A B C D}{f : el (Hom A B)}{g : el (Hom B C)}{h : el (Hom C D)}
               → ⟨ Hom A D ⟩[ f ○[ comp ] (g ○[ comp ] h)  ≡  (f ○[ comp ] g) ○[ comp ] h ]
    idPfCom : ∀{A B}{f : el (Hom A B)} → ⟨ Hom A B ⟩[ id ○[ comp ] f ≡ f ○[ comp ] id  ]
    idPf    : ∀{A B}{f : el (Hom A B)} → ⟨ Hom A B ⟩[ id ○[ comp ] f ≡ f ]

open Cat public

objectSetoid : {l : Level} → (ℂ : Cat {l}) → Setoid {l}
objectSetoid {l} ℂ = record { el = Obj ℂ;
                              eq = λ a b → _≅_ a b;
                           eqRpf = record { parEqPf = record { symPf = λ x₁ → sym x₁ ; transPf = λ x₁ x₂ → trans x₁ x₂ } ; refPf = refl }
                 }

-- Identities composed on the left cancel.
idPf-left : ∀{l}{ℂ : Cat {l}}{A B : Obj ℂ}{f : el (Hom ℂ A B)} → ⟨ Hom ℂ A B ⟩[ f ○[ comp ℂ ] id ℂ ≡ f ]
idPf-left {_}{ℂ}{A}{B}{f} =
  transPf (parEqPf (eqRpf (Hom ℂ A B)))
          (symPf (parEqPf (eqRpf (Hom ℂ A B))) (idPfCom ℂ {A} {B} {f}))
          (idPf ℂ)

-- Congruence results for composition.
eq-comp-right : ∀{l}
    {ℂ : Cat {l}}
    {A B C : Obj ℂ}
    {f : el (Hom ℂ A B)}
    {g₁ g₂ : el (Hom ℂ B C)}
  → ⟨ Hom ℂ B C ⟩[ g₁ ≡ g₂ ]
  → ⟨ Hom ℂ A C ⟩[ f ○[ comp ℂ ] g₁ ≡ f ○[ comp ℂ ] g₂ ]
eq-comp-right {_}{ℂ}{A}{B}{C}{f}{g₁}{g₂} eq =
  extT (appT {_}{_}{Hom ℂ A B}{SetoidFunSpace (Hom ℂ B C) (Hom ℂ A C)} (comp ℂ) f) eq

eq-comp-left : ∀{l}
    {ℂ : Cat {l}}
    {A B C : Obj ℂ}
    {f₁ f₂ : el (Hom ℂ A B)}
    {g : el (Hom ℂ B C)}
  → ⟨ Hom ℂ A B ⟩[ f₁ ≡ f₂ ]
  → ⟨ Hom ℂ A C ⟩[ f₁ ○[ comp ℂ ] g ≡ f₂ ○[ comp ℂ ] g ]
eq-comp-left {_}{ℂ}{A}{B}{C}{f₁}{f₂}{g} eq = extT (comp ℂ) {f₁}{f₂} eq g

eq-comp-all : ∀{l}
    {ℂ : Cat {l}}
    {A B C : Obj ℂ}
    {f₁ f₂ : el (Hom ℂ A B)}
    {g₁ g₂ : el (Hom ℂ B C)}
  → ⟨ Hom ℂ A B ⟩[ f₁ ≡ f₂ ]
  → ⟨ Hom ℂ B C ⟩[ g₁ ≡ g₂ ]
  → ⟨ Hom ℂ A C ⟩[ f₁ ○[ comp ℂ ] g₁ ≡ f₂ ○[ comp ℂ ] g₂ ]
eq-comp-all {_}{ℂ}{A}{B}{C}{f₁}{f₂}{g₁}{g₂} eq₁ eq₂
  with eq-comp-left {_}{ℂ}{A}{B}{C}{f₁}{f₂}{g₁} eq₁ |
       eq-comp-right {_}{ℂ}{A}{B}{C}{f₂}{g₁}{g₂} eq₂
... | eq₃ | eq₄ = transPf (parEqPf (eqRpf (Hom ℂ A C))) eq₃ eq₄


{-

This file contains:

- Properties of groupoid truncations

-}
{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.HITs.GroupoidTruncation.Properties where

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

open import Cubical.HITs.GroupoidTruncation.Base

private
  variable
    ℓ : Level
    A : Type ℓ

rec : ∀ {B : Type ℓ} → isGroupoid B → (A → B) → ∥ A ∥₃ → B
rec gB f ∣ x ∣₃ = f x
rec gB f (squash₃ x y p q r s i j k) =
  gB _ _ _ _ (λ m n → rec gB f (r m n)) (λ m n → rec gB f (s m n)) i j k

elim : {B : ∥ A ∥₃ → Type ℓ}
       (bG : (x : ∥ A ∥₃) → isGroupoid (B x))
       (f : (x : A) → B ∣ x ∣₃) (x : ∥ A ∥₃) → B x
elim bG f (∣ x ∣₃) = f x
elim bG f (squash₃ x y p q r s i j k) =
  isOfHLevel→isOfHLevelDep 3 bG _ _ _ _
    (λ j k → elim bG f (r j k)) (λ j k → elim bG f (s j k))
    (squash₃ x y p q r s)
    i j k

elim2 : {B : ∥ A ∥₃ → ∥ A ∥₃ → Type ℓ}
        (gB : ((x y : ∥ A ∥₃) → isGroupoid (B x y)))
        (g : (a b : A) → B ∣ a ∣₃ ∣ b ∣₃)
        (x y : ∥ A ∥₃) → B x y
elim2 gB g = elim (λ _ → isGroupoidΠ (λ _ → gB _ _))
                  (λ a → elim (λ _ → gB _ _) (g a))

elim3 : {B : (x y z : ∥ A ∥₃) → Type ℓ}
        (gB : ((x y z : ∥ A ∥₃) → isGroupoid (B x y z)))
        (g : (a b c : A) → B ∣ a ∣₃ ∣ b ∣₃ ∣ c ∣₃)
        (x y z : ∥ A ∥₃) → B x y z
elim3 gB g = elim2 (λ _ _ → isGroupoidΠ (λ _ → gB _ _ _))
                   (λ a b → elim (λ _ → gB _ _ _) (g a b))

groupoidTruncIsGroupoid : isGroupoid ∥ A ∥₃
groupoidTruncIsGroupoid a b p q r s = squash₃ a b p q r s

groupoidTruncIdempotent≃ : isGroupoid A → ∥ A ∥₃ ≃ A
groupoidTruncIdempotent≃ {A = A} hA = isoToEquiv f
  where
  f : Iso ∥ A ∥₃ A
  Iso.fun f = rec hA (idfun A)
  Iso.inv f x = ∣ x ∣₃
  Iso.rightInv f _ = refl
  Iso.leftInv f = elim (λ _ → isGroupoid→is2Groupoid groupoidTruncIsGroupoid _ _) (λ _ → refl)

groupoidTruncIdempotent : isGroupoid A → ∥ A ∥₃ ≡ A
groupoidTruncIdempotent hA = ua (groupoidTruncIdempotent≃ hA)


-- This module introduces parameterised modules.

module Introduction.Modules.Parameterised where

-- First some familiar datatypes.

data Bool : Set where
  false : Bool
  true  : Bool

data List (A : Set) : Set where
  nil  : List A
  _::_ : A -> List A -> List A

infixr 15 _::_    -- see 'Introduction.Operators' for information on infix
                  -- declarations

-- Agda supports parameterised modules. A parameterised module is declared by
-- giving the parameters after the module name.

module Sorting {A : Set}(_<_ : A -> A -> Bool) where

  insert : A -> List A -> List A
  insert x  nil      = x :: nil
  insert x (y :: ys) = ins (x < y)
    where
      ins : Bool -> List A      -- local functions can do pattern matching and
      ins true  = x :: y :: ys  -- be recursive
      ins false = y :: insert x ys

  sort : List A -> List A
  sort  nil      = nil
  sort (x :: xs) = insert x (sort xs)

-- Before a parameterised module can be used it has to be instantiated. So, we
-- need something to instantiate it with.

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

_<_ : Nat -> Nat -> Bool
zero  < zero  = false
zero  < suc _ = true
suc _ < zero  = false
suc n < suc m = n < m

-- To instantiate a module you define a new module in terms of the
-- parameterised module. Module instantiation also supports the using, hiding
-- and renaming modifiers.
module SortNat = Sorting _<_

sort' : {A : Set}(_<_ : A -> A -> Bool) -> List A -> List A
sort' less = Sort'.sort
  where
    module Sort' = Sorting less

-- Now the instantiated module can be opened and we can use the sorting
-- function.
open SortNat

test = sort (suc zero :: zero :: suc (suc zero) :: nil)


{-# OPTIONS --cubical --no-import-sorts --safe #-}
module Cubical.Data.Nat.Order.Recursive where

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

open import Cubical.Data.Empty
open import Cubical.Data.Unit

open import Cubical.Data.Nat.Base
open import Cubical.Data.Nat.Properties

open import Cubical.Relation.Nullary

infix 4 _≤_ _<_

_≤_ : ℕ → ℕ → Type₀
zero ≤ _ = Unit
suc m ≤ zero = ⊥
suc m ≤ suc n = m ≤ n

_<_ : ℕ → ℕ → Type₀
m < n = suc m ≤ n

data Trichotomy (m n : ℕ) : Type₀ where
  lt : m < n → Trichotomy m n
  eq : m ≡ n → Trichotomy m n
  gt : n < m → Trichotomy m n

private
  variable
    k l m n : ℕ

m≤n-isProp : isProp (m ≤ n)
m≤n-isProp {zero} = isPropUnit
m≤n-isProp {suc m} {zero}  = isProp⊥
m≤n-isProp {suc m} {suc n} = m≤n-isProp {m} {n}

≤-k+ : m ≤ n → k + m ≤ k + n
≤-k+ {k = zero}  m≤n = m≤n
≤-k+ {k = suc k} m≤n = ≤-k+ {k = k} m≤n

≤-+k : m ≤ n → m + k ≤ n + k
≤-+k {m} {n} {k} m≤n
  = transport (λ i → +-comm k m i ≤ +-comm k n i) (≤-k+ {m} {n} {k} m≤n)

≤-refl : ∀ m → m ≤ m
≤-refl zero = _
≤-refl (suc m) = ≤-refl m

≤-trans : k ≤ m → m ≤ n → k ≤ n
≤-trans {zero} _ _ = _
≤-trans {suc k} {suc m} {suc n} = ≤-trans {k} {m} {n}

≤-antisym : m ≤ n → n ≤ m → m ≡ n
≤-antisym {zero} {zero} _ _ = refl
≤-antisym {suc m} {suc n} m≤n n≤m = cong suc (≤-antisym m≤n n≤m)

≤-k+-cancel : k + m ≤ k + n → m ≤ n
≤-k+-cancel {k =  zero} m≤n = m≤n
≤-k+-cancel {k = suc k} m≤n = ≤-k+-cancel {k} m≤n

≤-+k-cancel : m + k ≤ n + k → m ≤ n
≤-+k-cancel {m} {k} {n}
  = ≤-k+-cancel {k} {m} {n} ∘ transport λ i → +-comm m k i ≤ +-comm n k i

¬m<m : ¬ m < m
¬m<m {suc m} = ¬m<m {m}

≤0→≡0 : n ≤ 0 → n ≡ 0
≤0→≡0 {zero} _ = refl

¬m+n<m : ¬ m + n < m
¬m+n<m {suc m} = ¬m+n<m {m}

<-weaken : m < n → m ≤ n
<-weaken {zero} _ = _
<-weaken {suc m} {suc n} = <-weaken {m}

Trichotomy-suc : Trichotomy m n → Trichotomy (suc m) (suc n)
Trichotomy-suc (lt m<n) = lt m<n
Trichotomy-suc (eq m≡n) = eq (cong suc m≡n)
Trichotomy-suc (gt n<m) = gt n<m

_≟_ : ∀ m n → Trichotomy m n
zero  ≟ zero = eq refl
zero  ≟ suc n = lt _
suc m ≟ zero = gt _
suc m ≟ suc n = Trichotomy-suc (m ≟ n)

k≤k+n : ∀ k → k ≤ k + n
k≤k+n zero    = _
k≤k+n (suc k) = k≤k+n k

n≤k+n : ∀ n → n ≤ k + n
n≤k+n {k} n = transport (λ i → n ≤ +-comm n k i) (k≤k+n n)


-- Andreas, 2017-01-12, issue #2386

open import Agda.Primitive

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

{-# BUILTIN EQUALITY _≡_ #-}

-- Should be accepted

-- The type of primErase has to match the flavor of EQUALITY

primitive primEraseEquality : ∀ {a b}{A : Set (a ⊔ b)} {x y : A} → _≡_ x y → _≡_ x y

testTM : ∀ {a b} {A : Set (a ⊔ b)} {x : A} (eq : _≡_ {a} {b} x x) → primEraseEquality {x = x} {y = x} eq ≡ refl _
testTM _ = refl _

-- Testing rewrite

subst : ∀{ℓ}{A : Set ℓ} {P : A → Set}{a b : A} → _≡_ {a = ℓ} {b = ℓ} a b → P a → P b
subst eq p rewrite eq = p


open import Level
module ordinal where

open import logic
open import nat
open import Data.Nat renaming ( zero to Zero ; suc to Suc ;  ℕ to Nat ; _⊔_ to _n⊔_ )
open import Data.Empty
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Definitions
open import Data.Nat.Properties
open import Relation.Nullary
open import Relation.Binary.Core

----
--
-- Countable Ordinals
--

data OrdinalD {n : Level} :  (lv : Nat) → Set n where
   Φ : (lv : Nat) → OrdinalD  lv
   OSuc : (lv : Nat) → OrdinalD {n} lv → OrdinalD lv

record Ordinal {n : Level} : Set n where
   constructor ordinal
   field
     lv : Nat
     ord : OrdinalD {n} lv

data _d<_ {n : Level} :   {lx ly : Nat} → OrdinalD {n} lx  →  OrdinalD {n} ly  → Set n where
   Φ<  : {lx : Nat} → {x : OrdinalD {n} lx}  →  Φ lx d< OSuc lx x
   s<  : {lx : Nat} → {x y : OrdinalD {n} lx}  →  x d< y  → OSuc  lx x d< OSuc  lx y

open Ordinal

_o<_ : {n : Level} ( x y : Ordinal ) → Set n
_o<_ x y =  (lv x < lv y )  ∨ ( ord x d< ord y )

s<refl : {n : Level } {lx : Nat } { x : OrdinalD {n} lx } → x d< OSuc lx x
s<refl {n} {lv} {Φ lv}  = Φ<
s<refl {n} {lv} {OSuc lv x}  = s< s<refl

trio<> : {n : Level} →  {lx : Nat} {x  : OrdinalD {n} lx } { y : OrdinalD  lx }  →  y d< x → x d< y → ⊥
trio<>  {n} {lx} {.(OSuc lx _)} {.(OSuc lx _)} (s< s) (s< t) = trio<> s t
trio<> {n} {lx} {.(OSuc lx _)} {.(Φ lx)} Φ< ()

d<→lv : {n : Level} {x y  : Ordinal {n}}   → ord x d< ord y → lv x ≡ lv y
d<→lv Φ< = refl
d<→lv (s< lt) = refl

o∅ : {n : Level} → Ordinal {n}
o∅  = record { lv = Zero ; ord = Φ Zero }

open import Relation.Binary.HeterogeneousEquality using (_≅_;refl)

ordinal-cong : {n : Level} {x y : Ordinal {n}}  →
      lv x  ≡ lv y → ord x ≅ ord y →  x ≡ y
ordinal-cong refl refl = refl

≡→¬d< : {n : Level} →  {lv : Nat} → {x  : OrdinalD {n}  lv }  → x d< x → ⊥
≡→¬d<  {n} {lx} {OSuc lx y} (s< t) = ≡→¬d< t

trio<≡ : {n : Level} →  {lx : Nat} {x  : OrdinalD {n} lx } { y : OrdinalD  lx }  → x ≡ y  → x d< y → ⊥
trio<≡ refl = ≡→¬d<

trio>≡ : {n : Level} →  {lx : Nat} {x  : OrdinalD {n} lx } { y : OrdinalD  lx }  → x ≡ y  → y d< x → ⊥
trio>≡ refl = ≡→¬d<

triOrdd : {n : Level} →  {lx : Nat}   → Trichotomous  _≡_ ( _d<_  {n} {lx} {lx} )
triOrdd  {_} {lv} (Φ lv) (Φ lv) = tri≈ ≡→¬d< refl ≡→¬d<
triOrdd  {_} {lv} (Φ lv) (OSuc lv y) = tri< Φ< (λ ()) ( λ lt → trio<> lt Φ< )
triOrdd  {_} {lv} (OSuc lv x) (Φ lv) = tri> (λ lt → trio<> lt Φ<) (λ ()) Φ<
triOrdd  {_} {lv} (OSuc lv x) (OSuc lv y) with triOrdd x y
triOrdd  {_} {lv} (OSuc lv x) (OSuc lv y) | tri< a ¬b ¬c = tri< (s< a) (λ tx=ty → trio<≡ tx=ty (s< a) )  (  λ lt → trio<> lt (s< a) )
triOrdd  {_} {lv} (OSuc lv x) (OSuc lv x) | tri≈ ¬a refl ¬c = tri≈ ≡→¬d< refl ≡→¬d<
triOrdd  {_} {lv} (OSuc lv x) (OSuc lv y) | tri> ¬a ¬b c = tri> (  λ lt → trio<> lt (s< c) ) (λ tx=ty → trio>≡ tx=ty (s< c) ) (s< c)

osuc : {n : Level} ( x : Ordinal {n} ) → Ordinal {n}
osuc record { lv = lx ; ord = ox } = record { lv = lx ; ord = OSuc lx ox }

<-osuc : {n : Level} { x : Ordinal {n} } → x o< osuc x
<-osuc {n} {record { lv = lx ; ord = Φ .lx }} =  case2 Φ<
<-osuc {n} {record { lv = lx ; ord = OSuc .lx ox }} = case2 ( s< s<refl )

o<¬≡ : {n : Level } { ox oy : Ordinal {suc n}} → ox ≡ oy  → ox o< oy  → ⊥
o<¬≡ {_} {ox} {ox} refl (case1 lt) =  =→¬< lt
o<¬≡ {_} {ox} {ox} refl (case2 (s< lt)) = trio<≡ refl lt

¬x<0 : {n : Level} →  { x  : Ordinal {suc n} } → ¬ ( x o< o∅ {suc n} )
¬x<0 {n} {x} (case1 ())
¬x<0 {n} {x} (case2 ())

o<> : {n : Level} →  {x y : Ordinal {n}  }  →  y o< x → x o< y → ⊥
o<> {n} {x} {y} (case1 x₁) (case1 x₂) = nat-<>  x₁ x₂
o<> {n} {x} {y} (case1 x₁) (case2 x₂) = nat-≡< (sym (d<→lv x₂)) x₁
o<> {n} {x} {y} (case2 x₁) (case1 x₂) = nat-≡< (sym (d<→lv x₁)) x₂
o<> {n} {record { lv = lv₁ ; ord = .(OSuc lv₁ _) }} {record { lv = .lv₁ ; ord = .(Φ lv₁) }} (case2 Φ<) (case2 ())
o<> {n} {record { lv = lv₁ ; ord = .(OSuc lv₁ _) }} {record { lv = .lv₁ ; ord = .(OSuc lv₁ _) }} (case2 (s< y<x)) (case2 (s< x<y)) =
   o<> (case2 y<x) (case2 x<y)

orddtrans : {n : Level} {lx : Nat} {x y z : OrdinalD {n}  lx }   → x d< y → y d< z → x d< z
orddtrans {_} {lx} {.(Φ lx)} {.(OSuc lx _)} {.(OSuc lx _)} Φ< (s< y<z) = Φ<
orddtrans {_} {lx} {.(OSuc lx _)} {.(OSuc lx _)} {.(OSuc lx _)} (s< x<y) (s< y<z) = s< ( orddtrans x<y y<z )

osuc-≡< : {n : Level} { a x : Ordinal {n} } → x o< osuc a  →  (x ≡ a ) ∨ (x o< a)
osuc-≡< {n} {a} {x} (case1 lt) = case2 (case1 lt)
osuc-≡< {n} {record { lv = lv₁ ; ord = Φ .lv₁ }} {record { lv = .lv₁ ; ord = .(Φ lv₁) }} (case2 Φ<) = case1 refl
osuc-≡< {n} {record { lv = lv₁ ; ord = OSuc .lv₁ ord₁ }} {record { lv = .lv₁ ; ord = .(Φ lv₁) }} (case2 Φ<) = case2 (case2 Φ<)
osuc-≡< {n} {record { lv = lv₁ ; ord = Φ .lv₁ }} {record { lv = .lv₁ ; ord = .(OSuc lv₁ _) }} (case2 (s< ()))
osuc-≡< {n} {record { lv = la ; ord = OSuc la oa }} {record { lv = la ; ord = (OSuc la ox) }} (case2 (s< lt)) with
      osuc-≡< {n} {record { lv = la ; ord = oa }} {record { lv = la ; ord = ox }} (case2 lt )
... | case1 refl = case1 refl
... | case2 (case2 x) = case2 (case2( s< x) )
... | case2 (case1 x) = ⊥-elim (¬a≤a  x)

osuc-< : {n : Level} { x y : Ordinal {n} } → y o< osuc x  → x o< y → ⊥
osuc-< {n} {x} {y} y<ox x<y with osuc-≡< y<ox
osuc-< {n} {x} {x} y<ox (case1 x₁) | case1 refl = ⊥-elim (¬a≤a x₁)
osuc-< {n} {x} {x} (case1 x₂) (case2 x₁) | case1 refl = ⊥-elim (¬a≤a x₂)
osuc-< {n} {x} {x} (case2 x₂) (case2 x₁) | case1 refl = ≡→¬d<  x₁
osuc-< {n} {x} {y} y<ox (case1 x₂) | case2 (case1 x₁) = nat-<> x₂ x₁
osuc-< {n} {x} {y} y<ox (case1 x₂) | case2 (case2 x₁) = nat-≡< (sym (d<→lv x₁)) x₂
osuc-< {n} {x} {y} y<ox (case2 x<y) | case2 y<x = o<> (case2 x<y) y<x

ordtrans : {n : Level} {x y z : Ordinal {n} }   → x o< y → y o< z → x o< z
ordtrans {n} {x} {y} {z} (case1 x₁) (case1 x₂) = case1 ( <-trans x₁ x₂ )
ordtrans {n} {x} {y} {z} (case1 x₁) (case2 x₂) with  d<→lv x₂
... | refl = case1 x₁
ordtrans {n} {x} {y} {z} (case2 x₁) (case1 x₂)  with  d<→lv x₁
... | refl = case1 x₂
ordtrans {n} {x} {y} {z} (case2 x₁) (case2 x₂) with d<→lv x₁ | d<→lv x₂
... | refl | refl = case2 ( orddtrans x₁ x₂ )

trio< : {n : Level } → Trichotomous {suc n} _≡_  _o<_
trio< a b with <-cmp (lv a) (lv b)
trio< a b | tri< a₁ ¬b ¬c = tri< (case1  a₁) (λ refl → ¬b (cong ( λ x → lv x ) refl ) ) lemma1 where
   lemma1 : ¬ (Suc (lv b) ≤ lv a) ∨ (ord b d< ord a)
   lemma1 (case1 x) = ¬c x
   lemma1 (case2 x) = ⊥-elim (nat-≡< (sym ( d<→lv x )) a₁  )
trio< a b | tri> ¬a ¬b c = tri> lemma1 (λ refl → ¬b (cong ( λ x → lv x ) refl ) ) (case1 c) where
   lemma1 : ¬ (Suc (lv a) ≤ lv b) ∨ (ord a d< ord b)
   lemma1 (case1 x) = ¬a x
   lemma1 (case2 x) = ⊥-elim (nat-≡< (sym ( d<→lv x )) c  )
trio< a b | tri≈ ¬a refl ¬c with triOrdd ( ord a ) ( ord b )
trio< record { lv = .(lv b) ; ord = x } b | tri≈ ¬a refl ¬c | tri< a ¬b ¬c₁ = tri< (case2 a) (λ refl → ¬b (lemma1 refl )) lemma2 where
   lemma1 :  (record { lv = _ ; ord = x }) ≡ b →  x ≡ ord b
   lemma1 refl = refl
   lemma2 : ¬ (Suc (lv b) ≤ lv b) ∨ (ord b d< x)
   lemma2 (case1 x) = ¬a x
   lemma2 (case2 x) = trio<> x a
trio< record { lv = .(lv b) ; ord = x } b | tri≈ ¬a refl ¬c | tri> ¬a₁ ¬b c = tri> lemma2 (λ refl → ¬b (lemma1 refl )) (case2 c) where
   lemma1 :  (record { lv = _ ; ord = x }) ≡ b →  x ≡ ord b
   lemma1 refl = refl
   lemma2 : ¬ (Suc (lv b) ≤ lv b) ∨ (x d< ord b)
   lemma2 (case1 x) = ¬a x
   lemma2 (case2 x) = trio<> x c
trio< record { lv = .(lv b) ; ord = x } b | tri≈ ¬a refl ¬c | tri≈ ¬a₁ refl ¬c₁ = tri≈ lemma1 refl lemma1 where
   lemma1 : ¬ (Suc (lv b) ≤ lv b) ∨ (ord b d< ord b)
   lemma1 (case1 x) = ¬a x
   lemma1 (case2 x) = ≡→¬d< x

open _∧_

TransFinite : {n m : Level} → { ψ : Ordinal {suc n} → Set m }
  → ( ∀ (lx : Nat ) → ( (x : Ordinal {suc n} ) → x o< ordinal lx (Φ lx)  → ψ x ) → ψ ( record { lv = lx ; ord = Φ lx } ) )
  → ( ∀ (lx : Nat ) → (x : OrdinalD lx ) → ( (y : Ordinal {suc n} ) → y o< ordinal lx (OSuc lx x)  → ψ y )   → ψ ( record { lv = lx ; ord = OSuc lx x } ) )
  →  ∀ (x : Ordinal)  → ψ x
TransFinite {n} {m} {ψ} caseΦ caseOSuc x = proj1 (TransFinite1 (lv x) (ord x) ) where
  TransFinite1 : (lx : Nat) (ox : OrdinalD lx ) → ψ (ordinal lx ox) ∧ ( ( (x : Ordinal {suc n} ) → x o< ordinal lx ox  → ψ x ) )
  TransFinite1 Zero (Φ 0) = ⟪  caseΦ Zero lemma , lemma1 ⟫ where
      lemma : (x : Ordinal) → x o< ordinal Zero (Φ Zero) → ψ x
      lemma x (case1 ())
      lemma x (case2 ())
      lemma1 : (x : Ordinal) → x o< ordinal Zero (Φ Zero) → ψ x
      lemma1 x (case1 ())
      lemma1 x (case2 ())
  TransFinite1 (Suc lx) (Φ (Suc lx)) = ⟪ caseΦ (Suc lx) (λ x → lemma (lv x) (ord x)) , (λ x → lemma (lv x) (ord x)) ⟫ where
      lemma0 : (ly : Nat) (oy : OrdinalD ly ) → ordinal ly oy  o< ordinal lx (Φ lx) → ψ (ordinal ly oy)
      lemma0 ly oy lt = proj2 ( TransFinite1 lx (Φ lx) ) (ordinal ly oy) lt
      lemma : (ly : Nat) (oy : OrdinalD ly ) → ordinal ly oy  o< ordinal (Suc lx) (Φ (Suc lx)) → ψ (ordinal ly oy)
      lemma lx1 ox1            (case1 lt) with <-∨ lt
      lemma lx (Φ lx)          (case1 lt) | case1 refl = proj1 ( TransFinite1 lx (Φ lx) )
      lemma lx (Φ lx)          (case1 lt) | case2 lt1 = lemma0  lx (Φ lx) (case1 lt1)
      lemma lx (OSuc lx ox1)   (case1 lt) | case1 refl = caseOSuc lx ox1 lemma2 where
          lemma2 : (y : Ordinal) → (Suc (lv y) ≤ lx) ∨ (ord y d< OSuc lx ox1) → ψ y
          lemma2 y lt1 with osuc-≡< lt1
          lemma2 y lt1 | case1 refl = lemma lx ox1 (case1 a<sa)
          lemma2 y lt1 | case2 t = proj2 (TransFinite1 lx ox1) y t
      lemma lx1 (OSuc lx1 ox1) (case1 lt) | case2 lt1 = caseOSuc lx1 ox1 lemma2 where
          lemma2 : (y : Ordinal) → (Suc (lv y) ≤ lx1) ∨ (ord y d< OSuc lx1 ox1) → ψ y
          lemma2 y lt2 with osuc-≡< lt2
          lemma2 y lt2 | case1 refl = lemma lx1 ox1 (ordtrans lt2 (case1 lt))
          lemma2 y lt2 | case2 (case1 lt3) = proj2 (TransFinite1 lx (Φ lx)) y (case1 (<-trans lt3 lt1 ))
          lemma2 y lt2 | case2 (case2 lt3) with d<→lv lt3
          ... | refl = proj2 (TransFinite1 lx (Φ lx)) y (case1 lt1)
  TransFinite1 lx (OSuc lx ox)  = ⟪ caseOSuc lx ox lemma , lemma ⟫ where
      lemma : (y : Ordinal) → y o< ordinal lx (OSuc lx ox) → ψ y
      lemma y lt with osuc-≡< lt
      lemma y lt | case1 refl = proj1 ( TransFinite1 lx ox )
      lemma y lt | case2 lt1 = proj2 ( TransFinite1 lx ox ) y lt1

--  record CountableOrdinal {n : Level} : Set (suc (suc n)) where
--     field
--         ctl→ : Nat → Ordinal {suc n}
--         ctl← : Ordinal → Nat
--         ctl-iso→ : { x : Ordinal } → ctl→ (ctl← x ) ≡ x
--         ctl-iso← : { x : Nat }  → ctl← (ctl→ x ) ≡ x
--
--  is-C-Ordinal : {n : Level} → CountableOrdinal {n}
--  is-C-Ordinal {n} = record {
--         ctl→ = {!!}
--      ;  ctl← = λ x → TransFinite {n} (λ lx lt → Zero ) ctl01 x
--      ;  ctl-iso→ = {!!}
--      ;  ctl-iso← = {!!}
--    } where
--        ctl01 : (lx : Nat) (x : OrdinalD lx) → ((y : Ordinal) → y o< ordinal lx (OSuc lx x) → Nat) → Nat
--        ctl01 Zero (Φ Zero) prev = Zero
--        ctl01 Zero (OSuc Zero x) prev = Suc ( prev (ordinal Zero x) (ordtrans <-osuc <-osuc ))
--        ctl01 (Suc lx) (Φ (Suc lx)) prev = Suc ( prev (ordinal lx {!!}) {!!})
--        ctl01 (Suc lx) (OSuc (Suc lx) x) prev = Suc ( prev (ordinal (Suc lx) x) (ordtrans <-osuc <-osuc ))

open import Ordinals

C-Ordinal : {n : Level} →  Ordinals {suc n}
C-Ordinal {n} = record {
     Ordinal = Ordinal {suc n}
   ; o∅ = o∅
   ; osuc = osuc
   ; _o<_ = _o<_
   ; next = next
   ; isOrdinal = record {
       ordtrans = ordtrans
     ; trio< = trio<
     ; ¬x<0 = ¬x<0
     ; <-osuc = <-osuc
     ; osuc-≡< = osuc-≡<
     ; TransFinite = TransFinite2
     ; Oprev-p  = Oprev-p
   } ;
   isNext = record {
        x<nx = x<nx
      ; osuc<nx = λ {x} {y} → osuc<nx {x} {y}
      ; ¬nx<nx = ¬nx<nx
   }
  } where
     next : Ordinal {suc n} → Ordinal {suc n}
     next (ordinal lv ord) = ordinal (Suc lv) (Φ (Suc lv))
     x<nx :    { y : Ordinal } → (y o< next y )
     x<nx = case1 a<sa
     osuc<nx : { x y : Ordinal } → x o< next y → osuc x o< next y
     osuc<nx (case1 lt) = case1 lt
     ¬nx<nx :  {x y : Ordinal} → y o< x → x o< next y →  ¬ ((z : Ordinal) → ¬ (x ≡ osuc z))
     ¬nx<nx {x} {y} = lemma2 x where
         lemma2 : (x : Ordinal) → y o< x → x o< next y → ¬ ((z : Ordinal) → ¬ x ≡ osuc z)
         lemma2 (ordinal Zero (Φ 0)) (case2 ()) (case1 (s≤s z≤n)) not
         lemma2 (ordinal Zero (OSuc 0 dx)) (case2 Φ<) (case1 (s≤s z≤n)) not = not _ refl
         lemma2 (ordinal Zero (OSuc 0 dx)) (case2 (s< x)) (case1 (s≤s z≤n)) not = not _ refl
         lemma2 (ordinal (Suc lx) (OSuc (Suc lx) ox)) y<x (case1 (s≤s (s≤s lt))) not = not _ refl
         lemma2 (ordinal (Suc lx) (Φ (Suc lx))) (case1 x) (case1 (s≤s (s≤s lt))) not = lemma3 x lt where
             lemma3 : {n l : Nat} → (Suc (Suc n) ≤ Suc l) → l ≤ n → ⊥
             lemma3   (s≤s sn≤l) (s≤s l≤n) = lemma3 sn≤l l≤n
     open Oprev
     Oprev-p  : (x : Ordinal) → Dec ( Oprev (Ordinal {suc n})  osuc x )
     Oprev-p  (ordinal lv (Φ lv)) = no (λ not → lemma (oprev not) (oprev=x not) ) where
          lemma : (x : Ordinal) → osuc x ≡ (ordinal lv (Φ lv)) → ⊥
          lemma x ()
     Oprev-p  (ordinal lv (OSuc lv ox)) = yes record { oprev = ordinal lv ox ; oprev=x = refl }
     ord1 : Set (suc n)
     ord1 = Ordinal {suc n}
     TransFinite2 : { ψ : ord1  → Set (suc (suc n)) }
          → ( (x : ord1)  → ( (y : ord1  ) → y o< x → ψ y ) → ψ x )
          →  ∀ (x : ord1)  → ψ x
     TransFinite2 {ψ} lt x = TransFinite {n} {suc (suc n)} {ψ} caseΦ caseOSuc x where
        caseΦ : (lx : Nat) → ((x₁ : Ordinal) → x₁ o< ordinal lx (Φ lx) → ψ x₁) →
            ψ (record { lv = lx ; ord = Φ lx })
        caseΦ lx prev = lt (ordinal lx (Φ lx) ) prev
        caseOSuc :  (lx : Nat) (x₁ : OrdinalD lx) → ((y : Ordinal) → y o< ordinal lx (OSuc lx x₁) → ψ y) →
            ψ (record { lv = lx ; ord = OSuc lx x₁ })
        caseOSuc lx ox prev = lt (ordinal lx (OSuc lx ox)) prev


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

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


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

open import LogicalFormulae
open import Setoids.Setoids
open import Rings.Definition

open import Agda.Primitive using (Level; lzero; lsuc; _⊔_)

module Rings.Units.Definition {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ _*_ : A → A → A} (R : Ring S _+_ _*_) where

open Setoid S
open Ring R

Unit : A → Set (a ⊔ b)
Unit r = Sg A (λ s → (r * s) ∼ 1R)


module Equality where

  postulate _==_ : {A : Set} -> A -> A -> Set
	    refl : {A : Set}{x : A} -> x == x

  {-# BUILTIN EQUAL _==_ #-}
  {-# BUILTIN REFL  refl #-}

  private
   primitive
    primEqElim : {A : Set}(x : A)(C : (y : A) -> x == y -> Set) ->
		 C x refl -> (y : A) -> (p : x == y) -> C y p

  elim-== = \{A : Set} -> primEqElim {A}

  subst : {A : Set}(C : A -> Set){x y : A} -> x == y -> C y -> C x
  subst C {x}{y} p Cy = elim-== x (\z _ -> C z -> C x) (\Cx -> Cx) y p Cy

  sym : {A : Set}{x y : A} -> x == y -> y == x
  sym {x = x}{y = y} p = subst (\z -> y == z) p refl

  trans : {A : Set}{x y z : A} -> x == y -> y == z -> x == z
  trans {x = x}{y = y}{z = z} xy yz = subst (\w -> w == z) xy yz

  cong : {A B : Set}{x y : A}(f : A -> B) -> x == y -> f x == f y
  cong {y = y} f xy = subst (\ ∙ -> f ∙ == f y) xy refl


{-# OPTIONS --termination-depth=2 #-}
module plfa-code.Quantifiers where

import Relation.Binary.PropositionalEquality as Eq
open Eq using (_≡_; refl)
open import Data.Nat using (ℕ; zero; suc; _+_; _*_)
open import Relation.Nullary using (¬_)
open import Data.Product using (_×_; proj₁; proj₂) renaming (_,_ to ⟨_,_⟩)
open import Data.Sum using (_⊎_; inj₁; inj₂)
open import plfa-code.Isomorphism using (_≃_; extensionality)

∀-elim : ∀ {A : Set} {B : A → Set}
  → (L : ∀ (x : A) → B x)
  → (M : A)
    --------------------------
  → B M
∀-elim L M = L M

---------- practice ----------
∀-distrib-× : ∀ {A : Set} {B C : A → Set} →
  (∀ (x : A) → B x × C x) ≃ (∀ (x : A) → B x) × (∀ (x : A) → C x)
∀-distrib-× =
  record
  { to      = λ fₗ → ⟨ (λ a → proj₁ (fₗ a)) , (λ a → proj₂ (fₗ a)) ⟩
  ; from    = λ x a → ⟨ (proj₁ x a) , (proj₂ x a) ⟩
  ; from∘to = λ fₗ → refl
  ; to∘from = λ x  → refl
  }

⊎∀-implies-∀⊎ : ∀ {A : Set} {B C : A → Set} →
    (∀ (x : A) → B x) ⊎ (∀ (x : A) → C x)  →  ∀ (x : A) → B x ⊎ C x
⊎∀-implies-∀⊎ (inj₁ f₁) a = inj₁ (f₁ a)
⊎∀-implies-∀⊎ (inj₂ f₂) a = inj₂ (f₂ a)

-- the converse doesn't hold. If we construct a function
-- '∀ (x : A) → B x', we could build a '∀ (x : A) → B x ⊎ C x',
-- but '∀ (x : A) → C x' maybe doesn't hold.

data Tri : Set where
  aa : Tri
  bb : Tri
  cc : Tri

postulate
  ∀-extensionality :
    ∀ {A : Set} {B : A → Set} (f g : ∀ (x : A) → B x)
    → (∀ (x : A) → (f x ≡ g x))
    → f ≡ g

∀-× : {B : Tri → Set} → (∀ (x : Tri) → B x) ≃ (B aa × B bb × B cc)
∀-× {B} =
  record
  { to      = to′
  ; from    = from′
  ; from∘to = λ f → ∀-extensionality (from′ ⟨ f aa , ⟨ f bb , f cc ⟩ ⟩) f
                                     λ{aa → refl; bb → refl; cc → refl}
  ; to∘from = λ xx → refl
  }
  where
  to′ : (∀ (x : Tri) → B x) → (B aa × B bb × B cc)
  to′ f = ⟨ f aa , ⟨ f bb , f cc ⟩ ⟩
  from′ : (B aa × B bb × B cc) → (∀ (x : Tri) → B x)
  from′ xx aa = proj₁ xx
  from′ xx bb = proj₁ (proj₂ xx)
  from′ xx cc = proj₂ (proj₂ xx)

-- every λ expression has different types , wtf
------------------------------

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

Σ-syntax = Σ
infix 2 Σ-syntax
syntax Σ-syntax A (λ x → B) = Σ[ x ∈ A ] B

record Σ′ (A : Set) (B : A → Set) : Set where
  field
    proj₁′ : A
    proj₂′ : B proj₁′

∃ : ∀ {A : Set} (B : A → Set) → Set
∃ {A} B = Σ A B

∃-syntax = ∃
syntax ∃-syntax (λ x → B) = ∃[ x ] B

∃-elim : ∀ {A : Set} {B : A → Set} {C : Set}
  → (∀ x → B x → C)
  → ∃[ x ] B x
    ---------------
  → C
∃-elim f ⟨ x , y ⟩ = f x y

∀∃-currying : ∀ {A : Set} {B : A → Set} {C : Set}
  → (∀ x → B x → C) ≃ (∃[ x ] B x → C)
∀∃-currying =
  record
  { to      = λ{ f → λ{ ⟨ x , y ⟩ → f x y }}
  ; from    = λ{ g → λ{ x → λ{ y → g ⟨ x , y ⟩ }}}
  ; from∘to = λ f → refl
  ; to∘from = λ g → extensionality (λ{ ⟨ x , y ⟩ → refl})
  }

---------- practice ----------
∃-distrib-⊎ : ∀ {A : Set} {B C : A → Set} →
  ∃[ x ] (B x ⊎ C x) ≃ (∃[ x ] B x) ⊎ (∃[ x ] C x)
∃-distrib-⊎ =
  record
  { to      = λ{ ⟨ a , inj₁ b ⟩ → inj₁ ⟨ a , b ⟩
               ; ⟨ a , inj₂ c ⟩ → inj₂ ⟨ a , c ⟩
               }
  ; from    = λ{ (inj₁ ⟨ a , b ⟩) → ⟨ a , inj₁ b ⟩
               ; (inj₂ ⟨ a , c ⟩) → ⟨ a , inj₂ c ⟩
               }
  ; from∘to = λ{ ⟨ a , inj₁ b ⟩ → refl
               ; ⟨ a , inj₂ c ⟩ → refl
               }
  ; to∘from = λ{ (inj₁ ⟨ a , b ⟩) → refl
               ; (inj₂ ⟨ a , c ⟩) → refl
               }
  }

∃×-implies-×∃ : ∀ {A : Set} {B C : A → Set} →
  ∃[ x ] (B x × C x) → (∃[ x ] B x) × (∃[ x ] C x)
∃×-implies-×∃ ⟨ a , ⟨ b , c ⟩ ⟩ = ⟨ ⟨ a , b ⟩ , ⟨ a , c ⟩ ⟩

-- the converse doesn't hold, because the x in ∃[ x ] B x is maybe not
-- the same 'x' in ∃[ x ] C x

∃-⊎ : ∀ {B : Tri → Set} → ∃[ x ] B x ≃ B aa ⊎ B bb ⊎ B cc
∃-⊎ =
  record
  { to      = λ{ ⟨ aa , a ⟩ → inj₁ a
               ; ⟨ bb , b ⟩ → inj₂ (inj₁ b)
               ; ⟨ cc , c ⟩ → inj₂ (inj₂ c)
               }
  ; from    = λ{ (inj₁ a) → ⟨ aa , a ⟩
               ; (inj₂ (inj₁ b)) → ⟨ bb , b ⟩
               ; (inj₂ (inj₂ c)) → ⟨ cc , c ⟩
               }
  ; from∘to = λ{ ⟨ aa , a ⟩ → refl
               ; ⟨ bb , b ⟩ → refl
               ; ⟨ cc , c ⟩ → refl
               }
  ; to∘from = λ{ (inj₁ a) → refl
               ; (inj₂ (inj₁ b)) → refl
               ; (inj₂ (inj₂ c)) → refl
               }
  }

data even : ℕ → Set
data odd  : ℕ → Set

data even where

  even-zero : even zero

  even-suc : ∀ {n : ℕ}
    → odd n
      ------------
    → even (suc n)

data odd where
  odd-suc : ∀ {n : ℕ}
    → even n
      -----------
    → odd (suc n)

even-∃ : ∀ {n : ℕ} → even n → ∃[ m ] (    m * 2 ≡ n)
odd-∃  : ∀ {n : ℕ} →  odd n → ∃[ m ] (1 + m * 2 ≡ n)

even-∃ even-zero                       =  ⟨ zero  , refl ⟩
even-∃ (even-suc o) with odd-∃ o
...                    | ⟨ m , refl ⟩  =  ⟨ suc m , refl ⟩

odd-∃  (odd-suc e)  with even-∃ e
...                    | ⟨ m , refl ⟩  =  ⟨ m , refl ⟩

∃-even : ∀ {n : ℕ} → ∃[ m ] (    m * 2 ≡ n) → even n
∃-odd  : ∀ {n : ℕ} → ∃[ m ] (1 + m * 2 ≡ n) →  odd n

∃-even ⟨  zero , refl ⟩  =  even-zero
∃-even ⟨ suc m , refl ⟩  =  even-suc (∃-odd ⟨ m , refl ⟩)

∃-odd  ⟨     m , refl ⟩  =  odd-suc (∃-even ⟨ m , refl ⟩)

--------- practice ----------
open import Data.Nat.Properties using (+-identityʳ; +-suc; +-assoc)
open Eq using (cong; sym; trans)
open Eq.≡-Reasoning using (begin_; _≡⟨⟩_)

open import plfa-code.Reasoning-legacy

∃-even′ : ∀ {n : ℕ} → ∃[ m ] (    2 * m ≡ n) → even n
∃-odd′  : ∀ {n : ℕ} → ∃[ m ] (2 * m + 1 ≡ n) →  odd n

dbl≡2* : ∀ n → n + n ≡ 2 * n
dbl≡2* n = cong (n +_) (sym (+-identityʳ n))

∃-even′ ⟨ zero , refl ⟩ = even-zero
∃-even′ ⟨ suc m , refl ⟩
  rewrite +-identityʳ m | +-suc m m | dbl≡2* m
                  = even-suc (odd-suc (∃-even′ ⟨ m , refl ⟩))

∃-odd′ ⟨ m , refl ⟩ rewrite +-suc (2 * m) 0
                          | +-identityʳ m
                          | +-identityʳ (m + m)
                          | dbl≡2* m           = odd-suc (∃-even′ ⟨ m , refl ⟩)

-- it's more difficult far away ...

open Data.Nat using (_≤_; z≤n; s≤s)
open Data.Nat.Properties using (≤-pred)

∃+⇒≤ : ∀ (y z : ℕ) → ∃[ x ] (x + y ≡ z) → y ≤ z
∃+⇒≤ zero .(x + 0) ⟨ x , refl ⟩ = z≤n
∃+⇒≤ (suc y) .(x + suc y) ⟨ x , refl ⟩ rewrite +-suc x y
                                = s≤s (∃+⇒≤ y (x + y) ⟨ x , refl ⟩)

≤⇒∃+ : ∀ (y z : ℕ) → y ≤ z → ∃[ x ] (x + y ≡ z)
≤⇒∃+ zero z y≤z = ⟨ z , (+-identityʳ z) ⟩
≤⇒∃+ (suc y) (suc z) y≤z with ≤⇒∃+ y z (≤-pred y≤z)
...         | ⟨ x , x+y≡z ⟩ = ⟨ x , trans (+-suc x y) (cong suc x+y≡z) ⟩

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

¬∃≃∀¬ : ∀ {A : Set} {B : A → Set}
  → (¬ ∃[ x ] B x) ≃ ∀ x → ¬ B x
¬∃≃∀¬ =
  record
    { to      = λ{ ¬∃xy x y → ¬∃xy ⟨ x , y ⟩ }
    ; from    = λ{ ∀¬xy ⟨ x , y ⟩ → ∀¬xy x y }
    ; from∘to = λ{ ¬∃xy → extensionality λ{ ⟨ x , y ⟩ → refl } }
    ; to∘from = λ{ ∀¬xy → refl }
    }

---------- practice ----------
∃¬-implies-¬∀ : ∀ {A : Set} {B : A → Set}
  → ∃[ x ] (¬ B x)
    --------------
  → ¬ (∀ x → B x)
∃¬-implies-¬∀ ⟨ a , ¬b ⟩ = λ a→b → ¬b (a→b a)
-- the converse doesn't hold. we couldn't get a instance
-- of A to construct ∃[ x ] (¬ B x)

open import plfa-code.Bin using (Bin; Can; One;
                                zero; can-one; x0_; x1_; nil; one;
                                from; to; can-to-n; can-tf-eq; from-to-const)
open Eq using (subst₂; cong₂)
open import Data.Empty using (⊥-elim)
open import Function using (_∘_)

one-assim : ∀ {b : Bin} → (x : One b) → (y : One b) → x ≡ y
one-assim one one = refl
one-assim (x0 x) (x0 y) = sym (cong x0_ (one-assim y x))
one-assim (x1 x) (x1 y) = sym (cong x1_ (one-assim y x))

can-assim : ∀ {b : Bin} → (x : Can b) → (y : Can b) → x ≡ y
can-assim zero zero = refl
can-assim zero (can-one (x0 ()))
can-assim (can-one (x0 ())) zero
can-assim (can-one one) (can-one one) = refl
can-assim (can-one (x0 x)) (can-one (x0 y)) = cong (can-one ∘ x0_) (one-assim x y)
can-assim (can-one (x1 x)) (can-one (x1 y)) = cong (can-one ∘ x1_) (one-assim x y)

∃-proj₁ : {A : Set} {B : A → Set} → ∃[ x ] B x → A
∃-proj₁ ⟨ x , _ ⟩ = x

∃≡ : ∀ {A : Set} {B : A → Set} (p₁ : ∃[ x ](B x)) (p₂ : ∃[ y ](B y))
  → ∃-proj₁ p₁ ≡ ∃-proj₁ p₂ → (∀ (x) → (b₁ : B x) → (b₂ : B x) → b₁ ≡ b₂)
  → p₁ ≡ p₂
∃≡ ⟨ x , bx ⟩ ⟨ .x , by ⟩ refl f = sym (cong (⟨_,_⟩ x) (f x by bx))

Bin-isomorphism : ℕ ≃ ∃[ x ](Can x)
Bin-isomorphism =
  record
  { to      = to′
  ; from    = from′
  ; from∘to = from-to-const
  ; to∘from = to∘from′
  }
  where
  to′ : ℕ → ∃[ x ](Can x)
  to′ n = ⟨ to n , can-to-n n ⟩
  from′ : ∃[ x ](Can x) → ℕ
  from′ ⟨ b , can-b ⟩ = from b
  to∘from′ : ∀ y → to′ (from′ y) ≡ y
  to∘from′ ⟨ b , can-b ⟩  = ∃≡ ⟨ to (from b) , can-to-n (from b) ⟩ ⟨ b , can-b ⟩ (can-tf-eq can-b) (λ x → can-assim {x})


module Lectures.Two where

-- Introduce imports
open import Lectures.One

-- Introduce type parameters

module List-types where

  data List (A : Set₁) : Set₁ where
    []  : List A
    _∷_ : A → List A → List A

  _ : List Set
  _ = ⊥ ∷ (ℕ ∷ (⊤ ∷ []))

module List {ℓ} where

  data List (A : Set ℓ) : Set ℓ where
    [] : List A
    _∷_ : A → List A → List A

  _++_ : {A : Set ℓ} → List A → List A → List A
  [] ++ ys = ys
  (x ∷ xs) ++ ys = x ∷ (xs ++ ys)

  map : {A B : Set ℓ} → (A → B) → List A → List B
  map f [] = []
  map f (x ∷ xs) = f x ∷ map f xs

open List using (List; []; _∷_)

_ : List ℕ
_ = 0 ∷ (1 ∷ (2 ∷ []))

-- Introduce type families

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

  head : ∀ {A n} → Vec A (suc n) → A
  head (x ∷ xs) = x

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

  map : ∀ {A B n} → (A → B) → Vec A n → Vec B n
  map f [] = []
  map f (x ∷ xs) = f x ∷ map f xs

  zipWith : ∀ {A B C : Set} {n} (f : A → B → C)
          → Vec A n → Vec B n → Vec C n
  zipWith f [] [] = []
  zipWith f (x ∷ xs) (y ∷ ys) = f x y ∷ zipWith f xs ys

--  \u+
data _⊎_ (A : Set) (B : Set) : Set where
  inj₁ : A → A ⊎ B
  inj₂ : B → A ⊎ B

Dec : Set → Set
Dec B = B ⊎ (¬ B)

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

  record _×''_ (A : Set) (B : Set) : Set where
    constructor _,''_
    field
      proj₁ : A
      proj₂ : B

-- \Sigma
record Σ {ℓ} (A : Set ℓ) (B : A → Set ℓ) : Set ℓ where
  constructor _,_
  field
    proj₁ : A
    proj₂ : B proj₁

open Σ public

_ : Σ ℕ _isEven
_ = 0 , tt

_×_ : Set → Set → Set
A × B = Σ A λ _ → B


module CaseSplit1 where

data ℕ : Set where
  Z : ℕ
  S : ℕ → ℕ

f0 : ℕ → ℕ
f0 = λ { x → {!   !} ; y → {!   !} }

f1 : ℕ → ℕ
f1 = λ
  { x → {!   !}
  ; y → {!   !}
  }

g0 : ℕ → ℕ
g0 = λ where x → {!   !}
             y → {!   !}

g1 : ℕ → ℕ
g1 = λ where
  x → {!   !}
  y → {!   !}

issue16 : ℕ → ℕ
issue16 = λ {x → {!   !} }


-- This module closely follows a section of Martín Escardó's HoTT lecture notes:
-- https://www.cs.bham.ac.uk/~mhe/HoTT-UF-in-Agda-Lecture-Notes/HoTT-UF-Agda.html#equivalenceinduction
{-# OPTIONS --without-K #-}
module Util.HoTT.Equiv.Induction where

open import Util.HoTT.HLevel.Core
open import Util.HoTT.Equiv
open import Util.HoTT.Univalence.ContrFormulation
open import Util.Prelude

private
  variable
    α β γ : Level

G-≃ : {A : Set α} (P : Σ[ B ∈ Set α ] (A ≃ B) → Set β)
  → P (A , ≃-refl)
  → ∀ {B} (A≃B : A ≃ B)
  → P (B , A≃B)
G-≃ {A = A} P p {B} A≃B = subst P (univalenceProp A (A , ≃-refl) (B , A≃B)) p

abstract
  G-≃-β : {A : Set α} (P : Σ[ B ∈ Set α ] (A ≃ B) → Set β)
    → (p : P (A , ≃-refl))
    → G-≃ P p ≃-refl ≡ p
  G-≃-β {A = A} P p = subst (λ q → subst P q p ≡ p) (sym go) refl
    where
      go : univalenceProp A (A , ≃-refl) (A , ≃-refl) ≡ refl
      go = IsContr→IsSet (univalenceContr A) _ _

H-≃ : {A : Set α} (P : (B : Set α) → A ≃ B → Set β)
  → P A ≃-refl
  → ∀ {B} (A≃B : A ≃ B)
  → P B A≃B
H-≃ P p A≃B = G-≃ (λ { (B , A≃B) → P B A≃B }) p A≃B

abstract
  H-≃-β : {A : Set α} (P : (B : Set α) → A ≃ B → Set β)
    → (p : P A ≃-refl)
    → H-≃ P p ≃-refl ≡ p
  H-≃-β P p = G-≃-β (λ { (B , A≃B) → P B A≃B }) p

J-≃ : (P : (A B : Set α) → A ≃ B → Set β)
  → (∀ A → P A A ≃-refl)
  → ∀ {A B} (A≃B : A ≃ B)
  → P A B A≃B
J-≃ P p {A} {B} A≃B = H-≃ (λ B A≃B → P A B A≃B) (p A) A≃B

abstract
  J-≃-β : (P : (A B : Set α) → A ≃ B → Set β)
    → (p : ∀ A → P A A ≃-refl)
    → ∀ {A}
    → J-≃ P p ≃-refl ≡ p A
  J-≃-β P p {A} = H-≃-β (λ B A≃B → P A B A≃B) (p A)

H-IsEquiv : {A : Set α} (P : (B : Set α) → (A → B) → Set β)
  → P A id
  → ∀ {B} (f : A → B)
  → IsEquiv f
  → P B f
H-IsEquiv P p f f-equiv
  = H-≃ (λ B A≃B → P B (A≃B .forth)) p
      (record { forth = f ; isEquiv = f-equiv })

J-IsEquiv : (P : (A B : Set α) → (A → B) → Set β)
  → (∀ A → P A A id)
  → ∀ {A B} (f : A → B)
  → IsEquiv f
  → P A B f
J-IsEquiv P p f f-equiv
  = J-≃ (λ A B A≃B → P A B (A≃B .forth)) p
      (record { forth = f ; isEquiv = f-equiv })


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

open import Groups.Abelian.Definition
open import Groups.Definition
open import Setoids.Setoids
open import Sets.EquivalenceRelations
open import Lists.Lists

module Groups.Polynomials.Group {a b : _} {A : Set a} {S : Setoid {a} {b} A} {_+_ : A → A → A} (G : Group S _+_) where

open import Groups.Polynomials.Definition G
open import Groups.Polynomials.Addition G public
open Setoid S
open Equivalence eq

polyGroup : Group naivePolySetoid _+P_
Group.+WellDefined polyGroup = +PwellDefined
Group.0G polyGroup = []
Group.inverse polyGroup = inverse'
Group.+Associative polyGroup {a} {b} {c} = assoc {a} {b} {c}
Group.identRight polyGroup = PidentRight
Group.identLeft polyGroup = PidentLeft
Group.invLeft polyGroup {a} = invLeft' {a}
Group.invRight polyGroup {a} = invRight' {a}

abelian : AbelianGroup G → AbelianGroup polyGroup
AbelianGroup.commutative (abelian ab) {x} {y} = comm ab {x} {y}