------------------------------------------------------------------------
-- The Agda standard library
--
-- Finding the maximum/minimum values in a list
------------------------------------------------------------------------

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

open import Relation.Binary using (TotalOrder; Setoid)

module Data.List.Extrema
  {b ℓ₁ ℓ₂} (totalOrder : TotalOrder b ℓ₁ ℓ₂) where

import Algebra.Construct.NaturalChoice.Min as Min
import Algebra.Construct.NaturalChoice.Max as Max
open import Data.List.Base using (List; foldr)
open import Data.List.Relation.Unary.Any as Any using (Any; here; there)
open import Data.List.Relation.Unary.All using (All; []; _∷_; lookup; map; tabulate)
open import Data.List.Membership.Propositional using (_∈_; lose)
open import Data.List.Membership.Propositional.Properties
  using (foldr-selective)
open import Data.List.Relation.Binary.Subset.Propositional using (_⊆_)
open import Data.List.Properties
open import Data.Sum.Base using (_⊎_; inj₁; inj₂)
open import Function using (id; flip; _on_)
open import Level using (Level)
open import Relation.Unary using (Pred)
import Relation.Binary.Construct.NonStrictToStrict as NonStrictToStrict
open import Relation.Binary.PropositionalEquality
  using (_≡_; sym; subst) renaming (refl to ≡-refl)
import Relation.Binary.Construct.On as On

------------------------------------------------------------------------------
-- Setup

open TotalOrder totalOrder renaming (Carrier to B)
open NonStrictToStrict _≈_ _≤_ using (_<_)
open import Data.List.Extrema.Core totalOrder
  renaming (⊓ᴸ to ⊓-lift; ⊔ᴸ to ⊔-lift)

private
  variable
    a p : Level
    A : Set a

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

argmin : (A → B) → A → List A → A
argmin f = foldr (⊓-lift f)

argmax : (A → B) → A → List A → A
argmax f = foldr (⊔-lift f)

min : B → List B → B
min = argmin id

max : B → List B → B
max = argmax id

------------------------------------------------------------------------------
-- Properties of argmin

module _ {f : A → B} where

  f[argmin]≤v⁺ : ∀ {v} ⊤ xs → (f ⊤ ≤ v) ⊎ (Any (λ x → f x ≤ v) xs) →
                f (argmin f ⊤ xs) ≤ v
  f[argmin]≤v⁺ = foldr-preservesᵒ (⊓ᴸ-presᵒ-≤v f)

  f[argmin]<v⁺ : ∀ {v} ⊤ xs → (f ⊤ < v) ⊎ (Any (λ x → f x < v) xs) →
                f (argmin f ⊤ xs) < v
  f[argmin]<v⁺ = foldr-preservesᵒ (⊓ᴸ-presᵒ-<v f)

  v≤f[argmin]⁺ : ∀ {v ⊤ xs} → v ≤ f ⊤ → All (λ x → v ≤ f x) xs →
                v ≤ f (argmin f ⊤ xs)
  v≤f[argmin]⁺ = foldr-preservesᵇ (⊓ᴸ-presᵇ-v≤ f)

  v<f[argmin]⁺ : ∀ {v ⊤ xs} → v < f ⊤ → All (λ x → v < f x) xs →
                v < f (argmin f ⊤ xs)
  v<f[argmin]⁺ = foldr-preservesᵇ (⊓ᴸ-presᵇ-v< f)

  f[argmin]≤f[⊤] : ∀ ⊤ xs → f (argmin f ⊤ xs) ≤ f ⊤
  f[argmin]≤f[⊤] ⊤ xs = f[argmin]≤v⁺ ⊤ xs (inj₁ refl)

  f[argmin]≤f[xs] : ∀ ⊤ xs → All (λ x → f (argmin f ⊤ xs) ≤ f x) xs
  f[argmin]≤f[xs] ⊤ xs = foldr-forcesᵇ (⊓ᴸ-forcesᵇ-v≤ f) ⊤ xs refl

  f[argmin]≈f[v]⁺ : ∀ {v ⊤ xs} → v ∈ xs → All (λ x → f v ≤ f x) xs → f v ≤ f ⊤ →
                    f (argmin f ⊤ xs) ≈ f v
  f[argmin]≈f[v]⁺ v∈xs fv≤fxs fv≤f⊤ = antisym
    (f[argmin]≤v⁺ _ _ (inj₂ (lose v∈xs refl)))
    (v≤f[argmin]⁺ fv≤f⊤ fv≤fxs)

argmin[xs]≤argmin[ys]⁺ : ∀ {f g : A → B} ⊤₁ {⊤₂} xs {ys : List A} →
                        (f ⊤₁ ≤ g ⊤₂) ⊎ Any (λ x → f x ≤ g ⊤₂) xs →
                        All (λ y → (f ⊤₁ ≤ g y) ⊎ Any (λ x → f x ≤ g y) xs) ys →
                        f (argmin f ⊤₁ xs) ≤ g (argmin g ⊤₂ ys)
argmin[xs]≤argmin[ys]⁺ ⊤₁ xs xs≤⊤₂ xs≤ys =
  v≤f[argmin]⁺ (f[argmin]≤v⁺ ⊤₁ _ xs≤⊤₂) (map (f[argmin]≤v⁺ ⊤₁ xs) xs≤ys)

argmin[xs]<argmin[ys]⁺ : ∀ {f g : A → B} ⊤₁ {⊤₂} xs {ys : List A} →
                        (f ⊤₁ < g ⊤₂) ⊎ Any (λ x → f x < g ⊤₂) xs →
                        All (λ y → (f ⊤₁ < g y) ⊎ Any (λ x → f x < g y) xs) ys →
                        f (argmin f ⊤₁ xs) < g (argmin g ⊤₂ ys)
argmin[xs]<argmin[ys]⁺ ⊤₁ xs xs<⊤₂ xs<ys =
  v<f[argmin]⁺ (f[argmin]<v⁺ ⊤₁ _ xs<⊤₂) (map (f[argmin]<v⁺ ⊤₁ xs) xs<ys)

argmin-sel : ∀ (f : A → B) ⊤ xs → (argmin f ⊤ xs ≡ ⊤) ⊎ (argmin f ⊤ xs ∈ xs)
argmin-sel f = foldr-selective (⊓ᴸ-sel f)

argmin-all : ∀ (f : A → B) {⊤ xs} {P : Pred A p} →
             P ⊤ → All P xs → P (argmin f ⊤ xs)
argmin-all f {⊤} {xs} {P = P}  p⊤ pxs with argmin-sel f ⊤ xs
... | inj₁ argmin≡⊤  = subst P (sym argmin≡⊤) p⊤
... | inj₂ argmin∈xs = lookup pxs argmin∈xs

------------------------------------------------------------------------------
-- Properties of argmax

module _ {f : A → B} where

  v≤f[argmax]⁺ : ∀ {v} ⊥ xs → (v ≤ f ⊥) ⊎ (Any (λ x → v ≤ f x) xs) →
                v ≤ f (argmax f ⊥ xs)
  v≤f[argmax]⁺ = foldr-preservesᵒ (⊔ᴸ-presᵒ-v≤ f)

  v<f[argmax]⁺ : ∀ {v} ⊥ xs → (v < f ⊥) ⊎ (Any (λ x → v < f x) xs) →
                v < f (argmax f ⊥ xs)
  v<f[argmax]⁺ = foldr-preservesᵒ (⊔ᴸ-presᵒ-v< f)

  f[argmax]≤v⁺ : ∀ {v ⊥ xs} → f ⊥ ≤ v → All (λ x → f x ≤ v) xs →
                f (argmax f ⊥ xs) ≤ v
  f[argmax]≤v⁺ = foldr-preservesᵇ (⊔ᴸ-presᵇ-≤v f)

  f[argmax]<v⁺ : ∀ {v ⊥ xs} → f ⊥ < v → All (λ x → f x < v) xs →
                f (argmax f ⊥ xs) < v
  f[argmax]<v⁺ = foldr-preservesᵇ (⊔ᴸ-presᵇ-<v f)

  f[⊥]≤f[argmax] : ∀ ⊥ xs → f ⊥ ≤ f (argmax f ⊥ xs)
  f[⊥]≤f[argmax] ⊥ xs = v≤f[argmax]⁺ ⊥ xs (inj₁ refl)

  f[xs]≤f[argmax] : ∀ ⊥ xs → All (λ x → f x ≤ f (argmax f ⊥ xs)) xs
  f[xs]≤f[argmax] ⊥ xs = foldr-forcesᵇ (⊔ᴸ-forcesᵇ-≤v f) ⊥ xs refl

  f[argmax]≈f[v]⁺ : ∀ {v ⊥ xs} → v ∈ xs → All (λ x → f x ≤ f v) xs → f ⊥ ≤ f v →
                    f (argmax f ⊥ xs) ≈ f v
  f[argmax]≈f[v]⁺ v∈xs fxs≤fv f⊥≤fv = antisym
    (f[argmax]≤v⁺ f⊥≤fv fxs≤fv)
    (v≤f[argmax]⁺ _ _ (inj₂ (lose v∈xs refl)))

argmax[xs]≤argmax[ys]⁺ : ∀ {f g : A → B} {⊥₁} ⊥₂ {xs : List A} ys →
                         (f ⊥₁ ≤ g ⊥₂) ⊎ Any (λ y → f ⊥₁ ≤ g y) ys →
                         All (λ x → (f x ≤ g ⊥₂) ⊎ Any (λ y → f x ≤ g y) ys) xs →
                         f (argmax f ⊥₁ xs) ≤ g (argmax g ⊥₂ ys)
argmax[xs]≤argmax[ys]⁺ ⊥₂ ys ⊥₁≤ys xs≤ys =
  f[argmax]≤v⁺ (v≤f[argmax]⁺ ⊥₂ _ ⊥₁≤ys) (map (v≤f[argmax]⁺ ⊥₂ ys) xs≤ys)

argmax[xs]<argmax[ys]⁺ : ∀ {f g : A → B} {⊥₁} ⊥₂ {xs : List A} ys →
                         (f ⊥₁ < g ⊥₂) ⊎ Any (λ y → f ⊥₁ < g y) ys →
                         All (λ x → (f x < g ⊥₂) ⊎ Any (λ y → f x < g y) ys) xs →
                         f (argmax f ⊥₁ xs) < g (argmax g ⊥₂ ys)
argmax[xs]<argmax[ys]⁺ ⊥₂ ys ⊥₁<ys xs<ys =
  f[argmax]<v⁺ (v<f[argmax]⁺ ⊥₂ _ ⊥₁<ys) (map (v<f[argmax]⁺ ⊥₂ ys) xs<ys)

argmax-sel : ∀ (f : A → B) ⊥ xs → (argmax f ⊥ xs ≡ ⊥) ⊎ (argmax f ⊥ xs ∈ xs)
argmax-sel f = foldr-selective (⊔ᴸ-sel f)

argmax-all : ∀ (f : A → B) {P : Pred A p} {⊥ xs} →
             P ⊥ → All P xs → P (argmax f ⊥ xs)
argmax-all f {P = P} {⊥} {xs} p⊥ pxs with argmax-sel f ⊥ xs
... | inj₁ argmax≡⊥  = subst P (sym argmax≡⊥) p⊥
... | inj₂ argmax∈xs = lookup pxs argmax∈xs

------------------------------------------------------------------------------
-- Properties of min

min≤v⁺ : ∀ {v} ⊤ xs → ⊤ ≤ v ⊎ Any (_≤ v) xs → min ⊤ xs ≤ v
min≤v⁺ = f[argmin]≤v⁺

min<v⁺ : ∀ {v} ⊤ xs → ⊤ < v ⊎ Any (_< v) xs → min ⊤ xs < v
min<v⁺ = f[argmin]<v⁺

v≤min⁺ : ∀ {v ⊤ xs} → v ≤ ⊤ → All (v ≤_) xs → v ≤ min ⊤ xs
v≤min⁺ = v≤f[argmin]⁺

v<min⁺ : ∀ {v ⊤ xs} → v < ⊤ → All (v <_) xs → v < min ⊤ xs
v<min⁺ = v<f[argmin]⁺

min≤⊤ : ∀ ⊤ xs → min ⊤ xs ≤ ⊤
min≤⊤ = f[argmin]≤f[⊤]

min≤xs : ∀ ⊥ xs → All (min ⊥ xs ≤_) xs
min≤xs = f[argmin]≤f[xs]

min≈v⁺ : ∀ {v ⊤ xs} → v ∈ xs → All (v ≤_) xs → v ≤ ⊤ → min ⊤ xs ≈ v
min≈v⁺ = f[argmin]≈f[v]⁺

min[xs]≤min[ys]⁺ : ∀ ⊤₁ {⊤₂} xs {ys} → (⊤₁ ≤ ⊤₂) ⊎ Any (_≤ ⊤₂) xs →
                   All (λ y → (⊤₁ ≤ y) ⊎ Any (λ x → x ≤ y) xs) ys →
                   min ⊤₁ xs ≤ min ⊤₂ ys
min[xs]≤min[ys]⁺ = argmin[xs]≤argmin[ys]⁺

min[xs]<min[ys]⁺ : ∀ ⊤₁ {⊤₂} xs {ys} → (⊤₁ < ⊤₂) ⊎ Any (_< ⊤₂) xs →
                   All (λ y → (⊤₁ < y) ⊎ Any (λ x → x < y) xs) ys →
                   min ⊤₁ xs < min ⊤₂ ys
min[xs]<min[ys]⁺ = argmin[xs]<argmin[ys]⁺

------------------------------------------------------------------------------
-- Properties of max

max≤v⁺ : ∀ {v ⊥ xs} → ⊥ ≤ v → All (_≤ v) xs → max ⊥ xs ≤ v
max≤v⁺ = f[argmax]≤v⁺

max<v⁺ : ∀ {v ⊥ xs} → ⊥ < v → All (_< v) xs → max ⊥ xs < v
max<v⁺ = f[argmax]<v⁺

v≤max⁺ : ∀ {v} ⊥ xs → v ≤ ⊥ ⊎ Any (v ≤_) xs → v ≤ max ⊥ xs
v≤max⁺ = v≤f[argmax]⁺

v<max⁺ : ∀ {v} ⊥ xs → v < ⊥ ⊎ Any (v <_) xs → v < max ⊥ xs
v<max⁺ = v<f[argmax]⁺

⊥≤max : ∀ ⊥ xs → ⊥ ≤ max ⊥ xs
⊥≤max = f[⊥]≤f[argmax]

xs≤max : ∀ ⊥ xs → All (_≤ max ⊥ xs) xs
xs≤max = f[xs]≤f[argmax]

max≈v⁺ : ∀ {v ⊤ xs} → v ∈ xs → All (_≤ v) xs → ⊤ ≤ v → max ⊤ xs ≈ v
max≈v⁺ = f[argmax]≈f[v]⁺

max[xs]≤max[ys]⁺ : ∀ {⊥₁} ⊥₂ {xs} ys → ⊥₁ ≤ ⊥₂ ⊎ Any (⊥₁ ≤_) ys →
                   All (λ x → x ≤ ⊥₂ ⊎ Any (x ≤_) ys) xs →
                   max ⊥₁ xs ≤ max ⊥₂ ys
max[xs]≤max[ys]⁺ = argmax[xs]≤argmax[ys]⁺

max[xs]<max[ys]⁺ : ∀ {⊥₁} ⊥₂ {xs} ys → ⊥₁ < ⊥₂ ⊎ Any (⊥₁ <_) ys →
                   All (λ x → x < ⊥₂ ⊎ Any (x <_) ys) xs →
                   max ⊥₁ xs < max ⊥₂ ys
max[xs]<max[ys]⁺ = argmax[xs]<argmax[ys]⁺


{- Type class for comonads. -}
module CategoryTheory.Comonad where

open import CategoryTheory.Categories
open import CategoryTheory.Functor
open import CategoryTheory.NatTrans

-- A comonad on a category
record Comonad {n} (ℂ : Category n) : Set (lsuc n) where
    open Category ℂ
    field
        -- Underlying endofunctor
        W : Endofunctor ℂ
    open Functor W

    field
        -- || Definitions
        -- Counit / extract
        ε : W ⟹ I
        -- Comultiplication / duplicate
        δ : W ⟹ (W ²)

    module ε = _⟹_ ε
    module δ = _⟹_ δ
    field
        -- || Laws
        -- Duplication is cancelled by extraction on both sides (counit)
        ε-unit1 : ∀ {A : obj} -> (ε.at (omap A)) ∘ (δ.at A) ≈ id
        ε-unit2 : ∀ {A : obj} -> (fmap (ε.at A)) ∘ (δ.at A) ≈ id

        -- Duplication can be performed on both sides (coassociativity)
        δ-assoc : ∀ {A : obj} -> (δ.at (omap A)) ∘ (δ.at A)
                               ≈ (fmap (δ.at A)) ∘ (δ.at A)


------------------------------------------------------------------------------
-- Addition as a function constant
------------------------------------------------------------------------------

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

module FOTC.AddConstant where

------------------------------------------------------------------------------
-- We add 3 to the fixities of the Agda standard library 0.8.1 (see
-- Algebra.agda and Relation/Binary/Core.agda).
infixl 9 _·_
infix  7 _≡_

