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

module Definition.Typed.Consequences.NeTypeEq where

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

open import Tools.Product
import Tools.PropositionalEquality as PE

-- Helper function for the same variable instance of a context have equal types.
varTypeEq′ : ∀ {n R T Γ} → n ∷ R ∈ Γ → n ∷ T ∈ Γ → R PE.≡ T
varTypeEq′ here here = PE.refl
varTypeEq′ (there n∷R) (there n∷T) rewrite varTypeEq′ n∷R n∷T = PE.refl

-- The same variable instance of a context have equal types.
varTypeEq : ∀ {x A B Γ} → Γ ⊢ A → Γ ⊢ B → x ∷ A ∈ Γ → x ∷ B ∈ Γ → Γ ⊢ A ≡ B
varTypeEq A B x∷A x∷B rewrite varTypeEq′ x∷A x∷B = refl A

-- The same neutral term have equal types.
neTypeEq : ∀ {t A B Γ} → Neutral t → Γ ⊢ t ∷ A → Γ ⊢ t ∷ B → Γ ⊢ A ≡ B
neTypeEq (var x) (var x₁ x₂) (var x₃ x₄) =
  varTypeEq (syntacticTerm (var x₃ x₂)) (syntacticTerm (var x₃ x₄)) x₂ x₄
neTypeEq (∘ₙ neT) (t∷A ∘ⱼ t∷A₁) (t∷B ∘ⱼ t∷B₁) with neTypeEq neT t∷A t∷B
... | q = let w = proj₂ (injectivity q)
          in  substTypeEq w (refl t∷A₁)
neTypeEq (natrecₙ neT) (natrecⱼ x t∷A t∷A₁ t∷A₂) (natrecⱼ x₁ t∷B t∷B₁ t∷B₂) =
  refl (substType x₁ t∷B₂)
neTypeEq x (conv t∷A x₁) t∷B = let q = neTypeEq x t∷A t∷B
                               in  trans (sym x₁) q
neTypeEq x t∷A (conv t∷B x₃) = let q = neTypeEq x t∷A t∷B
                               in  trans q x₃


open import Agda.Builtin.Unit
open import Agda.Builtin.List
open import Agda.Builtin.Reflection

id : ∀ {a} {A : Set a} → A → A
id x = x

macro
  my-macro : Term → TC ⊤
  my-macro goal = bindTC
    (getType (quote id))
    λ idType → bindTC
      (reduce idType)
      λ _ → returnTC _

fails? : ⊤
fails? = my-macro


------------------------------------------------------------------------
-- The sequential colimit HIT with an erased higher constructor
------------------------------------------------------------------------

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

-- The definition of sequential colimits and the statement of the
-- non-dependent universal property are based on those in van Doorn's
-- "Constructing the Propositional Truncation using Non-recursive
-- HITs".

-- The module is parametrised by a notion of equality. The higher
-- constructor of the HIT defining sequential colimits uses path
-- equality, but the supplied notion of equality is used for many
-- other things.

import Equality.Path as P

module Colimit.Sequential.Erased
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

open P.Derived-definitions-and-properties eq hiding (elim)

open import Prelude

open import Bijection equality-with-J using (_↔_)
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Erased.Cubical eq

private
  variable
    a b p q : Level
    A B     : Type a
    P       : A → Type p
    n       : ℕ
    e x     : A

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

-- Sequential colimits, with an erased higher constructor.

data Colimitᴱ (P : ℕ → Type p) (@0 step : ∀ {n} → P n → P (suc n)) :
             Type p where
  ∣_∣       : P n → Colimitᴱ P step
  @0 ∣∣≡∣∣ᴾ : (x : P n) → ∣ step x ∣ P.≡ ∣ x ∣

-- A variant of ∣∣≡∣∣ᴾ.

@0 ∣∣≡∣∣ :
  {step : ∀ {n} → P n → P (suc n)} (x : P n) →
  _≡_ {A = Colimitᴱ P step} ∣ step x ∣ ∣ x ∣
∣∣≡∣∣ x = _↔_.from ≡↔≡ (∣∣≡∣∣ᴾ x)

------------------------------------------------------------------------
-- Eliminators

-- A dependent eliminator, expressed using paths.

record Elimᴾ
         {P : ℕ → Type p} {@0 step : ∀ {n} → P n → P (suc n)}
         (Q : Colimitᴱ P step → Type q) : Type (p ⊔ q) where
  no-eta-equality
  field
    ∣∣ʳ       : (x : P n) → Q ∣ x ∣
    @0 ∣∣≡∣∣ʳ :
      (x : P n) →
      P.[ (λ i → Q (∣∣≡∣∣ᴾ x i)) ] ∣∣ʳ (step x) ≡ ∣∣ʳ x

open Elimᴾ public

elimᴾ :
  {@0 step : ∀ {n} → P n → P (suc n)} {Q : Colimitᴱ P step → Type q} →
  Elimᴾ Q → (x : Colimitᴱ P step) → Q x
elimᴾ {P = P} {step = step} {Q = Q} e = helper
  where
  module E = Elimᴾ e

  helper : (x : Colimitᴱ P step) → Q x
  helper ∣ x ∣        = E.∣∣ʳ x
  helper (∣∣≡∣∣ᴾ x i) = E.∣∣≡∣∣ʳ x i

-- A non-dependent eliminator, expressed using paths.

record Recᴾ
         (P : ℕ → Type p) (@0 step : ∀ {n} → P n → P (suc n))
         (B : Type b) : Type (p ⊔ b) where
  no-eta-equality
  field
    ∣∣ʳ       : P n → B
    @0 ∣∣≡∣∣ʳ : (x : P n) → ∣∣ʳ (step x) P.≡ ∣∣ʳ x

open Recᴾ public

recᴾ :
  {@0 step : ∀ {n} → P n → P (suc n)} →
  Recᴾ P step B → Colimitᴱ P step → B
recᴾ r = elimᴾ λ where
    .∣∣ʳ    → R.∣∣ʳ
    .∣∣≡∣∣ʳ → R.∣∣≡∣∣ʳ
  where
  module R = Recᴾ r

-- A dependent eliminator.

record Elim
         {P : ℕ → Type p} {@0 step : ∀ {n} → P n → P (suc n)}
         (Q : Colimitᴱ P step → Type q) : Type (p ⊔ q) where
  no-eta-equality
  field
    ∣∣ʳ       : (x : P n) → Q ∣ x ∣
    @0 ∣∣≡∣∣ʳ : (x : P n) → subst Q (∣∣≡∣∣ x) (∣∣ʳ (step x)) ≡ ∣∣ʳ x

open Elim public

elim :
  {@0 step : ∀ {n} → P n → P (suc n)} {Q : Colimitᴱ P step → Type q} →
  Elim Q → (x : Colimitᴱ P step) → Q x
elim e = elimᴾ λ where
    .∣∣ʳ      → E.∣∣ʳ
    .∣∣≡∣∣ʳ x → subst≡→[]≡ (E.∣∣≡∣∣ʳ x)
  where
  module E = Elim e

-- A "computation" rule.

@0 elim-∣∣≡∣∣ : dcong (elim e) (∣∣≡∣∣ x) ≡ Elim.∣∣≡∣∣ʳ e x
elim-∣∣≡∣∣ = dcong-subst≡→[]≡ (refl _)

-- A non-dependent eliminator.

record Rec
         (P : ℕ → Type p) (@0 step : ∀ {n} → P n → P (suc n))
         (B : Type b) : Type (p ⊔ b) where
  no-eta-equality
  field
    ∣∣ʳ    : P n → B
    @0 ∣∣≡∣∣ʳ : (x : P n) → ∣∣ʳ (step x) ≡ ∣∣ʳ x

open Rec public

rec :
  {@0 step : ∀ {n} → P n → P (suc n)} →
  Rec P step B → Colimitᴱ P step → B
rec r = recᴾ λ where
    .∣∣ʳ      → R.∣∣ʳ
    .∣∣≡∣∣ʳ x → _↔_.to ≡↔≡ (R.∣∣≡∣∣ʳ x)
  where
  module R = Rec r

-- A "computation" rule.

@0 rec-∣∣≡∣∣ :
  {step : ∀ {n} → P n → P (suc n)} {r : Rec P step B} {x : P n} →
  cong (rec r) (∣∣≡∣∣ x) ≡ Rec.∣∣≡∣∣ʳ r x
rec-∣∣≡∣∣ = cong-≡↔≡ (refl _)

------------------------------------------------------------------------
-- The universal property

-- The universal property of the sequential colimit.

universal-property :
  {@0 step : ∀ {n} → P n → P (suc n)} →
  (Colimitᴱ P step → B) ≃
  (∃ λ (f : ∀ n → P n → B) →
     Erased (∀ n x → f (suc n) (step x) ≡ f n x))
universal-property {P = P} {B = B} {step = step} =
  Eq.↔→≃ to from to∘from from∘to
  where
  to :
    (Colimitᴱ P step → B) →
    ∃ λ (f : ∀ n → P n → B) →
      Erased (∀ n x → f (suc n) (step x) ≡ f n x)
  to h = (λ _ → h ∘ ∣_∣)
       , [ (λ _ x →
              h ∣ step x ∣  ≡⟨ cong h (∣∣≡∣∣ x) ⟩∎
              h ∣ x ∣       ∎)
         ]

  from :
    (∃ λ (f : ∀ n → P n → B) →
       Erased (∀ n x → f (suc n) (step x) ≡ f n x)) →
    Colimitᴱ P step → B
  from (f , g) = rec λ where
    .∣∣ʳ    → f _
    .∣∣≡∣∣ʳ → erased g _

  to∘from : ∀ p → to (from p) ≡ p
  to∘from (f , g) =
    cong (f ,_) $
    []-cong
      [ (⟨ext⟩ λ n → ⟨ext⟩ λ x →
           cong (rec _) (∣∣≡∣∣ x)  ≡⟨ rec-∣∣≡∣∣ ⟩∎
           erased g n x            ∎)
      ]

  from∘to : ∀ h → from (to h) ≡ h
  from∘to h = ⟨ext⟩ $ elim λ where
    .∣∣ʳ _    → refl _
    .∣∣≡∣∣ʳ x →
      subst (λ z → from (to h) z ≡ h z) (∣∣≡∣∣ x) (refl _)  ≡⟨ subst-in-terms-of-trans-and-cong ⟩

      trans (sym (cong (from (to h)) (∣∣≡∣∣ x)))
        (trans (refl _) (cong h (∣∣≡∣∣ x)))                 ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                 rec-∣∣≡∣∣
                                                                 (trans-reflˡ _) ⟩

      trans (sym (cong h (∣∣≡∣∣ x))) (cong h (∣∣≡∣∣ x))     ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                ∎

-- A dependently typed variant of the sequential colimit's universal
-- property.

universal-property-Π :
  {@0 step : ∀ {n} → P n → P (suc n)} →
  {Q : Colimitᴱ P step → Type q} →
  ((x : Colimitᴱ P step) → Q x) ≃
  (∃ λ (f : ∀ n (x : P n) → Q ∣ x ∣) →
     Erased (∀ n x → subst Q (∣∣≡∣∣ x) (f (suc n) (step x)) ≡ f n x))
universal-property-Π {P = P} {step = step} {Q = Q} =
  Eq.↔→≃ to from to∘from from∘to
  where
  to :
    ((x : Colimitᴱ P step) → Q x) →
    ∃ λ (f : ∀ n (x : P n) → Q ∣ x ∣) →
      Erased (∀ n x → subst Q (∣∣≡∣∣ x) (f (suc n) (step x)) ≡ f n x)
  to h = (λ _ → h ∘ ∣_∣)
       , [ (λ _ x →
              subst Q (∣∣≡∣∣ x) (h ∣ step x ∣)  ≡⟨ dcong h (∣∣≡∣∣ x) ⟩∎
              h ∣ x ∣                           ∎)
         ]

  from :
    (∃ λ (f : ∀ n (x : P n) → Q ∣ x ∣) →
       Erased (∀ n x →
               subst Q (∣∣≡∣∣ x) (f (suc n) (step x)) ≡ f n x)) →
    (x : Colimitᴱ P step) → Q x
  from (f , [ g ]) = elim λ where
    .∣∣ʳ    → f _
    .∣∣≡∣∣ʳ → g _

  to∘from : ∀ p → to (from p) ≡ p
  to∘from (f , [ g ]) = cong (f ,_) $ []-cong
    [ (⟨ext⟩ λ n → ⟨ext⟩ λ x →
         dcong (elim _) (∣∣≡∣∣ x)  ≡⟨ elim-∣∣≡∣∣ ⟩∎
         g n x                     ∎)
    ]

  from∘to : ∀ h → from (to h) ≡ h
  from∘to h = ⟨ext⟩ $ elim λ where
    .∣∣ʳ    _ → refl _
    .∣∣≡∣∣ʳ x →
      subst (λ z → from (to h) z ≡ h z) (∣∣≡∣∣ x) (refl _)  ≡⟨ subst-in-terms-of-trans-and-dcong ⟩

      trans (sym (dcong (from (to h)) (∣∣≡∣∣ x)))
        (trans (cong (subst Q (∣∣≡∣∣ x)) (refl _))
           (dcong h (∣∣≡∣∣ x)))                             ≡⟨ cong₂ (λ p q → trans (sym p) q)
                                                                 elim-∣∣≡∣∣
                                                                 (trans (cong (flip trans _) $
                                                                         cong-refl _) $
                                                                  trans-reflˡ _) ⟩

      trans (sym (dcong h (∣∣≡∣∣ x))) (dcong h (∣∣≡∣∣ x))   ≡⟨ trans-symˡ _ ⟩∎

      refl _                                                ∎


module SetInf where

id : ∀ {A} → A → A
id x = x


module Structure.Categorical.Multi where

open import Data
open import Data.Boolean
open import Data.Tuple using (_⨯_ ; _,_)
open import Data.Tuple.Raiseᵣ
import      Data.Tuple.Raiseᵣ.Functions as Raise
open import Data.Tuple.RaiseTypeᵣ
import      Data.Tuple.RaiseTypeᵣ.Functions as RaiseType
open import Function.Multi
open import Function.Multi.Functions
open import Functional using (_→ᶠ_)
import      Functional.Dependent as Fn
open import Lang.Instance
import      Lvl
open import Logic
open import Logic.Predicate
open import Logic.Propositional
open import Numeral.Natural
open import Numeral.Natural.Oper.Comparisons
open import Structure.Setoid
import      Structure.Categorical.Names as Names
import      Structure.Operator.Names as Names
import      Structure.Relator.Names as Names
open import Structure.Relator.Properties
open import Syntax.Function
open import Type
open import Type.Properties.Singleton

private variable ℓ ℓₒ ℓₘ ℓₘ₁ ℓₘ₂ ℓₑ ℓₑ₁ ℓₑ₂ : Lvl.Level
private variable Obj Obj₁ Obj₂ : Type{ℓₒ}

