module Cats.Limit where

open import Level

open import Cats.Category.Base
open import Cats.Category.Cones using
  (Cone ; Cones ; HasObj-Cone ; HasArrow-⇒ ; cone-iso→obj-iso ; apFunctor)
open import Cats.Functor using (Functor)
open import Cats.Util.Conv

import Cats.Category.Constructions.Terminal as Terminal
import Cats.Category.Constructions.Iso as Iso

module _ {lo la l≈ lo′ la′ l≈′}
  {J : Category lo la l≈}
  {Z : Category lo′ la′ l≈′}
  where

  IsLimit : {D : Functor J Z} → Cone D → Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′)
  IsLimit {D} = Terminal.Build.IsTerminal (Cones D)

  record Limit (D : Functor J Z) : Set (lo ⊔ la ⊔ lo′ ⊔ la′ ⊔ l≈′) where
    field
      cone : Cone D
      isLimit : IsLimit cone

  instance
    HasObj-Limit : ∀ D → HasObj (Limit D) _ _ _
    HasObj-Limit D = record { Cat = Cones D ; _ᴼ = Limit.cone }

  module _ {D : Functor J Z} where

    open Iso.Build (Cones D) using (_≅_)
    open Iso.Build Z using () renaming (_≅_ to _≅Z_)
    open Limit using (isLimit)

    unique : (l m : Limit D) → l ᴼ ≅ m ᴼ
    unique l m = Terminal.Build.terminal-unique (Cones D) (isLimit l) (isLimit m)

    obj-unique : (l m : Limit D) → l ᴼ ᴼ ≅Z m ᴼ ᴼ
    obj-unique l m = cone-iso→obj-iso _ (unique l m)

module _ {lo la l≈ lo′ la′ l≈′}
  {C : Category lo la l≈}
  {D : Category lo′ la′ l≈′}
  where

  preservesLimits : (lo″ la″ l≈″ : Level) → (F : Functor C D) → Set _
  preservesLimits lo″ la″ l≈″ F
      = {J : Category lo″ la″ l≈″}
      → {D : Functor J C}
      → {c : Cone D}
      → IsLimit c
      → IsLimit (apFunctor F c)


------------------------------------------------------------------------
-- An example
------------------------------------------------------------------------

module RecursiveTypes.Subtyping.Example where

open import Codata.Musical.Notation
open import Data.Fin
open import Data.Nat

open import RecursiveTypes.Syntax
open import RecursiveTypes.Subtyping.Semantic.Coinductive

-- σ = μX. X ⟶ X.

σ : Ty 0
σ = μ var zero ⟶ var zero

-- τ = μX. (X ⟶ ⊥) ⟶ ⊤.

τ : Ty 0
τ = μ (var zero ⟶ ⊥) ⟶ ⊤

-- σ is a subtype of τ.

σ≤τ : σ ≤Coind τ
σ≤τ = ♯ (♯ σ≤τ ⟶ ♯ ⊥) ⟶ ♯ ⊤


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

syntax QIO

type
  T : 0-ary
  P : 0-ary

term
  new      : P.T  ->  T
  measure  : P  T  T  ->  T
  applyX   : P  P.T  ->  T
  applyI2  : P  P.T  ->  T
  applyDuv : P  P  (P,P).T  ->  T
  applyDu  : P  P.T  ->  T
  applyDv  : P  P.T  ->  T

theory
  (A) a:P   t u:T         |> applyX (a, b.measure(b, t, u)) = measure(a, u, t)
  (B) a:P   b:P  t u:P.T  |> measure(a, applyDu(b, b.t[b]), applyDv(b, b.u[b])) = applyDuv(a, b, a b.measure(a, t[b], u[b]))
  (D) t u:T               |> new(a.measure(a, t, u)) = t
  (E) b:P  t:(P, P).T     |> new(a.applyDuv(a, b, a b. t[a,b])) = applyDu(b, b.new(a.t[a,b]))
-}

module QIO.Signature where

open import SOAS.Context

-- Type declaration
data QIOT : Set where
  T : QIOT
  P : QIOT

open import SOAS.Syntax.Signature QIOT public
open import SOAS.Syntax.Build QIOT public

-- Operator symbols
data QIOₒ : Set where
  newₒ measureₒ applyXₒ applyI2ₒ applyDuvₒ applyDuₒ applyDvₒ : QIOₒ