postulate
  D                      : Set
  _·_                    : D → D → D
  true false if          : D
  zero succ pred iszero  : D
  _≡_                    : D → D → Set

postulate
  if-true  : ∀ t {t'} → if · true  · t · t' ≡ t
  if-false : ∀ {t} t' → if · false · t · t' ≡ t'
  pred-0   : pred · zero ≡ zero
  pred-S   : ∀ n → pred · (succ · n) ≡ n
  iszero-0 : iszero · zero ≡ true
  iszero-S : ∀ n → iszero · (succ · n) ≡ false
{-# ATP axioms if-true if-false pred-0 pred-S iszero-0 iszero-S #-}

postulate
  +    : D
  +-eq : ∀ m n → + · m · n ≡
         if · (iszero · m) · n · (succ · (+ · (pred · m) · n))
{-# ATP axiom +-eq #-}

postulate
  +-0x : ∀ n → + · zero · n ≡ n
  +-Sx : ∀ m n → + · (succ · m) · n ≡ succ · (+ · m · n)
{-# ATP prove +-0x #-}
{-# ATP prove +-Sx #-}

-- $ cd fotc/notes/thesis
-- $ agda -i. -i ~/fot FOTC/AddConstant.agda
-- $ apia -i. -i ~/fot FOTC/AddConstant.agda
-- Proving the conjecture in /tmp/FOTC/AddConstant/37-43-0x.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture
-- Proving the conjecture in /tmp/FOTC/AddConstant/38-43-Sx.tptp ...
-- Vampire 0.6 (revision 903) proved the conjecture


------------------------------------------------------------------------------
-- Totality of predecessor function
------------------------------------------------------------------------------

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

module FOT.FOTC.Data.Nat.PredTotality where

open import FOTC.Base

data N : D → Set where
  nzero : N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Induction principle generated by Coq 8.4pl4 when we define the data
-- type N in Prop.
N-ind₁ : (A : D → Set) →
         A zero →
         (∀ {n} → N n → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₁ A A0 h nzero      = A0
N-ind₁ A A0 h (nsucc Nn) = h Nn (N-ind₁ A A0 h Nn)

-- The induction principle removing the hypothesis N n from the
-- inductive step.
N-ind₂ : (A : D → Set) →
         A zero →
         (∀ {n} → A n → A (succ₁ n)) →
         ∀ {n} → N n → A n
N-ind₂ A A0 h nzero      = A0
N-ind₂ A A0 h (nsucc Nn) = h (N-ind₂ A A0 h Nn)

-- Proof by pattern matching.
pred-N : ∀ {n} → N n → N (pred₁ n)
pred-N nzero          = subst N (sym pred-0) nzero
pred-N (nsucc {n} Nn) = subst N (sym (pred-S n)) Nn

-- Proof using N-ind₁.
pred-N₁ : ∀ {n} → N n → N (pred₁ n)
pred-N₁ = N-ind₁ A A0 is
  where
  A : D → Set
  A i = N (pred₁ i)

  A0 : A zero
  A0 = subst N (sym pred-0) nzero

  is : ∀ {i} → N i → A i → A (succ₁ i)
  is {i} Ni Ai = subst N (sym (pred-S i)) Ni

-- Proof using N-ind₂.
-- pred-N₂ : ∀ {n} → N n → N (pred₁ n)
-- pred-N₂ = N-ind₂ A A0 is
--   where
--   A : D → Set
--   A i = N (pred₁ i)

--   A0 : A zero
--   A0 = subst N (sym pred-0) nzero

--   is : ∀ {i} → A i → A (succ₁ i)
--   is {i} Ai = {!!}


{-# OPTIONS --experimental-irrelevance #-}
-- Andreas, 2011-04-15
-- {-# OPTIONS -v tc.data:20 #-}
module IrrelevantDataParameter where

postulate
  A : Set

data K .(a : A) : Set where
  c : K a

postulate
  a : A

data K' .(b : A) : Set where
  c : K' a
-- ok, since parameter irrelevant

-- 2011-09-09

postulate
  _×_ : ..(A B : Set) -> Set
  Lst : ..(A : Set) -> Set
  nl  : .(A : Set) -> Lst A
  cns : .(A : Set) -> A × Lst A -> Lst A
  -- cns' : .(A : Set) -> (a : A) -> (as : Lst A) -> Lst A -- not well-formed!


-- Minimal implicational logic, PHOAS approach, initial encoding

module STLC where

-- Types

infixr 0 _=>_

data Ty : Set where
  UNIT :             Ty
  _=>_ : Ty -> Ty -> Ty

-- Context

Cx : Set1
Cx = Ty -> Set

-- Terms

infixl 1 _$_

data Tm (tc : Cx) : Ty -> Set
  where
    var : forall {a}   ->  tc a
                       ----------
                       -> Tm tc a

    lam : forall {a b} ->  (tc a -> Tm tc b)
                       ---------------------
                         -> Tm tc (a => b)

    _$_ : forall {a b} -> Tm tc (a => b) -> Tm tc a
                       ----------------------------
                               -> Tm tc b

T : Ty -> Set1
T a = forall {tc} -> Tm tc a

-- Example theorems

I : forall {a} -> T (a => a)
I = lam \x ->
      var x

K : forall {a b} -> T (a => b => a)
K = lam \x ->
      lam \_ ->
        var x

S : forall {a b c} -> T ((a => b => c) => (a => b) => a => c)
S = lam \f ->
      lam \g ->
        lam \x ->
          (var f $ var x) $ (var g $ var x)

SKK : forall {a} -> T (a => a)
SKK {a = a} = S {b = a => a} $ K $ K


-- Andreas, 2012-02-13: polarity info must be correct

{-# OPTIONS --sized-types --show-implicit #-}
-- {-# OPTIONS -v tc.size.solve:20 -v tc.conv.size:20 #-}
-- {-# OPTIONS -v tc.polarity.set:10 -v tc.conv.term.shortcut:20 #-}
module WrongPolarity where

open import Common.Size

data ⊥ : Set where

data Sink (A : Set) : Set where
  sink : (A → ⊥) → Sink A

postulate
  dump : {A : Set} → A → Sink A

-- A sized type
data Nat : {size : Size} → Set where
  zero : {size : Size} → Nat {↑ size}
  suc  : {size : Size} → Nat {size} → Nat {↑ size}

dumpNat : {i : Size} → Nat {i} → Sink (Nat {i})
dumpNat zero        = dump zero
dumpNat (suc {i} n) = dumpNat {i} n
-- should fail!
-- i != ↑ i of type Size
-- when checking that the expression dumpNat n has type Sink Nat


------------------------------------------------------------------------
-- Some examples
------------------------------------------------------------------------

module Contractive.Examples where

open import Codata.Musical.Notation
open import Codata.Musical.Stream
open import Data.Nat
open import Data.Nat.Properties
import Data.Vec as Vec
open Vec using (_∷_; [])
open import Function
open import Contractive
import Contractive.Stream as S
open import StreamProg using (Ord; lt; eq; gt; merge)
open import Relation.Binary.PropositionalEquality
open ≡-Reasoning

open COFE (S.cofe 0)

fibF : ContractiveFun (S.cofe 0)
fibF = record
  { F             = F
  ; isContractive = isCon _ _ _
  }
  where
  F = λ xs → 0 ∷ ♯ (1 ∷ ♯ zipWith _+_ xs (tail xs))

  lemma₁ : ∀ _∙_ (xs ys : Stream ℕ) n →
           take n (zipWith _∙_ xs ys) ≡
           Vec.zipWith _∙_ (take n xs) (take n ys)
  lemma₁ _∙_ _        _        zero    = refl
  lemma₁ _∙_ (x ∷ xs) (y ∷ ys) (suc n) =
    cong (_∷_ (x ∙ y)) (lemma₁ _∙_ (♭ xs) (♭ ys) n)

  lemma₂ : ∀ (xs ys : Stream ℕ) n →
           Eq n xs ys → take n xs ≡ take n ys
  lemma₂ _        _         zero    _   = refl
  lemma₂ (x ∷ xs) ( y ∷ ys) (suc n) hyp
    with cong Vec.head hyp | take n (♭ xs) | lemma₂ (♭ xs) (♭ ys) n (cong Vec.tail hyp)
  lemma₂ (x ∷ xs) (.x ∷ ys) (suc n) hyp | refl | .(take n (♭ ys)) | refl = refl

  isCon : ∀ (xs ys : Stream ℕ) n →
          (∀ {m} → m <′ n → Eq m xs ys) →
          Eq n (F xs) (F ys)
  isCon _        _        zero    _   = refl
  isCon (x ∷ xs) (y ∷ ys) (suc n) hyp = cong (λ zs → 0 ∷ 1 ∷ zs) (begin
    take n (zipWith _+_ (x ∷ xs) (♭ xs))               ≡⟨ lemma₁ _+_ (x ∷ xs) (♭ xs) n ⟩
    Vec.zipWith _+_ (take n (x ∷ xs)) (take n (♭ xs))  ≡⟨ cong₂ (Vec.zipWith _+_)
                                                                (lemma₂ _ _ n (hyp ≤′-refl))
                                                                (cong Vec.tail (hyp ≤′-refl)) ⟩
    Vec.zipWith _+_ (take n (y ∷ ys)) (take n (♭ ys))  ≡⟨ sym $ lemma₁ _+_ (y ∷ ys) (♭ ys) n ⟩
    take n (zipWith _+_ (y ∷ ys) (♭ ys))               ∎)

fib : Stream ℕ
fib = ContractiveFun.fixpoint fibF

-- Note that I could not be bothered to finish the following
-- definition.

hammingF : ContractiveFun (S.cofe 0)
hammingF = record
  { F             = F
  ; isContractive = isCon _ _ _
  }
  where
  toOrd : ∀ {m n} → Ordering m n → Ord
  toOrd (less _ _)    = lt
  toOrd (equal _)     = eq
  toOrd (greater _ _) = gt

  cmp : ℕ → ℕ → Ord
  cmp m n = toOrd (compare m n)

  F = λ (xs : _) → 0 ∷ ♯ merge cmp (map (_*_ 2) xs) (map (_*_ 3) xs)

  postulate
    lemma : ∀ n → cmp (2 * suc n) (3 * suc n) ≡ lt

  isCon : ∀ (xs ys : Stream ℕ) n →
          (∀ {m} → m <′ n → Eq m xs ys) →
          Eq n (F xs) (F ys)
  isCon _        _         zero    _   = refl
  isCon (x ∷ xs) (y  ∷ ys) (suc n) hyp with cong Vec.head (hyp (s≤′s z≤′n))
  isCon (0 ∷ xs) (.0 ∷ ys) (suc n) hyp | refl =
    cong (λ zs → 0 ∷ 0 ∷ zs) (begin
      take n (merge cmp (map (_*_ 2) (♭ xs)) (map (_*_ 3) (♭ xs)))  ≡⟨ iCantBeBothered ⟩
      take n (merge cmp (map (_*_ 2) (♭ ys)) (map (_*_ 3) (♭ ys)))  ∎)
    where postulate iCantBeBothered : _
  isCon (suc x ∷ xs) (.(suc x) ∷ ys) (suc n) hyp | refl
    with cmp (2 * suc x) (3 * suc x) | lemma x
  isCon (suc x ∷ xs) (.(suc x) ∷ ys) (suc n) hyp | refl | .lt | refl =
    cong (λ zs → 0 ∷ 2 * suc x ∷ zs) (begin
      take n (merge cmp (map (_*_ 2) (♭ xs))
                        (map (_*_ 3) (suc x ∷ xs)))  ≡⟨ iCantBeBothered ⟩
      take n (merge cmp (map (_*_ 2) (♭ ys))
                        (map (_*_ 3) (suc x ∷ ys)))  ∎)
    where postulate iCantBeBothered : _

hamming : Stream ℕ
hamming = ContractiveFun.fixpoint hammingF


-- Andreas, 2014-04-12, Order of declaration mattered in the presence
-- of meta variables involving sizes
-- {-# OPTIONS -v tc.meta:10 -v tc.meta.assign:10 #-}

-- Error persists without option sized-types
{-# OPTIONS --sized-types #-}
module _ where

open import Common.Size
-- different error if we do not use the built-ins (Size vs Size<)

module Works where
  mutual

    data Colist' i : Set where
      inn  : (xs : Colist i) → Colist' i

    record Colist i : Set where
      coinductive
      field out : ∀ {j : Size< i} → Colist' j

module Fails where
  mutual

    record Colist i : Set where
      coinductive
      field out : ∀ {j : Size< i} → Colist' j

    data Colist' i : Set where
      inn  : (xs : Colist i) → Colist' i

-- Error: Issue1087.agda:21,45-46
-- Cannot instantiate the metavariable _20 to solution (Size< i) since
-- it contains the variable i which is not in scope of the
-- metavariable or irrelevant in the metavariable but relevant in the
-- solution
-- when checking that the expression j has type _20

-- Works now.


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

module PComp where

open import Data.Empty
open import Data.Sum
open import Data.Nat as Nat
open import Data.Nat.Properties.Simple
open import Data.Nat.Properties
open import Data.Product
open import Data.Bool renaming (Bool to 𝔹)
open import Data.Bool.Properties
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality

open import Relation.Binary
open DecTotalOrder ≤-decTotalOrder using ()
  renaming (refl to ≤-refl; trans to ≤-trans)

-- open import Size

-- record D {i : Size} (A : Set) : Set where
--   coinductive
--   field step : {j : Size< i} → A ⊎ D {j} A

-- open D public

-- μ' : ∀{i} → (ℕ → 𝔹) → ℕ → D {i} ℕ
-- μ' p n .step = if p n then inj₁ n else inj₂ (μ' p (suc n))

primRec : {X Y : Set} → (X → Y) → (ℕ → Y → X → Y) → ℕ → X → Y
primRec f g zero    x = f x
primRec f g (suc n) x = g n (primRec f g n x) x

record D (A : Set) : Set where
  coinductive
  field step : A ⊎ D A

open D public

μ' : (ℕ → 𝔹) → ℕ → D ℕ
c : (ℕ → 𝔹) → ℕ → 𝔹 → ℕ ⊎ (D ℕ)

μ' p n .step = c p n (p n)

c p n false = inj₂ (μ' p (1 + n))
c p n true  = inj₁ n

μ : (ℕ → 𝔹) → D ℕ
μ p = μ' p 0

isEven : ℕ → 𝔹
isEven zero = true
isEven (suc zero) = false
isEven (suc (suc n)) = isEven n

data _↓_ {A : Set} (d : D A) (a : A) : Set where
  now    :                d .step ≡ inj₁ a            → d ↓ a
  later  : {d' : D A} →  d .step ≡ inj₂ d' → d' ↓ a  → d ↓ a

foo : μ' isEven 3 ↓ 4
foo = later (cong inj₂ refl) (now refl)

μ-finds-tt : ∀{p : ℕ → 𝔹} {m n : ℕ} → μ' p m ↓ n → p n ≡ true
μ-finds-tt {p} {m} (now q)        with p m  | inspect p m
μ-finds-tt {p} {m} (now ())        | false  | _
μ-finds-tt {p} {m} (now refl)      | true   | [ eq ]       = eq
μ-finds-tt {p} {m} (later q t)    with p m
μ-finds-tt {p} {m} (later refl t)  | false = μ-finds-tt t
μ-finds-tt {p} {m} (later () t)    | true

-- | Compute the number of steps taken to obtain p n = tt.
μ-dist : ∀{p : ℕ → 𝔹} {m n : ℕ} → μ' p m ↓ n → ∃ λ k → n ≡ m + k
μ-dist {p} {m} (now q)        with p m
μ-dist {p} {m} (now ())        | false
μ-dist {p} {m} (now refl)      | true = (0 , sym (+-identityʳ m))
μ-dist {p} {m} (later q t)    with p m
μ-dist {p} {m} (later refl t)  | false =
  let (k , e) = μ-dist t
  in (1 + k , trans e (sym (+-suc m k)))
μ-dist {p} {m} (later () t)    | true

empty-interval : ∀ {m k} → m ≤ k → k < m → ⊥
empty-interval z≤n      ()
empty-interval (s≤s p)  (s≤s q) = empty-interval p q

suc≤⇒≤ : ∀ m n → suc m ≤ n → m ≤ n
suc≤⇒≤ m         zero            ()
suc≤⇒≤ .0        (suc n)         (s≤s z≤n)      = z≤n
suc≤⇒≤ .(suc _)  (suc .(suc _))  (s≤s (s≤s p))  = s≤s (suc≤⇒≤ _ _ (s≤s p))

-- | The proof proceeds by induction on the termination proof t : μ' p m ↓ n.
-- In the process, we first distinguishing whether m = k or m < k.
-- Next, we check whether the computation has termination, that is, whether
-- t = now ... or t = later.
-- Finally, we distinguish on the values of p m, which allows us to make
-- a computation step with μ'. The other cases follow then from there.
μ-min : ∀{p : ℕ → 𝔹} {m n : ℕ} → μ' p m ↓ n → ∀ k → m ≤′ k → k < n → p k ≡ false
-- m = k
---- t = now
μ-min {p} {.m} (now q)       m ≤′-refl u with p m
μ-min {p} {.m} (now q)       m ≤′-refl u | false = refl
μ-min {p} {.m} (now refl)    m ≤′-refl u | true  = ⊥-elim (1+n≰n u)

-- m = k
---- t = later
μ-min {p} {.m} (later q t)   m ≤′-refl u with p m
μ-min {p} {.m} (later q t)   m ≤′-refl u | false = refl
μ-min {p} {.m} (later () t)  m ≤′-refl u | true

-- m < k
---- t = now
μ-min {p} {m}        (now q)     .(suc _) (≤′-step l) u    with p m
μ-min {p} {m}        (now ())    .(suc _) (≤′-step l) u       | false
μ-min {p} {.(suc _)} (now refl)  .(suc _) (≤′-step l) (s≤s u) | true =
  ⊥-elim (empty-interval (suc≤⇒≤ _ _ (≤′⇒≤ l)) u)

-- m < k
---- t = later
μ-min {p} {m} (later q    t) .(suc _) (≤′-step {k'} l) u with p m
μ-min {p} {m} (later refl t) .(suc _) (≤′-step {k'} l) u    | false =
  μ-min t (suc k') (s≤′s l) u
μ-min {p} {m} (later ()   t) .(suc n) (≤′-step {n} l)  u    | true

Min : (ℕ → Set) → ℕ → Set
Min P n = P n × ∀ k → k < n → ¬ (P k)

-- | Definition of partial correctness for the μ-operator.
-- This states that if μ p terminates with n as result, then n is the
-- minimal number, for which p n ≡ true.
PartialCorrectness : Set
PartialCorrectness = ∀{p : ℕ → 𝔹} {n : ℕ} →
  μ p ↓ n → Min (λ k → p k ≡ true) n

μ-pcorrect : PartialCorrectness
μ-pcorrect t = (μ-finds-tt t , (λ k u → not-¬ (μ-min t k (z≤′n) u)))

-- Correctness : Set
-- Correctness = ∀{p : ℕ → 𝔹} →
--   ¬(∃ λ n → μ p ↓ n) → ∀ n → ¬(p n ≡ true)

-- find-min' : ∀{p : ℕ → 𝔹} → ∀ n → p n ≡ true → (m : ℕ) → m ≤ n →
--             (∃ λ k → k ≤ n × p k ≡ true)
-- find-min' {p} last pt zero l with p 0 | inspect p 0
-- find-min' {p} last pt zero l | false | e = (last , ≤-refl , pt)
-- find-min' {p} last pt zero l | true | [ e ] = (zero , l , e)
-- find-min' {p} last pt (suc m) l with p m | inspect p m
-- find-min' {p} last pt (suc m) l | false | e =
--   find-min' last pt m (suc≤⇒≤ m last l)
-- find-min' {p} last pt (suc m) l | true | [ e ] =
--   let (k , k≤last , q) = find-min' {p} m e m ≤-refl
--   in (k , ≤-trans k≤last (suc≤⇒≤ m last l) , q)

-- find-min : ∀{p : ℕ → 𝔹} → ∀ n → p n ≡ true → (∃ λ k → k ≤ n × p k ≡ true)
-- find-min {p} n pt = find-min' {p} n pt n ≤-refl

-- min-terminate : ∀{p : ℕ → 𝔹} → ∀ n (e : p n ≡ true) (m : ℕ) → m ≤ n → ∃ λ k → μ p ↓ k
-- min-terminate {p} last pt zero m≤n with p 0 | inspect p 0
-- min-terminate {p} last pt zero m≤n | false | e = {!!} , {!!}
-- min-terminate {p} last pt zero m≤n | true | e = {!!}
-- min-terminate {p} last pt (suc m) m≤n = {!!}

-- lem : ∀{p : ℕ → 𝔹} → ∀ n → p n ≡ true → ∃ λ k → μ p ↓ k
-- lem {p} zero q with p 0   | inspect p 0
-- lem {p} zero () | false | _
-- lem {p} zero q | true | [ e ] = (0 , now (cong (c p 0) e))
-- lem {p} (suc n) q with p (suc n)   | inspect p (suc n)
-- lem {p} (suc n) () | false | e
-- lem {p} (suc n) q | true | e =
--   let (k , t) = lem n {!!}
--   in (suc n , now {!!})

-- μ-correct : Correctness
-- μ-correct q n pt = q (lem n pt)


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

module Calf.Prelude where

open import Agda.Builtin.Equality
open import Agda.Builtin.Equality.Rewrite public

Ω = Prop
□ = Set

postulate
  funext : ∀ {a b} {A : Set a} {B : A → Set b} {f g : (a : A) → B a} → (∀ x → f x ≡ g x) → f ≡ g
  funext/Ω : {A : Prop} {B : □} {f g : A → B} → (∀ x → f x ≡ g x) → f ≡ g


open import Agda.Primitive
open import Agda.Builtin.Equality
open import Agda.Builtin.List
open import Agda.Builtin.Reflection

testQuote : quoteTerm Setω ≡ agda-sort (inf 0)
testQuote = refl

macro
  doUnquote : Term → Term → TC _
  doUnquote t hole = bindTC (unquoteTC t) (unify hole)

testUnquote : doUnquote (agda-sort (inf 0))
testUnquote = ∀ ℓ → Set ℓ


{-# OPTIONS --without-K #-}
module function.isomorphism.two-out-of-six where

open import sum
open import equality
open import function.core
open import function.isomorphism.core
open import function.overloading
open import hott.equivalence.core
open import hott.equivalence.biinvertible

module two-out-of-six
         {i j k l}{X : Set i}{Y : Set j}{Z : Set k}{W : Set l}
         (f : X → Y)(g : Y → Z)(h : Z → W)
         (gf-equiv : weak-equiv (g ∘ f))
         (hg-equiv : weak-equiv (h ∘ g)) where
  private
    r : X ≅ Z
    r = ≈⇒≅ (g ∘ f , gf-equiv)

    s : Y ≅ W
    s = ≈⇒≅ (h ∘ g , hg-equiv)

    gl : Z → Y
    gl = invert s ∘ h

    gr : Z → Y
    gr = f ∘ invert r

  g-iso : Y ≅ Z
  g-iso = b⇒≅ (g , (gl , _≅_.iso₁ s) , (gr , _≅_.iso₂ r))

  f-iso : X ≅ Y
  f-iso = record
    { to = f
    ; from = λ y → invert r (g y)
    ; iso₁ = _≅_.iso₁ r
    ; iso₂ = λ y → sym (_≅_.iso₁ g-iso (f (invert r (g y))))
                 · ap (invert g-iso) (_≅_.iso₂ r (g y))
                 · _≅_.iso₁ g-iso y }

  h-iso : Z ≅ W
  h-iso = record
    { to = h
    ; from = λ w → g (invert s w)
    ; iso₁ = λ z → sym (ap (λ z → g (invert s (h z))) (_≅_.iso₂ g-iso z))
                 · ap g (_≅_.iso₁ s (invert g-iso z))
                 · _≅_.iso₂ g-iso z
    ; iso₂ = _≅_.iso₂ s }


module lambda.stack where

open import Relation.Binary.PropositionalEquality

infixr 40 _▸_
infixl 35 _∈_

data stack (T : Set) : Set where
  ε : stack T
  _▸_ : stack T → T → stack T

data _∈_ {T : Set} (x : T) : stack T → Set where
  here : ∀ {Γ} → x ∈ Γ ▸ x
  there : ∀ {Γ y} → x ∈ Γ → x ∈ Γ ▸ y

data _⊇_ {T : Set} : stack T → stack T → Set where
  bot : ε ⊇ ε
  skip : ∀ {Γ Δ x} → Γ ⊇ Δ → Γ ▸ x ⊇ Δ
  keep : ∀ {Γ Δ x} → Γ ⊇ Δ → Γ ▸ x ⊇ Δ ▸ x

module _ {T : Set} where

  id : ∀ {Γ : stack T} → Γ ⊇ Γ
  id {ε} = bot
  id {Γ ▸ x} = keep id

  shift : ∀ {Γ Δ} {x : T} → Γ ⊇ Δ → x ∈ Δ → x ∈ Γ
  shift bot ()
  shift (skip x) v = there (shift x v)
  shift (keep _) here = here
  shift (keep x) (there y) = there (shift x y)

  shift-id : ∀ {Γ : stack T} {x} → (e : x ∈ Γ) → shift id e ≡ e
  shift-id here = refl
  shift-id (there e) = cong there (shift-id e)

  _∘⊇_ : {Γ Δ Λ : stack T} → Γ ⊇ Δ → Δ ⊇ Λ → Γ ⊇ Λ
  bot ∘⊇ bot = bot
  skip x ∘⊇ y = skip (x ∘⊇ y)
  keep x ∘⊇ skip y = skip (x ∘⊇ y)
  keep x ∘⊇ keep y = keep (x ∘⊇ y)

  ∘⊇-idˡ : {Γ Δ : stack T} → (w : Γ ⊇ Δ) → id ∘⊇ w ≡ w
  ∘⊇-idˡ bot = refl
  ∘⊇-idˡ (skip x) = cong skip (∘⊇-idˡ x)
  ∘⊇-idˡ (keep x) = cong keep (∘⊇-idˡ x)

  ∘⊇-idʳ : {Δ Γ : stack T} → (w : Γ ⊇ Δ) → w ∘⊇ id ≡ w
  ∘⊇-idʳ bot = refl
  ∘⊇-idʳ (skip x) = cong skip (∘⊇-idʳ x)
  ∘⊇-idʳ (keep x) = cong keep (∘⊇-idʳ x)

  ∘⊇-assoc : {Γ Δ Λ Ω : stack T} → (w₁ : Γ ⊇ Δ) → (w₂ : Δ ⊇ Λ) → (w₃ : Λ ⊇ Ω) → (w₁ ∘⊇ w₂) ∘⊇ w₃ ≡ w₁ ∘⊇ (w₂ ∘⊇ w₃)
  ∘⊇-assoc bot bot bot = refl
  ∘⊇-assoc (skip w₁) w₂ w₃ = cong skip (∘⊇-assoc w₁ w₂ w₃)
  ∘⊇-assoc (keep w₁) (skip w₂) w₃ = cong skip (∘⊇-assoc w₁ w₂ w₃)
  ∘⊇-assoc (keep w₁) (keep w₂) (skip w₃) = cong skip (∘⊇-assoc w₁ w₂ w₃)
  ∘⊇-assoc (keep w₁) (keep w₂) (keep w₃) = cong keep (∘⊇-assoc w₁ w₂ w₃)


------------------------------------------------------------------------
-- Binomial theorem
------------------------------------------------------------------------

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

module Math.BinomialTheorem.Nat where

-- agda-stdlib
open import Data.Nat
open import Data.Nat.Properties
open import Data.Nat.Solver
open import Relation.Binary.PropositionalEquality
open import Function

-- agda-combinatorics
open import Math.Combinatorics.Function
open import Math.Combinatorics.Function.Properties

-- agda-misc
open import Math.NumberTheory.Summation.Nat
open import Math.NumberTheory.Summation.Nat.Properties

open ≤-Reasoning

private
  lemma₁ : ∀ x y n k → x * (C n k * (x ^ k * y ^ (n ∸ k))) ≡
                       C n k * (x ^ suc k * y ^ (n ∸ k))
  lemma₁ x y n k =
    solve 4 (λ m n o p → m :* (n :* (o :* p)) := n :* (m :* o :* p))
            refl x (C n k) (x ^ k) (y ^ (n ∸ k))
    where open +-*-Solver

  lemma₂ : ∀ x y n k → y * (C n k * (x ^ k * y ^ (n ∸ k))) ≡
                       C n k * (x ^ k * y ^ suc (n ∸ k))
  lemma₂ x y n k =
    solve 4 (λ m n o p → m :* (n :* (o :* p)) := n :* (o :* (m :* p)) )
            refl y (C n k) (x ^ k) (y ^ (n ∸ k))
    where open +-*-Solver

  glemma₃ : ∀ x y m n → C m m * (x ^ suc n * y ^ (n ∸ n)) ≡ x ^ suc n
  glemma₃ x y m n = begin-equality
    C m m * (x ^ suc n * y ^ (n ∸ n))
      ≡⟨ cong₂ (λ u v → u * (x ^ suc n * y ^ v)) (C[n,n]≡1 m) (n∸n≡0 n) ⟩
    1 * (x ^ suc n * 1)
      ≡⟨ *-identityˡ (x ^ suc n * 1) ⟩
    x ^ suc n * 1
      ≡⟨ *-identityʳ (x ^ suc n) ⟩
    x ^ suc n
      ∎

  lemma₃ : ∀ x y n → C n n * (x ^ suc n * y ^ (n ∸ n)) ≡ x ^ suc n
  lemma₃ x y n = glemma₃ x y n n

  lemma₄ : ∀ {k n} → k < n → suc (n ∸ suc k) ≡ suc n ∸ suc k
  lemma₄ k<n = sym $ +-∸-assoc 1 k<n

  lemma₅ : ∀ n → 1 * (1 * n) ≡ n
  lemma₅ n = trans (*-identityˡ (1 * n)) (*-identityˡ n)

  lemma₆ : ∀ x y n → C (suc n) (suc n) * (x ^ suc n * y ^ (n ∸ n)) ≡ x ^ suc n
  lemma₆ x y n = glemma₃ x y (suc n) n

  lemma₇ : ∀ m n o p → m + n + (o + p) ≡ n + o + (m + p)
  lemma₇ = solve 4 (λ m n o p → m :+ n :+ (o :+ p) := n :+ o :+ (m :+ p) ) refl
    where open +-*-Solver

  lemma₈ : ∀ m n o → m + n + o ≡ n + (o + m)
  lemma₈ = solve 3 (λ m n o → m :+ n :+ o := n :+ (o :+ m)) refl
    where open +-*-Solver
{-
(x+y)*(x+y)^n
(x+y)*Σ[k≤n][Cnk*x^k*y^(n∸k)]
-}

theorem : ∀ x y n →
          (x + y) ^ n ≡ Σ[ k ≤ n ] (C n k * (x ^ k * y ^ (n ∸ k)))
theorem x y 0       = begin-equality
  C 0 0 * ((x ^ 0) * y ^ (0 ∸ 0))
    ≡⟨ sym $ Σ≤[0,f]≈f[0] (λ k → C 0 k * (x ^ k * y ^ (0 ∸ k))) ⟩
  Σ≤ 0 (λ k → C 0 k * (x ^ k * y ^ (0 ∸ k)))
    ∎
theorem x y (suc n) = begin-equality
  (x + y) * (x + y) ^ n
    ≡⟨ cong ((x + y) *_) $ theorem x y n ⟩
  (x + y) * Σ[ k ≤ n ] (C n k * (x ^ k * y ^ (n ∸ k)))
    ≡⟨ *-distribʳ-+ (Σ[ k ≤ n ] (C n k * (x ^ k * y ^ (n ∸ k)))) x y ⟩
  x * Σ[ k ≤ n ] (C n k * (x ^ k * y ^ (n ∸ k))) + y * Σ[ k ≤ n ] (C n k * (x ^ k * y ^ (n ∸ k)))
    ≡⟨ sym $ cong₂ _+_ (Σ≤-*-commute n x (λ k → C n k * (x ^ k * y ^ (n ∸ k)))) (Σ≤-*-commute n y (λ k → C n k * (x ^ k * y ^ (n ∸ k)))) ⟩
  Σ[ k ≤ n ] (x * (C n k * (x ^ k * y ^ (n ∸ k)))) + Σ[ k ≤ n ] (y * (C n k * (x ^ k * y ^ (n ∸ k))))
    ≡⟨ cong₂ _+_ (Σ≤-congˡ n (λ k → lemma₁ x y n k)) (Σ≤-congˡ n (λ k → lemma₂ x y n k)) ⟩
  Σ[ k ≤ n ] (C n k * ((x ^ suc k) * y ^ (n ∸ k))) + Σ[ k ≤ n ] (C n k * (x ^ k * y ^ suc (n ∸ k)))
    ≡⟨ cong (Σ[ k ≤ n ] (C n k * (x ^ suc k * y ^ (n ∸ k))) +_) $ Σ<-push-suc n (λ k → C n k * (x ^ k * y ^ suc (n ∸ k))) ⟩
  Σ[ k < n ] (C n k * ((x ^ suc k) * y ^ (n ∸ k))) + C n n * ((x ^ suc n) * y ^ (n ∸ n))
    + (C n 0 * (x ^ 0 * y ^ (suc (n ∸ 0))) + Σ[ k < n ] (C n (suc k) * (x ^ suc k * y ^ suc (n ∸ suc k))))
    ≡⟨⟩
  Σ[ k < n ] (C n k * ((x ^ suc k) * y ^ (n ∸ k))) + C n n * ((x ^ suc n) * y ^ (n ∸ n))
    + (1 * (1 * y ^ suc n) + Σ[ k < n ] (C n (suc k) * (x ^ suc k * y ^ suc (n ∸ suc k))))
    ≡⟨ cong₂ _+_ (cong (Σ[ k < n ] (C n k * (x ^ suc k * y ^ (n ∸ k))) +_) $ lemma₃ x y n)
                 (cong₂ _+_ (lemma₅ (y ^ suc n))
                    (Σ<-congˡ-with-< n $ λ k k<n → cong (λ v → C n (suc k) * (x ^ suc k * y ^ v)) $ lemma₄ k<n)) ⟩
  Σ[ k < n ] (C n k * (x ^ suc k * y ^ (n ∸ k))) + x ^ suc n
    + (y ^ suc n + Σ[ k < n ] (C n (suc k) * (x ^ suc k * y ^ (n ∸ k))))
    ≡⟨ lemma₇ (Σ[ k < n ] (C n k * (x ^ suc k * y ^ (n ∸ k)))) (x ^ suc n) (y ^ suc n) (Σ[ k < n ] (C n (suc k) * (x ^ suc k * y ^ (n ∸ k)))) ⟩
  x ^ suc n + y ^ suc n + (Σ[ k < n ] (C n k * (x ^ suc k * y ^ (n ∸ k))) +
                          Σ[ k < n ] (C n (suc k) * (x ^ suc k * y ^ (n ∸ k))))
   ≡⟨ cong (λ v → (x ^ suc n + y ^ suc n) + v) $ lemma ⟩
  x ^ suc n + y ^ suc n + Σ[ k < n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k)))
    ≡⟨ lemma₈ (x ^ suc n) (y ^ suc n) (Σ[ k < n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k)))) ⟩
  y ^ suc n + (Σ[ k < n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k))) + x ^ suc n)
    ≡⟨ cong (λ v → y ^ suc n + (Σ[ k < n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k))) + v)) $ sym $ lemma₆ x y n ⟩
  y ^ suc n + (Σ[ k < n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k))) + C (suc n) (suc n) * (x ^ suc n * y ^ (n ∸ n)))
    ≡⟨⟩
  y ^ suc n + Σ[ k ≤ n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k)))
   ≡⟨ cong (_+ Σ[ k ≤ n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k)))) $ sym $ lemma₅ (y ^ suc n) ⟩
  1 * (1 * y ^ suc n) + Σ[ k ≤ n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k)))
   ≡⟨ sym $ Σ≤-push-suc n (λ k → C (suc n) k * (x ^ k * y ^ (suc n ∸ k))) ⟩
  Σ≤ (suc n) (λ k → C (suc n) k * (x ^ k * y ^ (suc n ∸ k)))
    ∎
  where
  lemma : Σ[ k < n ] (C n k * (x ^ suc k * y ^ (n ∸ k))) +
          Σ[ k < n ] (C n (suc k) * (x ^ suc k * y ^ (n ∸ k))) ≡
          Σ[ k < n ] (C (suc n) (suc k) * (x ^ suc k * y ^ (n ∸ k)))
  lemma = begin-equality
    Σ[ k < n ] (C n k * z k) + Σ[ k < n ] (C n (suc k) * z k)
      ≡⟨ sym $ Σ<-distrib-+ n (λ k → C n k * z k) (λ k → C n (suc k) * z k) ⟩
    Σ[ k < n ] (C n k * z k + C n (suc k) * z k)
      ≡⟨ Σ<-congˡ n (λ k → sym $ *-distribʳ-+ (z k) (C n k) (C n (suc k))) ⟩
    Σ[ k < n ] ((C n k + C n (suc k)) * z k)
      ≡⟨ Σ<-congˡ n (λ k → cong (_* z k) $ sym $ C[1+n,1+k]≡C[n,k]+C[n,1+k] n k) ⟩
    Σ[ k < n ] (C (suc n) (suc k) * z k)
      ∎
    where
    z = λ k → x ^ suc k * y ^ (n ∸ k)

Σ[k≤n]C[n,k]≡2^n : ∀ n → Σ[ k ≤ n ] C n k ≡ 2 ^ n
Σ[k≤n]C[n,k]≡2^n n = begin-equality
  Σ[ k ≤ n ] (C n k)
    ≡⟨ sym $ Σ≤-congˡ n (λ k → begin-equality
        C n k * (1 ^ k * 1 ^ (n ∸ k))
          ≡⟨ cong (C n k *_) $ cong₂ _*_ (^-zeroˡ k) (^-zeroˡ (n ∸ k)) ⟩
        C n k * (1 * 1)
          ≡⟨ *-identityʳ (C n k) ⟩
        C n k
          ∎ ) ⟩
  Σ[ k ≤ n ] (C n k * (1 ^ k * 1 ^ (n ∸ k)))
    ≡⟨ sym $ theorem 1 1 n ⟩
  (1 + 1) ^ n
    ∎


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

open import HoTT
open import homotopy.Freudenthal

module homotopy.IterSuspensionStable where

{- π (S k) (Ptd-Susp^ (S n) X) == π k (Ptd-Susp^ n X), where k = S k'
   Susp^Stable below assumes k ≠ O instead of taking k' as the argument -}
module Susp^StableSucc {i} (X : Ptd i) (cX : is-connected ⟨0⟩ (fst X))
  (n : ℕ) (k' : ℕ) (kle : S k' ≤ n *2) where

  {- need k,n ≥ 1 -}
  k : ℕ
  k = S k'

  {- some numeric computations -}
  private
    kle' : ⟨ k ⟩ ≤T S ((n -2) +2+ S (n -2))
    kle' = ≤T-trans (⟨⟩-monotone-≤ kle) (inl (lemma n))
      where lemma : (n : ℕ) → ⟨ n *2 ⟩ == S ((n -2) +2+ S (n -2))
            lemma O = idp
            lemma (S n') = ap S (ap S (lemma n')
                                 ∙ ! (+2+-βr (S n' -2) (S n' -2)))

    nlemma₁ : (n : ℕ) → (n -2) +2+ ⟨0⟩ == S (S (n -2))
    nlemma₁ n = +2+-comm (n -2) ⟨0⟩

    nlemma₂ : (k : ℕ) → (k -2) +2+ ⟨0⟩ == ⟨ k ⟩
    nlemma₂ O = idp
    nlemma₂ (S k) = ap S (nlemma₂ k)

  private
    module F = FreudenthalIso
      (n -2) k (ℕ-S≠O _) kle' (⊙Susp^ n X)
      (transport (λ t → is-connected t (fst (⊙Susp^ n X)))
                 (nlemma₁ n) (⊙Susp^-conn n cX))

  stable : (tk : k ≠ 0) (tsk : S k ≠ 0)
    → π (S k) tsk (⊙Susp^ (S n) X) == π k tk (⊙Susp^ n X)
  stable tk tsk =
    π (S k) tsk (⊙Susp^ (S n) X)
      =⟨ π-inner-iso k tk tsk (⊙Susp^ (S n) X) ⟩
    π k tk (⊙Ω (⊙Susp^ (S n) X))
      =⟨ ! (π-Trunc-shift-iso k tk (⊙Ω (⊙Susp^ (S n) X))) ⟩
    Ω^-Group k tk (⊙Trunc ⟨ k ⟩ (⊙Ω (⊙Susp^ (S n) X))) Trunc-level
      =⟨ ! (group-ua F.iso) ⟩
    Ω^-Group k tk (⊙Trunc ⟨ k ⟩ (⊙Susp^ n X)) Trunc-level
      =⟨ π-Trunc-shift-iso k tk (⊙Susp^ n X) ⟩
    π k tk (⊙Susp^ n X) ∎

{- π (S k) (⊙Susp^ (S n) X) == π k (⊙Susp^ n X), where k > 0 -}
module Susp^Stable {i} (X : Ptd i) (cX : is-connected ⟨0⟩ (fst X))
  (n : ℕ) (k : ℕ) (tk : k ≠ 0) (tsk : S k ≠ 0) (kle : k ≤ n *2) where

  private
    lemma : ∀ {i} (C : (n : ℕ) → n ≠ 0 → S n ≠ 0 → Type i)
      → ((n : ℕ) (tsn : S n ≠ 0) (tssn : S (S n) ≠ 0)
            → C (S n) tsn tssn)
      → ((n : ℕ) (tn : n ≠ 0) (tsn : S n ≠ 0)
            → C n tn tsn)
    lemma C f O tn _ = ⊥-rec (tn idp)
    lemma C f (S n) tsn tssn = f n tsn tssn

  abstract
    stable : π (S k) tsk (⊙Susp^ (S n) X) == π k tk (⊙Susp^ n X)
    stable = lemma
      (λ r tr tsr → (r ≤ n *2) →
         π (S r) tsr (⊙Susp^ (S n) X) == π r tr (⊙Susp^ n X))
      (λ r' tsr' tssr' → λ rle →
        Susp^StableSucc.stable X cX n r' rle tsr' tssr')
      k tk tsk kle


module Q where
import AlonzoPrelude
open AlonzoPrelude -- , using(Bool,False,True,String,showBool)
import PreludeNat
open PreludeNat
import PreludeBool
open PreludeBool
import PreludeShow
open PreludeShow

pred : Nat -> Nat
pred (zero) = zero
pred (suc n) = n

mplus : Nat -> Nat -> Nat
mplus zero y = y
mplus (suc n) y = suc (mplus n  y )

Q : Bool -> Set
Q true = Nat
Q false = Bool

f : (b : Bool) -> Q b
f true = pred 3
f false = true

mid : {A : Set} -> A -> A
mid x = x

mainS : String
mainS = showBool (f (const false true))


------------------------------------------------------------------------
-- The Agda standard library
--
-- Lists where every pair of elements are related (symmetrically)
------------------------------------------------------------------------

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

open import Relation.Binary using (Rel)

module Data.List.Relation.Unary.AllPairs
       {a ℓ} {A : Set a} {R : Rel A ℓ} where

open import Data.List.Base using (List; []; _∷_)
open import Data.List.Relation.Unary.All as All using (All; []; _∷_)
open import Data.Product as Prod using (_,_; _×_; uncurry; <_,_>)
open import Function using (id; _∘_)
open import Level using (_⊔_)
open import Relation.Binary as B using (Rel; _⇒_)
open import Relation.Binary.Construct.Intersection renaming (_∩_ to _∩ᵇ_)
open import Relation.Binary.PropositionalEquality
open import Relation.Unary as U renaming (_∩_ to _∩ᵘ_) hiding (_⇒_)
open import Relation.Nullary using (yes; no)
import Relation.Nullary.Decidable as Dec
open import Relation.Nullary.Product using (_×-dec_)

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

open import Data.List.Relation.Unary.AllPairs.Core public

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

head : ∀ {x xs} → AllPairs R (x ∷ xs) → All (R x) xs
head (px ∷ pxs) = px

tail : ∀ {x xs} → AllPairs R (x ∷ xs) → AllPairs R xs
tail (px ∷ pxs) = pxs

uncons : ∀ {x xs} → AllPairs R (x ∷ xs) → All (R x) xs × AllPairs R xs
uncons = < head , tail >

module _ {q} {S : Rel A q} where

  map : R ⇒ S → AllPairs R ⊆ AllPairs S
  map ~₁⇒~₂ [] = []
  map ~₁⇒~₂ (x~xs ∷ pxs) = All.map ~₁⇒~₂ x~xs ∷ (map ~₁⇒~₂ pxs)

module _ {s t} {S : Rel A s} {T : Rel A t} where

  zipWith : R ∩ᵇ S ⇒ T → AllPairs R ∩ᵘ AllPairs S ⊆ AllPairs T
  zipWith f ([] , [])             = []
  zipWith f (px ∷ pxs , qx ∷ qxs) = All.zipWith f (px , qx) ∷ zipWith f (pxs , qxs)

  unzipWith : T ⇒ R ∩ᵇ S → AllPairs T ⊆ AllPairs R ∩ᵘ AllPairs S
  unzipWith f []         = [] , []
  unzipWith f (rx ∷ rxs) = Prod.zip _∷_ _∷_ (All.unzipWith f rx) (unzipWith f rxs)

module _ {s} {S : Rel A s} where

  zip : AllPairs R ∩ᵘ AllPairs S ⊆ AllPairs (R ∩ᵇ S)
  zip = zipWith id

  unzip : AllPairs (R ∩ᵇ S) ⊆ AllPairs R ∩ᵘ AllPairs S
  unzip = unzipWith id

------------------------------------------------------------------------
-- Properties of predicates preserved by AllPairs

allPairs? : B.Decidable R → U.Decidable (AllPairs R)
allPairs? R? []       = yes []
allPairs? R? (x ∷ xs) =
  Dec.map′ (uncurry _∷_) uncons (All.all (R? x) xs ×-dec allPairs? R? xs)

irrelevant : B.Irrelevant R → U.Irrelevant (AllPairs R)
irrelevant irr []           []           = refl
irrelevant irr (px₁ ∷ pxs₁) (px₂ ∷ pxs₂) =
  cong₂ _∷_ (All.irrelevant irr px₁ px₂) (irrelevant irr pxs₁ pxs₂)

satisfiable : U.Satisfiable (AllPairs R)
satisfiable = [] , []


module Control.Monad.Reader where

open import Prelude
open import Control.Monad.Zero
open import Control.Monad.Identity
open import Control.Monad.Transformer

record ReaderT {a} (R : Set a) (M : Set a → Set a) (A : Set a) : Set a where
  no-eta-equality
  constructor readerT
  field runReaderT : R → M A

open ReaderT public

module _ {a} {R : Set a} {M : Set a → Set a} where

  instance
    FunctorReaderT : {{_ : Functor M}} → Functor {a = a} (ReaderT R M)
    runReaderT (fmap {{ FunctorReaderT }} f m) r = f <$> runReaderT m r

    FunctorZeroReaderT : {{_ : FunctorZero M}} → FunctorZero {a = a} (ReaderT R M)
    runReaderT (empty {{FunctorZeroReaderT}}) r = empty

    AlternativeReaderT : {{_ : Alternative M}} → Alternative {a = a} (ReaderT R M)
    runReaderT (_<|>_ {{AlternativeReaderT}} x y) r = runReaderT x r <|> runReaderT y r

  module _ {{_ : Monad M}} where

    private
      bindReaderT : ∀ {A B} → ReaderT R M A → (A → ReaderT R M B) → ReaderT R M B
      runReaderT (bindReaderT m f) r = runReaderT m r >>= λ x → runReaderT (f x) r

    instance
      ApplicativeReaderT : Applicative {a = a} (ReaderT R M)
      runReaderT (pure {{ApplicativeReaderT}} x) r = pure x
      _<*>_ {{ApplicativeReaderT}} = monadAp bindReaderT

      MonadReaderT : Monad {a = a} (ReaderT R M)
      _>>=_  {{MonadReaderT}} = bindReaderT

    liftReaderT : {A : Set a} → M A → ReaderT R M A
    runReaderT (liftReaderT m) r = m

    asks : {A : Set a} → (R → A) → ReaderT R M A
    runReaderT (asks f) r = return (f r)

    ask : ReaderT R M R
    ask = asks id

    local : {A : Set a} → (R → R) → ReaderT R M A → ReaderT R M A
    runReaderT (local f m) r = runReaderT m (f r)

instance
  TransformerReaderT : ∀ {a} {R : Set a} → Transformer (ReaderT R)
  lift {{TransformerReaderT}} = liftReaderT

Reader : ∀ {a} (R : Set a) (A : Set a) → Set a
Reader R = ReaderT R Identity

runReader : ∀ {a} {R : Set a} {A : Set a} → Reader R A → R → A
runReader m r = runIdentity (runReaderT m r)


------------------------------------------------------------------------------
-- First-order logic (without equality)
------------------------------------------------------------------------------

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

-- This module is re-exported by the "base" modules whose theories are
-- defined on first-order logic (without equality).

-- The logical connectives are hard-coded in our translation, i.e. the
-- symbols ⊥, ⊤, ¬, ∧, ∨, → and ↔ must be used.
--
-- N.B. For the implication we use the Agda function type.
--
-- N.B For the universal quantifier we use the Agda (dependent)
-- function type.

module Common.FOL.FOL where

infixr 4 _,_
infix  3 ¬_
infixr 2 _∧_
infix  2 ∃
infixr 1 _∨_
infixr 0 _↔_

----------------------------------------------------------------------------
-- The universe of discourse/universal domain.
postulate D : Set

------------------------------------------------------------------------------
-- The conjunction data type.

-- It is not necessary to add the data constructor _,_ as an
-- axiom because the ATPs implement it.
data _∧_ (A B : Set) : Set where
  _,_ : A → B → A ∧ B

-- It is not strictly necessary define the projections ∧-proj₁ and
-- ∧-proj₂ because the ATPs implement them. For the same reason, it is
-- not necessary to add them as (general/local) hints.
∧-proj₁ : ∀ {A B} → A ∧ B → A
∧-proj₁ (a , _) = a

∧-proj₂ : ∀ {A B} → A ∧ B → B
∧-proj₂ (_ , b) = b

-----------------------------------------------------------------------------
-- The disjunction data type.

-- It is not necessary to add the data constructors inj₁ and inj₂ as
-- axioms because the ATPs implement them.
data _∨_ (A B : Set) : Set where
  inj₁ : A → A ∨ B
  inj₂ : B → A ∨ B

-- It is not strictly necessary define the eliminator `case` because
-- the ATPs implement it. For the same reason, it is not necessary to
-- add it as a (general/local) hint.
case : ∀ {A B} → {C : Set} → (A → C) → (B → C) → A ∨ B → C
case f g (inj₁ a) = f a
case f g (inj₂ b) = g b

------------------------------------------------------------------------------
-- The empty type.
data ⊥ : Set where

⊥-elim : {A : Set} → ⊥ → A
⊥-elim ()

------------------------------------------------------------------------------
-- The unit type.
-- N.B. The name of this type is "\top", not T.
data ⊤ : Set where
  tt : ⊤

------------------------------------------------------------------------------
-- Negation.

-- The underscore allows to write for example '¬ ¬ A' instead of '¬ (¬ A)'.

-- We do not add a definition because: i) the definition of negation
-- is not a FOL-definition and ii) the translation of the neagation is
-- hard-coded in Apia.

¬_ : Set → Set
¬ A = A → ⊥

------------------------------------------------------------------------------
-- Biconditional.

-- We do not add a definition because: i) the definition of the
-- biconditional is not a FOL-definition, ii) the translation of the
-- biconditional is hard-coded in Apia.

_↔_ : Set → Set → Set
A ↔ B = (A → B) ∧ (B → A)

------------------------------------------------------------------------------
-- The existential quantifier type on D.
data ∃ (A : D → Set) : Set where
  _,_ : (t : D) → A t → ∃ A

-- Sugar syntax for the existential quantifier.
syntax ∃ (λ x → e) = ∃[ x ] e

-- 2012-03-05: We avoid to use the existential elimination or the
-- existential projections because we use pattern matching (and the
-- Agda's with constructor).

-- The existential elimination.
--
-- NB. We do not use the usual type theory elimination with two
-- projections because we are working in first-order logic where we do
-- not need extract a witness from an existence proof.
-- ∃-elim : {A : D → Set}{B : Set} → ∃ A → (∀ {x} → A x → B) → B
-- ∃-elim (_ , Ax) h = h Ax

-- The existential proyections.
-- ∃-proj₁ : ∀ {A} → ∃ A → D
-- ∃-proj₁ (x , _) = x

-- ∃-proj₂ : ∀ {A} → (h : ∃ A) → A (∃-proj₁ h)
-- ∃-proj₂ (_ , Ax) = Ax

------------------------------------------------------------------------------
-- Properties

→-trans : {A B C : Set} → (A → B) → (B → C) → A → C
→-trans f g a = g (f a)


{-# OPTIONS --type-in-type #-}

data IBool : Set where
  itrue ifalse : IBool

Bool : Set; Bool
 = (B : Set) → B → B → B

toIBool : Bool → IBool
toIBool b = b _ itrue ifalse

true : Bool; true
 = λ B t f → t

and : Bool → Bool → Bool; and
 = λ a b B t f → a B (b B t f) f

Nat : Set; Nat
 = (n : Set) → (n → n) → n → n

add : Nat → Nat → Nat; add
 = λ a b n s z → a n s (b n s z)

mul : Nat → Nat → Nat; mul
 = λ a b n s → a n (b n s)

suc : Nat → Nat; suc
 = λ a n s z → s (a n s z)

Eq : {A : Set} → A → A → Set
Eq {A} x y = (P : A → Set) → P x → P y

refl : {A : Set}{x : A} → Eq {A} x x; refl
 = λ P px → px

n2  : Nat; n2 = λ N s z → s (s z)
n3  : Nat; n3 = λ N s z → s (s (s z))
n4  : Nat; n4 = λ N s z → s (s (s (s z)))
n5  : Nat; n5 = λ N s z → s (s (s (s (s z))))
n10    = mul n2 n5
n10b   = mul n5 n2
n15    = add n10  n5
n15b   = add n10b n5
n18    = add n15  n3
n18b   = add n15b n3
n19    = add n15  n4
n19b   = add n15b n4
n20    = mul n2 n10
n20b   = mul n2 n10b
n21    = suc n20
n21b   = suc n20b
n22    = suc n21
n22b   = suc n21b
n23    = suc n22
n23b   = suc n22b
n100   = mul n10   n10
n100b  = mul n10b  n10b
n10k   = mul n100  n100
n10kb  = mul n100b n100b
n100k  = mul n10k  n10
n100kb = mul n10kb n10b
n1M    = mul n10k  n100
n1Mb   = mul n10kb n100b
n5M    = mul n1M   n5
n5Mb   = mul n1Mb  n5
n10M   = mul n5M   n2
n10Mb  = mul n5Mb  n2

Tree : Set; Tree = (T : Set) → (T → T → T) → T → T
leaf : Tree; leaf = λ T n l → l
node : Tree → Tree → Tree; node = λ t1 t2 T n l → n (t1 T n l) (t2 T n l)

fullTree : Nat → Tree; fullTree
 = λ n → n Tree (λ t → node t t) leaf

-- full tree with given trees at bottom level
fullTreeWithLeaf : Tree → Nat → Tree; fullTreeWithLeaf
 = λ bottom n → n Tree (λ t → node t t) bottom

forceTree : Tree → Bool; forceTree
 = λ t → t Bool and true

t15  = fullTree n15
t15b = fullTree n15b
t18  = fullTree n18
t18b = fullTree n18b
t19  = fullTree n19
t19b = fullTree n19b
t20  = fullTree n20
t20b = fullTree n20b
t21  = fullTree n21
t21b = fullTree n21b
t22  = fullTree n22
t22b = fullTree n22b
t23  = fullTree n23
t23b = fullTree n23b

-- Nat conversion
--------------------------------------------------------------------------------

-- convn1M : Eq n1M n1Mb; convn1M = refl
-- convn5M : Eq n5M n5Mb; convn5M = refl
-- convn10M : Eq n10M n10Mb; convn10M = refl

-- Full tree conversion
--------------------------------------------------------------------------------

-- convt15  : Eq t15  t15b; convt15  = refl -- 16 ms
-- convt18  : Eq t18  t18b; convt18  = refl -- 20 ms
-- convt19  : Eq t19  t19b; convt19  = refl -- 30 ms
-- convt20  : Eq t20  t20b; convt20  = refl -- 1.7 s
-- convt21  : Eq t21  t21b; convt21  = refl -- 3.4 s
-- convt22  : Eq t22  t22b; convt22  = refl -- 6.6 s
-- convt23  : Eq t23  t23b; convt23  = refl -- 13.1 s

-- Full meta-containing tree conversion
--------------------------------------------------------------------------------

-- convmt15 : Eq t15b  (fullTreeWithLeaf _ n15 ); convmt15 = refl --
-- convmt18 : Eq t18b  (fullTreeWithLeaf _ n18 ); convmt18 = refl --
-- convmt19 : Eq t19b  (fullTreeWithLeaf _ n19 ); convmt19 = refl --
-- convmt20 : Eq t20b  (fullTreeWithLeaf _ n20 ); convmt20 = refl --
-- convmt21 : Eq t21b  (fullTreeWithLeaf _ n21 ); convmt21 = refl
-- convmt22 : Eq t22b  (fullTreeWithLeaf _ n22 ); convmt22 = refl
-- convmt23 : Eq t23b  (fullTreeWithLeaf _ n23 ); convmt23 = refl

-- Full tree forcing
--------------------------------------------------------------------------------

-- forcet15 : Eq (toIBool (forceTree t15)) itrue; forcet15 = refl -- 50 ms
-- forcet18 : Eq (toIBool (forceTree t18)) itrue; forcet18 = refl -- 450 ms
-- forcet19 : Eq (toIBool (forceTree t19)) itrue; forcet19 = refl -- 900 ms
-- forcet20 : Eq (toIBool (forceTree t20)) itrue; forcet20 = refl -- 1.75 s
-- forcet21 : Eq (toIBool (forceTree t21)) itrue; forcet21 = refl -- 3.5 s
-- forcet22 : Eq (toIBool (forceTree t22)) itrue; forcet22 = refl -- 7.5 s
-- forcet23 : Eq (toIBool (forceTree t23)) itrue; forcet23 = refl -- 15 s


-- In a mutual block, either all or none must have a MEASURE declaration.

module _ where

open import Common.Prelude

mutual

  {-# MEASURE n #-}
  f : (n : Nat) → Nat
  f zero = zero
  f (suc n) = g n

  {-# MEASURE n #-}
  g : (n : Nat) → Nat
  g zero = zero
  g (suc n) = suc (f n)


module Function.Proofs where

import      Lvl
open import Logic
open import Logic.Classical
open import Logic.Propositional
open import Logic.Propositional.Theorems
open import Logic.Predicate
open import Functional
open import Function.Inverseᵣ
open import Function.Names using (_⊜_)
open import Structure.Setoid using (Equiv) renaming (_≡_ to _≡ₛ_)
open import Structure.Setoid.Uniqueness
open import Structure.Relator.Properties
open import Structure.Relator
open import Structure.Function.Domain
open import Structure.Function.Domain.Proofs
open import Structure.Function
open import Structure.Operator
open import Syntax.Transitivity
open import Type
open import Type.Properties.Empty

private variable ℓ ℓ₁ ℓ₂ ℓ₃ ℓₗ ℓₒ ℓₒ₁ ℓₒ₂ ℓₒ₃ ℓₒ₄ ℓₒ₅ ℓₒ₆ ℓₒ₇ ℓₑ ℓₑ₁ ℓₑ₂ ℓₑ₃ ℓₑ₄ ℓₑ₅ ℓₑ₆ ℓₑ₇ : Lvl.Level

module _ {T : Type{ℓₒ}} ⦃ eq : Equiv{ℓₑ}(T) ⦄ where
  instance
    -- Identity function is a function.
    id-function : Function(id)
    Function.congruence(id-function) = id

  instance
    -- Identity function is injective.
    id-injective : Injective(id)
    Injective.proof(id-injective) = id

  instance
    -- Identity function is surjective.
    id-surjective : Surjective(id)
    Surjective.proof(id-surjective) {y} = [∃]-intro (y) ⦃ reflexivity(_≡ₛ_) ⦄

  instance
    -- Identity function is bijective.
    id-bijective : Bijective(id)
    id-bijective = injective-surjective-to-bijective(id)

  instance
    id-idempotent : Idempotent(id)
    id-idempotent = intro(reflexivity _)

  instance
    id-involution : Involution(id)
    id-involution = intro(reflexivity _)

  instance
    id-inverseₗ : Inverseₗ(id)(id)
    id-inverseₗ = intro(reflexivity _)

  instance
    id-inverseᵣ : Inverseᵣ(id)(id)
    id-inverseᵣ = intro(reflexivity _)

  instance
    id-inverse : Inverse(id)(id)
    id-inverse = [∧]-intro id-inverseₗ id-inverseᵣ

module _ {A : Type{ℓₒ₁}} ⦃ eq-a : Equiv{ℓₑ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ eq-b : Equiv{ℓₑ₂}(B) ⦄ where
  instance
    -- Constant functions are functions.
    const-function : ∀{c : B} → Function {A = A}{B = B} (const(c))
    Function.congruence(const-function) _ = reflexivity(_≡ₛ_)

  instance
    -- Constant functions are constant.
    const-constant : ∀{c : B} → Constant {A = A}{B = B} (const(c))
    Constant.proof const-constant = reflexivity(_≡ₛ_)

module _ {A : Type{ℓₒ₁}} ⦃ eq-a : Equiv{ℓₑ₁}(A) ⦄ {B : Type{ℓₒ₂}} ⦃ eq-b : Equiv{ℓₑ₂}(B) ⦄ where
  open import Function.Equals
  open import Function.Equals.Proofs

  -- The constant function is extensionally a function.
  instance
    const-function-function : ∀{c : B} → Function {A = B}{B = A → B} const
    Function.congruence const-function-function = [⊜]-abstract

module _ {a : Type{ℓₒ₁}}{b : Type{ℓₒ₂}}{c : Type{ℓₒ₃}}{d : Type{ℓₒ₄}} ⦃ _ : Equiv{ℓₑ}(a → d) ⦄ where
  -- Function composition is associative.
  [∘]-associativity : ∀{f : c → d}{g : b → c}{h : a → b} → ((f ∘ (g ∘ h)) ≡ₛ ((f ∘ g) ∘ h))
  [∘]-associativity = reflexivity(_≡ₛ_)

module _ {a : Type{ℓₒ₁}}{b : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₑ}(a → b) ⦄ {f : a → b} where
  -- Function composition has left identity element.
  [∘]-identityₗ : (id ∘ f ≡ₛ f)
  [∘]-identityₗ = reflexivity(_≡ₛ_)

  -- Function composition has right identity element.
  [∘]-identityᵣ : (f ∘ id ≡ₛ f)
  [∘]-identityᵣ = reflexivity(_≡ₛ_)

module _ {a : Type{ℓₒ₁}} ⦃ _ : Equiv{ℓₑ₁}(a) ⦄ {b : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₑ₂}(b) ⦄ {c : Type{ℓₒ₃}} ⦃ _ : Equiv{ℓₑ₃}(c) ⦄ where
  -- The composition of injective functions is injective.
  -- Source: https://math.stackexchange.com/questions/2049511/is-the-composition-of-two-injective-functions-injective/2049521
  -- Alternative proof: [∘]-associativity {f⁻¹}{g⁻¹}{g}{f} becomes id by inverseₗ-value injective equivalence
  [∘]-injective : ∀{f : b → c}{g : a → b} → ⦃ inj-f : Injective(f) ⦄ → ⦃ inj-g : Injective(g) ⦄ → Injective(f ∘ g)
  Injective.proof([∘]-injective {f = f}{g = g} ⦃ inj-f ⦄ ⦃ inj-g ⦄ ) {x₁}{x₂} = (injective(g) ⦃ inj-g ⦄ {x₁} {x₂}) ∘ (injective(f) ⦃ inj-f ⦄ {g(x₁)} {g(x₂)})

  -- RHS of composition is injective if the composition is injective.
  [∘]-injective-elim : ∀{f : b → c} → ⦃ func-f : Function(f) ⦄ → ∀{g : a → b} → ⦃ inj-fg : Injective(f ∘ g) ⦄ → Injective(g)
  Injective.proof([∘]-injective-elim {f = f}{g = g} ⦃ inj-fg ⦄) {x₁}{x₂} (gx₁gx₂) = injective(f ∘ g) ⦃ inj-fg ⦄ {x₁} {x₂} (congruence₁(f) (gx₁gx₂))

module _ {a : Type{ℓₒ₁}} {b : Type{ℓₒ₂}} ⦃ _ : Equiv{ℓₑ₂}(b) ⦄ {c : Type{ℓₒ₃}} ⦃ _ : Equiv{ℓₑ₃}(c) ⦄ where
  -- The composition of surjective functions is surjective.
  [∘]-surjective : ∀{f : b → c} → ⦃ func-f : Function(f) ⦄ → ∀{g : a → b} → ⦃ surj-f : Surjective(f) ⦄ → ⦃ surj-g : Surjective(g) ⦄ → Surjective(f ∘ g)
  Surjective.proof([∘]-surjective {f = f}{g = g}) {y}
    with [∃]-intro (a) ⦃ fa≡y ⦄ ← surjective(f) {y}
    with [∃]-intro (x) ⦃ gx≡a ⦄ ← surjective(g) {a}
    = [∃]-intro (x) ⦃ congruence₁(f) gx≡a 🝖 fa≡y ⦄

  -- LHS of composition is surjective if the composition is surjective.
  [∘]-surjective-elim : ∀{f : b → c}{g : a → b} → ⦃ _ : Surjective(f ∘ g) ⦄ → Surjective(f)
  Surjective.proof([∘]-surjective-elim {f = f}{g = g}) {y} with (surjective(f ∘ g) {y})
  ... | [∃]-intro (x) ⦃ fgx≡y ⦄ = [∃]-intro (g(x)) ⦃ fgx≡y ⦄

module _
  {a : Type{ℓₒ₁}} ⦃ equiv-a : Equiv{ℓₑ₁}(a) ⦄
  {b : Type{ℓₒ₂}} ⦃ equiv-b : Equiv{ℓₑ₂}(b) ⦄
  {c : Type{ℓₒ₃}} ⦃ equiv-c : Equiv{ℓₑ₃}(c) ⦄
  where

  -- Bijective functions are closed under function composition.
  -- The composition of bijective functions is bijective.
  [∘]-bijective : ∀{f : b → c} → ⦃ func-f : Function(f) ⦄ → ∀{g : a → b} → ⦃ bij-f : Bijective(f) ⦄ → ⦃ bij-g : Bijective(g) ⦄ → Bijective(f ∘ g)
  [∘]-bijective {f = f} {g = g} =
    injective-surjective-to-bijective(f ∘ g)
      ⦃ [∘]-injective
        ⦃ inj-f = bijective-to-injective(f) ⦄
        ⦃ inj-g = bijective-to-injective(g) ⦄
      ⦄
      ⦃ [∘]-surjective
        ⦃ surj-f = bijective-to-surjective(f) ⦄
        ⦃ surj-g = bijective-to-surjective(g) ⦄
      ⦄

  [∘]-inverseᵣ : ∀{f : b → c} ⦃ func-f : Function(f) ⦄ {f⁻¹ : b ← c}{g : a → b}{g⁻¹ : a ← b} → ⦃ inv-f : Inverseᵣ(f)(f⁻¹) ⦄ ⦃ inv-g : Inverseᵣ(g)(g⁻¹) ⦄ → Inverseᵣ(f ∘ g)(g⁻¹ ∘ f⁻¹)
  Inverseᵣ.proof ([∘]-inverseᵣ {f} {f⁻¹} {g} {g⁻¹}) {x} =
    ((f ∘ g) ∘ (g⁻¹ ∘ f⁻¹))(x) 🝖[ _≡ₛ_ ]-[]
    (f ∘ ((g ∘ g⁻¹) ∘ f⁻¹))(x) 🝖[ _≡ₛ_ ]-[ congruence₁(f) (inverseᵣ(g)(g⁻¹)) ]
    (f ∘ (id ∘ f⁻¹))(x)        🝖[ _≡ₛ_ ]-[]
    (f ∘ f⁻¹)(x)               🝖[ _≡ₛ_ ]-[ inverseᵣ(f)(f⁻¹) ]
    x                          🝖-end

  -- The composition of functions is a function.
  [∘]-function : ∀{f : b → c}{g : a → b} → ⦃ func-f : Function(f) ⦄ → ⦃ func-g : Function(g) ⦄ → Function(f ∘ g)
  Function.congruence([∘]-function {f = f}{g = g}) = congruence₁(f) ∘ congruence₁(g)

module _
  {a₁ : Type{ℓₒ₁}} ⦃ equiv-a₁ : Equiv{ℓₑ₁}(a₁) ⦄
  {b₁ : Type{ℓₒ₂}} ⦃ equiv-b₁ : Equiv{ℓₑ₂}(b₁) ⦄
  {a₂ : Type{ℓₒ₃}} ⦃ equiv-a₂ : Equiv{ℓₑ₃}(a₂) ⦄
  {b₂ : Type{ℓₒ₄}} ⦃ equiv-b₂ : Equiv{ℓₑ₄}(b₂) ⦄
  {c  : Type{ℓₒ₅}} ⦃ equiv-c  : Equiv{ℓₑ₅}(c) ⦄
  {f : a₂ → b₂ → c}  ⦃ func-f : BinaryOperator(f) ⦄
  {g : a₁ → b₁ → a₂} ⦃ func-g : BinaryOperator(g) ⦄
  {h : a₁ → b₁ → b₂} ⦃ func-h : BinaryOperator(h) ⦄
  where

  [∘]-binaryOperator : BinaryOperator(x ↦ y ↦ f(g x y)(h x y))
  BinaryOperator.congruence [∘]-binaryOperator xy1 xy2 = congruence₂(f) (congruence₂(g) xy1 xy2) (congruence₂(h) xy1 xy2)

module _
  {a : Type{ℓₒ₁}} ⦃ equiv-a : Equiv{ℓₑ₁}(a) ⦄
  {b : Type{ℓₒ₂}} ⦃ equiv-b : Equiv{ℓₑ₂}(b) ⦄
  {f : a → a → b}  ⦃ func-f : BinaryOperator(f) ⦄
  where

  [$₂]-function : Function(f $₂_)
  Function.congruence [$₂]-function = congruence₂(f) $₂_

module _ {X : Type{ℓ₁}} {Y : Type{ℓ₂}} {Z : Type{ℓ₃}} where
  swap-involution : ⦃ _ : Equiv{ℓₑ}(X → Y → Z) ⦄ → ∀{f : X → Y → Z} → (swap(swap(f)) ≡ₛ f)
  swap-involution = reflexivity(_≡ₛ_)

  swap-involution-fn : ⦃ _ : Equiv{ℓₑ}((X → Y → Z) → (X → Y → Z)) ⦄ → (swap ∘ swap ≡ₛ id {T = X → Y → Z})
  swap-involution-fn = reflexivity(_≡ₛ_)

  swap-binaryOperator : ⦃ _ : Equiv{ℓₑ₁}(X) ⦄ ⦃ _ : Equiv{ℓₑ₂}(Y) ⦄ ⦃ _ : Equiv{ℓₑ₃}(Z) ⦄ → ∀{_▫_ : X → Y → Z} → ⦃ _ : BinaryOperator(_▫_) ⦄ → BinaryOperator(swap(_▫_))
  BinaryOperator.congruence (swap-binaryOperator {_▫_ = _▫_} ⦃ intro p ⦄) x₁y₁ x₂y₂ = p x₂y₂ x₁y₁

module _ {X : Type{ℓ₁}} {Y : Type{ℓ₂}} where
  s-combinator-const-id : ⦃ _ : Equiv{ℓₑ}(X → X) ⦄ → (_∘ₛ_ {X = X}{Y = Y → X}{Z = X} const const ≡ₛ id)
  s-combinator-const-id = reflexivity(_≡ₛ_)

module _ {X : Type{ℓ₁}} {Y : Type{ℓ₂}} {Z : Type{ℓ₃}} ⦃ equiv-z : Equiv{ℓₑ₃}(Z) ⦄ where
  s-combinator-const-eq : ∀{f}{a}{b} → (_∘ₛ_{X = X}{Y = Y}{Z = Z} f (const b) a ≡ₛ f a b)
  s-combinator-const-eq = reflexivity(_≡ₛ_)

{- TODO: Maybe this is unprovable because types. https://plato.stanford.edu/entries/axiom-choice/#AxiChoLog https://plato.stanford.edu/entries/axiom-choice/choice-and-type-theory.html https://en.wikipedia.org/wiki/Diaconescu%27s_theorem
module _ {fn-ext : FunctionExtensionality} where
  open import Function.Names
  open import Data.Boolean

  function-extensionality-to-classical : ∀{P} → (P ∨ (¬ P))
  function-extensionality-to-classical{P} = where
    A : Bool → Stmt
    A(x) = (P ∨ (x ≡ 𝐹))

    B : Bool → Stmt
    B(x) = (P ∨ (x ≡ 𝑇))

    C : (Bool → Stmt) → Stmt
    C(F) = (F ⊜ A) ∨ (F ⊜ B)
-}

module _ {X : Type{ℓₒ₁}} ⦃ eq-x : Equiv{ℓₑ₁}(X) ⦄ {Y : Type{ℓₒ₂}} ⦃ eq-y : Equiv{ℓₑ₂}(Y) ⦄ {Z : Type{ℓₒ₃}} ⦃ eq-z : Equiv{ℓₑ₃}(Z) ⦄ where
  open import Function.Equals
  open import Function.Equals.Proofs

  s-combinator-injective : Injective(_∘ₛ_ {X = X}{Y = Y}{Z = Z})
  _⊜_.proof (Injective.proof s-combinator-injective {f} {g} sxsy) {x} = Function.Equals.intro(\{a} → [⊜]-apply([⊜]-apply sxsy {const(a)}){x})

  s-combinator-inverseₗ : Inverseₗ(_∘ₛ_ {X = X}{Y = Y}{Z = Z})(f ↦ a ↦ b ↦ f (const b) a)
  _⊜_.proof (Inverseᵣ.proof s-combinator-inverseₗ) = reflexivity(_≡ₛ_)

module _ {A : Type{ℓ}} ⦃ equiv-A : Equiv{ℓₑ}(A) ⦄ where
  classical-constant-endofunction-existence : ⦃ classical : Classical(A) ⦄ → ∃{Obj = A → A}(Constant)
  classical-constant-endofunction-existence with excluded-middle(A)
  ... | [∨]-introₗ a  = [∃]-intro (const a)
  ... | [∨]-introᵣ na = [∃]-intro id ⦃ intro(\{a} → [⊥]-elim(na a)) ⦄

module _ {T : Type{ℓ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  open import Logic.Propositional.Theorems
  open import Structure.Operator.Properties

  proj₂ₗ-associativity : Associativity{T = T}(proj₂ₗ)
  proj₂ₗ-associativity = intro(reflexivity(_))

  proj₂ᵣ-associativity : Associativity{T = T}(proj₂ᵣ)
  proj₂ᵣ-associativity = intro(reflexivity(_))

  proj₂ₗ-identityₗ : ∀{id : T} → Identityₗ(proj₂ₗ)(id) ↔ (∀{x} → (Equiv._≡_ equiv id x))
  proj₂ₗ-identityₗ = [↔]-intro intro Identityₗ.proof

  proj₂ₗ-identityᵣ : ∀{id : T} → Identityᵣ(proj₂ₗ)(id)
  proj₂ₗ-identityᵣ = intro(reflexivity(_))

  proj₂ₗ-identity : ∀{id : T} → Identity(proj₂ₗ)(id) ↔ (∀{x} → (Equiv._≡_ equiv id x))
  proj₂ₗ-identity =
    [↔]-transitivity
      ([↔]-intro (l ↦ intro ⦃ left = l ⦄ ⦃ right = proj₂ₗ-identityᵣ ⦄) Identity.left)
      proj₂ₗ-identityₗ

  proj₂ᵣ-identityₗ : ∀{id : T} → Identityₗ(proj₂ᵣ)(id)
  proj₂ᵣ-identityₗ = intro(reflexivity(_))

  proj₂ᵣ-identityᵣ : ∀{id : T} → Identityᵣ(proj₂ᵣ)(id) ↔ (∀{x} → (Equiv._≡_ equiv id x))
  proj₂ᵣ-identityᵣ = [↔]-intro intro Identityᵣ.proof

  proj₂ᵣ-identity : ∀{id : T} → Identity(proj₂ᵣ)(id) ↔ (∀{x} → (Equiv._≡_ equiv id x))
  proj₂ᵣ-identity =
    [↔]-transitivity
      ([↔]-intro (r ↦ intro ⦃ left = proj₂ᵣ-identityₗ ⦄ ⦃ right = r ⦄) Identity.right)
      proj₂ᵣ-identityᵣ

module _ {T : Type{ℓₒ}} ⦃ equiv : Equiv{ℓₑ}(T) ⦄ where
  instance
    id-inversePair : InversePair{A = T}([↔]-reflexivity)
    id-inversePair = intro ⦃ left = intro(reflexivity(_≡ₛ_)) ⦄ ⦃ right = intro(reflexivity(_≡ₛ_)) ⦄

module _
  {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {p : A ↔ B}
  where

  sym-inversePair : ⦃ InversePair(p) ⦄ → InversePair([↔]-symmetry p)
  sym-inversePair = intro

module _
  {A : Type{ℓₒ₁}} ⦃ equiv-A : Equiv{ℓₑ₁}(A) ⦄
  {B : Type{ℓₒ₂}} ⦃ equiv-B : Equiv{ℓₑ₂}(B) ⦄
  {C : Type{ℓₒ₃}} ⦃ equiv-C : Equiv{ℓₑ₃}(C) ⦄
  {p₁ : A ↔ B} ⦃ func-p₁ₗ : Function([↔]-to-[←] p₁) ⦄
  {p₂ : B ↔ C} ⦃ func-p₂ᵣ : Function([↔]-to-[→] p₂) ⦄
  where

  trans-inversePair : ⦃ inv₁ : InversePair(p₁) ⦄ → ⦃ inv₂ : InversePair(p₂) ⦄ → InversePair([↔]-transitivity p₁ p₂)
  trans-inversePair = intro ⦃ left = [∘]-inverseᵣ {f = [↔]-to-[→] p₂} ⦄ ⦃ right = [∘]-inverseᵣ {f = [↔]-to-[←] p₁} ⦄


------------------------------------------------------------------------------
-- LTC-PCF terms properties
------------------------------------------------------------------------------

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

module LTC-PCF.Base.Properties where

open import LTC-PCF.Base

------------------------------------------------------------------------------
-- Congruence properties

·-leftCong : ∀ {m n o} → m ≡ n → m · o ≡ n · o
·-leftCong refl = refl

·-rightCong : ∀ {m n o} → n ≡ o → m · n ≡ m · o
·-rightCong refl = refl

succCong : ∀ {m n} → m ≡ n → succ₁ m ≡ succ₁ n
succCong refl = refl

predCong : ∀ {m n} → m ≡ n → pred₁ m ≡ pred₁ n
predCong refl = refl

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

S≢0 : ∀ {n} → succ₁ n ≢ zero
S≢0 S≡0 = 0≢S (sym S≡0)

-- We added Common.Relation.Binary.PropositionalEquality.cong, so this
-- theorem is not necessary.
-- x≡y→Sx≡Sy : ∀ {m n} → m ≡ n → succ₁ m ≡
-- succ₁ n x≡y→Sx≡Sy refl = refl


module _ where

record Structure : Set1 where
  infixl 20 _×_
  infix   8 _⟶_
  infixl 20 _,_
  infixr 40 _∘_

  infix 5 _~_

  field
    Type : Set
    _×_  : Type → Type → Type

    _⟶_ : Type → Type → Set
    _∘_ : ∀ {X Y Z} → Y ⟶ Z → X ⟶ Y → X ⟶ Z
    _,_ : ∀ {X A B} → X ⟶ A → X ⟶ B → X ⟶ A × B
    π₁  : ∀ {A B} → A × B ⟶ A
    π₂  : ∀ {A B} → A × B ⟶ B
    Op3 : ∀ {X} → X × X × X ⟶ X

    _~_ : ∀ {X Y} → X ⟶ Y → X ⟶ Y → Set

record Map {{C : Structure}} {{D : Structure}} : Set1 where
  open Structure {{...}}
  field
    Ty⟦_⟧ : Structure.Type C → Structure.Type D
    Tm⟦_⟧ : ∀ {X A} → X ⟶ A → Ty⟦ X ⟧ ⟶ Ty⟦ A ⟧

    ×-inv : ∀ {X A} → Ty⟦ X ⟧ × Ty⟦ A ⟧ ⟶ Ty⟦ X × A ⟧

    ⟦Op3⟧ : ∀ {X} → Tm⟦ Op3 {X = X} ⟧ ∘ ×-inv ∘ (×-inv ∘ (π₁ ∘ π₁ , π₂ ∘ π₁) , π₂) ~ Op3


module regex where

data Regex ( Σ : Set) : Set  where
  ε     : Regex Σ                -- empty
  φ     : Regex  Σ               -- fail
  _*    : Regex  Σ  → Regex  Σ
  _&_   : Regex  Σ  → Regex  Σ → Regex Σ
  _||_  : Regex  Σ  → Regex  Σ → Regex Σ
  <_>   : Σ → Regex  Σ

infixr 40 _&_ _||_


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

open import Symmetric
open import Data.Unit
open import Function.Inverse as Inverse using (_↔_; Inverse; _InverseOf_)
open import Function
open import Data.Nat hiding (_⊔_) -- using (ℕ; suc; zero)
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
open import Data.Fin.Permutation hiding (_∘ₚ_)

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

sym3solvable : solvable (Symmetric 3)
solvable.dervied-length sym3solvable = 2
solvable.end sym3solvable x d = solved1 x d where

   open import Data.List using ( List ; [] ; _∷_ )

   open Solvable (Symmetric 3)
   open import FLutil
   open import Data.List.Fresh hiding ([_])
   open import Relation.Nary using (⌊_⌋)

   p0id :  FL→perm ((# 0) :: ((# 0) :: ((# 0 ) :: f0))) =p= pid
   p0id = pleq _ _ refl

   open import Data.List.Fresh.Relation.Unary.Any
   open import FLComm

   stage3FList : CommFListN 3 2 ≡ cons (zero :: zero :: zero :: f0) [] (Level.lift tt)
   stage3FList = refl

   solved1 :  (x : Permutation 3 3) → deriving 2 x → x =p= pid
   solved1 x dr = CommSolved 3 x ( CommFListN 3 2 ) stage3FList p0id solved2 where
      solved2 : Any (perm→FL x ≡_) ( CommFListN 3 2 )
      solved2 = CommStage→ 3 2 x dr


------------------------------------------------------------------------------
-- The gcd is commutative
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.GCD.Total.CommutativeI where

open import Common.FOL.Relation.Binary.EqReasoning

open import FOTC.Base
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.EliminationPropertiesI
open import FOTC.Data.Nat.Inequalities.PropertiesI
open import FOTC.Data.Nat.PropertiesI
open import FOTC.Program.GCD.Total.ConversionRulesI
open import FOTC.Program.GCD.Total.GCD

------------------------------------------------------------------------------
-- Informal proof:
-- 1. gcd 0 n = n        -- gcd def
--            = gcd n 0  -- gcd def

-- 2. gcd n 0 = n        -- gcd def
--            = gcd 0 n  -- gcd def

-- 3.1. Case: S m > S n
-- gcd (S m) (S n) = gcd (S m - S n) (S n)  -- gcd def
--                 = gcd (S n) (S m - S n)  -- IH
--                 = gcd (S n) (S m)        -- gcd def

-- 3.2. Case: S m ≮ S n
-- gcd (S m) (S n) = gcd (S m) (S n - S m)  -- gcd def
--                 = gcd (S n - S m) (S m)  -- IH
--                 = gcd (S n) (S m)        -- gcd def

------------------------------------------------------------------------------
-- Commutativity property.
Comm : D → D → Set
Comm t t' = gcd t t' ≡ gcd t' t
{-# ATP definition Comm #-}

x>y→y≯x : ∀ {m n} → N m → N n → m > n → n ≯ m
x>y→y≯x nzero          Nn             0>n   = ⊥-elim (0>x→⊥ Nn 0>n)
{-# CATCHALL #-}
x>y→y≯x Nm             nzero          _     = 0≯x Nm
x>y→y≯x (nsucc {m} Nm) (nsucc {n} Nn) Sm>Sn =
  trans (lt-SS m n) (x>y→y≯x Nm Nn (trans (sym (lt-SS n m)) Sm>Sn))

postulate x≯Sy→Sy>x : ∀ {m n} → N m → N n → m ≯ succ₁ n → succ₁ n > m
-- x≯Sy→Sy>x {n = n} nzero      Nn _ = <-0S n
-- x≯Sy→Sy>x {n = n} (nsucc {m} Nm) Nn h = {!!}

------------------------------------------------------------------------------
-- gcd 0 0 is commutative.
gcd-00-comm : Comm zero zero
gcd-00-comm = refl

------------------------------------------------------------------------------
-- gcd (succ₁ n) 0 is commutative.
gcd-S0-comm : ∀ n → Comm (succ₁ n) zero
gcd-S0-comm n = trans (gcd-S0 n) (sym (gcd-0S n))

------------------------------------------------------------------------------
-- gcd (succ₁ m) (succ₁ n) when succ₁ m > succ₁ n is commutative.
gcd-S>S-comm : ∀ {m n} → N m → N n →
               Comm (succ₁ m ∸ succ₁ n) (succ₁ n) →
               succ₁ m > succ₁ n →
               Comm (succ₁ m) (succ₁ n)
gcd-S>S-comm {m} {n} Nm Nn ih Sm>Sn =
  gcd (succ₁ m) (succ₁ n)
    ≡⟨ gcd-S>S m n Sm>Sn ⟩
  gcd (succ₁ m ∸ succ₁ n) (succ₁ n)
    ≡⟨ ih ⟩
  gcd (succ₁ n) (succ₁ m ∸ succ₁ n)
    ≡⟨ sym (gcd-S≯S n m (x>y→y≯x (nsucc Nm) (nsucc Nn) Sm>Sn)) ⟩
  gcd (succ₁ n) (succ₁ m) ∎

------------------------------------------------------------------------------
-- gcd (succ₁ m) (succ₁ n) when succ₁ m ≯ succ₁ n is commutative.
gcd-S≯S-comm : ∀ {m n} → N m → N n →
               Comm (succ₁ m) (succ₁ n ∸ succ₁ m) →
               succ₁ m ≯ succ₁ n →
               Comm (succ₁ m) (succ₁ n)
gcd-S≯S-comm {m} {n} Nm Nn ih Sm≯Sn =
  gcd (succ₁ m) (succ₁ n)
    ≡⟨ gcd-S≯S m n Sm≯Sn ⟩
  gcd (succ₁ m) (succ₁ n ∸ succ₁ m)
    ≡⟨ ih ⟩
  gcd (succ₁ n ∸ succ₁ m) (succ₁ m)
    ≡⟨ sym (gcd-S>S n m (x≯Sy→Sy>x (nsucc Nm) Nn Sm≯Sn)) ⟩
  gcd (succ₁ n) (succ₁ m) ∎

------------------------------------------------------------------------------
-- gcd m n when m > n is commutative.
gcd-x>y-comm :
  ∀ {m n} → N m → N n →
  (∀ {o p} → N o → N p → Lexi o p m n → Comm o p) →
  m > n →
  Comm m n
gcd-x>y-comm nzero          Nn             _  0>n   = ⊥-elim (0>x→⊥ Nn 0>n)
gcd-x>y-comm (nsucc {n} _)  nzero          _  _     = gcd-S0-comm n
gcd-x>y-comm (nsucc {m} Nm) (nsucc {n} Nn) ah Sm>Sn = gcd-S>S-comm Nm Nn ih Sm>Sn
  where
  -- Inductive hypothesis.
  ih : Comm (succ₁ m ∸ succ₁ n) (succ₁ n)
  ih = ah {succ₁ m ∸ succ₁ n}
          {succ₁ n}
          (∸-N (nsucc Nm) (nsucc Nn))
          (nsucc Nn)
          ([Sx∸Sy,Sy]<[Sx,Sy] Nm Nn)

------------------------------------------------------------------------------
-- gcd m n when m ≯ n is commutative.
gcd-x≯y-comm :
  ∀ {m n} → N m → N n →
  (∀ {o p} → N o → N p → Lexi o p m n → Comm o p) →
  m ≯ n →
  Comm m n
gcd-x≯y-comm nzero          nzero          _  _     = gcd-00-comm
gcd-x≯y-comm nzero          (nsucc {n} _)  _  _     = sym (gcd-S0-comm n)
gcd-x≯y-comm (nsucc _)      nzero          _  Sm≯0  = ⊥-elim (S≯0→⊥ Sm≯0)
gcd-x≯y-comm (nsucc {m} Nm) (nsucc {n} Nn) ah Sm≯Sn = gcd-S≯S-comm Nm Nn ih Sm≯Sn
  where
  -- Inductive hypothesis.
  ih : Comm (succ₁ m) (succ₁ n ∸ succ₁ m)
  ih = ah {succ₁ m}
          {succ₁ n ∸ succ₁ m}
          (nsucc Nm)
          (∸-N (nsucc Nn) (nsucc Nm))
          ([Sx,Sy∸Sx]<[Sx,Sy] Nm Nn)

------------------------------------------------------------------------------
-- gcd is commutative.
gcd-comm : ∀ {m n} → N m → N n → Comm m n
gcd-comm = Lexi-wfind A h
  where
  A : D → D → Set
  A i j = Comm i j

  h : ∀ {i j} → N i → N j → (∀ {k l} → N k → N l → Lexi k l i j → A k l) →
      A i j
  h Ni Nj ah = case (gcd-x>y-comm Ni Nj ah)
                    (gcd-x≯y-comm Ni Nj ah)
                    (x>y∨x≯y Ni Nj)


module Data.List.Properties.Extra {a}{A : Set a} where

open import Data.Nat
open import Data.Fin hiding (_<_)
open import Data.List
open import Data.Product hiding (map)
open import Data.Fin using (fromℕ≤; zero; suc)
open import Data.List.Relation.Unary.All hiding (map; lookup; _[_]≔_)
open import Data.List.Relation.Unary.Any hiding (map; lookup)
open import Data.List.Membership.Propositional

open import Data.List.Relation.Binary.Pointwise hiding (refl; map)
open import Relation.Binary.PropositionalEquality

∈-∷ʳ : ∀ (l : List A)(x : A) → x ∈ (l ∷ʳ x)
∈-∷ʳ [] x = here refl
∈-∷ʳ (x ∷ l) y = there (∈-∷ʳ l y)

infixl 10 _[_]≔_
_[_]≔_ : (l : List A) → Fin (length l) → A → List A
[] [ () ]≔ x
(x ∷ xs) [ zero ]≔ x' = x' ∷ xs
(x ∷ xs) [ suc i ]≔ y = x ∷ xs [ i ]≔ y

infixl 10 _[_]≔'_
_[_]≔'_ : ∀ {x} → (l : List A) → x ∈ l → A → List A
[] [ () ]≔' y
(x ∷ l) [ here px ]≔' y = y ∷ l
(x ∷ l) [ there px ]≔' y = x ∷ (l [ px ]≔' y)

≔'-[]= :  ∀ {x}{l : List A} (p : x ∈ l) → ∀ {y} → y ∈ (l [ p ]≔' y)
≔'-[]= (here px) = here refl
≔'-[]= (there p) = there (≔'-[]= p)

drop-prefix : ∀ (l m : List A) → drop (length l) (l ++ m) ≡ m
drop-prefix [] m = refl
drop-prefix (x ∷ l) m = drop-prefix l m


module RenamingAndSubstitution where

open import Library
open import Syntax
open ≡-Reasoning

infixr 4 _,_

------------------------------------------------------------------------
-- Renaming
------------------------------------------------------------------------

-- Renamings from Γ to Δ are snoc-lists of variables living in Δ,
-- one for each entry in Γ.

data Ren (Δ : Cxt) : (Γ : Cxt) → Set where
  ε   : Ren Δ ε
  _,_ : ∀ {Γ a} (ρ : Ren Δ Γ) (x : Var Δ a) → Ren Δ (Γ , a)

-- A renaming in  Ren Δ Γ  is a code for a
-- renaming function in  Var Γ ∙→ Var Δ.

lookr : ∀{Γ Δ} → Ren Δ Γ → ∀ {σ} → Var Γ σ → Var Δ σ
lookr (xs , x) zero    = x
lookr (xs , x) (suc i) = lookr xs i

-- Weaking a renaming by increasing all variables by 1.
-- This lets them live in the extended context Γ , σ.

wkr : ∀{Γ Δ σ} → Ren Γ Δ → Ren (Γ , σ) Δ
wkr ε        = ε
wkr (xs , x) = wkr xs , suc x

-- Lifting a renaming to go under a binder.

liftr : ∀{Γ Δ σ} → Ren Γ Δ → Ren (Γ , σ) (Δ , σ)
liftr xs = wkr xs , zero

-- The category of renamings (operations only).
------------------------------------------------------------------------

-- The identity renaming.

renId : ∀{Γ} → Ren Γ Γ
renId {ε}     = ε
renId {Γ , _} = liftr (renId {Γ})

-- Forward composition of renamings.

renComp : ∀{Φ Γ Δ} → Ren Δ Γ → Ren Γ Φ → Ren Δ Φ
renComp xs ε        = ε
renComp xs (ys , y) = renComp xs ys , lookr xs y

-- Various combinations of renamings.
------------------------------------------------------------------------

-- Weakening a renaming acts behaves like
-- post-composing the renaming function with successor.

lookrwkr : ∀{Γ Δ σ τ}(xs : Ren Δ Γ)(i : Var Γ σ) →
           lookr (wkr {σ = τ} xs) i ≡ suc (lookr xs i)
lookrwkr (xs , _) zero    = refl
lookrwkr (xs , _) (suc i) = lookrwkr xs i

-- A weakning cancels a renaming extension.

lemrr : ∀{Φ Γ Δ σ}(xs : Ren Φ Γ)(x : Var Φ σ)(ys : Ren Γ Δ) →
       renComp (xs , x) (wkr ys) ≡ renComp xs ys
lemrr xs x ε        = refl
lemrr xs x (ys , y) = cong (_, lookr xs y) (lemrr xs x ys)

-- Associativity of renaming composition in case the first
-- renaming is a weakening.

wkrcomp : ∀{Φ Γ Δ σ}(xs : Ren Φ Γ)(ys : Ren Γ Δ) →
  renComp (wkr {σ = σ} xs) ys ≡ wkr {σ = σ} (renComp xs ys)
wkrcomp xs ε        = refl
wkrcomp xs (ys , y) = cong₂ _,_ (wkrcomp xs ys) (lookrwkr xs y)

-- Composition of liftings is a lifting.

liftrcomp : ∀{Φ Γ Δ σ}(xs : Ren Φ Γ)(ys : Ren Γ Δ) →
  renComp (liftr {σ = σ} xs) (liftr {σ = σ} ys) ≡ liftr {σ = σ} (renComp xs ys)
liftrcomp xs ys = begin
  renComp (wkr xs , zero) (wkr ys) , zero  ≡⟨ cong (_, zero) (lemrr (wkr xs) zero ys) ⟩
  renComp (wkr xs) ys              , zero  ≡⟨ cong (_, zero) (wkrcomp xs ys) ⟩
  wkr (renComp xs ys)              , zero  ∎

-- lookr is a morphism from the category  Ren
-- to the category of the corresponding renaming functions on variables.
------------------------------------------------------------------------

-- The identity renaming corresponds to the identity function.

lookrid : ∀{Γ σ}(x : Var Γ σ) → lookr renId x ≡ x
lookrid zero    = refl
lookrid (suc x) = begin
  lookr (wkr renId) x  ≡⟨ lookrwkr renId x ⟩
  suc (lookr renId x)  ≡⟨ cong suc (lookrid x) ⟩
  suc x                ∎

-- A composition of renamings corresponds to the composition
-- of the corresponding renaming functions.

lookrcomp : ∀{Φ Γ Δ}(f : Ren Δ Γ)(g : Ren Γ Φ){σ}(i : Var Φ σ) →
            lookr (renComp f g) i ≡ (lookr f ∘ lookr g) i
lookrcomp f (g , v) zero = refl
lookrcomp f (g , v) (suc i) = lookrcomp f g i

-- Laws for the category of renamings.
------------------------------------------------------------------------

-- Left identity of forward composition

lidr : ∀{Φ Γ}(xs : Ren Φ Γ) → renComp renId xs ≡ xs
lidr ε        = refl
lidr (xs , x) = cong₂ _,_ (lidr xs) (lookrid x)

-- Right identity of forward composition

ridr : ∀{Φ Γ}(xs : Ren Φ Γ) → renComp xs renId ≡ xs
ridr {Γ = ε}     ε  = refl
ridr {Γ = Γ , σ} (xs , x) = begin
  renComp (xs , x) (wkr renId) , x  ≡⟨ cong (_, x) (lemrr xs x renId) ⟩
  renComp xs renId             , x  ≡⟨ cong (_, x) (ridr xs) ⟩
  xs                           , x  ∎

-- Renaming of terms.
------------------------------------------------------------------------

-- Renaming in a term.

ren : ∀{Γ Δ} → Ren Δ Γ → ∀ {σ} → Tm Γ σ → Tm Δ σ
ren xs (var x)   = var (lookr xs x)
ren xs (abs t)   = abs (ren (liftr xs) t)
ren xs (app t u) = app (ren xs t) (ren xs u)

-- ren is a morphism from Ren
-- to the corresponding category of renaming functions on terms.

renid : ∀{Γ σ}(t : Tm Γ σ) → ren renId t ≡ t
renid (var x)   = cong var (lookrid x)
renid (abs t)   = cong abs (renid t)
renid (app t u) = cong₂ app (renid t) (renid u)

rencomp : ∀ {Φ Γ Δ}(f : Ren Δ Γ)(g : Ren Γ Φ){σ}(t : Tm Φ σ) →
            ren (renComp f g) t ≡ (ren f ∘ ren g) t
rencomp f g (var x)   = cong var (lookrcomp f g x)
rencomp f g (abs t)   = begin
  abs (ren (liftr (renComp f g))         t)   ≡⟨ cong (λ xs → abs $ ren xs t) (sym $ liftrcomp f g) ⟩
  abs (ren (renComp (liftr f) (liftr g)) t)   ≡⟨ cong abs (rencomp (liftr f) (liftr g) t) ⟩
  abs (ren (liftr f) (ren (liftr g) t))       ∎
rencomp f g (app t u) = cong₂ app (rencomp f g t) (rencomp f g u)

-- Weakening a term.

weak : ∀{Γ b} a → Tm Γ b → Tm (Γ , a) b
weak a = ren (wkr renId)

-- Renaming of normal forms.
------------------------------------------------------------------------

mutual
  rennf : ∀{Γ Δ} → Ren Γ Δ → ∀{a} → Nf Δ a → Nf Γ a
  rennf α (ne t)   = ne (rennen α t)
  rennf α (abs t)  = abs (rennf (liftr α) t)

  rennen : ∀{Γ Δ} → Ren Γ Δ → ∀{a} → Ne Δ a → Ne Γ a
  rennen α (var x) = var (lookr α x)
  rennen α (app n x) = app (rennen α n) (rennf α x)

------------------------------------------------------------------------
-- Substitution
------------------------------------------------------------------------

data Sub (Δ : Cxt) : (Γ : Cxt) → Set where
  ε   : Sub Δ ε
  _,_ : ∀ {Γ a} (ρ : Sub Δ Γ) (v : Tm Δ a) → Sub Δ (Γ , a)

ren2sub : ∀{Γ Δ} → Ren Γ Δ → Sub Γ Δ
ren2sub ε        = ε
ren2sub (xs , x) = ren2sub xs , var x

looks : ∀{Γ Δ} → Sub Δ Γ → ∀ {σ} → Var Γ σ → Tm Δ σ
looks (xs , x) zero    = x
looks (xs , x) (suc i) = looks xs i

wks : ∀{Γ Δ σ} → Sub Γ Δ → Sub (Γ , σ) Δ
wks ε        = ε
wks (xs , x) = wks xs , ren (wkr renId) x

lifts : ∀{Γ Δ σ} → Sub Γ Δ → Sub (Γ , σ) (Δ , σ)
lifts xs = wks xs , var zero

sub : ∀{Γ Δ} → Sub Δ Γ → ∀{σ} → Tm Γ σ → Tm Δ σ
sub xs (var x)   = looks xs x
sub xs (abs t)   = abs (sub (lifts xs) t)
sub xs (app t u) = app (sub xs t) (sub xs u)

subId : ∀{Γ} → Sub Γ Γ
subId {ε}     = ε
subId {Γ , _} = lifts (subId {Γ})

subComp : ∀{Φ Γ Δ} → Sub Δ Γ → Sub Γ Φ → Sub Δ Φ
subComp xs ε        = ε
subComp xs (ys , y) = subComp xs ys , sub xs y

-- Substitute the last variable

sub0 : ∀{Γ a b} → Tm (Γ , a) b → Tm Γ a → Tm Γ b
sub0 t u = sub (subId , u) t

-- Substitution laws

lookswks : ∀{Γ Δ σ τ}(i : Var Γ σ)(xs : Sub Δ Γ) →
           looks (wks {σ = τ} xs) i ≡ ren (wkr {σ = τ} renId) (looks xs i)
lookswks zero    (xs , _) = refl
lookswks (suc i) (xs , _) = lookswks i xs

lemsr : ∀{Φ Γ Δ σ}(xs : Sub Φ Γ)(x : Tm Φ σ)(ys : Ren Γ Δ) →
        subComp (xs , x) (ren2sub (wkr ys)) ≡ subComp xs (ren2sub ys)
lemsr xs x ε        = refl
lemsr xs x (ys , y) = cong (λ zs → zs , looks xs y) (lemsr xs x ys)

lookslookr : ∀{Φ Γ Δ}(f : Sub Δ Γ)(g : Ren Γ Φ){σ}(x : Var Φ σ) →
            looks (subComp f (ren2sub g)) x ≡ looks f (lookr g x)
lookslookr f (g , _) zero    = refl
lookslookr f (g , _) (suc x) = lookslookr f g x

wksrcomp : ∀{Φ Γ Δ σ}(xs : Sub Φ Γ)(ys : Ren Γ Δ) →
  subComp (wks {σ = σ} xs) (ren2sub ys) ≡ wks {σ = σ} (subComp xs (ren2sub ys))
wksrcomp xs ε        = refl
wksrcomp xs (ys , y) = cong₂ Sub._,_ (wksrcomp xs ys) (lookswks y xs)

liftsrcomp : ∀{Φ Γ Δ σ}(xs : Sub Φ Γ)(ys : Ren Γ Δ) →
             subComp (lifts {σ = σ} xs) (ren2sub (liftr ys)) ≡ lifts {σ = σ} (subComp xs (ren2sub ys))
liftsrcomp xs ys = begin
  subComp (wks xs , var zero) (ren2sub (wkr ys)) , var zero ≡⟨ cong (_, var zero) (lemsr (wks xs) (var zero) ys) ⟩
  subComp (wks xs) (ren2sub ys)                  , var zero ≡⟨ cong (_, var zero) (wksrcomp xs ys) ⟩
  wks (subComp xs (ren2sub ys))                  , var zero ∎

subren : ∀{Φ Γ Δ}(f : Sub Δ Γ)(g : Ren Γ Φ){σ}(t : Tm Φ σ) →
         (sub f ∘ ren g) t ≡ sub (subComp f (ren2sub g)) t
subren f g (var x)   = sym $ lookslookr f g x
subren f g (abs t)   = begin
  abs (sub (lifts f) (ren (liftr g) t))               ≡⟨ cong abs $ subren (lifts f) (liftr g) t ⟩
  abs (sub (subComp (lifts f) (ren2sub (liftr g))) t) ≡⟨ cong (λ f → abs (sub f t)) $ liftsrcomp f g ⟩
  abs (sub (lifts (subComp f (ren2sub g))) t)         ∎
subren f g (app t u) = cong₂ app (subren f g t) (subren f g u)

looksid : ∀{Γ σ}(x : Var Γ σ) → looks subId x ≡ var x
looksid zero    = refl
looksid (suc x) = begin
  looks (wks subId) x             ≡⟨ lookswks x subId ⟩
  ren (wkr renId) (looks subId x) ≡⟨ cong (ren (wkr renId)) (looksid x) ⟩
  ren (wkr renId) (var x)         ≡⟨⟩
  var (lookr (wkr renId) x)       ≡⟨ cong var $ lookrwkr renId x ⟩
  var (suc (lookr renId x))       ≡⟨ cong (λ x → var (suc x)) (lookrid x) ⟩ -- using ∘ makes it go yellow
  var (suc x)                     ∎

subid : ∀{Γ σ}(t : Tm Γ σ) → sub subId t ≡ t
subid (var x)   = looksid x
subid (abs t)   = cong abs (subid t)
subid (app t u) = cong₂ app (subid t) (subid u)

sidl : ∀{Φ Γ}(xs : Sub Φ Γ) → subComp subId xs ≡ xs
sidl ε        = refl
sidl (xs , t) = cong₂ _,_ (sidl xs) (subid t)

sidr2 : ∀{Φ Γ}(xs : Sub Φ Γ) → subComp xs (ren2sub renId) ≡ xs
sidr2 {Γ = ε} ε            = refl
sidr2 {Γ = Γ , a} (xs , x) = begin
  subComp (xs , x) (ren2sub (wkr renId)) , x ≡⟨ cong (_, x) (lemsr xs x renId) ⟩
  subComp xs (ren2sub renId)             , x ≡⟨ cong (_, x) (sidr2 xs) ⟩
  xs                                     , x ∎

liftSubRen : ∀{Γ Δ a b} (f : Sub Δ Γ) (t : Tm Γ b)
  → sub (lifts f) (weak a t) ≡ sub (wks f) t
liftSubRen {a = a} f t = begin
  sub (lifts f) (weak a t)  ≡⟨ subren (lifts f) (wkr renId) t ⟩
  sub (subComp (lifts f) (ren2sub (wkr renId))) t ≡⟨ cong (λ f' → sub f' t) (lemsr (wks f) (var zero) renId) ⟩
  sub (subComp (wks f) (ren2sub renId)) t ≡⟨ cong (λ f' → sub f' t) (sidr2 (wks f)) ⟩
  sub (wks f) t ∎

lemss : ∀{Φ Γ Δ σ}(xs : Sub Φ Γ)(x : Tm Φ σ)(ys : Sub Γ Δ) →
        subComp (xs , x) (wks ys) ≡ subComp xs ys
lemss xs x ε        = refl
lemss xs x (ys , y) = begin
  subComp (xs , x) (wks ys) , sub (xs , x) (ren (wkr renId) y)               ≡⟨ cong₂ _,_ (lemss xs x ys) (subren (xs , x) (wkr renId) y) ⟩
  subComp xs       ys       , sub (subComp (xs , x) (ren2sub (wkr renId))) y ≡⟨ cong (λ g → subComp xs ys , sub g y) (lemsr xs x renId) ⟩
  subComp xs       ys       , sub (subComp xs       (ren2sub renId))       y ≡⟨ cong (λ g → subComp xs ys , sub g y) (sidr2 xs) ⟩
  subComp xs       ys       , sub xs                                       y ∎

ren2sublook : ∀{Γ Δ σ}(f : Ren Δ Γ)(i : Var Γ σ) →
              var (lookr f i) ≡ looks (ren2sub f) i
ren2sublook (f , _) zero    = refl
ren2sublook (f , _) (suc i) = ren2sublook f i

ren2subwk : ∀{Γ Δ σ}(g : Ren Δ Γ) →
            ren2sub (wkr {σ = σ} g) ≡ wks {σ = σ} (ren2sub g)
ren2subwk ε       = refl
ren2subwk (g , x) = begin
  (ren2sub (wkr g) , var (suc x))               ≡⟨ cong₂ (λ xs x → xs , var (suc x)) (ren2subwk g) (sym $ lookrid x) ⟩
  (wks (ren2sub g) , var (suc (lookr renId x))) ≡⟨ cong (λ x → wks (ren2sub g) , var x) (sym $ lookrwkr renId x) ⟩
  (wks (ren2sub g) , var (lookr (wkr renId) x)) ∎

ren2sublift : ∀{Γ Δ σ}(g : Ren Δ Γ) →
            ren2sub (liftr {σ = σ} g) ≡ lifts {σ = σ} (ren2sub g)
ren2sublift g = cong (_, var zero) (ren2subwk g)

ren2subren : ∀{Γ Δ σ}(f : Ren Δ Γ)(t : Tm Γ σ) → ren f t ≡ sub (ren2sub f) t
ren2subren f (var x)   = ren2sublook f x
ren2subren f (abs t)   = begin
  abs (ren (liftr f) t)               ≡⟨ cong abs (ren2subren (liftr f) t) ⟩
  abs (sub (ren2sub (liftr f)) t)     ≡⟨ cong (λ f → abs (sub f t)) (ren2sublift f) ⟩
  abs (sub (lifts (ren2sub f)) t) ∎
ren2subren f (app t u) = cong₂ app (ren2subren f t) (ren2subren f u)

wkrscomp : ∀{Φ Γ Δ σ}(xs : Ren Φ Γ)(ys : Sub Γ Δ) →
  subComp (ren2sub (wkr {σ = σ} xs)) ys ≡ wks {σ = σ} (subComp (ren2sub xs) ys)
wkrscomp xs ε        = refl
wkrscomp xs (ys , y) = begin
  subComp (ren2sub (wkr xs)) ys , sub (ren2sub (wkr xs)) y                 ≡⟨ cong₂ _,_ (wkrscomp xs ys) (sym $ ren2subren (wkr xs) y) ⟩
  wks (subComp (ren2sub xs) ys) , ren (wkr xs) y                           ≡⟨ cong (λ f → wks (subComp (ren2sub xs) ys) , ren (wkr f) y) (sym $ lidr xs) ⟩
  wks (subComp (ren2sub xs) ys) , ren (wkr (renComp renId xs))  y          ≡⟨ cong (λ f → wks (subComp (ren2sub xs) ys) , ren f y) (sym $ wkrcomp renId xs) ⟩
  wks (subComp (ren2sub xs) ys) , ren (renComp (wkr renId)  xs) y          ≡⟨ cong (wks (subComp (ren2sub xs) ys) ,_) (rencomp (wkr renId) xs y) ⟩
  wks (subComp (ren2sub xs) ys) , ren (wkr renId) (ren xs y)               ≡⟨ cong (λ t → wks (subComp (ren2sub xs) ys) , ren (wkr renId) t) (ren2subren xs y)  ⟩
  wks (subComp (ren2sub xs) ys) , ren (wkr renId) (sub (ren2sub xs) y)     ∎

liftrscomp : ∀{Φ Γ Δ σ}(xs : Ren Φ Γ)(ys : Sub Γ Δ) →
  subComp (ren2sub (liftr {σ = σ} xs)) (lifts ys) ≡ lifts {σ = σ} (subComp (ren2sub xs) ys)
liftrscomp xs ys = begin
  (subComp (ren2sub (wkr xs) , var zero) (wks ys) , var zero) ≡⟨ cong (_, var zero) (lemss (ren2sub (wkr xs)) (var zero) ys) ⟩
  (subComp (ren2sub (wkr xs)) ys                  , var zero) ≡⟨ cong (_, var zero) (wkrscomp xs ys) ⟩
  (wks (subComp (ren2sub xs) ys)                  , var zero) ∎

renlooks : ∀{Φ Γ Δ}(f : Ren Δ Γ)(g : Sub Γ Φ){σ}(x : Var Φ σ) →
         (ren f ∘ looks g) x ≡ looks (subComp (ren2sub f) g) x
renlooks f (_ , v) zero    = ren2subren f v
renlooks f (g , _) (suc x) = renlooks f g x

rensub : ∀{Φ Γ Δ}(f : Ren Δ Γ)(g : Sub Γ Φ){σ}(t : Tm Φ σ) →
         (ren f ∘ sub g) t ≡ sub (subComp (ren2sub f) g) t
rensub f g (var x) = renlooks f g x
rensub f g (abs t) = begin
  abs (ren (liftr f) (sub (lifts g) t))               ≡⟨ cong abs $ rensub (liftr f) (lifts g) t ⟩
  abs (sub (subComp (ren2sub (liftr f)) (lifts g)) t) ≡⟨ cong (λ f → abs (sub f t)) (liftrscomp f g) ⟩
  abs (sub (lifts (subComp (ren2sub f) g)) t)         ∎
rensub f g (app t u) = cong₂ app (rensub f g t) (rensub f g u)

lookscomp : ∀{Φ Γ Δ}(f : Sub Δ Γ)(g : Sub Γ Φ){σ}(x : Var Φ σ) →
            looks (subComp f g) x ≡ sub f (looks g x)
lookscomp f (g , _) zero    = refl
lookscomp f (g , _) (suc x) = lookscomp f g x

ren2subid : ∀{Γ} → subId {Γ} ≡ ren2sub renId
ren2subid {ε}     = refl
ren2subid {Γ , a} = begin
  (wks subId           , var zero) ≡⟨ cong (λ f → wks f , var zero) (ren2subid {Γ}) ⟩
  (wks (ren2sub renId) , var zero) ≡⟨ cong (_, var zero) (sym $ ren2subwk renId) ⟩
  (ren2sub (wkr renId) , var zero) ∎

wksscomp : ∀{Φ Γ Δ σ}(xs : Sub Φ Γ)(ys : Sub Γ Δ) →
  subComp (wks {σ = σ} xs) ys ≡ wks {σ = σ} (subComp xs ys)
wksscomp xs ε        = refl
wksscomp xs (ys , y) = begin
  subComp (wks xs) ys , sub (wks xs)                           y ≡⟨ cong (λ f → subComp (wks xs) ys , sub (wks f) y) (sym $ sidl xs) ⟩
  subComp (wks xs) ys , sub (wks (subComp subId xs))           y ≡⟨ cong₂ _,_ (wksscomp xs ys) (cong (λ f → sub (wks (subComp f xs)) y) ren2subid) ⟩
  wks (subComp xs ys) , sub (wks (subComp (ren2sub renId) xs)) y ≡⟨ cong (λ f → wks (subComp xs ys) , sub f y) (sym $ wkrscomp renId xs) ⟩
  wks (subComp xs ys) , sub (subComp (ren2sub (wkr renId)) xs) y ≡⟨ cong (wks (subComp xs ys) ,_) (sym $ rensub (wkr renId) xs y) ⟩
  wks (subComp xs ys) , ren (wkr renId) (sub xs y)               ∎

sidr : ∀{Φ Γ}(xs : Sub Φ Γ) → subComp xs subId ≡ xs
sidr xs = begin
  subComp xs subId           ≡⟨ cong (subComp xs) ren2subid ⟩
  subComp xs (ren2sub renId) ≡⟨ sidr2 xs ⟩
  xs                         ∎

liftscomp : ∀{Φ Γ Δ σ}(xs : Sub Φ Γ)(ys : Sub Γ Δ) →
  subComp (lifts {σ = σ} xs) (lifts ys) ≡ lifts {σ = σ} (subComp xs ys)
liftscomp xs ys = begin
  subComp (wks xs , var zero) (wks ys) , var zero ≡⟨ cong (_, var zero) (lemss (wks xs) (var zero) ys) ⟩
  subComp (wks xs) ys                  , var zero ≡⟨ cong (_, var zero) (wksscomp xs ys) ⟩
  wks (subComp xs ys)                  , var zero ∎

subcomp : ∀{Φ Γ Δ}(f : Sub Δ Γ)(g : Sub Γ Φ){σ}(t : Tm Φ σ) →
          sub (subComp f g) t ≡ (sub f ∘ sub g) t
subcomp f g (var x)   = lookscomp f g x
subcomp f g (abs t)   = begin
  abs (sub (lifts (subComp f g)) t)         ≡⟨ cong (λ f → abs (sub f t)) (sym $ liftscomp f g) ⟩
  abs (sub (subComp (lifts f) (lifts g)) t) ≡⟨ cong abs (subcomp (lifts f) (lifts g) t) ⟩
  abs (sub (lifts f) (sub (lifts g) t))     ∎
subcomp f g (app t u) = cong₂ app (subcomp f g t) (subcomp f g u)

--

mutual
  renembNe : ∀{Γ Δ a}(u : Ne Γ a)(σ : Ren Δ Γ) →
             ren σ (embNe u) ≡ embNe (rennen σ u)
  renembNe (var x)   σ = refl
  renembNe (app u n) σ = cong₂ app (renembNe u σ) (renembNf n σ)

  renembNf : ∀{Γ Δ a}(n : Nf Γ a)(σ : Ren Δ Γ) →
             ren σ (embNf n) ≡ embNf (rennf σ n)
  renembNf (abs n) σ = cong abs (renembNf n (liftr σ))
  renembNf (ne n)  σ = renembNe n σ
-- -}


------------------------------------------------------------------------------
-- Exclusive disjunction theorems
------------------------------------------------------------------------------

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

module FOL.ExclusiveDisjunction.TheoremsATP where

-- The theorems below are valid on intuitionistic logic and with an
-- empty domain.
open import FOL.Base hiding ( D≢∅ ; pem )
open import FOL.ExclusiveDisjunction.Base

------------------------------------------------------------------------------
-- We postulate some propositional formulae (which are translated as
-- 0-ary predicates).
postulate P Q : Set

-- We do not use the _⊻_ operator because its definition is not a
-- FOL-definition.

postulate
  p⊻q→p→¬q : ((P ∨ Q) ∧ ¬ (P ∧ Q)) → P → ¬ Q
{-# ATP prove p⊻q→p→¬q #-}

postulate
  p⊻q→q→¬p : ((P ∨ Q) ∧ ¬ (P ∧ Q)) → Q → ¬ P
{-# ATP prove p⊻q→q→¬p #-}

postulate
  p⊻q→¬p→q : ((P ∨ Q) ∧ ¬ (P ∧ Q)) → ¬ P → Q
{-# ATP prove p⊻q→¬p→q #-}

postulate
  p⊻q→¬q→p : ((P ∨ Q) ∧ ¬ (P ∧ Q)) → ¬ Q → P
{-# ATP prove p⊻q→¬q→p #-}

postulate
  ¬[p⊻q] : ¬ ((P ∨ Q) ∧ ¬ (P ∧ Q)) → ((P ∧ Q) ∨ (¬ P ∧ ¬ Q))
{-# ATP prove ¬[p⊻q] #-}


module nats where

open import Data.Nat

ten : ℕ
ten = 10