module Morphism where
  module _
    (_⟶_ : Obj → Obj → Stmt{ℓₘ})
    ⦃ morphism-equiv : ∀{x y} → Equiv{ℓₑ}(x ⟶ y) ⦄
    where

    {-
    -- Examples:
    --   MorphismChain(3) T x y z
    --   = compose(1) ((x ⟶ y) ,_) (MorphismChain(2) T y) z
    --   = (x ⟶ y) , (MorphismChain(2) T y z)
    --   = (x ⟶ y) , (y ⟶ z) , T(z)
    --
    --   MorphismChain(4) T x y z w
    --   = compose(2) ((x ⟶ y) ,_) (MorphismChain(3) T y) z w
    --   = (x ⟶ y) , (MorphismChain(3) T y z w)
    --   = (x ⟶ y) , (y ⟶ z) , (z ⟶ w) , T(w)
    MorphismChain : (n : ℕ) → (Obj → Type{ℓₘ}) → (RaiseType.repeat (𝐒(n)) Obj) ⇉ Types(Raise.repeat (𝐒(n)) ℓₘ)
    MorphismChain 0         T x   = T(x)
    MorphismChain 1         T x y = (x ⟶ y) , T(y)
    MorphismChain (𝐒(𝐒(n))) T x y = compose(𝐒(n)) ((x ⟶ y) ,_) (MorphismChain(𝐒(n)) T y)

    -- Examples:
    --   MorphismMapping(2) x y
    --   = MorphismChain(2)(x ⟶_) x y
    --   = (x ⟶ y) → (x ⟶ y)
    --
    --   MorphismMapping(3) x y z
    --   = MorphismChain(3)(x ⟶_) x y z
    --   = (x ⟶ y) → (y ⟶ z) → (x ⟶ z)
    --
    --   MorphismMapping(4) x y z w
    --   = MorphismChain(4)(x ⟶_) x y z w
    --   = (x ⟶ y) → (y ⟶ z) → (z ⟶ w) → (x ⟶ w)
    MorphismMapping : (n : ℕ) → (RaiseType.repeat n Obj) ⇉ Type{ℓₘ}
    MorphismMapping(0)   = Unit
    MorphismMapping(1)      = {!!}
    MorphismMapping(𝐒(𝐒 n)) = {!!}
    --MorphismMapping(𝐒 n) = curry(n) {!Fs ↦ (uncurry(n) (MorphismChain(n)) Fs ⇉ (? → ?))!}
    {-
    MorphismMapping(1)       x   = ? -- MorphismChain(1)(x ⟶_) x
    MorphismMapping(𝐒(𝐒(n))) x   = compose(𝐒(n)) (RaiseType.reduceᵣ{𝐒(n)}{\ℓ₁ ℓ₂ → ℓ₁ Lvl.⊔ ℓ₂} _→ᶠ_) (MorphismChain(𝐒(𝐒(n))) (x ⟶_) x)
    -- MorphismChain(𝐒(𝐒(n)))(x ⟶_) x-}
    -}

    MorphismFlippedChain : (n : ℕ) → (RaiseType.repeat (𝐒(n)) Obj) ⇉ Type{ℓₘ}
    MorphismFlippedChain 𝟎      x = x ⟶ x
    MorphismFlippedChain (𝐒(n)) x = Out(𝐒(n)) (x ⟶_) x where
      Out : (n : ℕ) → (Obj → Type{ℓₘ}) → (RaiseType.repeat (𝐒(n)) Obj) ⇉ Type{ℓₘ}
      Out 0         T x   = T(x)
      Out 1         T x y = (x ⟶ y) → T(y)
      Out (𝐒(𝐒(n))) T x y = Out(𝐒(n)) (z ↦ ((x ⟶ y) → T(z))) y

  module _
    (_⟶₁_ : Obj₁ → Obj₁ → Stmt{ℓₘ₁})
    ⦃ morphism-equiv₁ : ∀{x y} → Equiv{ℓₑ₁}(x ⟶₁ y) ⦄
    (_⟶₂_ : Obj₂ → Obj₂ → Stmt{ℓₘ₂})
    ⦃ morphism-equiv₂ : ∀{x y} → Equiv{ℓₑ₂}(x ⟶₂ y) ⦄
    where

    private open module Equiv₂{x}{y} = Equiv(morphism-equiv₂{x}{y}) using () renaming (_≡_ to _≡₂_)

    module _
      {F : Obj₁ → Obj₂}
      where

      -- Definition of the relation between a function and an operation that says:
      -- The function preserves the operation.
      -- Often used when defining homomorphisms.
      -- Examples:
      --   Preserving(0) (map)(G₁)(G₂)
      --   = ∀{x} → (map ∘₀ G₁ ≡ G₂ on₀ map)
      --   = ∀{x} → (map(G₁) ≡ G₂(f))
      --   Preserving(1) (map)(G₁)(G₂)
      --   = ∀{x y}{f : x ⟶ y} → ((map ∘₁ G₁)(f) ≡ (G₂ on₁ map)(f))
      --   = ∀{x y}{f : x ⟶ y} → (map(G₁(f)) ≡ G₂(map(f)))
      --   Preserving(2) (map)(G₁)(G₂)
      --   = ∀{x y z}{f₁ : y ⟶ z}{f₂ : x ⟶ y} → ((map ∘₂ G₁)(f₁)(f₂) ≡ (G₂ on₂ map)(f₁)(f₂))
      --   = ∀{x y z}{f₁ : y ⟶ z}{f₂ : x ⟶ y} → (map(G₁ f₁ f₂) ≡ G₂ (map(f₁)) (map(f₂)))
      --   Preserving(3) (map)(G₁)(G₂)
      --   = ∀{f₁ f₂ f₃} → ((map ∘₃ G₁)(f₁)(f₂)(f₃) ≡ (G₂ on₃ map)(f₁)(f₂)(f₃))
      --   = ∀{f₁ f₂ f₃} → (map(G₁ f₁ f₂ f₃) ≡ G₂ (map(f₁)) (map(f₂)) (map(f₃)))
      Preserving : (n : ℕ) → (map : ∀{x y} → (x ⟶₁ y) → (F(x) ⟶₂ F(y))) → (quantifier₊(𝐒(n))(∀ₗ) (MorphismFlippedChain(_⟶₁_)(n))) → (quantifier₊(𝐒(n))(∀ₗ) (MorphismFlippedChain(_⟶₂_)(n))) → (RaiseType.repeat (𝐒(n)) Obj₁) ⇉ Stmt{if(n ≤? 0) then (ℓₑ₂) else (ℓₘ₁ Lvl.⊔ ℓₑ₂)}
      Preserving 0            map G₁ G₂ x     = (map{x}(G₁) ≡ G₂)
      Preserving 1            map G₁ G₂ x y   = ∀{f : x ⟶₁ y} → map (G₁(f)) ≡ G₂(map f)
      Preserving (𝐒(𝐒(n)))    map G₁ G₂ x y   = {!Preserving(𝐒(n)) map ? ? y!}
      -- ∀{f} → (G₁(f)) (G₂(map f))
      --Preserving 2            map G₁ G₂ x y z = ∀{f₁ : y ⟶₁ z}{f₂ : x ⟶₁ y} → (map(G₁(f₁)(f₂)) ≡ G₂(map f₁)(map f₂))
      -- Preserving (𝐒(𝐒(𝐒(n)))) map G₁ G₂ x y z = {!∀{f} → Preserving(𝐒(𝐒(n))) map !}
      --test (P ↦ (∀{f} → P f)) (f ↦ Preserving (𝐒(𝐒(n))) map {!G₁!} {!G₂!} y z) where
      --  test : ((P : {!!}) → TYPE ({!!} Lvl.⊔ {!!})) → ((f : {!!} ⟶₁ {!!}) → RaiseType.repeat (𝐒 n) Obj₁ ⇉ Type) → (RaiseType.repeat (𝐒 n) Obj₁ ⇉ Type)
        -- compose(𝐒(n)) (P ↦ (∀{f} → P f)) ({!f ↦ Preserving (𝐒(𝐒(n))) map {!G₁!} {!G₂!} {!!} {!!}!})
      -- compose(𝐒(n)) {!!} {!!}
      -- ∀{f : x ⟶₁ y} →
      -- Preserving(𝐒(𝐒(n))) map (\{a b} → {!G₁{a}{x}{b}!}) \{a b} → {!G₂{a}{F x}{b}!}

{-
-- Preserving 3 map G₁ G₂ a x y z
-- = ∀{f : a ⟶₁ x} → Preserving 2 map (G₁(f)) (G₂(map f)) x y z
-- = ∀{f : a ⟶₁ x}{f₁ : x ⟶₁ y}{f₂ : y ⟶₁ z} → (map(G₁(f)(f₁)(f₂)) ≡ G₂(map f)(map f₁)(map f₂))

      -- ∀{x y}{f : x ⟶₁ y} → Preserving(𝐒(𝐒(n))) (map) (G₁(f)) (G₂(map(f)))
{-      Preserving(𝟎)       (f)(g₁)(g₂) = (f(g₁) ≡ g₂)
      Preserving(𝐒(𝟎))    (f)(g₁)(g₂) = (∀{x} → f(g₁(x)) ≡ g₂(f(x)))
      Preserving(𝐒(𝐒(n))) (f)(g₁)(g₂) = (∀{x} → Preserving(𝐒(n)) (f) (g₁(x)) (g₂(f(x))))
  -- ∀{x y z : Objₗ}{f : y ⟶ z}{g : x ⟶ y} → (map(f ∘ g) ≡ map(f) ∘ map(g))
-}

-}