-- Term signature
QIO:Sig : Signature QIOₒ
QIO:Sig = sig λ
  {  newₒ       → (P ⊢₁ T) ⟼₁ T
  ;  measureₒ   → (⊢₀ P) , (⊢₀ T) , (⊢₀ T) ⟼₃ T
  ;  applyXₒ    → (⊢₀ P) , (P ⊢₁ T) ⟼₂ T
  ;  applyI2ₒ   → (⊢₀ P) , (P ⊢₁ T) ⟼₂ T
  ;  applyDuvₒ  → (⊢₀ P) , (⊢₀ P) , (P , P ⊢₂ T) ⟼₃ T
  ;  applyDuₒ   → (⊢₀ P) , (P ⊢₁ T) ⟼₂ T
  ;  applyDvₒ   → (⊢₀ P) , (P ⊢₁ T) ⟼₂ T
  }

open Signature QIO:Sig public


{-# OPTIONS --cubical --allow-unsolved-metas #-}

open import Agda.Builtin.Cubical.Path
open import Agda.Builtin.Nat

pred : Nat → Nat
pred (suc n) = n
pred zero = zero

data [0-1] : Set where
  𝟎 𝟏 : [0-1]
  int : 𝟎 ≡ 𝟏

-- The following holes can be filled, so they should not cause a
-- typechecking failure.

0=x : ∀ i → 𝟎 ≡ int i
0=x i = \ j → int {!!}

si : {n m : Nat} → suc n ≡ suc m → n ≡ m
si p i = pred (p {!!})


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

module Number.InclusionModules where

import Number.Postulates
import Number.Inclusions

-- NOTE: the following takes a very long time to typecheck
-- see https://lists.chalmers.se/pipermail/agda-dev/2015-September/000201.html
-- see https://github.com/agda/agda/issues/1646
--     Exponential module chain leads to infeasible scope checking

module Isℕ↪ℤ = Number.Inclusions.IsROrderedCommSemiringInclusion Number.Postulates.ℕ↪ℤinc
module Isℕ↪ℚ = Number.Inclusions.IsROrderedCommSemiringInclusion Number.Postulates.ℕ↪ℚinc
module Isℕ↪ℂ = Number.Inclusions.Isℕ↪ℂ                           Number.Postulates.ℕ↪ℂinc
module Isℕ↪ℝ = Number.Inclusions.IsROrderedCommSemiringInclusion Number.Postulates.ℕ↪ℝinc
module Isℤ↪ℚ = Number.Inclusions.IsROrderedCommRingInclusion     Number.Postulates.ℤ↪ℚinc
module Isℤ↪ℝ = Number.Inclusions.IsROrderedCommRingInclusion     Number.Postulates.ℤ↪ℝinc
module Isℤ↪ℂ = Number.Inclusions.Isℤ↪ℂ                           Number.Postulates.ℤ↪ℂinc
module Isℚ↪ℝ = Number.Inclusions.IsROrderedFieldInclusion        Number.Postulates.ℚ↪ℝinc
module Isℚ↪ℂ = Number.Inclusions.IsRFieldInclusion               Number.Postulates.ℚ↪ℂinc
module Isℝ↪ℂ = Number.Inclusions.IsRFieldInclusion               Number.Postulates.ℝ↪ℂinc

{-
-- NOTE: the following is a little faster but does not help us

module Isℕ↪ℤ = Number.Inclusions.IsROrderedCommSemiringInclusion
module Isℕ↪ℚ = Number.Inclusions.IsROrderedCommSemiringInclusion
module Isℕ↪ℂ = Number.Inclusions.Isℕ↪ℂ
module Isℕ↪ℝ = Number.Inclusions.IsROrderedCommSemiringInclusion
module Isℤ↪ℚ = Number.Inclusions.IsROrderedCommRingInclusion
module Isℤ↪ℝ = Number.Inclusions.IsROrderedCommRingInclusion
module Isℤ↪ℂ = Number.Inclusions.Isℤ↪ℂ
module Isℚ↪ℝ = Number.Inclusions.IsROrderedFieldInclusion
module Isℚ↪ℂ = Number.Inclusions.IsRFieldInclusion
module Isℝ↪ℂ = Number.Inclusions.IsRFieldInclusion
-}


------------------------------------------------------------------------------
-- Properties related with the totality of the rose tree type
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.Mirror.Tree.TotalityNonTerminationI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Base.List
open import FOTC.Data.List
open import FOTC.Program.Mirror.Mirror
open import FOTC.Program.Mirror.Type
open import FOTC.Program.Mirror.Forest.TotalityI
open import FOTC.Program.Mirror.Forest.PropertiesI

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

-- Requires --injective-type-constructors
-- Peter: To use injectivity of type constructors means asking for
-- trouble. The logic behind this is very unclear.
node-Forest : ∀ {d ts} → Tree (node d ts) → Forest ts
node-Forest {d} (tree .d Fts) = Fts

postulate reverse-∷' : ∀ x ys → reverse (x ∷ ys) ≡ reverse ys ++ (x ∷ [])

-- The termination checker can not determine that the function mirror-Tree
-- defined by
--
-- mirror-Tree (tree d (fcons {t} {ts} Tt Fts)) =
--   ... mirror-Tree (tree d Fts) ... mirror-Tree Tt ...
--
-- is structurally recursive.

-- Andreas Abel: The function does not terminate because we are using
-- postulates (i.e. D, _∷_, etc). In particular, x is not structurally
-- smaller than x ∷ xs.

{-# TERMINATING #-}
mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
mirror-Tree (tree d fnil) =
  subst Tree (sym (mirror-eq d [])) (tree d helper₂)
    where
      helper₁ : rev (map mirror []) [] ≡ []
      helper₁ =
          rev (map mirror []) []
            ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
                     (map-[] mirror)
                     refl
           ⟩
          rev [] []
            ≡⟨ rev-[] [] ⟩
          [] ∎

      helper₂ : Forest (rev (map mirror []) [])
      helper₂ = subst Forest (sym helper₁) fnil

mirror-Tree (tree d (fcons {t} {ts} Tt Fts)) =
  subst Tree (sym (mirror-eq d (t ∷ ts))) (tree d helper)

  where
     h₁ : Tree (node d (reverse (map mirror ts)))
     h₁ = subst Tree (mirror-eq d ts) (mirror-Tree (tree d Fts))

     h₂ : Forest (reverse (map mirror ts))
     h₂ = node-Forest h₁

     h₃ : Forest ((reverse (map mirror ts)) ++ (mirror · t ∷ []))
     h₃ = ++-Forest h₂ (fcons (mirror-Tree Tt) fnil)

     h₄ : Forest (reverse (mirror · t ∷ map mirror ts))
     h₄ = subst Forest (sym (reverse-∷' (mirror · t) (map mirror ts))) h₃

     helper : Forest (reverse (map mirror (t ∷ ts)))
     helper = subst Forest
              (subst (λ x → reverse x ≡ reverse (map mirror (t ∷ ts)))
                     (map-∷ mirror t ts)
                     refl)
              h₄


{-# OPTIONS --without-K --rewriting #-}
open import HoTT.Base
open import HoTT.Identity
open import HoTT.Identity.Sigma
open import HoTT.Identity.Pi
open import HoTT.Identity.Universe
open import HoTT.Identity.Product
open import HoTT.HLevel
open import HoTT.HLevel.Truncate
open import HoTT.Equivalence
open import HoTT.Equivalence.Lift

module HoTT.Logic where

private variable i j k : Level

LiftProp : Prop𝒰 i → Prop𝒰 (i ⊔ j)
LiftProp {i} {j} P = type (Lift {j} (P ty))

⊤ : Prop𝒰 i
⊤ = type 𝟏

⊥ : Prop𝒰 i
⊥ = type 𝟎

_∧_ : Prop𝒰 i → Prop𝒰 j → Prop𝒰 (i ⊔ j)
P ∧ Q = type (P ty × Q ty) ⦃ ×-hlevel ⦄

_⇒_ : Prop𝒰 i → Prop𝒰 j → Prop𝒰 (i ⊔ j)
P ⇒ Q = type (P ty → Q ty)
infix 10 _⇒_

_⇔_ : Prop𝒰 i → Prop𝒰 i → Prop𝒰 (lsuc i)
P ⇔ Q = type (P ty == Q ty) ⦃ equiv-hlevel (=𝒰-equiv ⁻¹ₑ) ⦄
  where
  instance
    _ = Σ-hlevel
    _ = raise ⦃ hlevel𝒰.h P ⦄
    _ = raise ⦃ hlevel𝒰.h Q ⦄

_∨_ : Prop𝒰 i → Prop𝒰 j → Prop𝒰 (i ⊔ j)
P ∨ Q = type ∥ P ty + Q ty ∥

∃ : (A : 𝒰 i) → (A → Prop𝒰 j) → Prop𝒰 (i ⊔ j)
∃ A P = type ∥ Σ A (_ty ∘ P) ∥
syntax ∃ A (λ x → Φ) = ∃[ x ∶ A ] Φ

∀' : (A : 𝒰 i) → (P : A → Prop𝒰 j) → Prop𝒰 (i ⊔ j)
∀' A P = type (Π A (_ty ∘ P))
  where instance _ = λ {x} → hlevel𝒰.h (P x)
syntax ∀' A (λ x → Φ) = ∀[ x ∶ A ] Φ

LEM : 𝒰 (lsuc i)
LEM {i} = (A : Prop𝒰 i) → A ty + ¬ A ty

LEM∞ : 𝒰 (lsuc i)
LEM∞ {i} = (A : 𝒰 i) → A + ¬ A

LDN : 𝒰 (lsuc i)
LDN {i} = (A : Prop𝒰 i) → ¬ ¬ A ty → A ty

AC : 𝒰 (lsuc i ⊔ lsuc j ⊔ lsuc k)
AC {i} {j} {k} =
  {X : 𝒰 i} {A : X → 𝒰 j} {P : (x : X) → A x → 𝒰 k} →
  ⦃ hlevel 2 X ⦄ → ⦃ {x : X} → hlevel 2 (A x) ⦄ →
  ⦃ {x : X} {a : A x} → hlevel 1 (P x a) ⦄ →
  Π[ x ∶ X ] ∥ Σ[ a ∶ A x ] P x a ∥ →
  ∥ Σ[ g ∶ Π[ x ∶ X ] A x ] Π[ x ∶ X ] P x (g x) ∥

Lemma3/9/1 : (P : 𝒰 i) → ⦃ hlevel 1 P ⦄ → P ≃ ∥ P ∥
Lemma3/9/1 P = let open Iso in iso→eqv λ where
  .f → ∣_∣ ; .g → ∥-rec id ; .η _ → refl ; .ε _ → center

-- Principle of unique choice
Corollary3/9/2 : {A : 𝒰 i} {P : A → 𝒰 i} → ⦃ {x : A} → hlevel 1 (P x) ⦄ →
                 ((x : A) → ∥ P x ∥) → (x : A) → P x
Corollary3/9/2 {P = P} f = ∥-rec id ∘ f


module Syntax.Number where

import      Lvl
open import Logic.Propositional
open import Numeral.Natural
open import Type

record Numeral {ℓ} (T : Type{ℓ}) : Typeω where
  field
    {restriction-ℓ} : Lvl.Level
    restriction : ℕ → Type{restriction-ℓ}
    num : (n : ℕ) → ⦃ _ : restriction(n) ⦄ → T
open Numeral ⦃ ... ⦄ public using (num)
{-# BUILTIN FROMNAT num #-}

InfiniteNumeral = Numeral
module InfiniteNumeral {ℓ} {T : Type{ℓ}} where
  intro : (ℕ → T) → InfiniteNumeral(T)
  Numeral.restriction-ℓ (intro(_))         = Lvl.𝟎
  Numeral.restriction   (intro(_)) _       = ⊤
  Numeral.num           (intro(f)) n ⦃ _ ⦄ = f(n)

-- record InfiniteNumeral {ℓ} (T : Type{ℓ}) : Type{ℓ} where
-- record InfiniteNumeral {ℓ} (T : Type{ℓ}) : Type{ℓ} where
--   field
--     num : ℕ → T

-- instance
--   Numeral-from-InfiniteNumeral : ∀{ℓ}{T} → ⦃ _ : InfiniteNumeral{ℓ}(T) ⦄ → Numeral{ℓ}(T)
--   Numeral.restriction-ℓ ( Numeral-from-InfiniteNumeral ) = Lvl.𝟎
--   Numeral.restriction ( Numeral-from-InfiniteNumeral ) (_) = ⊤
--   num ⦃ Numeral-from-InfiniteNumeral ⦃ infNum ⦄ ⦄ (n) ⦃ _ ⦄ = InfiniteNumeral.num(infNum) (n)

instance
  ℕ-InfiniteNumeral : InfiniteNumeral (ℕ)
  ℕ-InfiniteNumeral = InfiniteNumeral.intro(id) where
    id : ℕ → ℕ
    id x = x

instance
  Level-InfiniteNumeral : InfiniteNumeral (Lvl.Level)
  Level-InfiniteNumeral = InfiniteNumeral.intro(f) where
    f : ℕ → Lvl.Level
    f(ℕ.𝟎)    = Lvl.𝟎
    f(ℕ.𝐒(n)) = Lvl.𝐒(f(n))

record NegativeNumeral {ℓ} (T : Type{ℓ}) : Typeω where
  field
    {restriction-ℓ} : Lvl.Level
    restriction : ℕ → Type{restriction-ℓ}
    num : (n : ℕ) → ⦃ _ : restriction(n) ⦄ → T
open NegativeNumeral ⦃ ... ⦄ public using () renaming (num to -num)
{-# BUILTIN FROMNEG -num #-}

InfiniteNegativeNumeral = NegativeNumeral
module InfiniteNegativeNumeral {ℓ} {T : Type{ℓ}} where
  intro : (ℕ → T) → InfiniteNegativeNumeral(T)
  NegativeNumeral.restriction-ℓ (intro(_))         = Lvl.𝟎
  NegativeNumeral.restriction   (intro(_)) _       = ⊤
  NegativeNumeral.num           (intro(f)) n ⦃ _ ⦄ = f(n)

-- record InfiniteNegativeNumeral {ℓ} (T : Type{ℓ}) : Type{ℓ} where
--   field
--     num : ℕ → T
-- open InfiniteNegativeNumeral ⦃ ... ⦄ public

-- instance
--   NegativeNumeral-from-InfiniteNegativeNumeral : ∀{ℓ}{T} → ⦃ _ : InfiniteNegativeNumeral{ℓ}(T) ⦄ → NegativeNumeral{ℓ}(T)
--   NegativeNumeral.restriction-ℓ ( NegativeNumeral-from-InfiniteNegativeNumeral ) = Lvl.𝟎
--   NegativeNumeral.restriction ( NegativeNumeral-from-InfiniteNegativeNumeral ) (_) = ⊤
--   -num ⦃ NegativeNumeral-from-InfiniteNegativeNumeral ⦃ infNegNum ⦄ ⦄ (n) ⦃ _ ⦄ = InfiniteNegativeNumeral.num(infNegNum) (n)


module Formalization.LambdaCalculus.SyntaxTransformation where

open import Formalization.LambdaCalculus
open import Lang.Instance
open import Numeral.Natural
open import Numeral.Finite
open import Numeral.Finite.Bound
open import Numeral.Natural.Relation.Order
open import Numeral.Natural.Relation.Order.Proofs
open import Relator.Equals

private variable d d₁ d₂ : ℕ
private variable x y : Term(d)

-- Increase the depth level of the given term by something.
-- Example: `depth-[≤](Var(2) : Term(5)) = Var(2) : Term(50)`
depth-[≤] : ⦃ _ : (d₁ ≤ d₂) ⦄ → Term(d₁) → Term(d₂)
depth-[≤] (Apply t1 t2) = Apply(depth-[≤] t1) (depth-[≤] t2)
depth-[≤] (Abstract t)  = Abstract(depth-[≤] t)
depth-[≤] (Var x)       = Var(bound-[≤] infer x)

-- Increment the depth level of the given term by 1.
-- Example: `depth-𝐒(Var(2) : Term(5)) = Var(2) : Term(6)`
depth-𝐒 : Term(d) → Term(𝐒(d))
depth-𝐒 = depth-[≤]
-- depth-𝐒 (Apply(f)(x))       = Apply (depth-𝐒(f)) (depth-𝐒(x))
-- depth-𝐒 (Abstract(body))    = Abstract(depth-𝐒(body))
-- depth-𝐒 (Var(n))            = Var(bound-𝐒 (n))

Apply₊ : ⦃ _ : (d₁ ≤ d₂) ⦄ → Term(d₂) → Term(d₁) → Term(d₂)
Apply₊ {d₁}{d₂} f(x) = Apply f(depth-[≤] {d₁}{d₂} (x))

{-
-- Increase all variables of the given term
var-[≤] : ∀{d₁ d₂} → ⦃ _ : (d₁ ≤ d₂) ⦄ → Term(d₁) → Term(d₂)
var-[≤] (Apply t1 t2) = Apply(depth-[≤] t1) (depth-[≤] t2)
var-[≤] (Abstract t)  = Abstract(depth-[≤] t)
var-[≤] (Var x) = Var({!x + (d₂ − d₁)!}) where
  open import Numeral.Natural.TotalOper
-}

-- Increment all variables of the given term.
-- Example: `var-𝐒(Var(2) : Term(5)) = Var(3) : Term(6)`
-- Examples:
--   term : Term(1)
--   term = (1 ↦ (2 ↦ 2 ← 2) ← 0 ← 1 ← 0)
--
--   Then:
--   term               = 1 ↦ (2 ↦ 2 ← 2) ← 0 ← 1 ← 0
--   var-𝐒(term)        = 2 ↦ (3 ↦ 3 ← 3) ← 1 ← 2 ← 1
--   var-𝐒(var-𝐒(term)) = 3 ↦ (4 ↦ 4 ← 4) ← 2 ← 3 ← 2
var-𝐒 : Term(d) → Term(𝐒(d))
var-𝐒 (Apply(f)(x))       = Apply (var-𝐒(f)) (var-𝐒(x))
var-𝐒 (Abstract{d}(body)) = Abstract{𝐒(d)} (var-𝐒(body))
var-𝐒 (Var{𝐒(d)}(n))      = Var{𝐒(𝐒(d))} (𝐒(n))

-- Substitutes the most recent free variable with a term in a term, while also decrementing them.
-- `substitute val term` is the term where all occurences in `term` of the outer-most variable is replaced with the term `val`.
-- Examples:
--   substituteOuterVar x (Var(0) : Term(1)) = x
--   substituteOuterVar x ((Apply (Var(1)) (Var(0))) : Term(2)) = Apply (Var(0)) x
--   substituteOuterVar (𝜆 0 0) ((𝜆 1 1) ← 0) = ((𝜆 0 0) ← (𝜆 0 0))
--   substituteOuterVar (𝜆 0 0) ((𝜆 1 1 ← 0) ← 0) = (((𝜆 0 0) ← (𝜆 0 0)) ← (𝜆 0 0))
substituteVar0 : Term(d) → Term(𝐒(d)) → Term(d)
substituteVar0 val (Apply(f)(x))    = Apply (substituteVar0 val f) (substituteVar0 val x)
substituteVar0 val (Abstract(body)) = Abstract (substituteVar0 (var-𝐒 val) body)
substituteVar0 val (Var(𝟎))         = val
substituteVar0 val (Var(𝐒(v)))      = Var v

{-
substituteMap : (𝕟(d₁) → Term(d₂)) → Term(d₁) → Term(d₂)
substituteMap F (Apply(f)(x))    = Apply (substituteMap F (f)) (substituteMap F (x))
substituteMap F (Var(v))         = F(v)
substituteMap F (Abstract(body)) = Abstract (substituteMap F (body)) -- TODO: Probably incorrect
-}

-- Substituting the outer variable of `var-𝐒 x` yields `x`.
-- This is useful because `substituteVar0` uses `var-𝐒` in its definition.
substituteVar0-var-𝐒 : (substituteVar0 y (var-𝐒 x) ≡ x)
substituteVar0-var-𝐒 {d}{y}{Apply f x}  rewrite substituteVar0-var-𝐒 {d}{y}{f} rewrite substituteVar0-var-𝐒 {d}{y}{x} = [≡]-intro
substituteVar0-var-𝐒 {d}{y}{Abstract x} rewrite substituteVar0-var-𝐒 {𝐒 d}{var-𝐒 y}{x} = [≡]-intro
substituteVar0-var-𝐒 {_}{_}{Var 𝟎}      = [≡]-intro
substituteVar0-var-𝐒 {_}{_}{Var(𝐒 _)}   = [≡]-intro
{-# REWRITE substituteVar0-var-𝐒 #-}


open import Oscar.Class.Congruity
open import Oscar.Data.Proposequality

module Oscar.Class.Congruity.Proposextensequality where

instance

  𝓒̇ongruityProposextensequality : ∀ {a b} → 𝓒̇ongruity a b Proposextensequality
  𝓒̇ongruity.ċongruity 𝓒̇ongruityProposextensequality _ f≡̇g x rewrite f≡̇g x = ∅


------------------------------------------------------------------------------
-- Arithmetic properties (added for the Collatz function example)
------------------------------------------------------------------------------

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

module FOTC.Program.Collatz.Data.Nat.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
  using ( x≤x
        ; 2*SSx≥2
        )
open import FOTC.Data.Nat.PropertiesATP
  using ( *-N
        ; *-rightZero
        ; *-rightIdentity
        ; x∸x≡0
        ; +-rightIdentity
        ; +-comm
        ; +-N
        ; xy≡0→x≡0∨y≡0
        ; Sx≢x
        ; xy≡1→x≡1
        ; 0∸x
        ; S∸S
        )
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Program.Collatz.Data.Nat

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

^-N : ∀ {m n} → N m → N n → N (m ^ n)
^-N {m} Nm nzero = prf
  where postulate prf : N (m ^ zero)
        {-# ATP prove prf #-}
^-N {m} Nm (nsucc {n} Nn) = prf (^-N Nm Nn)
  where postulate prf : N (m ^ n) → N (m ^ succ₁ n)
        {-# ATP prove prf *-N #-}

div-2x-2≡x : ∀ {n} → N n → div (2' * n) 2' ≡ n
div-2x-2≡x nzero = prf
  where postulate prf : div (2' * zero) 2' ≡ zero
        {-# ATP prove prf *-rightZero #-}
div-2x-2≡x (nsucc nzero) = prf
  where postulate prf : div (2' * (succ₁ zero)) 2' ≡ succ₁ zero
        {-# ATP prove prf *-rightIdentity x≤x x∸x≡0 #-}
div-2x-2≡x (nsucc (nsucc {n} Nn)) = prf (div-2x-2≡x (nsucc Nn))
  where postulate prf : div (2' * succ₁ n) 2' ≡ succ₁ n →
                        div (2' * (succ₁ (succ₁ n))) 2' ≡ succ₁ (succ₁ n)
        {-# ATP prove prf 2*SSx≥2 +-rightIdentity +-comm +-N #-}

postulate div-2^[x+1]-2≡2^x : ∀ {n} → N n → div (2' ^ succ₁ n) 2' ≡ 2' ^ n
{-# ATP prove div-2^[x+1]-2≡2^x ^-N div-2x-2≡x #-}

+∸2 : ∀ {n} → N n → n ≢ zero → n ≢ 1' → n ≡ succ₁ (succ₁ (n ∸ 2'))
+∸2 nzero                  n≢0 n≢1 = ⊥-elim (n≢0 refl)
+∸2 (nsucc nzero)          n≢0 n≢1 = ⊥-elim (n≢1 refl)
+∸2 (nsucc (nsucc {n} Nn)) n≢0 n≢1 = prf
  where
  -- TODO (06 December 2012). We do not use the ATPs because we do not
  -- how to erase a term.
  --
  -- See the interactive proof.
  postulate prf : succ₁ (succ₁ n) ≡ succ₁ (succ₁ (succ₁ (succ₁ n) ∸ 2'))
  -- {-# ATP prove prf S∸S #-}

2^x≢0 : ∀ {n} → N n → 2' ^ n ≢ zero
2^x≢0 nzero          h = ⊥-elim (0≢S (trans (sym h) (^-0 2')))
2^x≢0 (nsucc {n} Nn) h = prf (2^x≢0 Nn)
  where postulate prf : 2' ^ n ≢ zero → ⊥
        {-# ATP prove prf xy≡0→x≡0∨y≡0 ^-N #-}

postulate 2^[x+1]≢1 : ∀ {n} → N n → 2' ^ succ₁ n ≢ 1'
{-# ATP prove 2^[x+1]≢1 Sx≢x xy≡1→x≡1 ^-N #-}

Sx-Even→x-Odd : ∀ {n} → N n → Even (succ₁ n) → Odd n
Sx-Even→x-Odd nzero  h = ⊥-elim prf
  where postulate prf : ⊥
        {-# ATP prove prf #-}
Sx-Even→x-Odd (nsucc {n} Nn) h = prf
  where postulate prf : odd (succ₁ n) ≡ true
        {-# ATP prove prf #-}

Sx-Odd→x-Even : ∀ {n} → N n → Odd (succ₁ n) → Even n
Sx-Odd→x-Even nzero          _ = even-0
Sx-Odd→x-Even (nsucc {n} Nn) h = trans (sym (odd-S (succ₁ n))) h

postulate 2-Even : Even 2'
{-# ATP prove 2-Even #-}

∸-Even : ∀ {m n} → N m → N n → Even m → Even n → Even (m ∸ n)
∸-Odd : ∀ {m n} → N m → N n → Odd m → Odd n → Even (m ∸ n)

∸-Even {m} Nm nzero                      h₁ _  = subst Even (sym (∸-x0 m)) h₁
∸-Even     nzero          (nsucc {n} Nn) h₁ _  = subst Even (sym (0∸x (nsucc Nn))) h₁
∸-Even     (nsucc {m} Nm) (nsucc {n} Nn) h₁ h₂ = prf
  where postulate prf : Even (succ₁ m ∸ succ₁ n)
        {-# ATP prove prf ∸-Odd Sx-Even→x-Odd S∸S #-}

∸-Odd nzero          Nn             h₁ _  = ⊥-elim (t≢f (trans (sym h₁) odd-0))
∸-Odd (nsucc Nm)     nzero          _  h₂ = ⊥-elim (t≢f (trans (sym h₂) odd-0))
∸-Odd (nsucc {m} Nm) (nsucc {n} Nn) h₁ h₂ = prf
  where postulate prf : Even (succ₁ m ∸ succ₁ n)
        {-# ATP prove prf ∸-Even Sx-Odd→x-Even S∸S #-}

x-Even→SSx-Even : ∀ {n} → N n → Even n → Even (succ₁ (succ₁ n))
x-Even→SSx-Even nzero h = prf
  where postulate prf : Even (succ₁ (succ₁ zero))
        {-# ATP prove prf #-}

x-Even→SSx-Even (nsucc {n} Nn) h = prf
  where postulate prf : Even (succ₁ (succ₁ (succ₁ n)))
        {-# ATP prove prf #-}

x+x-Even : ∀ {n} → N n → Even (n + n)
x+x-Even nzero  = prf
  where postulate prf : even (zero + zero) ≡ true
        {-# ATP prove prf #-}
x+x-Even (nsucc {n} Nn) = prf (x+x-Even Nn)
  where postulate prf : Even (n + n) → Even (succ₁ n + succ₁ n)
        {-# ATP prove prf x-Even→SSx-Even +-N +-comm #-}

2x-Even : ∀ {n} → N n → Even (2' * n)
2x-Even nzero = prf
  where postulate prf : Even (2' * zero)
        {-# ATP prove prf #-}
2x-Even (nsucc {n} Nn) = prf
  where
  postulate prf : Even (2' * succ₁ n)
  {-# ATP prove prf x-Even→SSx-Even x+x-Even +-N +-comm +-rightIdentity #-}

postulate 2^[x+1]-Even : ∀ {n} → N n → Even (2' ^ succ₁ n)
{-# ATP prove 2^[x+1]-Even ^-N 2x-Even #-}


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

module Testers where

open import Prelude
open import Data.List using (List; map; _⋯_)
open import Data.List.Sugar using (liftA2)

testIso : (fns : A ↔ B) → List A → Type _
testIso (to iff fro) xs = xs ≡ map (fro ∘ to) xs

testIsoℕ : (fns : ℕ ↔ A) → ℕ → Type _
testIsoℕ fns n = testIso fns (0 ⋯ n)

testUnary : (A → B) → (A → A) → (B → B) → List A → Type _
testUnary to f g xs =
  map (to ∘ f) xs ≡ map (g ∘ to) xs

testBinary : (A → B) → (A → A → A) → (B → B → B) → List A → Type _
testBinary to f g xs =
  liftA2 (λ x y → to (f x y)) xs xs ≡ liftA2 (λ x y → g (to x) (to y)) xs xs

testUnaryℕ : (ℕ → A) → (ℕ → ℕ) → (A → A) → ℕ → Type _
testUnaryℕ to f g n = testUnary to f g (0 ⋯ n)

testBinaryℕ : (ℕ → A) → (ℕ → ℕ → ℕ) → (A → A → A) → ℕ → Type _
testBinaryℕ to f g n = testBinary to f g (0 ⋯ n)