-- Andreas, 2012-05-04
-- Occurs check when unifying indices in patterns
{-# OPTIONS --allow-unsolved-metas #-}
-- The option is supplied to force a real error to pass the regression test.
module OccursCheck1 where

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

data _==_ {A : Set}(x : A) : A -> Set where
  refl : x == x

test :
  let X : Nat
      X = _
  in  X == suc X
test = refl
-- should fail with error message indicating no solution possible


module AKS.Binary where

open import AKS.Binary.Base public


{-# OPTIONS --rewriting #-}

module Properties.DecSubtyping where

open import Agda.Builtin.Equality using (_≡_; refl)
open import FFI.Data.Either using (Either; Left; Right; mapLR; swapLR; cond)
open import Luau.FunctionTypes using (src; srcⁿ; tgt)
open import Luau.Subtyping using (_<:_; _≮:_; Tree; Language; ¬Language; witness; unknown; never; scalar; function; scalar-function; scalar-function-ok; scalar-function-err; scalar-scalar; function-scalar; function-ok; function-err; left; right; _,_)
open import Luau.Type using (Type; Scalar; nil; number; string; boolean; never; unknown; _⇒_; _∪_; _∩_)
open import Properties.Contradiction using (CONTRADICTION; ¬)
open import Properties.Functions using (_∘_)
open import Properties.Subtyping using (<:-refl; <:-trans; ≮:-trans-<:; <:-trans-≮:; <:-never; <:-unknown; <:-∪-left; <:-∪-right; <:-∪-lub;  ≮:-∪-left; ≮:-∪-right; <:-∩-left; <:-∩-right; <:-∩-glb;  ≮:-∩-left; ≮:-∩-right; dec-language; scalar-<:; <:-everything; <:-function; ≮:-function-left; ≮:-function-right)
open import Properties.TypeNormalization using (FunType; Normal; never; unknown; _∩_; _∪_; _⇒_; normal; <:-normalize; normalize-<:)
open import Properties.FunctionTypes using (fun-¬scalar; ¬fun-scalar; fun-function; src-unknown-≮:; tgt-never-≮:; src-tgtᶠ-<:)
open import Properties.Equality using (_≢_)

-- Honest this terminates, since src and tgt reduce the depth of nested arrows
{-# TERMINATING #-}
dec-subtypingˢⁿ : ∀ {T U} → Scalar T → Normal U → Either (T ≮: U) (T <: U)
dec-subtypingᶠ : ∀ {T U} → FunType T → FunType U → Either (T ≮: U) (T <: U)
dec-subtypingᶠⁿ : ∀ {T U} → FunType T → Normal U → Either (T ≮: U) (T <: U)
dec-subtypingⁿ : ∀ {T U} → Normal T → Normal U → Either (T ≮: U) (T <: U)
dec-subtyping : ∀ T U → Either (T ≮: U) (T <: U)

dec-subtypingˢⁿ T U with dec-language _ (scalar T)
dec-subtypingˢⁿ T U | Left p = Left (witness (scalar T) (scalar T) p)
dec-subtypingˢⁿ T U | Right p = Right (scalar-<: T p)

dec-subtypingᶠ {T = T} _ (U ⇒ V) with dec-subtypingⁿ U (normal (src T)) | dec-subtypingⁿ (normal (tgt T)) V
dec-subtypingᶠ {T = T} _ (U ⇒ V) | Left p | q = Left (≮:-trans-<: (src-unknown-≮: (≮:-trans-<: p (<:-normalize (src T)))) (<:-function <:-refl <:-unknown))
dec-subtypingᶠ {T = T} _ (U ⇒ V) | Right p | Left q = Left (≮:-trans-<: (tgt-never-≮: (<:-trans-≮: (normalize-<: (tgt T)) q)) (<:-trans (<:-function <:-never <:-refl) <:-∪-right))
dec-subtypingᶠ T (U ⇒ V) | Right p | Right q = Right (src-tgtᶠ-<: T (<:-trans p (normalize-<: _)) (<:-trans (<:-normalize _) q))

dec-subtypingᶠ T (U ∩ V) with dec-subtypingᶠ T U | dec-subtypingᶠ T V
dec-subtypingᶠ T (U ∩ V) | Left p | q = Left (≮:-∩-left p)
dec-subtypingᶠ T (U ∩ V) | Right p | Left q = Left (≮:-∩-right q)
dec-subtypingᶠ T (U ∩ V) | Right p | Right q = Right (<:-∩-glb p q)

dec-subtypingᶠⁿ T never = Left (witness function (fun-function T) never)
dec-subtypingᶠⁿ T unknown = Right <:-unknown
dec-subtypingᶠⁿ T (U ⇒ V) = dec-subtypingᶠ T (U ⇒ V)
dec-subtypingᶠⁿ T (U ∩ V) = dec-subtypingᶠ T (U ∩ V)
dec-subtypingᶠⁿ T (U ∪ V) with dec-subtypingᶠⁿ T U
dec-subtypingᶠⁿ T (U ∪ V) | Left (witness t p q) = Left (witness t p (q , ¬fun-scalar V T p))
dec-subtypingᶠⁿ T (U ∪ V) | Right p = Right (<:-trans p <:-∪-left)

dec-subtypingⁿ never U = Right <:-never
dec-subtypingⁿ unknown unknown = Right <:-refl
dec-subtypingⁿ unknown U with dec-subtypingᶠⁿ (never ⇒ unknown) U
dec-subtypingⁿ unknown U | Left p = Left (<:-trans-≮: <:-unknown p)
dec-subtypingⁿ unknown U | Right p₁ with dec-subtypingˢⁿ number U
dec-subtypingⁿ unknown U | Right p₁ | Left p = Left (<:-trans-≮: <:-unknown p)
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ with dec-subtypingˢⁿ string U
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ | Left p = Left (<:-trans-≮: <:-unknown p)
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ | Right p₃ with dec-subtypingˢⁿ nil U
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ | Right p₃ | Left p = Left (<:-trans-≮: <:-unknown p)
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ | Right p₃ | Right p₄ with dec-subtypingˢⁿ boolean U
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ | Right p₃ | Right p₄ | Left p = Left (<:-trans-≮: <:-unknown p)
dec-subtypingⁿ unknown U | Right p₁ | Right p₂ | Right p₃ | Right p₄ | Right p₅ = Right (<:-trans <:-everything (<:-∪-lub p₁ (<:-∪-lub p₂ (<:-∪-lub p₃ (<:-∪-lub p₄ p₅)))))
dec-subtypingⁿ (S ⇒ T) U = dec-subtypingᶠⁿ (S ⇒ T) U
dec-subtypingⁿ (S ∩ T) U = dec-subtypingᶠⁿ (S ∩ T) U
dec-subtypingⁿ (S ∪ T) U with dec-subtypingⁿ S U | dec-subtypingˢⁿ T U
dec-subtypingⁿ (S ∪ T) U | Left p | q = Left (≮:-∪-left p)
dec-subtypingⁿ (S ∪ T) U | Right p | Left q = Left (≮:-∪-right q)
dec-subtypingⁿ (S ∪ T) U | Right p | Right q = Right (<:-∪-lub p q)

dec-subtyping T U with dec-subtypingⁿ (normal T) (normal U)
dec-subtyping T U | Left p = Left (<:-trans-≮: (normalize-<: T) (≮:-trans-<: p (<:-normalize U)))
dec-subtyping T U | Right p = Right (<:-trans (<:-normalize T) (<:-trans p (normalize-<: U)))


module NonLinearConstraint where

import Common.Level
open import Common.Equality

test : let X : Set -> Set -> Set
           X = _
       in (A : Set) -> X A A ≡ A
test A = refl
-- should not be solved, solution not uniquely determined


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

open import Coequalizers.Definition

open import lib.Basics
open import lib.types.Paths

open import Graphs.Definition

module Coequalizers.EdgeCoproduct where

module CoeqCoprodEquiv {i j k : ULevel} (V : Type i) (E₁ : Type j) (E₂ : Type k) ⦃ gph : Graph (E₁ ⊔ E₂) V ⦄ where

  instance
    gph1 : Graph E₁ V
    gph1 = record { π₀ = (Graph.π₀ gph) ∘ inl ; π₁ = (Graph.π₁ gph) ∘ inl }

  instance
    gph2 : Graph E₂ (V / E₁)
    gph2 = record { π₀ = c[_] ∘ (Graph.π₀ gph) ∘ inr ; π₁ = c[_] ∘ (Graph.π₁ gph) ∘ inr }

  edge-coproduct-expand : (V / (E₁ ⊔ E₂)) ≃ ((V / E₁) / E₂)
  edge-coproduct-expand = equiv f g f-g g-f
    where
      f : V / (E₁ ⊔ E₂) → (V / E₁) / E₂
      f = Coeq-rec (c[_] ∘ c[_]) λ { (inl x) → ap c[_] (quot x) ; (inr x) → quot x}

      g : (V / E₁) / E₂ → V / (E₁ ⊔ E₂)
      g = Coeq-rec (Coeq-rec c[_] (λ e → quot (inl e))) (λ e → quot (inr e))

      f-g : (x : (V / E₁) / E₂) → (f (g x) == x)
      f-g = Coeq-elim (λ x' → f (g x') == x') (Coeq-elim (λ x' → f (g (c[ x' ])) == c[ x' ]) (λ v → idp) (λ e → ↓-='-in (lemma1 e))) λ e → ↓-app=idf-in $
        idp ∙' quot e
          =⟨ ∙'-unit-l _ ⟩
        quot e
          =⟨ ! (Coeq-rec-β= _ _ _) ⟩
        ap f (quot (inr e))
          =⟨ ap (ap f) (! (Coeq-rec-β= _ _ _)) ⟩
        ap f (ap g (quot e))
          =⟨ ! (ap-∘ f g (quot e)) ⟩
        ap (f ∘ g) (quot e)
          =⟨ ! (∙-unit-r _) ⟩
        ap (f ∘ g) (quot e) ∙ idp
          =∎
        where
          lemma1 : (e : E₁) → idp ∙' ap (λ z → c[ z ]) (quot e) ==
                      ap (λ z → f (g c[ z ])) (quot e) ∙ idp
          lemma1 e =
            idp ∙' ap c[_] (quot e)
              =⟨ ∙'-unit-l _ ⟩
            ap c[_] (quot e)
              =⟨ ! (Coeq-rec-β= _ _ _) ⟩
            ap f (quot (inl e))
              =⟨ ap (ap f) (! (Coeq-rec-β= _ _ _)) ⟩
            ap f (ap (Coeq-rec c[_] (λ e → quot (inl e))) (quot e))
              =⟨ idp ⟩
            ap f (ap (g ∘ c[_]) (quot e))
              =⟨ ! (ap-∘ f (g ∘ c[_]) (quot e)) ⟩
            ap (f ∘ g ∘ c[_]) (quot e)
              =⟨ ! (∙-unit-r _) ⟩
            ap (f ∘ g ∘ c[_]) (quot e) ∙ idp
              =∎

      g-f : (x : V / (E₁ ⊔ E₂)) → (g (f x) == x)
      g-f = Coeq-elim (λ x → g (f x) == x) (λ v → idp) (λ { (inl e) → ↓-app=idf-in (! (lemma1 e)) ; (inr e) → ↓-app=idf-in (! (lemma2 e))})
        where
          lemma1 : (e : E₁) → ap (λ z → g (f z)) (quot (inl e)) ∙ idp == idp ∙' quot (inl e)
          lemma1 e =
            ap (g ∘ f) (quot (inl e)) ∙ idp
              =⟨ ∙-unit-r _ ⟩
            ap (g ∘ f) (quot (inl e))
               =⟨ ap-∘ g f (quot (inl e)) ⟩
            ap g (ap f (quot (inl e)))
              =⟨ ap (ap g) (Coeq-rec-β= _ _ _) ⟩
            ap g (ap c[_] (quot e))
              =⟨ ! (ap-∘ g c[_] (quot e)) ⟩
            ap (g ∘ c[_]) (quot e)
              =⟨ idp ⟩
            ap (Coeq-rec c[_] (λ e' → quot (inl e'))) (quot e)
              =⟨ Coeq-rec-β= _ _ _ ⟩
            quot (inl e)
              =⟨ ! (∙'-unit-l _) ⟩
            idp ∙' quot (inl e)
              =∎

          lemma2 : (e : E₂) → ap (λ z → g (f z)) (quot (inr e)) ∙ idp == idp ∙' quot (inr e)
          lemma2 e =
            ap (g ∘ f) (quot (inr e)) ∙ idp
              =⟨ ∙-unit-r _ ⟩
            ap (g ∘ f) (quot (inr e))
              =⟨ ap-∘ g f (quot (inr e)) ⟩
            ap g (ap f (quot (inr e)))
              =⟨ ap (ap g) (Coeq-rec-β= _ _ _) ⟩
            ap g (quot e)
              =⟨ Coeq-rec-β= _ _ _ ⟩
            quot (inr e)
              =⟨ ! (∙'-unit-l _) ⟩
            idp ∙' quot (inr e)
              =∎


module Test where

open import Pitch
open import Interval
open import Counterpoint

open import Data.Vec using (Vec; []; _∷_; zip)
open import Data.Fin using (zero; suc)

open import Relation.Binary.PropositionalEquality using (refl)

-- Last five notes of Yamanote melody
cantusFirmus : Vec Pitch 5
cantusFirmus = c 5 ∷ e 5 ∷ g 5 ∷ d 6 ∷ c 6 ∷ []

counterpoint : Vec Interval 5
counterpoint = maj10 ∷ min10 ∷ per8 ∷ maj6 ∷ per8 ∷ []

firstSpecies : Counterpoint 3
firstSpecies = zip cantusFirmus counterpoint

testCorrect : FirstSpecies firstSpecies
testCorrect = fs firstSpecies
                 (λ { zero → refl ;
                      (suc zero) → refl ;
                      (suc (suc zero)) → refl ;
                      (suc (suc (suc zero))) → refl ;
                      (suc (suc (suc (suc zero)))) → refl })
                 (λ { zero → refl ;
                      (suc zero) → refl ;
                      (suc (suc zero)) → refl ;
                      (suc (suc (suc zero))) → refl})
                 refl


{-# OPTIONS --warning=error #-}
module UnknownNameInFixityDecl where

infix 40 _+_
infixr 60 _*_


{-# OPTIONS --safe #-}

module Cubical.HITs.Bouquet where

open import Cubical.HITs.Bouquet.Base public
open import Cubical.HITs.Bouquet.FundamentalGroupProof public


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

module Number.Instances.Nat where

open import Agda.Primitive renaming (_⊔_ to ℓ-max; lsuc to ℓ-suc; lzero to ℓ-zero)
open import Cubical.Foundations.Everything renaming (_⁻¹ to _⁻¹ᵖ; assoc to ∙-assoc)
open import Cubical.Foundations.Logic renaming (inl to inlᵖ; inr to inrᵖ)
-- open import Cubical.Structures.Ring
-- open import Cubical.Structures.Group
-- open import Cubical.Structures.AbGroup

open import Cubical.Relation.Nullary.Base renaming (¬_ to ¬ᵗ_)
open import Cubical.Relation.Binary.Base
open import Cubical.Data.Sum.Base renaming (_⊎_ to infixr 4 _⊎_)
open import Cubical.Data.Sigma.Base renaming (_×_ to infixr 4 _×_)
open import Cubical.Data.Sigma
open import Cubical.Data.Empty renaming (elim to ⊥-elim; ⊥ to ⊥⊥) -- `⊥` and `elim`
open import Cubical.Foundations.Logic renaming (¬_ to ¬ᵖ_; inl to inlᵖ; inr to inrᵖ)
open import Function.Base using (it; _∋_; _$_)

open import Cubical.HITs.PropositionalTruncation --.Properties

open import Utils using (!_; !!_)
open import MoreLogic.Reasoning
open import MoreLogic.Definitions
open import MoreLogic.Properties
open import MorePropAlgebra.Definitions hiding (_≤''_)
open import MorePropAlgebra.Structures
open import MorePropAlgebra.Bundles
open import MorePropAlgebra.Consequences
open import Number.Structures2
open import Number.Bundles2

open import Cubical.Data.Nat as Nat renaming (_*_ to _·_)
open import Cubical.Data.Nat.Order renaming (_<_ to _<ᵗ_)
open import Cubical.Data.Nat.Properties using
  ( inj-*sm
  ; inj-sm*
  ) renaming
  ( *-distribʳ  to ·-distribʳ
  ; *-distribˡ  to ·-distribˡ
  ; *-assoc     to ·-assoc
  ; *-comm      to ·-comm
  ; *-identityʳ to ·-identityʳ
  ; *-identityˡ to ·-identityˡ
  )
-- open import Data.Nat.Properties using (+-assoc)
open import Data.Nat.Base using () renaming
  ( _⊔_ to max
  ; _⊓_ to min
  )

-- _<_ as an hProp-valued relation
_<_ : (x y : ℕ) → hProp ℓ-zero
(x < y) .fst = x <ᵗ y
(x < y) .snd (k₁ , k₁+sx≡y) (k₂ , k₂+sx≡y) = φ where
  abstract φ = Σ≡Prop (λ k → isSetℕ _ _) (inj-+m (k₁+sx≡y ∙ sym k₂+sx≡y))

0<suc : ∀ a → 0 <ᵗ suc a
0<suc a = a , +-comm a 1

·-nullifiesˡ : ∀ x → 0 · x ≡ 0
·-nullifiesˡ x = refl

·-nullifiesʳ : ∀ x → x · 0 ≡ 0
·-nullifiesʳ zero = refl
·-nullifiesʳ (suc x) = ·-nullifiesʳ x

abstract
  lemma10   : ∀ n → (n <ᵗ 0) ≡ [ ⊥ ]
  lemma10   n = isoToPath (iso (λ{ (k , p) → snotz (sym (+-suc k n) ∙ p) }) ⊥-elim (λ b → isProp⊥ _ _) (λ a → isProp[] (n < 0) _ _))

  lemma10'' : ∀ n → (n < 0) ≡ ⊥
  lemma10'' n = ⇔toPath (transport (lemma10 n)) (transport (sym (lemma10 n)))

  lemma12 : ∀ n → [ 0 < suc n ] ≡ [ ⊤ ]
  lemma12 n = isoToPath (iso (λ _ →  tt) (λ _ → n , +-suc n 0 ∙ (λ i → suc (+-zero n i))) (λ b → isProp⊤ _ _) (λ a → isProp[] (0 < suc n) _ _))

  lemma12'' : ∀ n → (0 < suc n) ≡ ⊤
  lemma12'' n = ⇔toPath (transport (lemma12 n)) (transport (sym (lemma12 n)))

abstract
  <-irrefl       : (a       : ℕ) → [ ¬ (a < a) ]
  <-irrefl zero q = transp (λ i → [ lemma10'' 0 i ]) i0 q
  <-irrefl (suc a) (k , p) =
    snotz (inj-m+ {a} (+-suc a k ∙ (λ i → suc (+-comm a k i)) ∙ sym (+-suc k a) ∙ inj-m+ {1} (sym (+-suc k (suc a)) ∙ p) ∙ sym (+-zero a)))

  suc-creates-< : ∀ a b → [ a < b ⇔ suc a < suc b ]
  suc-creates-< a b .fst (k , p) = k , (+-suc k (suc a)) ∙ (λ i → suc (p i))
  suc-creates-< a b .snd (k , p) = k , inj-m+ {1} (sym (+-suc k (suc a)) ∙ p)

  +-createsˡ-< : ∀ a b x → [ a < b ⇔ (x + a) < (x + b) ]
  +-createsˡ-< a b  zero   .fst a<b = a<b
  +-createsˡ-< a b (suc x) .fst a<b = suc-creates-< (x + a) (x + b) .fst $ +-createsˡ-< a b x .fst a<b
  +-createsˡ-< a b zero .snd a<b = a<b
  +-createsˡ-< a b (suc x) .snd p = +-createsˡ-< a b x .snd (suc-creates-< (x + a) (x + b) .snd p)

  +-createsʳ-< : ∀ a b x → [ a < b ⇔ (a + x) < (b + x) ]
  +-createsʳ-< a b x .fst p = transport (λ i → [ +-comm x a i < +-comm x b i ]) $ +-createsˡ-< a b x .fst p
  +-createsʳ-< a b x .snd p = +-createsˡ-< a b x .snd (transport (λ i → [ +-comm a x i < +-comm b x i ]) p)

  <-cotrans      : (a b     : ℕ) → [ a < b ] → (x : ℕ) → [ (a < x) ⊔ (x < b) ]
  <-cotrans  zero    zero        q      c  = ⊥-elim {A = λ _ → [ (zero < c) ⊔ (c < zero) ]}  (<-irrefl _ q)
  <-cotrans  zero   (suc b)      q  zero   = inrᵖ q
  <-cotrans  zero   (suc b)      q (suc c) = inlᵖ (c , +-comm c 1)
  <-cotrans (suc a)  zero   (k , p)     c  = ⊥-elim {A = λ _ → [ (suc a < c) ⊔ (c < zero) ]} (snotz (sym (+-suc k (suc a)) ∙ p))
  <-cotrans (suc a) (suc b)      q  zero   = inrᵖ (b , +-comm b 1)
  <-cotrans (suc a) (suc b)      q (suc c) = transport (λ i → [ r i ⊔ s i ]) (<-cotrans a b (suc-creates-< a b .snd q) c)
    where r : (a < c) ≡ (suc a < suc c)
          s : (c < b) ≡ (suc c < suc b)
          r = ⇔toPath (suc-creates-< a c .fst) (suc-creates-< a c .snd)
          s = ⇔toPath (suc-creates-< c b .fst) (suc-creates-< c b .snd)

·-reflects-≡ʳ : ∀ a b x → [ 0 < x ] → a · x ≡ b · x → a ≡ b
·-reflects-≡ʳ a b zero    p q = ⊥-elim {A = λ _ → a ≡ b} $ <-irrefl 0 p
·-reflects-≡ʳ a b (suc x) p q = inj-*sm {l = a} {m = x} {n = b} q

·-reflects-≡ˡ : ∀ a b x → [ 0 < x ] → x · a ≡ x · b → a ≡ b
·-reflects-≡ˡ a b zero    p q = ⊥-elim {A = λ _ → a ≡ b} $ <-irrefl 0 p
·-reflects-≡ˡ a b (suc x) p q = inj-sm* {m = x} {l = a} {n = b} q

¬suc<0 : ∀ x → [ ¬ (suc x < 0) ]
¬suc<0 x (k , p) = snotz $ sym (+-suc k (suc x)) ∙ p

·-reflects-< : ∀ a b x → [ 0 < x ] → [ (a · x) < (b · x) ] → [ a < b ]
·-reflects-< zero zero x p q = q
·-reflects-< zero (suc b) x p q = 0<suc b
·-reflects-< (suc a) zero x p q = ⊥-elim {A = λ _ → [ suc a < 0 ]} $ ¬-<-zero q
·-reflects-< (suc a) (suc b) x p q = suc-creates-< a b .fst $ ·-reflects-< a b x p (+-createsˡ-< (a · x) (b · x) x .snd q)

min-comm : ∀ x y → min x y ≡ min y x
min-comm zero zero = refl
min-comm zero (suc y) = refl
min-comm (suc x) zero = refl
min-comm (suc x) (suc y) i = suc $ min-comm x y i

min-tightˡ : ∀ x y → [ x < y ] → min x y ≡ x
min-tightˡ zero zero x<y = refl
min-tightˡ zero (suc y) x<y = refl
min-tightˡ (suc x) zero x<y = ⊥-elim {A = λ _ → zero ≡ suc x} (¬suc<0 x x<y)
min-tightˡ (suc x) (suc y) x<y i = suc $ min-tightˡ x y (suc-creates-< x y .snd x<y) i

min-tightʳ : ∀ x y → [ y < x ] → min x y ≡ y
min-tightʳ x y y<x = min-comm x y ∙ min-tightˡ y x y<x

min-identity : ∀ x → min x x ≡ x
min-identity zero = refl
min-identity (suc x) i = suc $ min-identity x i

max-comm : ∀ x y → max x y ≡ max y x
max-comm zero zero = refl
max-comm zero (suc y) = refl
max-comm (suc x) zero = refl
max-comm (suc x) (suc y) i = suc $ max-comm x y i

max-tightˡ : ∀ x y → [ y < x ] → max x y ≡ x
max-tightˡ zero zero y<x = refl
max-tightˡ zero (suc y) y<x = ⊥-elim {A = λ _ → suc y ≡ zero} (¬suc<0 y y<x)
max-tightˡ (suc x) zero y<x = refl
max-tightˡ (suc x) (suc y) y<x i = suc $ max-tightˡ x y (suc-creates-< y x .snd y<x) i

max-tightʳ : ∀ x y → [ x < y ] → max x y ≡ y
max-tightʳ x y x<y = max-comm x y ∙ max-tightˡ y x x<y

max-identity : ∀ x → max x x ≡ x
max-identity zero = refl
max-identity (suc x) i = suc $ max-identity x i

-- +-reflects-< : ∀ a b x → [ a + x < b + x ] → [ a < b ]
-- +-reflects-< a b x

-- suc-preserves-min : ∀ x y → suc (min x y) ≡ min (suc x) (suc y)
-- suc-preserves-min zero y = refl
-- suc-preserves-min (suc x) zero = refl
-- suc-preserves-min (suc x) (suc y) = refl
--
-- min-dichotomy : ∀ x y → (min x y ≡ x) ⊎ (min x y ≡ y)
-- min-dichotomy zero y = inl refl
-- min-dichotomy (suc x) zero = inr refl
-- min-dichotomy (suc x) (suc y) with min-dichotomy x y
-- ... | inl p = inl λ i → suc (p i)
-- ... | inr p = inr λ i → suc (p i)

data MinTrichtotomy (x y : ℕ) : Type where
  min-lt : min x y ≡ x → [ x < y ]   → MinTrichtotomy x y
  min-gt : min x y ≡ y → [ y < x ]   → MinTrichtotomy x y
  min-eq : min x y ≡ x → min x y ≡ y → MinTrichtotomy x y

data MaxTrichtotomy (x y : ℕ) : Type where
  max-lt : max x y ≡ y → [ x < y ]   → MaxTrichtotomy x y
  max-gt : max x y ≡ x → [ y < x ]   → MaxTrichtotomy x y
  max-eq : max x y ≡ x → max x y ≡ y → MaxTrichtotomy x y

abstract
  min-trichotomy : ∀ x y → MinTrichtotomy x y
  min-trichotomy zero zero = min-eq refl refl
  min-trichotomy zero (suc y) = min-lt refl (y , (+-comm y 1))
  min-trichotomy (suc x) zero = min-gt refl (x , (+-comm x 1))
  min-trichotomy (suc x) (suc y) with min-trichotomy x y
  ... | min-lt p (k , q) = min-lt (λ i → suc (p i)) (k , (+-assoc k 1 (suc x) ∙ (λ i → +-comm k 1 i + suc x) ∙ (λ i → 1 + q i)))
  ... | min-gt p (k , q) = min-gt (λ i → suc (p i)) (k , (+-assoc k 1 (suc y) ∙ (λ i → +-comm k 1 i + suc y) ∙ (λ i → 1 + q i)))
  ... | min-eq p q       = min-eq (λ i → suc (p i)) (λ i → suc (q i))

  max-trichotomy : ∀ x y → MaxTrichtotomy x y
  max-trichotomy zero zero = max-eq refl refl
  max-trichotomy zero (suc y) = max-lt refl (y , (+-comm y 1))
  max-trichotomy (suc x) zero = max-gt refl (x , (+-comm x 1))
  max-trichotomy (suc x) (suc y) with max-trichotomy x y
  ... | max-lt p (k , q) = max-lt (λ i → suc (p i)) (k , (+-assoc k 1 (suc x) ∙ (λ i → +-comm k 1 i + suc x) ∙ (λ i → 1 + q i)))
  ... | max-gt p (k , q) = max-gt (λ i → suc (p i)) (k , (+-assoc k 1 (suc y) ∙ (λ i → +-comm k 1 i + suc y) ∙ (λ i → 1 + q i)))
  ... | max-eq p q       = max-eq (λ i → suc (p i)) (λ i → suc (q i))

  is-min : (x y z : ℕ) → [ ¬ᵖ (min x y < z) ⇔ ¬ᵖ (x < z) ⊓ ¬ᵖ (y < z) ]
  is-min x y z .fst z≤minxy with min-trichotomy x y
  ... | min-lt p x<y = (λ x<z → z≤minxy $ pathTo⇐ (λ i → p i < z) x<z)
                     , (λ y<z → z≤minxy $ pathTo⇐ (λ i → p i < z) $ <-trans {x} {y} {z} x<y y<z)
  ... | min-gt p y<x = (λ x<z → z≤minxy $ pathTo⇐ (λ i → p i < z) $ <-trans {y} {x} {z} y<x x<z)
                     , (λ y<z → z≤minxy $ pathTo⇐ (λ i → p i < z) y<z)
  ... | min-eq p q   = (λ x<z → z≤minxy $ pathTo⇐ (λ i → p i < z) x<z)
                     , (λ y<z → z≤minxy $ pathTo⇐ (λ i → q i < z) y<z)
  is-min x y z .snd (z≤x , z≤y) minxy<z with min-trichotomy x y
  ... | min-lt p _   = z≤x $ pathTo⇒ (λ i → p i < z) minxy<z
  ... | min-gt p _   = z≤y $ pathTo⇒ (λ i → p i < z) minxy<z
  ... | min-eq p q   = z≤x $ pathTo⇒ (λ i → p i < z) minxy<z

  is-max : (x y z : ℕ) → [ ¬ᵖ (z < max x y) ⇔ ¬ᵖ (z < x) ⊓ ¬ᵖ (z < y) ]
  is-max x y z .fst maxxy≤z with max-trichotomy x y
  ... | max-gt p y<x = (λ z<x → maxxy≤z $ pathTo⇐ (λ i → z < p i) z<x )
                     , (λ z<y → maxxy≤z $ pathTo⇐ (λ i → z < p i) $ <-trans {z} {y} {x} z<y y<x )
  ... | max-lt p x<y = (λ z<x → maxxy≤z $ pathTo⇐ (λ i → z < p i) $ <-trans {z} {x} {y} z<x x<y )
                     , (λ z<y → maxxy≤z $ pathTo⇐ (λ i → z < p i) z<y )
  ... | max-eq p q   = (λ z<x → maxxy≤z $ pathTo⇐ (λ i → z < p i) z<x )
                     , (λ z<y → maxxy≤z $ pathTo⇐ (λ i → z < q i) z<y )
  is-max x y z .snd (z≤x , z≤y) maxxy<z with max-trichotomy x y
  ... | max-gt p _   = z≤x $ pathTo⇒ (λ i → z < p i) maxxy<z
  ... | max-lt p _   = z≤y $ pathTo⇒ (λ i → z < p i) maxxy<z
  ... | max-eq p q   = z≤x $ pathTo⇒ (λ i → z < p i) maxxy<z

abstract
  -- NOTE: maybe some clever use of cotrans makes this a bit shorter
  +-<-ext : (w x y z : ℕ) → [ (w + x) < (y + z) ] → [ (w < y) ⊔ (x < z) ]
  +-<-ext w x y z (k , k+suc[w+x]≡y+z) with w ≟ y | x ≟ z
  ... | lt w<y | q = ∣ inl w<y ∣
  ... | gt (l , l+suc[y]≡w) | q = inrᵖ (k + suc l , inj-m+ ((
    y + ((k + suc l) + suc x) ≡⟨ +-assoc y (k + suc l) (suc x) ⟩
    (y + (k + suc l)) + suc x ≡⟨ (λ i → +-assoc y k (suc l) i + suc x) ⟩
    ((y + k) + suc l) + suc x ≡⟨ (λ i → (+-comm y k i + suc l) + suc x) ⟩
    ((k + y) + suc l) + suc x ≡⟨ (λ i → +-assoc k y (suc l) (~ i) + suc x) ⟩
    (k + (y + suc l)) + suc x ≡⟨ sym $ +-assoc k (y + suc l) (suc x) ⟩
    k + ((y + suc l) + suc x) ≡⟨ (λ i → k + (+-suc y l i + suc x)) ⟩
    k + (suc (y + l) + suc x) ≡⟨ (λ i → k + (suc (+-comm y l i) + suc x)) ⟩
    k + (suc (l + y) + suc x) ≡⟨ (λ i → k + (+-suc l y (~ i) + suc x)) ⟩
    k + ((l + suc y) + suc x) ≡⟨ (λ i → k + +-suc (l + suc y) x i) ⟩
    k + suc ((l + suc y) + x) ≡⟨ (λ i → k + suc (l+suc[y]≡w i + x)) ⟩
    k + suc (w + x) ∎) ∙ k+suc[w+x]≡y+z))
  ... | eq w≡y | q = inrᵖ (k , inj-m+ ((
    y + (k + suc x) ≡⟨ +-assoc y k (suc x) ⟩
    (y + k) + suc x ≡⟨ (λ i → +-comm y k i + suc x) ⟩
    (k + y) + suc x ≡⟨ sym $ +-assoc k y (suc x) ⟩
    k + (y + suc x) ≡⟨ (λ i → k + +-suc y x i) ⟩
    k + suc (y + x) ≡⟨ (λ i → k + suc (w≡y (~ i) + x)) ⟩
    k + suc (w + x) ∎) ∙ k+suc[w+x]≡y+z))

  -- NOTE: instead of equational reasoning, this might follow more easily from induction on `z`?
  ·-preserves-< : (x y z : ℕ) → [ 0 < z ] → [ x < y ] → [ (x · z) < (y · z) ]
  ·-preserves-< x y z (k , k+1≡z) (l , l+suc[x]≡y) = l · z + k , (
    (l · z + k) + suc (x · z) ≡⟨ sym $ +-assoc (l · z) k (suc (x · z)) ⟩
    l · z + (k + suc (x · z)) ≡⟨ refl ⟩ -- 1 + x ≡ suc x holds definitionally
    l · z + (k + (1 + x · z)) ≡⟨ (λ i → l · z + +-assoc k 1 (x · z) i) ⟩
    l · z + ((k + 1) + x · z) ≡⟨ (λ i → l · z + (k+1≡z i + x · z)) ⟩
    l · z + (z + x · z)       ≡⟨ refl ⟩ -- suc x · z ≡ z + x · z holds definitionally
    l · z + (suc x) · z       ≡⟨ ·-distribʳ l (suc x) z ⟩
    (l + suc x) · z           ∎) ∙ (λ i → l+suc[x]≡y i · z) ∙ refl

  -- ·-reflects-< : (x y z : ℕ) → [ 0 < z ] → [ (x · z) < (y · z) ] → [ x < y ]
  -- ·-reflects-< x y zero (k , k+1≡z) _ = ⊥-elim {A = λ _ → [ x < y ]} $ snotz (sym (+-comm k 1) ∙ k+1≡z)
  -- ·-reflects-< x y (suc zero) _ (l , l+suc[xz]≡yz) = l , (λ i → l + suc (·-identityʳ x (~ i))) ∙ l+suc[xz]≡yz ∙ ·-identityʳ y
  -- ·-reflects-< x y (suc (suc z)) _ p@(l , l+suc[xz]≡yz) =
  --   let ind = {! ·-reflects-< x y (suc z) (0<suc z)   !}
  --     -- (x · suc (suc z)) < (y · suc (suc z))
  --     -- x + x · suc z < y + y · suc z
  --     -- (x + x · suc z) + < (y + y · suc z)
  --   in {! ·-suc x (suc z)  !}
  -- -- ·-reflects-< x y zero 0<z xz<yz = {!   !} -- ·-suc x z
  -- -- ·-reflects-< x y (suc z) 0<z xz<yz = {! ·-reflects-< x y z  !}
  -- --   (x · suc z) < (y · suc z)

+-Semigroup : [ isSemigroup _+_ ]
+-Semigroup .IsSemigroup.is-set   = isSetℕ
+-Semigroup .IsSemigroup.is-assoc = +-assoc

·-Semigroup : [ isSemigroup _·_ ]
·-Semigroup .IsSemigroup.is-set   = isSetℕ
·-Semigroup .IsSemigroup.is-assoc = ·-assoc

+-Monoid : [ isMonoid 0 _+_ ]
+-Monoid .IsMonoid.is-Semigroup = +-Semigroup
+-Monoid .IsMonoid.is-identity x = +-zero x , refl

·-Monoid : [ isMonoid 1 _·_ ]
·-Monoid .IsMonoid.is-Semigroup = ·-Semigroup
·-Monoid .IsMonoid.is-identity x = ·-identityʳ x , ·-identityˡ x

is-Semiring : [ isSemiring 0 1 _+_ _·_ ]
is-Semiring .IsSemiring.+-Monoid = +-Monoid
is-Semiring .IsSemiring.·-Monoid = ·-Monoid
is-Semiring .IsSemiring.+-comm   = +-comm
is-Semiring .IsSemiring.is-dist x y z = sym (·-distribˡ x y z) , sym (·-distribʳ x y z)

is-CommSemiring : [ isCommSemiring 0 1 _+_ _·_ ]
is-CommSemiring .IsCommSemiring.is-Semiring = is-Semiring
is-CommSemiring .IsCommSemiring.·-comm      = ·-comm

<-StrictLinearOrder : [ isStrictLinearOrder _<_ ]
<-StrictLinearOrder .IsStrictLinearOrder.is-irrefl = <-irrefl
<-StrictLinearOrder .IsStrictLinearOrder.is-trans  a b c = <-trans {a} {b} {c}
<-StrictLinearOrder .IsStrictLinearOrder.is-tricho a b with a ≟ b
... | lt a<b = inl (inl a<b)
... | eq a≡b = inr ∣ a≡b ∣
... | gt b<a = inl (inr b<a)

≤-Lattice : [ isLattice (λ x y → ¬ᵖ (y < x)) min max ]
≤-Lattice .IsLattice.≤-PartialOrder = linearorder⇒partialorder _ (≤'-isLinearOrder <-StrictLinearOrder)
≤-Lattice .IsLattice.is-min         = is-min
≤-Lattice .IsLattice.is-max         = is-max

is-LinearlyOrderedCommSemiring : [ isLinearlyOrderedCommSemiring 0 1 _+_ _·_ _<_ min max ]
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.is-CommSemiring     = is-CommSemiring
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.<-StrictLinearOrder = <-StrictLinearOrder
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.≤-Lattice           = ≤-Lattice
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.+-<-ext             = +-<-ext
is-LinearlyOrderedCommSemiring .IsLinearlyOrderedCommSemiring.·-preserves-<       = ·-preserves-<

bundle : LinearlyOrderedCommSemiring {ℓ-zero} {ℓ-zero}
bundle .LinearlyOrderedCommSemiring.Carrier                         = ℕ
bundle .LinearlyOrderedCommSemiring.0f                              = 0
bundle .LinearlyOrderedCommSemiring.1f                              = 1
bundle .LinearlyOrderedCommSemiring._+_                             = _+_
bundle .LinearlyOrderedCommSemiring._·_                             = _·_
bundle .LinearlyOrderedCommSemiring.min                             = min
bundle .LinearlyOrderedCommSemiring.max                             = max
bundle .LinearlyOrderedCommSemiring._<_                             = _<_
bundle .LinearlyOrderedCommSemiring.is-LinearlyOrderedCommSemiring  = is-LinearlyOrderedCommSemiring


--{-# OPTIONS --allow-unsolved-metas #-}
module Theorem1 where

open import OscarPrelude

open import HasSatisfaction
open import HasSubstantiveDischarge

open import LiteralFormula

open import 𝑱udgement
open import HasSalvation

open import Membership

open import Interpretation
open import HasNegation

open import IsLiteralFormula

Theorem1 : (Φ : 𝑱udgement LiteralFormula) → ⊨ Φ ↔ ▷ Φ
Theorem1 Φ@(χs ⊢ ι) = Theorem1a , Theorem1b where
  Theorem1a : ⊨ Φ → ▷ Φ
  Theorem1a ⊨Φ with ▷? Φ
  … | yes ▷Φ = ▷Φ
  … | no ⋫Φ =
    let I , I⊨χs , I⊭ι = Lemma1a in
      ⊥-elim ∘ I⊭ι $ ⊨Φ I I⊨χs
    where
    Lemma1a : ∃ λ I → I ⊨ χs × I ⊭ ι
    Lemma1a = {!!}

{-
To construct the interpretation, consider a unique list, τ₀, τ₁, …, τₙ, of terms in ι ∷ χs. For each term, τ, we find <TODO> interpretations, 𝓘, such that for any I ∈ 𝓘, and any i ∈ 0, …, n, τ⟦ I ⟧ τᵢ = i. For each formula φ ∈ ι ∷ χs, we find <TODO> an interpretation I ∈ 𝓘 such that 𝑃⟦ I ⟧ φ = true when φ ∈ χs and 𝑃⟦ I ⟧ φ = false when φ = ι.
For all terms in ι ∷ χs, find a coding into Nat that uniquely determines each term. To do this, compute the maximum functional depth of terms, D, the maximal arity of terms, A, the maximal function name, F, and the maximal variable name, V. Each term can then be coded into Fin V + (D₀ = F + F * V + F * V ^ 2 + ... + F * V ^ A) + (D₀ ...
Encode each term in a discrimination network. Each new term stored is assigned a unique id
-}

  Theorem1b : ▷ Φ → ⊨ Φ
  Theorem1b (left ◁χs) I I⊨χs = {!!}
  Theorem1b (right χs≽ι) I I⊨χs = {!!}


open import Level hiding ( suc ; zero )
open import Algebra
module sym5 where

open import Symmetric
open import Data.Unit using (⊤ ; tt )
open import Function.Inverse as Inverse using (_↔_; Inverse; _InverseOf_)
open import Function hiding (flip)
open import Data.Nat hiding (_⊔_) -- using (ℕ; suc; zero)
open import Data.Nat.Properties
open import Relation.Nullary
open import Data.Empty
open import Data.Product

open import Gutil
open import Putil
open import Solvable using (solvable)
open import  Relation.Binary.PropositionalEquality hiding ( [_] )

open import Data.Fin hiding (_<_ ; _≤_  ; lift )
open import Data.Fin.Permutation  hiding (_∘ₚ_)

infixr  200 _∘ₚ_
_∘ₚ_ = Data.Fin.Permutation._∘ₚ_

open import Data.List  hiding ( [_] )
open import nat
open import fin
open import logic

open _∧_

¬sym5solvable : ¬ ( solvable (Symmetric 5) )
¬sym5solvable sol = counter-example (end5 (abc 0<3 0<4 ) (dervie-any-3rot0 (dervied-length sol) 0<3 0<4 ) ) where
--
--    dba       1320      d → b → a → d
--    (dba)⁻¹   3021      a → b → d → a
--    aec       21430
--    (aec)⁻¹   41032
--    [ dba , aec ] = (abd)(cea)(dba)(aec) = abc
--      so commutator always contains abc, dba and aec

     open ≡-Reasoning

     open solvable
     open Solvable ( Symmetric 5)
     end5 : (x : Permutation 5 5) → deriving (dervied-length sol) x →  x =p= pid
     end5 x der = end sol x der

     0<4 : 0 < 4
     0<4 = s≤s z≤n

     0<3 : 0 < 3
     0<3 = s≤s z≤n

     --- 1 ∷ 2 ∷ 0 ∷ []      abc
     3rot : Permutation 3 3
     3rot = pid {3} ∘ₚ pins (n≤ 2)

     save2 : {i j : ℕ }  → (i ≤ 3 ) → ( j ≤ 4 ) →  Permutation  5 5
     save2 i<3 j<4 = flip (pins (s≤s i<3)) ∘ₚ flip (pins j<4)

     ins2 : {i j : ℕ }  → Permutation 3 3  → (i ≤ 3 ) → ( j ≤ 4 ) → Permutation  5 5
     ins2 abc i<3 j<4 = (save2 i<3 j<4 ∘ₚ (pprep (pprep abc))) ∘ₚ flip (save2 i<3 j<4 )

     ins2cong : {i j : ℕ }  → {x y : Permutation 3 3 } → {i<3 : i ≤ 3 } → {j<4 : j ≤ 4 } → x =p= y → ins2 x i<3 j<4  =p= ins2 y i<3 j<4
     ins2cong {i} {j} {x} {y} {i<3} {j<4} x=y = presp {5} {save2 i<3 j<4 ∘ₚ (pprep (pprep x))} {_} {flip (save2 i<3 j<4 )}
         (presp {5} {save2 i<3 j<4} prefl (pprep-cong (pprep-cong x=y)) ) prefl

     open _=p=_

     abc : {i j : ℕ }  → (i ≤ 3 ) → ( j ≤ 4 ) → Permutation  5 5
     abc i<3 j<4 = ins2 3rot i<3 j<4
     dba : {i j : ℕ }  → (i ≤ 3 ) → ( j ≤ 4 ) → Permutation  5 5
     dba i<3 j<4 = ins2 (3rot ∘ₚ 3rot) i<3 j<4

     counter-example :  ¬ (abc 0<3 0<4  =p= pid )
     counter-example eq with ←pleq _ _ eq
     ...  | ()

     record Triple {i j : ℕ } (i<3 : i ≤ 3) (j<4 : j ≤ 4) (rot : Permutation 3 3) : Set where
       field
         dba0<3 : Fin 4
         dba1<4 : Fin 5
         aec0<3 : Fin 4
         aec1<4 : Fin 5
         abc= : ins2 rot i<3 j<4 =p= [ ins2 (rot ∘ₚ rot)  (fin≤n {3} dba0<3) (fin≤n {4} dba1<4)  , ins2 (rot ∘ₚ rot) (fin≤n {3} aec0<3) (fin≤n {4} aec1<4) ]

     open Triple
     triple : {i j : ℕ } → (i<3 : i ≤ 3) (j<4 : j ≤ 4) → Triple i<3 j<4 3rot
     triple z≤n z≤n =                               record { dba0<3 = # 0 ; dba1<4 = # 4 ; aec0<3 = # 2 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple z≤n (s≤s z≤n) =                         record { dba0<3 = # 0 ; dba1<4 = # 4 ; aec0<3 = # 2 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple z≤n (s≤s (s≤s z≤n)) =                   record { dba0<3 = # 1 ; dba1<4 = # 0 ; aec0<3 = # 3 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     triple z≤n (s≤s (s≤s (s≤s z≤n))) =             record { dba0<3 = # 1 ; dba1<4 = # 3 ; aec0<3 = # 0 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple z≤n (s≤s (s≤s (s≤s (s≤s z≤n)))) =       record { dba0<3 = # 0 ; dba1<4 = # 0 ; aec0<3 = # 2 ; aec1<4 = # 4 ; abc= = pleq _ _ refl }
     triple (s≤s z≤n) z≤n =                         record { dba0<3 = # 0 ; dba1<4 = # 2 ; aec0<3 = # 3 ; aec1<4 = # 1 ; abc= = pleq _ _ refl }
     triple (s≤s z≤n) (s≤s z≤n) =                   record { dba0<3 = # 0 ; dba1<4 = # 2 ; aec0<3 = # 3 ; aec1<4 = # 1 ; abc= = pleq _ _ refl }
     triple (s≤s z≤n) (s≤s (s≤s z≤n)) =             record { dba0<3 = # 1 ; dba1<4 = # 0 ; aec0<3 = # 3 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     triple (s≤s z≤n) (s≤s (s≤s (s≤s z≤n))) =       record { dba0<3 = # 0 ; dba1<4 = # 3 ; aec0<3 = # 1 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple (s≤s z≤n) (s≤s (s≤s (s≤s (s≤s z≤n)))) = record { dba0<3 = # 2 ; dba1<4 = # 4 ; aec0<3 = # 0 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s z≤n)) z≤n =                   record { dba0<3 = # 3 ; dba1<4 = # 0 ; aec0<3 = # 1 ; aec1<4 = # 3 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s z≤n)) (s≤s z≤n) =             record { dba0<3 = # 3 ; dba1<4 = # 0 ; aec0<3 = # 1 ; aec1<4 = # 3 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s z≤n)) (s≤s (s≤s z≤n)) =       record { dba0<3 = # 1 ; dba1<4 = # 3 ; aec0<3 = # 0 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s z≤n)) (s≤s (s≤s (s≤s z≤n))) = record { dba0<3 = # 0 ; dba1<4 = # 3 ; aec0<3 = # 1 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s z≤n)) (s≤s (s≤s (s≤s (s≤s z≤n)))) = record { dba0<3 = # 1 ; dba1<4 = # 4 ; aec0<3 = # 2 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s (s≤s z≤n))) z≤n =             record { dba0<3 = # 2 ; dba1<4 = # 4 ; aec0<3 = # 1 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s (s≤s z≤n))) (s≤s z≤n) =       record { dba0<3 = # 2 ; dba1<4 = # 4 ; aec0<3 = # 1 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s (s≤s z≤n))) (s≤s (s≤s z≤n)) = record { dba0<3 = # 0 ; dba1<4 = # 0 ; aec0<3 = # 2 ; aec1<4 = # 4 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s (s≤s z≤n))) (s≤s (s≤s (s≤s z≤n))) = record { dba0<3 = # 2 ; dba1<4 = # 4 ; aec0<3 = # 0 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     triple (s≤s (s≤s (s≤s z≤n))) (s≤s (s≤s (s≤s (s≤s z≤n)))) =
                                                    record { dba0<3 = # 1 ; dba1<4 = # 4 ; aec0<3 = # 0 ; aec1<4 = # 3 ; abc= = pleq _ _ refl }

     _⁻¹ : {n : ℕ } ( x : Permutation n n) → Permutation n n
     _⁻¹ = pinv

     -- tt5 : (i : Fin 4) (j : Fin 5) → (z : Fin 4) → (w : Fin 5) → (x : Fin 5) (y : Fin 4)  → (rot : Permutation 3 3 )  → List (List ℕ) → List (List ℕ)
     -- tt5 i j z w x y rot t with is-=p= (ins2 rot (fin≤n  i) (fin≤n  j))
     --             [ ins2 (rot ∘ₚ rot)   (fin≤n  z) (fin≤n  x)  , ins2 (pinv rot) (fin≤n  y)  (fin≤n  w) ]
     -- ... | yes _ = ( toℕ i ∷ toℕ j ∷ 9 ∷ toℕ z ∷ toℕ x ∷ toℕ y ∷ toℕ w  ∷ [] ) ∷ t
     -- ... | no _ = t

     -- open import  Relation.Binary.Definitions

     -- tt2 : (i : Fin 4) (j : Fin 5) →  (rot : Permutation 3 3 ) → List (List ℕ)
     -- tt2  i j rot = tt3 (# 4) (# 3) (# 3) (# 4) [] where
     --     tt3 : (w : Fin 5) (z : Fin 4) (x : Fin 4) (y : Fin 5) → List (List ℕ) → List (List ℕ)
     --     tt3 zero zero zero zero t =                                       ( tt5 i j zero zero zero zero    rot [] ) ++ t
     --     tt3 (suc w)  zero zero zero t =  tt3 (fin+1 w) (# 3) (# 3) (# 4)       ((tt5 i j zero (suc w) zero zero    rot [] ) ++ t)
     --     tt3 w z zero (suc y) t =       tt3 w z         (# 3) (fin+1 y)   ((tt5 i j z w (suc y) zero    rot [] ) ++ t)
     --     tt3 w z (suc x) y    t =       tt3 w z         (fin+1 x)    y    ((tt5 i j z  w y    (suc x) rot [] ) ++ t)
     --     tt3 w (suc z) zero zero t =    tt3 w (fin+1 z) (# 3) (# 4)       ((tt5 i j (suc z) w zero zero    rot [] ) ++ t)

     -- tt4 :  List (List (List ℕ))
     -- tt4  = tt2 (# 0) (# 0) (pinv 3rot) ∷
     --       tt2 (# 1) (# 0) (pinv 3rot) ∷
     --       tt2 (# 2) (# 0) (pinv 3rot) ∷
     --       tt2 (# 3) (# 0) (pinv 3rot) ∷
     --       tt2 (# 0) (# 1) (pinv 3rot) ∷
     --       tt2 (# 1) (# 1) (pinv 3rot) ∷
     --       tt2 (# 2) (# 1) (pinv 3rot) ∷
     --       tt2 (# 3) (# 1) (pinv 3rot) ∷
     --       tt2 (# 0) (# 2) (pinv 3rot) ∷
     --       tt2 (# 1) (# 2) (pinv 3rot) ∷
     --       tt2 (# 2) (# 2) (pinv 3rot) ∷
     --       tt2 (# 3) (# 2) (pinv 3rot) ∷
     --       tt2 (# 0) (# 3) (pinv 3rot) ∷
     --       tt2 (# 1) (# 3) (pinv 3rot) ∷
     --       tt2 (# 2) (# 3) (pinv 3rot) ∷
     --       tt2 (# 3) (# 3) (pinv 3rot) ∷
     --       tt2 (# 0) (# 4) (pinv 3rot) ∷
     --       tt2 (# 1) (# 4) (pinv 3rot) ∷
     --       tt2 (# 2) (# 4) (pinv 3rot) ∷
     --       tt2 (# 3) (# 4) (pinv 3rot) ∷
     --       []

     open Triple
     dba-triple : {i j : ℕ }  → (i<3 : i ≤ 3 ) → (j<4 :  j ≤ 4 ) → Triple i<3 j<4 (3rot  ∘ₚ 3rot )
     dba-triple z≤n z≤n =                               record { dba0<3 = # 0 ; dba1<4 = # 2 ; aec0<3 = # 2 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple z≤n (s≤s z≤n) =                         record { dba0<3 = # 0 ; dba1<4 = # 2 ; aec0<3 = # 2 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple z≤n (s≤s (s≤s z≤n)) =                   record { dba0<3 = # 1 ; dba1<4 = # 3 ; aec0<3 = # 3 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     dba-triple z≤n (s≤s (s≤s (s≤s z≤n))) =             record { dba0<3 = # 0 ; dba1<4 = # 2 ; aec0<3 = # 2 ; aec1<4 = # 4 ; abc= = pleq _ _ refl }
     dba-triple z≤n (s≤s (s≤s (s≤s (s≤s z≤n)))) =       record { dba0<3 = # 3 ; dba1<4 = # 0 ; aec0<3 = # 0 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     dba-triple (s≤s z≤n) z≤n =                         record { dba0<3 = # 0 ; dba1<4 = # 0 ; aec0<3 = # 1 ; aec1<4 = # 3 ; abc= = pleq _ _ refl }
     dba-triple (s≤s z≤n) (s≤s z≤n) =                   record { dba0<3 = # 0 ; dba1<4 = # 0 ; aec0<3 = # 1 ; aec1<4 = # 3 ; abc= = pleq _ _ refl }
     dba-triple (s≤s z≤n) (s≤s (s≤s z≤n)) =             record { dba0<3 = # 1 ; dba1<4 = # 3 ; aec0<3 = # 3 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     dba-triple (s≤s z≤n) (s≤s (s≤s (s≤s z≤n))) =       record { dba0<3 = # 1 ; dba1<4 = # 4 ; aec0<3 = # 2 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s z≤n) (s≤s (s≤s (s≤s (s≤s z≤n)))) = record { dba0<3 = # 1 ; dba1<4 = # 3 ; aec0<3 = # 3 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s z≤n)) z≤n =                   record { dba0<3 = # 2 ; dba1<4 = # 4 ; aec0<3 = # 0 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s z≤n)) (s≤s z≤n) =             record { dba0<3 = # 2 ; dba1<4 = # 4 ; aec0<3 = # 0 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s z≤n)) (s≤s (s≤s z≤n)) =       record { dba0<3 = # 0 ; dba1<4 = # 2 ; aec0<3 = # 2 ; aec1<4 = # 4 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s z≤n)) (s≤s (s≤s (s≤s z≤n))) = record { dba0<3 = # 1 ; dba1<4 = # 4 ; aec0<3 = # 2 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s z≤n)) (s≤s (s≤s (s≤s (s≤s z≤n)))) = record { dba0<3 = # 2 ; dba1<4 = # 0 ; aec0<3 = # 3 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s (s≤s z≤n))) z≤n =             record { dba0<3 = # 0 ; dba1<4 = # 4 ; aec0<3 = # 1 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s (s≤s z≤n))) (s≤s z≤n) =       record { dba0<3 = # 0 ; dba1<4 = # 4 ; aec0<3 = # 1 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s (s≤s z≤n))) (s≤s (s≤s z≤n)) = record { dba0<3 = # 3 ; dba1<4 = # 0 ; aec0<3 = # 0 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s (s≤s z≤n))) (s≤s (s≤s (s≤s z≤n))) = record { dba0<3 = # 1 ; dba1<4 = # 3 ; aec0<3 = # 3 ; aec1<4 = # 0 ; abc= = pleq _ _ refl }
     dba-triple (s≤s (s≤s (s≤s z≤n))) (s≤s (s≤s (s≤s (s≤s z≤n)))) =
                                                    record { dba0<3 = # 2 ; dba1<4 = # 0 ; aec0<3 = # 3 ; aec1<4 = # 2 ; abc= = pleq _ _ refl }

     -3=33 : pinv 3rot =p= (3rot ∘ₚ 3rot )
     -3=33 = pleq _ _ refl

     4=1 : (3rot ∘ₚ 3rot) ∘ₚ (3rot ∘ₚ 3rot ) =p= 3rot
     4=1 = pleq _ _ refl

     dervie-any-3rot0 : (n : ℕ ) → {i j : ℕ }  → (i<3 : i ≤ 3 ) → (j<4 : j ≤ 4 )
          → deriving n (abc i<3 j<4 )
     dervie-any-3rot1 : (n : ℕ ) → {i j : ℕ }  → (i<3 : i ≤ 3 ) → (j<4 : j ≤ 4 )
          → deriving n (dba i<3 j<4 )

     commd : {n : ℕ } → (f g : Permutation 5 5)
           →  deriving n f
           →  deriving n g
           → Commutator (deriving n) [ f , g ]
     commd {n} f g df dg =  comm {deriving n} {f} {g} df dg

     dervie-any-3rot0 0 i<3 j<4 = lift tt
     dervie-any-3rot0 (suc i) i<3 j<4 = ccong {deriving i} (psym ceq) (commd dba0 aec0 df dg )where
        tc = triple i<3 j<4
        dba0 = dba (fin≤n {3} (dba0<3 tc)) (fin≤n {4} (dba1<4 tc))
        aec0 = dba (fin≤n {3} (aec0<3 tc)) (fin≤n {4} (aec1<4 tc))
        ceq : abc i<3 j<4  =p=  [ dba0 , aec0 ]
        ceq = record { peq = peq (abc= tc) }
        df =  dervie-any-3rot1 i  (fin≤n {3} (dba0<3 tc)) (fin≤n {4} (dba1<4 tc))
        dg =  dervie-any-3rot1 i  (fin≤n {3} (aec0<3 tc)) (fin≤n {4} (aec1<4 tc))

     dervie-any-3rot1 0 i<3 j<4 = lift tt
     dervie-any-3rot1 (suc n) {i} {j} i<3 j<4 = ccong {deriving n} ( psym ceq )  (commd aec0 abc0 df dg ) where
        tdba = dba-triple i<3 j<4
        aec0 = ins2 ((3rot ∘ₚ 3rot) ∘ₚ (3rot ∘ₚ 3rot )) (fin≤n {3} (dba0<3 tdba)) (fin≤n {4} (dba1<4 tdba))
        abc0 = ins2 ((3rot ∘ₚ 3rot) ∘ₚ (3rot ∘ₚ 3rot )) (fin≤n {3} (aec0<3 tdba)) (fin≤n {4} (aec1<4 tdba))
        ceq : dba i<3 j<4 =p=  [ aec0 , abc0 ]
        ceq = record { peq = peq (abc= tdba) }
        df : deriving n (ins2 ((3rot ∘ₚ 3rot) ∘ₚ (3rot ∘ₚ 3rot )) (fin≤n {3} (dba0<3 tdba)) (fin≤n {4} (dba1<4 tdba)))
        df = deriving-subst (psym (ins2cong {toℕ (dba0<3 (dba-triple i<3 j<4))} {toℕ (dba1<4 (dba-triple i<3 j<4))} 4=1 ))
             (dervie-any-3rot0 n  (fin≤n {3} (dba0<3 tdba)) (fin≤n {4} (dba1<4 tdba)))
        dg : deriving n (ins2 ((3rot ∘ₚ 3rot) ∘ₚ (3rot ∘ₚ 3rot )) (fin≤n {3} (aec0<3 tdba)) (fin≤n {4} (aec1<4 tdba)))
        dg = deriving-subst (psym (ins2cong {toℕ (aec0<3 (dba-triple i<3 j<4))} {toℕ (aec1<4 (dba-triple i<3 j<4))} 4=1 ))
             (dervie-any-3rot0 n  (fin≤n {3} (aec0<3 tdba)) (fin≤n {4} (aec1<4 tdba)))


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

record NoEta : Set where
  no-eta-equality
  constructor _,_
  field fst : Nat
        snd : Nat

open NoEta

data ⊥ : Set where

soft-fail : (a : NoEta) (x : Nat) → (fst a , x) ≡ a → ⊥
soft-fail a x ()  -- Should be yellow (not sure if empty)

loop : ⊥
loop = soft-fail (0 , 0) 0 refl


open import Relation.Binary hiding (_⇒_)

module Category.Monad.Monotone.Error {i}(pre : Preorder i i i)(Exc : Set i) where

open Preorder pre renaming (Carrier to I; _∼_ to _≤_; refl to ≤-refl)

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

open import Relation.Unary
open import Relation.Unary.Monotone pre
open import Relation.Unary.PredicateTransformer

open import Category.Monad.Monotone pre
open import Category.Monad.Monotone.Identity pre

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

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

Error = ErrorT Identity

record ErrorMonad (M : Pt I i) : Set (suc i) where
  field
    throw : ∀ {P i} → Exc → M P i
    try_catch_ : ∀ {P}   → M P ⊆ ((const Exc ↗ M P) ⇒ M P)

module _ {M} ⦃ Mon : RawMPMonad M ⦄ where
  private module M = RawMPMonad Mon

  open RawMPMonad
  errorT-monad : RawMPMonad (ErrorT M)
  return errorT-monad px = M.return (right px)
  _≥=_ errorT-monad {P}{Q} px f = px M.≥= λ where
      _ (left e)  → M.return (left e)
      w (right x) → f w x

  open ErrorMonad
  errorT-monad-ops : ErrorMonad (ErrorT M)
  throw errorT-monad-ops e = M.return (left e)
  try_catch_ errorT-monad-ops c f = c M.≥= λ where
    w (left e)  → f w e
    w (right x) → M.return (right x)

  lift-error : ∀ {P} → M P ⊆ ErrorT M P
  lift-error x = x M.>>= (λ z → M.return (right z))

module Instances where
  -- Defining instances for the transformer
  -- leads to divergence of instance search,
  -- because M is on the outside.
  instance
    open RawMPMonad
    error-monad : RawMPMonad Error
    error-monad = errorT-monad

    open ErrorMonad
    error-monad-ops : ErrorMonad Error
    error-monad-ops = errorT-monad-ops


-- Andreas, 2013-03-22
module Issue473a where

data D : Set where
  d : D

data P : D → Set where
  p : P d

record Rc : Set where
  constructor c
  field f : D

works : {r : Rc} → P (Rc.f r) → Set
works p = D

works' : (r : Rc) → P (Rc.f r) → Set
works' (c .d) p = D

-- We remove the constructor:

record R : Set where
  field f : D

test : {r : R} → P (R.f r) → Set
test p = D


------------------------------------------------------------------------------
-- Testing the non-internal ATP equality
------------------------------------------------------------------------------

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

module NonInternalEquality where

postulate D : Set

data _≡_ (x : D) : D → Set where
  refl : x ≡ x
{-# ATP axiom refl #-}

postulate foo : ∀ x → x ≡ x
{-# ATP prove foo #-}


open import Agda.Builtin.Bool

f : Bool → Bool
f x =
  let id : Bool → Bool
      id b = {!!}
  in id x


module Tactic.Nat.Auto where

open import Prelude
open import Builtin.Reflection
open import Tactic.Reflection.Quote
open import Tactic.Reflection

open import Tactic.Nat.NF
open import Tactic.Nat.Exp
open import Tactic.Nat.Reflect
open import Tactic.Nat.Auto.Lemmas

open Tactic.Nat.Reflect public using (cantProve; invalidGoal)

module _ {Atom : Set} {{_ : Eq Atom}} {{_ : Ord Atom}} where
  liftNFEq : ∀ (e₁ : Exp Atom) e₂ ρ → ⟦ norm e₁ ⟧n ρ ≡ ⟦ norm e₂ ⟧n ρ → ⟦ e₁ ⟧e ρ ≡ ⟦ e₂ ⟧e ρ
  liftNFEq e₁ e₂ ρ H = eraseEquality $
    ⟦ e₁      ⟧e ρ ≡⟨ sound e₁ ρ ⟩
    ⟦ norm e₁ ⟧n ρ ≡⟨ H ⟩
    ⟦ norm e₂ ⟧n ρ ≡⟨ sound e₂ ρ ⟩ʳ
    ⟦ e₂      ⟧e ρ ∎

  unliftNFEq : ∀ (e₁ : Exp Atom) e₂ ρ → ⟦ e₁ ⟧e ρ ≡ ⟦ e₂ ⟧e ρ → ⟦ norm e₁ ⟧n ρ ≡ ⟦ norm e₂ ⟧n ρ
  unliftNFEq e₁ e₂ ρ H =
    ⟦ norm e₁ ⟧n ρ ≡⟨ sound e₁ ρ ⟩ʳ
    ⟦ e₁      ⟧e ρ ≡⟨ H ⟩
    ⟦ e₂      ⟧e ρ ≡⟨ sound e₂ ρ ⟩
    ⟦ norm e₂ ⟧n ρ ∎

  auto-proof : ∀ e₁ e₂ → norm e₁ ≡ norm e₂ → ∀ ρ → ⟦ e₁ ⟧e ρ ≡ ⟦ e₂ ⟧e ρ
  auto-proof e₁ e₂ nfeq ρ = liftNFEq e₁ e₂ ρ (cong (λ n → ⟦ n ⟧n ρ) nfeq)

auto-tactic : Type → Tactic
auto-tactic t hole = do
  just ((e₁ , e₂) , Γ) ← termToEq t
    where nothing → unify hole $ failedProof (quote invalidGoal) t
  prf ← newMeta!
  unify hole (def₄ (quote auto-proof) (` e₁) (` e₂) prf (quotedEnv Γ))
  unify prf (con₀ (quote refl)) <|> do
    def (quote _≡_) (_ ∷ _ ∷ vArg lnf ∷ vArg rnf ∷ []) ← normalise =<< inferType prf
      where sgoal → typeError $ strErr "Huh? This is a weird equality goal:" ∷ termErr sgoal ∷ []
    typeError $ strErr "Normal forms are not equal:" ∷ termErr lnf ∷ strErr "≠" ∷ termErr rnf ∷ []

macro
  auto : Tactic
  auto = on-goal auto-tactic


{-# OPTIONS --no-auto-inline #-}

-- Basic things needed by other primitive modules.

module Haskell.Prim where

open import Agda.Primitive
open import Agda.Builtin.Bool
open import Agda.Builtin.Nat
open import Agda.Builtin.Unit       public
open import Agda.Builtin.List
open import Agda.Builtin.String
open import Agda.Builtin.Equality
open import Agda.Builtin.FromNat    public
open import Agda.Builtin.FromNeg    public
open import Agda.Builtin.FromString public

variable
  ℓ : Level
  a b c d e : Set
  f m s t : Set → Set

--------------------------------------------------
-- Functions

id : a → a
id x = x

infixr 9 _∘_
_∘_ : (b → c) → (a → b) → a → c
(f ∘ g) x = f (g x)

flip : (a → b → c) → b → a → c
flip f x y = f y x

const : a → b → a
const x _ = x

infixr 0 _$_
_$_ : (a → b) → a → b
f $ x = f x

--------------------------------------------------
-- Language constructs

infix -1 case_of_
case_of_ : a → (a → b) → b
case x of f = f x

infix -2 if_then_else_
if_then_else_ : {a : Set ℓ} → Bool → a → a → a
if false then x else y = y
if true  then x else y = x

--------------------------------------------------
-- Agda strings

instance
  iIsStringAgdaString : IsString String
  iIsStringAgdaString .IsString.Constraint _ = ⊤
  iIsStringAgdaString .fromString s = s

--------------------------------------------------
-- Numbers

instance
  iNumberNat : Number Nat
  iNumberNat .Number.Constraint _ = ⊤
  iNumberNat .fromNat n = n

--------------------------------------------------
-- Lists

lengthNat : List a → Nat
lengthNat []       = 0
lengthNat (_ ∷ xs) = 1 + lengthNat xs

--------------------------------------------------
-- Proof things

data ⊥ : Set where

-- Use to bundle up constraints
data All {a b} {A : Set a} (B : A → Set b) : List A → Set (a ⊔ b) where
  instance
    allNil  : All B []
    allCons : ∀ {x xs} ⦃ i : B x ⦄ ⦃ is : All B xs ⦄ → All B (x ∷ xs)

data IsTrue : Bool → Set where
  instance itsTrue : IsTrue true

data IsFalse : Bool → Set where
  instance itsFalse : IsFalse false

data NonEmpty {a : Set} : List a → Set where
  instance itsNonEmpty : ∀ {x xs} → NonEmpty (x ∷ xs)

data TypeError (err : String) : Set where

it : ∀ {ℓ} {a : Set ℓ} → ⦃ a ⦄ → a
it ⦃ x ⦄ = x


open import Agda.Builtin.Unit
open import Agda.Builtin.List
open import Agda.Builtin.Reflection

id : {A : Set} → A → A
id x = x

macro
  tac : Term → TC ⊤
  tac hole = unify hole (def (quote id) (arg (arg-info visible relevant) (var 0 []) ∷ []))

test : {A : Set} → A → A
test x = {!tac!}


------------------------------------------------------------------------
-- A virtual machine
------------------------------------------------------------------------

{-# OPTIONS --erased-cubical --sized-types #-}

module Lambda.Partiality-monad.Inductive.Virtual-machine where

open import Prelude hiding (⊥)

open import Partiality-monad.Inductive

open import Lambda.Syntax
open import Lambda.Virtual-machine

open Closure Code

-- A functional semantics for the VM.
--
-- For an alternative definition, see the semantics in
-- Lambda.Simplified.Partiality-monad.Inductive.Virtual-machine, which
-- is defined using a fixpoint combinator.

steps : State → ℕ → Maybe Value ⊥
steps s n       with step s
steps s zero    | continue s′ = never
steps s (suc n) | continue s′ = steps s′ n
steps s n       | done v      = now (just v)
steps s n       | crash       = now nothing

steps-increasing : ∀ s n → steps s n ⊑ steps s (suc n)
steps-increasing s n       with step s
steps-increasing s zero    | continue s′ = never⊑ _
steps-increasing s (suc n) | continue s′ = steps-increasing s′ n
steps-increasing s n       | done v      = ⊑-refl _
steps-increasing s n       | crash       = ⊑-refl _

stepsˢ : State → Increasing-sequence (Maybe Value)
stepsˢ s = (steps s , steps-increasing s)

exec : State → Maybe Value ⊥
exec s = ⨆ (stepsˢ s)


-- Issue #2791, reported by Ulf 2017-10-05
-- Reported fixed by Victor 2018-08-11

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

IF : Bool → Set → Set → Set
IF true  X Y = X
IF false X Y = Y

postulate
  F : (A : Set) (x : A) (B : Set) (y : B) → Set

mutual
  ?b : Bool
  ?b = _

  IFb = IF ?b Nat Bool

  ?X : IFb
  ?X = _

  ?Y : Nat
  ?Y = _

  foo : F Bool true Nat ?Y ≡ F IFb ?X IFb ?X
  foo = refl

-- ?Y gets solved with 'true'
error : ?Y + 1 ≡ 3
error = refl

-- Expected failure:

-- Nat != Bool of type Set
-- when checking that the expression refl has type
-- F Bool true Nat ?Y ≡ F IFb ?X IFb ?X


-- {-# OPTIONS -v tc.meta:20 #-}
-- Agdalist 2010-09-24 David Leduc
module Issue323 where

data Sigma (A : Set)(B : A -> Set) : Set where
  _,_ : (a : A) -> B a -> Sigma A B

data Trivial {A : Set}(a : A) : Set where
  trivial : Trivial a

lemma : (A : Set)(x y : A) -> Trivial (x , y)
lemma A x y = trivial


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

module FOT.FOTC.Data.List.PostulatesVersusDataTypes where

-- See Agda mailing list.
-- Subject: Agda's unification: postulates versus data types

module M₁ where
  data D : Set where
    _∷_ : D → D → D

  data List : D → Set where
    cons : ∀ x xs → List xs → List (x ∷ xs)

  tail : ∀ {x xs} → List (x ∷ xs) → List xs
  tail {x} {xs} (cons .x .xs xsL) = xsL

module M₂ where
  postulate
    D   : Set
    _∷_ : D → D → D

  data List : D → Set where
    cons : ∀ x xs → List xs → List (x ∷ xs)

  tail : ∀ {x xs} → List (x ∷ xs) → List xs
  tail l = {!!}  -- C-c C-c fails


{-# OPTIONS --safe #-}

module Tools.Function where

-- Identity function
idᶠ : {A : Set} → A → A
idᶠ x = x

-- Function composition (simply typed variant)
_∘ᶠ_ : {A B C : Set} → (B → C) → (A → B) → A → C
_∘ᶠ_ f g a = f (g a)


------------------------------------------------------------------------
-- A non-recursive variant of H-level.Truncation.Propositional.Erased
------------------------------------------------------------------------

-- The definition does use natural numbers. The code is based on van
-- Doorn's "Constructing the Propositional Truncation using
-- Non-recursive HITs".

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

import Equality.Path as P

module H-level.Truncation.Propositional.Non-recursive.Erased
  {e⁺} (eq : ∀ {a p} → P.Equality-with-paths a p e⁺) where

private
  open module PD = P.Derived-definitions-and-properties eq
    hiding (elim)

open import Logical-equivalence using (_⇔_)
open import Prelude hiding ([_,_])

open import Colimit.Sequential.Very-erased eq as C using (Colimitᴱ)
open import Equality.Decidable-UIP equality-with-J
open import Equality.Path.Isomorphisms eq
open import Equivalence equality-with-J as Eq using (_≃_)
open import Equivalence.Erased.Cubical eq as EEq using (_≃ᴱ_)
open import Erased.Cubical eq
open import Function-universe equality-with-J as F hiding (_∘_)
open import H-level equality-with-J
open import H-level.Closure equality-with-J
open import H-level.Truncation.Propositional.One-step eq as O
  using (∥_∥¹-out-^)

private
  variable
    a p   : Level
    A     : Type a
    P     : A → Type p
    e x z : A

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

-- The propositional truncation operator.

∥_∥ᴱ : Type a → Type a
∥ A ∥ᴱ = Colimitᴱ A (∥ A ∥¹-out-^ ∘ suc) O.∣_∣ O.∣_∣

-- The point constructor.

∣_∣ : A → ∥ A ∥ᴱ
∣_∣ = C.∣_∣₀

-- The eliminator.

record Elim {A : Type a} (P : ∥ A ∥ᴱ → Type p) : Type (a ⊔ p) where
  no-eta-equality
  field
    ∣∣ʳ                : ∀ x → P ∣ x ∣
    @0 is-propositionʳ : ∀ x → Is-proposition (P x)

open Elim public

elim : Elim P → (x : ∥ A ∥ᴱ) → P x
elim {A = A} {P = P} e = C.elim λ where
    .C.Elim.∣∣₀ʳ         → E.∣∣ʳ
    .C.Elim.∣∣₊ʳ {n = n} → helper n
    .C.Elim.∣∣₊≡∣∣₀ʳ x   →
      subst P (C.∣∣₊≡∣∣₀ x) (subst P (sym (C.∣∣₊≡∣∣₀ x)) (E.∣∣ʳ x))  ≡⟨ subst-subst-sym _ _ _ ⟩∎
      E.∣∣ʳ x                                                        ∎
    .C.Elim.∣∣₊≡∣∣₊ʳ {n = n} x →
      subst P (C.∣∣₊≡∣∣₊ x) (subst P (sym (C.∣∣₊≡∣∣₊ x)) (helper n x))  ≡⟨ subst-subst-sym _ _ _ ⟩∎
      helper n x                                                        ∎
  where
  module E = Elim e

  @0 helper : ∀ n (x : ∥ A ∥¹-out-^ (suc n)) → P C.∣ x ∣₊

  helper zero = O.elim e₀
    where
    e₀ : O.Elim _
    e₀ .O.Elim.∣∣ʳ x            = subst P (sym (C.∣∣₊≡∣∣₀ x)) (E.∣∣ʳ x)
    e₀ .O.Elim.∣∣-constantʳ _ _ = E.is-propositionʳ _ _ _

  helper (suc n) = O.elim e₊
    where
    e₊ : O.Elim _
    e₊ .O.Elim.∣∣ʳ x            = subst P (sym (C.∣∣₊≡∣∣₊ x))
                                    (helper n x)
    e₊ .O.Elim.∣∣-constantʳ _ _ = E.is-propositionʳ _ _ _

_ : elim e ∣ x ∣ ≡ e .∣∣ʳ x
_ = refl _

-- The propositional truncation operator returns propositions (in
-- erased contexts).

@0 ∥∥ᴱ-proposition : Is-proposition ∥ A ∥ᴱ
∥∥ᴱ-proposition {A = A} = elim lemma₅
  where
  lemma₀ : ∀ n (x : A) → C.∣ O.∣ x ∣-out-^ (1 + n) ∣₊ ≡ ∣ x ∣
  lemma₀ zero x =
    C.∣ O.∣ x ∣ ∣₊  ≡⟨ C.∣∣₊≡∣∣₀ x ⟩∎
    C.∣ x ∣₀        ∎
  lemma₀ (suc n) x =
    C.∣ O.∣ O.∣ x ∣-out-^ (1 + n) ∣ ∣₊  ≡⟨ C.∣∣₊≡∣∣₊ (O.∣ x ∣-out-^ (1 + n)) ⟩
    C.∣ O.∣ x ∣-out-^ (1 + n) ∣₊        ≡⟨ lemma₀ n x ⟩∎
    ∣ x ∣                               ∎

  lemma₁₀ : ∀ (x y : A) → ∣ x ∣ ≡ C.∣ y ∣₀
  lemma₁₀ x y =
    ∣ x ∣                         ≡⟨ sym (lemma₀ 0 x) ⟩
    C.∣ O.∣ x ∣-out-^ 1 ∣₊        ≡⟨⟩
    C.∣ O.∣ O.∣ x ∣-out-^ 0 ∣ ∣₊  ≡⟨ cong C.∣_∣₊ (O.∣∣-constant _ _) ⟩
    C.∣ O.∣ y ∣ ∣₊                ≡⟨ C.∣∣₊≡∣∣₀ y ⟩∎
    C.∣ y ∣₀                      ∎

  lemma₁₊ : ∀ n (x : A) (y : ∥ A ∥¹-out-^ (1 + n)) → ∣ x ∣ ≡ C.∣ y ∣₊
  lemma₁₊ n x y =
    ∣ x ∣                               ≡⟨ sym (lemma₀ (1 + n) x) ⟩
    C.∣ O.∣ x ∣-out-^ (2 + n) ∣₊        ≡⟨⟩
    C.∣ O.∣ O.∣ x ∣-out-^ (1 + n) ∣ ∣₊  ≡⟨ cong C.∣_∣₊ (O.∣∣-constant _ _) ⟩
    C.∣ O.∣ y ∣ ∣₊                      ≡⟨ C.∣∣₊≡∣∣₊ y ⟩∎
    C.∣ y ∣₊                            ∎

  lemma₂ :
    ∀ n (x y : ∥ A ∥¹-out-^ (1 + n))
    (p : x ≡ y) (q : O.∣ x ∣ ≡ O.∣ y ∣) →
    trans (C.∣∣₊≡∣∣₊ {P₊ = ∥ A ∥¹-out-^ ∘ suc} {step₀ = O.∣_∣} x)
      (cong C.∣_∣₊ p) ≡
    trans (cong C.∣_∣₊ q) (C.∣∣₊≡∣∣₊ y)
  lemma₂ n x y p q =
    trans (C.∣∣₊≡∣∣₊ x) (cong C.∣_∣₊ p)                        ≡⟨ PD.elim
                                                                    (λ {x y} p → trans (C.∣∣₊≡∣∣₊ x) (cong C.∣_∣₊ p) ≡
                                                                                trans (cong C.∣_∣₊ (cong O.∣_∣ p)) (C.∣∣₊≡∣∣₊ y))
                                                                    (λ x →
      trans (C.∣∣₊≡∣∣₊ x) (cong C.∣_∣₊ (refl _))                       ≡⟨ cong (trans _) $ cong-refl _ ⟩
      trans (C.∣∣₊≡∣∣₊ x) (refl _)                                     ≡⟨ trans-reflʳ _ ⟩
      C.∣∣₊≡∣∣₊ x                                                      ≡⟨ sym $ trans-reflˡ _ ⟩
      trans (refl _) (C.∣∣₊≡∣∣₊ x)                                     ≡⟨ cong (flip trans _) $ sym $
                                                                          trans (cong (cong C.∣_∣₊) $ cong-refl _) $
                                                                          cong-refl _ ⟩∎
      trans (cong C.∣_∣₊ (cong O.∣_∣ (refl _))) (C.∣∣₊≡∣∣₊ x)          ∎)
                                                                    p ⟩

    trans (cong C.∣_∣₊ (cong O.∣_∣ p)) (C.∣∣₊≡∣∣₊ y)           ≡⟨ cong (flip trans _) $
                                                                  cong-preserves-Constant
                                                                    (λ u v →
      C.∣ u ∣₊                                                          ≡⟨ sym (C.∣∣₊≡∣∣₊ u) ⟩
      C.∣ O.∣ u ∣ ∣₊                                                    ≡⟨ cong C.∣_∣₊ (O.∣∣-constant _ _) ⟩
      C.∣ O.∣ v ∣ ∣₊                                                    ≡⟨ C.∣∣₊≡∣∣₊ v ⟩∎
      C.∣ v ∣₊                                                          ∎)
                                                                    _ _ ⟩∎
    trans (cong C.∣_∣₊ q) (C.∣∣₊≡∣∣₊ y)                        ∎

  lemma₃ :
    ∀ n x y (p : C.∣ O.∣ y ∣ ∣₊ ≡ z) →
    subst (∣ x ∣ ≡_) p (lemma₁₊ n x O.∣ y ∣) ≡
    trans (sym (lemma₀ n x))
      (trans (cong C.∣_∣₊ (O.∣∣-constant _ _)) p)
  lemma₃ n x y p =
    subst (∣ x ∣ ≡_) p (lemma₁₊ n x O.∣ y ∣)                      ≡⟨ sym trans-subst ⟩

    trans (lemma₁₊ n x O.∣ y ∣) p                                 ≡⟨⟩

    trans (trans (sym (trans (C.∣∣₊≡∣∣₊ (O.∣ x ∣-out-^ (1 + n)))
                         (lemma₀ n x)))
             (trans (cong C.∣_∣₊
                       (O.∣∣-constant
                          (O.∣ x ∣-out-^ (1 + n)) O.∣ y ∣))
                (C.∣∣₊≡∣∣₊ O.∣ y ∣)))
      p                                                           ≡⟨ trans (cong (λ eq →
                                                                                trans (trans eq
                                                                                (trans (cong C.∣_∣₊ (O.∣∣-constant _ _))
                                                                                (C.∣∣₊≡∣∣₊ _)))
                                                                                p) $
                                                                            sym-trans _ _) $
                                                                     trans (trans-assoc _ _ _) $
                                                                     trans (trans-assoc _ _ _) $
                                                                     cong (trans (sym (lemma₀ n _))) $
                                                                     sym $ trans-assoc _ _ _ ⟩
    trans (sym (lemma₀ n x))
      (trans (trans (sym (C.∣∣₊≡∣∣₊ (O.∣ x ∣-out-^ (1 + n))))
                (trans (cong C.∣_∣₊
                          (O.∣∣-constant
                             (O.∣ x ∣-out-^ (1 + n)) O.∣ y ∣))
                   (C.∣∣₊≡∣∣₊ O.∣ y ∣)))
         p)                                                       ≡⟨ cong (λ eq → trans (sym (lemma₀ n _))
                                                                                (trans (trans (sym (C.∣∣₊≡∣∣₊ _)) eq) p)) $ sym $
                                                                     lemma₂ _ _ _ _ _ ⟩
    trans (sym (lemma₀ n x))
      (trans (trans (sym (C.∣∣₊≡∣∣₊ (O.∣ x ∣-out-^ (1 + n))))
                (trans (C.∣∣₊≡∣∣₊ (O.∣ x ∣-out-^ (1 + n)))
                   (cong C.∣_∣₊ (O.∣∣-constant _ _))))
         p)                                                       ≡⟨ cong (λ eq → trans (sym (lemma₀ n _)) (trans eq p)) $
                                                                     trans-sym-[trans] _ _ ⟩∎
    trans (sym (lemma₀ n x))
      (trans (cong C.∣_∣₊ (O.∣∣-constant _ _)) p)                 ∎

  lemma₄ : ∀ _ → C.Elim _
  lemma₄ x .C.Elim.∣∣₀ʳ       = lemma₁₀ x
  lemma₄ x .C.Elim.∣∣₊ʳ       = lemma₁₊ _ x
  lemma₄ x .C.Elim.∣∣₊≡∣∣₀ʳ y =
    subst (∣ x ∣ ≡_) (C.∣∣₊≡∣∣₀ y) (lemma₁₊ 0 x O.∣ y ∣)       ≡⟨ lemma₃ _ _ _ _ ⟩

    trans (sym (lemma₀ 0 x))
      (trans (cong C.∣_∣₊ (O.∣∣-constant _ _)) (C.∣∣₊≡∣∣₀ y))  ≡⟨⟩

    lemma₁₀ x y                                                ∎
  lemma₄ x .C.Elim.∣∣₊≡∣∣₊ʳ {n = n} y =
    subst (∣ x ∣ ≡_) (C.∣∣₊≡∣∣₊ y) (lemma₁₊ (1 + n) x O.∣ y ∣)  ≡⟨ lemma₃ _ _ _ _ ⟩

    trans (sym (lemma₀ (1 + n) x))
      (trans (cong C.∣_∣₊ (O.∣∣-constant _ _)) (C.∣∣₊≡∣∣₊ y))   ≡⟨⟩

    lemma₁₊ n x y                                               ∎

  lemma₅ : Elim _
  lemma₅ .is-propositionʳ = Π≡-proposition ext
  lemma₅ .∣∣ʳ x           = C.elim (lemma₄ x)

------------------------------------------------------------------------
-- A lemma

-- A function of type (x : ∥ A ∥ᴱ) → P x, along with an erased proof
-- showing that the function is equal to some erased function, is
-- equivalent to a function of type (x : A) → P ∣ x ∣, along with an
-- erased equality proof.

Σ-Π-∥∥ᴱ-Erased-≡-≃ :
  {@0 g : (x : ∥ A ∥ᴱ) → P x} →
  (∃ λ (f : (x : ∥ A ∥ᴱ) → P x) → Erased (f ≡ g)) ≃
  (∃ λ (f : (x : A) → P ∣ x ∣) → Erased (f ≡ g ∘ ∣_∣))
Σ-Π-∥∥ᴱ-Erased-≡-≃ {A = A} {P = P} {g = g} =
  (∃ λ (f : (x : ∥ A ∥ᴱ) → P x) → Erased (f ≡ g))                         ↝⟨ (inverse $
                                                                              Σ-cong (inverse C.universal-property-Π) λ _ → F.id) ⟩
  (∃ λ (f :
        ∃ λ (f₀ : (x : A) → P ∣ x ∣) →
        Erased (
        ∃ λ (f₊ : ∀ n (x : ∥ A ∥¹-out-^ (suc n)) → P C.∣ x ∣₊) →
        (∀ x → subst P (C.∣∣₊≡∣∣₀ x) (f₊ zero O.∣ x ∣) ≡ f₀ x) ×
        (∀ n x → subst P (C.∣∣₊≡∣∣₊ x) (f₊ (suc n) O.∣ x ∣) ≡
                         f₊ n x))) →
   Erased (u⁻¹ f ≡ g))                                                    ↔⟨ inverse $
                                                                             Σ-assoc F.∘
                                                                             (∃-cong λ _ →
                                                                              Erased-Σ↔Σ F.∘
                                                                              (from-equivalence $ Erased-cong (∃-cong λ _ →
                                                                               Eq.extensionality-isomorphism bad-ext))) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ (e :
        ∃ λ (f₊ : ∀ n (x : ∥ A ∥¹-out-^ (suc n)) → P C.∣ x ∣₊) →
        (∀ x → subst P (C.∣∣₊≡∣∣₀ x) (f₊ zero O.∣ x ∣) ≡ f x) ×
        (∀ n x → subst P (C.∣∣₊≡∣∣₊ x) (f₊ (suc n) O.∣ x ∣) ≡ f₊ n x)) →
   ∀ x → u⁻¹ (f , [ e ]) x ≡ g x))                                        ↝⟨ (∃-cong λ _ → Erased-cong (∃-cong λ _ →
                                                                              (∃-cong λ _ → from-bijection $ erased Erased↔) F.∘
                                                                              C.universal-property-Π)) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ ((f₊ , eq₀ , eq₊) :
        ∃ λ (f₊ : ∀ n (x : ∥ A ∥¹-out-^ (suc n)) → P C.∣ x ∣₊) →
        (∀ x → subst P (C.∣∣₊≡∣∣₀ x) (f₊ zero O.∣ x ∣) ≡ f x) ×
        (∀ n x → subst P (C.∣∣₊≡∣∣₊ x) (f₊ (suc n) O.∣ x ∣) ≡ f₊ n x)) →
   ∃ λ (f≡g₀ : (x : A) → f x ≡ g ∣ x ∣) →
   ∃ λ (f≡g₊ : ∀ n (x : ∥ A ∥¹-out-^ (suc n)) → f₊ n x ≡ g C.∣ x ∣₊) →
   (∀ x → subst (λ x → u⁻¹ (f , [ f₊ , eq₀ , eq₊ ]) x ≡ g x)
            (C.∣∣₊≡∣∣₀ x) (f≡g₊ zero O.∣ x ∣) ≡
          f≡g₀ x) ×
   (∀ n (x : ∥ A ∥¹-out-^ (suc n)) →
    subst (λ x → u⁻¹ (f , [ f₊ , eq₀ , eq₊ ]) x ≡ g x)
      (C.∣∣₊≡∣∣₊ x) (f≡g₊ (suc n) O.∣ x ∣) ≡
    f≡g₊ n x)))                                                           ↔⟨ (∃-cong λ _ → Erased-cong (
                                                                              (∃-cong λ _ →
                                                                               (∃-cong λ _ →
                                                                                inverse Σ-assoc) F.∘
                                                                               Σ-assoc F.∘
                                                                               (∃-cong λ _ →
                                                                                (inverse $
                                                                                Σ-cong (inverse $
                                                                                Eq.extensionality-isomorphism bad-ext F.∘
                                                                                (∀-cong ext λ _ →
                                                                                Eq.extensionality-isomorphism bad-ext)) λ _ →
                                                                                F.id) F.∘
                                                                                ∃-comm) F.∘
                                                                               inverse Σ-assoc) F.∘
                                                                              ∃-comm)) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ (f≡g₀ : (x : A) → f x ≡ g ∣ x ∣) →
   ∃ λ ((f₊ , f≡g₊) :
        ∃ λ (f₊ : ∀ n (x : ∥ A ∥¹-out-^ (suc n)) → P C.∣ x ∣₊) →
        f₊ ≡ λ _ x → g C.∣ x ∣₊) →
   ∃ λ (eq₀ : ∀ x → subst P (C.∣∣₊≡∣∣₀ x) (f₊ zero O.∣ x ∣) ≡ f x) →
   ∃ λ (eq₊ : ∀ n x →
              subst P (C.∣∣₊≡∣∣₊ x) (f₊ (suc n) O.∣ x ∣) ≡ f₊ n x) →
   (∀ x → subst (λ x → u⁻¹ (f , [ f₊ , eq₀ , eq₊ ]) x ≡ g x)
            (C.∣∣₊≡∣∣₀ x) (cong (_$ O.∣ x ∣) (cong (_$ zero) f≡g₊)) ≡
          f≡g₀ x) ×
   (∀ n (x : ∥ A ∥¹-out-^ (suc n)) →
    subst (λ x → u⁻¹ (f , [ f₊ , eq₀ , eq₊ ]) x ≡ g x)
      (C.∣∣₊≡∣∣₊ x) (cong (_$ O.∣ x ∣) (cong (_$ suc n) f≡g₊)) ≡
    cong (_$ x) (cong (_$ n) f≡g₊))))                                     ↔⟨ (∃-cong λ _ → Erased-cong (∃-cong λ _ →
                                                                              (∃-cong λ _ → ∃-cong λ _ →
                                                                               (∀-cong ext λ _ → ≡⇒↝ _ $ cong (_≡ _) $
                                                                                cong (subst (λ x → u⁻¹ _ x ≡ g x) _) $
                                                                                trans (cong (cong (_$ _)) $ cong-refl _) $
                                                                                cong-refl _)
                                                                                ×-cong
                                                                               (∀-cong ext λ _ → ∀-cong ext λ _ → ≡⇒↝ _ $ cong₂ _≡_
                                                                                (cong (subst (λ x → u⁻¹ _ x ≡ g x) _) $
                                                                                trans (cong (cong (_$ _)) $ cong-refl _) $
                                                                                cong-refl _)
                                                                                (trans (cong (cong (_$ _)) $ cong-refl _) $
                                                                                cong-refl _))) F.∘
                                                                              (drop-⊤-left-Σ $
                                                                               _⇔_.to contractible⇔↔⊤ $
                                                                               singleton-contractible _))) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ (f≡g₀ : (x : A) → f x ≡ g ∣ x ∣) →
   ∃ λ (eq₀ : ∀ x → subst P (C.∣∣₊≡∣∣₀ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ f x) →
   ∃ λ (eq₊ : ∀ n x →
              subst P (C.∣∣₊≡∣∣₊ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ g C.∣ x ∣₊) →
   (∀ x → subst
            (λ x → u⁻¹ (f , [ (λ _ → g ∘ C.∣_∣₊) , eq₀ , eq₊ ]) x ≡ g x)
            (C.∣∣₊≡∣∣₀ x) (refl _) ≡
          f≡g₀ x) ×
   (∀ n (x : ∥ A ∥¹-out-^ (suc n)) →
    subst (λ x → u⁻¹ (f , [ (λ _ → g ∘ C.∣_∣₊) , eq₀ , eq₊ ]) x ≡ g x)
      (C.∣∣₊≡∣∣₊ x) (refl _) ≡
    refl _)))                                                             ↝⟨ (∃-cong λ _ → Erased-cong (∃-cong λ _ → ∃-cong λ _ → ∃-cong λ _ →
                                                                              (∀-cong ext λ _ → ≡⇒↝ _ $ cong (_≡ _) $
                                                                               lemma₀ _ _ _ _)
                                                                                ×-cong
                                                                              (∀-cong ext λ _ → ∀-cong ext λ _ → ≡⇒↝ _ $ cong (_≡ refl _) $
                                                                               lemma₊ _ _ _ _ _))) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ (f≡g₀ : (x : A) → f x ≡ g ∣ x ∣) →
   ∃ λ (eq₀ : ∀ x → subst P (C.∣∣₊≡∣∣₀ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ f x) →
   ∃ λ (eq₊ : ∀ n x →
              subst P (C.∣∣₊≡∣∣₊ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ g C.∣ x ∣₊) →
   (∀ x → trans (sym (eq₀ x)) (dcong g (C.∣∣₊≡∣∣₀ x)) ≡ f≡g₀ x) ×
   (∀ n (x : ∥ A ∥¹-out-^ (suc n)) →
    trans (sym (eq₊ n x)) (dcong g (C.∣∣₊≡∣∣₊ x)) ≡ refl _)))             ↝⟨ (∃-cong λ _ → Erased-cong (∃-cong λ _ → ∃-cong λ eq₀ → ∃-cong λ eq₊ →
                                                                              (Eq.extensionality-isomorphism bad-ext F.∘
                                                                               (∀-cong ext λ _ →
                                                                                Eq.≃-≡ (Eq.↔⇒≃ ≡-comm) F.∘
                                                                                (≡⇒↝ _ $
                                                                                trans ([trans≡]≡[≡trans-symʳ] _ _ _) $
                                                                                cong (sym (eq₀ _) ≡_) $ sym $ sym-sym _)))
                                                                                ×-cong
                                                                              (Eq.extensionality-isomorphism bad-ext F.∘
                                                                               (∀-cong ext λ _ →
                                                                                Eq.extensionality-isomorphism bad-ext F.∘
                                                                                (∀-cong ext λ _ →
                                                                                Eq.≃-≡ (Eq.↔⇒≃ ≡-comm) F.∘
                                                                                (≡⇒↝ _ $
                                                                                trans ([trans≡]≡[≡trans-symʳ] _ _ _) $
                                                                                cong (sym (eq₊ _ _) ≡_) $ sym $ sym-sym _)))))) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ (f≡g₀ : (x : A) → f x ≡ g ∣ x ∣) →
   ∃ λ (eq₀ : ∀ x → subst P (C.∣∣₊≡∣∣₀ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ f x) →
   ∃ λ (eq₊ : ∀ n x →
              subst P (C.∣∣₊≡∣∣₊ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ g C.∣ x ∣₊) →
   eq₀ ≡ (λ x → sym (trans (f≡g₀ x) (sym (dcong g (C.∣∣₊≡∣∣₀ x))))) ×
   eq₊ ≡ (λ _ x → sym (trans (refl _) (sym (dcong g (C.∣∣₊≡∣∣₊ x)))))))   ↔⟨ (∃-cong λ _ → Erased-cong (∃-cong λ _ → ∃-cong λ _ →
                                                                              (drop-⊤-right λ _ →
                                                                               _⇔_.to contractible⇔↔⊤ $
                                                                               singleton-contractible _) F.∘
                                                                              ∃-comm)) ⟩
  (∃ λ (f : (x : A) → P ∣ x ∣) →
   Erased (
   ∃ λ (f≡g₀ : (x : A) → f x ≡ g ∣ x ∣) →
   ∃ λ (eq₀ : ∀ x → subst P (C.∣∣₊≡∣∣₀ x) (g C.∣ O.∣ x ∣ ∣₊) ≡ f x) →
   eq₀ ≡ (λ x → sym (trans (f≡g₀ x) (sym (dcong g (C.∣∣₊≡∣∣₀ x)))))))     ↔⟨ (∃-cong λ _ → Erased-cong (
                                                                              drop-⊤-right λ _ →
                                                                              _⇔_.to contractible⇔↔⊤ $
                                                                              singleton-contractible _)) ⟩

  (∃ λ (f : (x : A) → P ∣ x ∣) → Erased ((x : A) → f x ≡ g ∣ x ∣))        ↝⟨ (∃-cong λ _ → Erased-cong (
                                                                              Eq.extensionality-isomorphism bad-ext)) ⟩□
  (∃ λ (f : (x : A) → P ∣ x ∣) → Erased (f ≡ g ∘ ∣_∣))                    □
  where
  u⁻¹ = _≃_.from C.universal-property-Π

  @0 lemma₀ : ∀ _ _ _ _ → _
  lemma₀ f eq₀ eq₊ x =
    subst (λ x → u⁻¹ (f , [ (λ _ → g ∘ C.∣_∣₊) , eq₀ , eq₊ ]) x ≡ g x)
      (C.∣∣₊≡∣∣₀ x) (refl _)                                            ≡⟨ subst-in-terms-of-trans-and-dcong ⟩

    trans (sym (dcong (u⁻¹ (f , [ (λ _ → g ∘ C.∣_∣₊) , eq₀ , eq₊ ]))
                  (C.∣∣₊≡∣∣₀ x)))
      (trans (cong (subst P (C.∣∣₊≡∣∣₀ x)) (refl _))
         (dcong g (C.∣∣₊≡∣∣₀ x)))                                       ≡⟨ cong₂ (trans ∘ sym)
                                                                             C.elim-∣∣₊≡∣∣₀
                                                                             (trans (cong (flip trans _) $
                                                                                cong-refl _) $
                                                                              trans-reflˡ _) ⟩∎
    trans (sym (eq₀ x)) (dcong g (C.∣∣₊≡∣∣₀ x))                         ∎

  @0 lemma₊ : ∀ _ _ _ _ _ → _
  lemma₊ f eq₀ eq₊ n x =
    subst (λ x → u⁻¹ (f , [ (λ _ → g ∘ C.∣_∣₊) , eq₀ , eq₊ ]) x ≡ g x)
      (C.∣∣₊≡∣∣₊ x) (refl _)                                            ≡⟨ subst-in-terms-of-trans-and-dcong ⟩

    trans (sym (dcong (u⁻¹ (f , [ (λ _ → g ∘ C.∣_∣₊) , eq₀ , eq₊ ]))
                  (C.∣∣₊≡∣∣₊ x)))
      (trans (cong (subst P (C.∣∣₊≡∣∣₊ x)) (refl _))
         (dcong g (C.∣∣₊≡∣∣₊ x)))                                       ≡⟨ cong₂ (trans ∘ sym)
                                                                             C.elim-∣∣₊≡∣∣₊
                                                                             (trans (cong (flip trans _) $
                                                                                cong-refl _) $
                                                                              trans-reflˡ _) ⟩∎
    trans (sym (eq₊ n x)) (dcong g (C.∣∣₊≡∣∣₊ x))                       ∎


-- Copyright:  (c) 2016 Ertugrul Söylemez
-- License:    BSD3
-- Maintainer: Ertugrul Söylemez <esz@posteo.de>

module Algebra.Group.Monoid where

open import Algebra.Category
open import Algebra.Group.Semigroup
open import Core

-- A monoid is a semigroup with an identity element.

record IsMonoid {a r} (S : Semigroup {a} {r}) : Set (a ⊔ r) where
  open Semigroup S

  field
    id : A
    left-id  : ∀ x → id ⋄ x ≈ x
    right-id : ∀ x → x ⋄ id ≈ x

  category : Category
  category =
    record {
      semigroupoid = semigroupoid;
      id = id;
      left-id = left-id;
      right-id = right-id
    }

  open Category category public
    using (id-unique; Iso)

record Monoid {a r} : Set (lsuc (a ⊔ r)) where
  field
    semigroup : Semigroup {a} {r}
    isMonoid  : IsMonoid semigroup

  open Semigroup semigroup public
  open IsMonoid isMonoid public

-- A monoid morphism is a function that maps the elements of one monoid
-- to another while preserving the compositional structure as well as
-- identity.

record MonoidMorphism
           {ma mr na nr}
           (M : Monoid {ma} {mr})
           (N : Monoid {na} {nr})
           : Set (ma ⊔ mr ⊔ na ⊔ nr)
       where

  private
    module M = Monoid M
    module N = Monoid N

  field semigroupMorphism : SemigroupMorphism M.semigroup N.semigroup
  open SemigroupMorphism semigroupMorphism public

  field
    id-preserving : map M.id N.≈ N.id

  functor : Functor M.category N.category
  functor =
    record {
      semifunctor = semifunctor;
      id-preserving = id-preserving
    }

  open Functor functor public
    using (Iso-preserving)

-- An equivalence relation on monoid morphisms that considers monoid
-- morphisms to be equal iff they map every element in the domain to the
-- same element in the codomain.

MonoidMorphismEq :
  ∀ {ma mr na nr}
    {M : Monoid {ma} {mr}} {N : Monoid {na} {nr}}
  → Equiv (MonoidMorphism M N)
MonoidMorphismEq {N = N} =
  record {
    _≈_ = λ F G →
            let module F = MonoidMorphism F
                module G = MonoidMorphism G
            in ∀ x → F.map x ≈ G.map x;
    refl = λ _ → refl;
    sym = λ x≈y x → sym (x≈y x);
    trans = λ x≈y y≈z x → trans (x≈y x) (y≈z x)
  }

  where
  module N = Monoid N
  open Equiv N.Eq

-- Category of monoids.

Monoids : ∀ {a r} → Category
Monoids {a} {r} =
  record {
    semigroupoid = record {
      Ob = Monoid {a} {r};
      Hom = MonoidMorphism;
      Eq = MonoidMorphismEq;
      _∘_ = _∘_;
      ∘-cong = λ {_} {_} {_} {f1} {f2} {g1} {g2} → ∘-cong {f1 = f1} {f2} {g1} {g2};
      assoc = assoc
    };
    id = id;
    left-id = left-id;
    right-id = right-id
  }

  where
  open module MyEquiv {M : Monoid} {N : Monoid} = Equiv (MonoidMorphismEq {M = M} {N})

  id : ∀ {M} → MonoidMorphism M M
  id {M} =
    record {
      semigroupMorphism = record {
        map = Sets.id;
        map-cong = Sets.id;
        ⋄-preserving = λ x y → M.refl
      };
      id-preserving = M.refl
    }

    where
    module M = Monoid M

  _∘_ : ∀ {M N O} → MonoidMorphism N O → MonoidMorphism M N → MonoidMorphism M O
  _∘_ {M} {N} {O} f g =
    record {
      semigroupMorphism = f.semigroupMorphism Semigroups.∘ g.semigroupMorphism;
      id-preserving =
        O.begin
          f.map (g.map M.id) O.≈[ f.map-cong g.id-preserving ]
          f.map N.id         O.≈[ f.id-preserving ]
          O.id
        O.qed
    }

    where
    module f = MonoidMorphism f
    module g = MonoidMorphism g
    module M = Monoid M
    module N = Monoid N
    module O = Monoid O

  ∘-cong :
    ∀ {M N O}
      {f1 f2 : MonoidMorphism N O}
      {g1 g2 : MonoidMorphism M N}
    → f1 ≈ f2
    → g1 ≈ g2
    → f1 ∘ g1 ≈ f2 ∘ g2
  ∘-cong {O = O} {f1} {f2} {g1} {g2} f1≈f2 g1≈g2 x =
    O.begin
      f1.map (g1.map x) O.≈[ f1.map-cong (g1≈g2 x) ]
      f1.map (g2.map x) O.≈[ f1≈f2 (g2.map x) ]
      f2.map (g2.map x)
    O.qed

    where
    module O = Monoid O
    module f1 = MonoidMorphism f1
    module f2 = MonoidMorphism f2
    module g1 = MonoidMorphism g1
    module g2 = MonoidMorphism g2

  assoc :
    ∀ {M N O P}
      (f : MonoidMorphism O P)
      (g : MonoidMorphism N O)
      (h : MonoidMorphism M N)
    → (f ∘ g) ∘ h ≈ f ∘ (g ∘ h)
  assoc {P = P} _ _ _ _ = P.refl
    where
    module P = Monoid P

  left-id : ∀ {M N} (f : MonoidMorphism M N) → id ∘ f ≈ f
  left-id {N = N} _ _ = N.refl
    where
    module N = Monoid N

  right-id : ∀ {M N} (f : MonoidMorphism M N) → f ∘ id ≈ f
  right-id {N = N} _ _ = N.refl
    where
    module N = Monoid N