Agda: sketch proof that foldGroup is indeed an homomorphism

I should fill in too many lemmas to make this go through.

Old-commit-hash: 5c3e9a678d7df2110bcc23ec8b1c432ec461e97e

module FoldableBag where

open import FoldableBagParametric
import Level as L

open import Algebra
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

import Data.Nat as N
import Data.Integer as Z

open import Data.Bool
open import Data.Maybe
open import Data.List as List using (List)

open import Data.Product

-- Note that hom is what I call foldGroup elsewhere!

-- This is the mathematical definition of group homomorphism. This is mostly
-- annoying to prove because one can't write the blackboard definition directly
-- (since bags are not freely generated).
homIsAnHom : ∀ {T} {{oT : Ord T}} G f (b₁ b₂ : Bag T) → let open AbelianGroup G in
  hom G f (union b₁ b₂) ≡ hom G f b₁ ∙ hom G f b₂
homIsAnHom {{oT}} G f (b⁺₁ , b⁻₁) (b⁺₂ , b⁻₂) =
  begin
    hom G f (union (b⁺₁ , b⁻₁) (b⁺₂ , b⁻₂))
  ≡⟨⟩
    hom G f (uunion b⁺₁ b⁺₂ , uunion b⁻₁ b⁻₂)
  -- TODO: Lots of straightforward group manipulation
  ≡⟨ {!!} ⟩
     hom G f (b⁺₁ , b⁻₁) ∙ hom G f (b⁺₂ , b⁻₂)
  ∎
   where
     open AbelianGroup G
     open ≡-Reasoning
     open import Data.List.Properties
     open import Sorting

     open Sort ord hiding (insert; toList)

-- Simplest possible definition of the derivative of hom (in the semantic domain).

homDelta : ∀ {T} {{oT : Ord T}} → (G : AbelianGroup L.zero L.zero) → let U = AbelianGroup.Carrier G in (T → U) → Bag T → ΔBag T → U
homDelta G f b db = hom G f db

-- This states that the derivative

homDeltaCorrect : ∀ G f b db → let open AbelianGroup G in
  hom G f (union b db) ≡ hom G f b ∙ homDelta G f b db
homDeltaCorrect G f b db =
  begin
    hom G f (union b db)
  ≡⟨  homIsAnHom G f b db  ⟩
    hom G f b ∙ hom G f db
  ≡⟨⟩
    hom G f b ∙ homDelta G f b db
  ∎
  where
    open AbelianGroup G
    open ≡-Reasoning
    open import Data.List.Properties

--postulate BagGroup :  ∀ {T} (oT : Ord T) → AbelianGroup L.zero L.zero

map₁ : ∀ {A B} {oA : Ord A} {oB : Ord B} → (A → B) → Bag A → Bag B
map₁ f = hom BagGroup (singleton ∘ f)

flatMap : ∀ {A B} {oA : Ord A} {oB : Ord B} → (A → Bag B) → Bag A → Bag B
flatMap f = hom BagGroup f

-- Use instance arguments for Ord.

filter : ∀ {A} {oA : Ord A} → (A → Bool) → Bag A → Bag A
filter p b = hom BagGroup (λ el → if (p el) then (singleton el) else empty) b

{-
TODOs:

 * Express basic functions using hom:
   remove
   ...

 * State and prove the main theorems. Define changes on bags (as bags first?),
   then the derivative of hom, then write the correctness theorem.

-}

{-
postulate Bag : Set → Set

hom : let B =  AbelianGroup.Carrier G in ∀ {A} → (A → B) → Bag A → B
hom = {!!}
-}

-- Whoops², that's hard to implement. Let's just postulate it.
--map₀ = {!T.map!}

-- map : ({k : Key} → Value k → Value k) → Tree → Tree
-- map f (tree t) = tree $ Indexed.map f t

-- _∈?_ : Key → Tree → Bool
-- k ∈? t = maybeToBool (lookup k t)

------------------------------------------------
-- Elimination forms for trees
------------------------------------------------

-- -- Naive implementations of union.

-- unionWith : (∀ {k} → Value k → Value k → Value k) →
--             -- Left → right → result.
--             Tree → Tree → Tree

-- union : Tree → Tree → Tree
-- union = unionWith const

-- unionsWith : (∀ {k} → Value k → Value k → Value k) → List Tree → Tree

-- -- Left-biased.

-- unions : List Tree → Tree
-- unions = unionsWith const

module FoldableBag where

open import FoldableBagParametric
import Level as L

open import Algebra
open import Function
open import Relation.Binary
open import Relation.Binary.PropositionalEquality

import Data.Nat as N
import Data.Integer as Z

open import Data.Bool
open import Data.Maybe
open import Data.List as List using (List)

open import Data.Product

-- Simplest possible definition of the derivative of hom (in the semantic domain).

homDelta : ∀ {T} {{oT : Ord T}} → (G : AbelianGroup L.zero L.zero) → let U = AbelianGroup.Carrier G in (T → U) → Bag T → ΔBag T → U
homDelta G f b db = hom G f db

-- This states that the derivative

homDeltaCorrect : ∀ G f b db → let open AbelianGroup G in
  hom G f (union b db) ≡ hom G f b ∙ homDelta G f b db
homDeltaCorrect G f b db =
  begin
    hom G f (union b db)
  ≡⟨ {!!} ⟩
    hom G f b ∙ hom G f db
  ≡⟨⟩
    hom G f b ∙ homDelta G f b db
  ∎
  where
    open AbelianGroup G
    open ≡-Reasoning
    open import Data.List.Properties

--postulate BagGroup :  ∀ {T} (oT : Ord T) → AbelianGroup L.zero L.zero

map₁ : ∀ {A B} {oA : Ord A} {oB : Ord B} → (A → B) → Bag A → Bag B
map₁ f = hom BagGroup (singleton ∘ f)

flatMap : ∀ {A B} {oA : Ord A} {oB : Ord B} → (A → Bag B) → Bag A → Bag B
flatMap f = hom BagGroup f

-- Use instance arguments for Ord.

filter : ∀ {A} {oA : Ord A} → (A → Bool) → Bag A → Bag A
filter p b = hom BagGroup (λ el → if (p el) then (singleton el) else empty) b

{-
TODOs:

 * Express basic functions using hom:
   remove
   ...

 * State and prove the main theorems. Define changes on bags (as bags first?),
   then the derivative of hom, then write the correctness theorem.

-}

{-
postulate Bag : Set → Set

hom : let B =  AbelianGroup.Carrier G in ∀ {A} → (A → B) → Bag A → B
hom = {!!}
-}

-- Whoops², that's hard to implement. Let's just postulate it.
--map₀ = {!T.map!}

-- map : ({k : Key} → Value k → Value k) → Tree → Tree
-- map f (tree t) = tree $ Indexed.map f t

-- _∈?_ : Key → Tree → Bool
-- k ∈? t = maybeToBool (lookup k t)

------------------------------------------------
-- Elimination forms for trees
------------------------------------------------

-- -- Naive implementations of union.

-- unionWith : (∀ {k} → Value k → Value k → Value k) →
--             -- Left → right → result.
--             Tree → Tree → Tree

-- union : Tree → Tree → Tree
-- union = unionWith const

-- unionsWith : (∀ {k} → Value k → Value k → Value k) → List Tree → Tree

-- -- Left-biased.

-- unions : List Tree → Tree
-- unions = unionsWith const


improved proof for leq-trans

improved proof for leq-trans

data Bool : Set where
  true  : Bool
  false : Bool

not : Bool → Bool
not true = false
not false = true

data ℕ : Set where
  O : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
O   + a = a
S a + b = S (a + b)

_*_ : ℕ → ℕ → ℕ
O   * a = O
S a * b = a + (a * b)

_or_ : Bool → Bool → Bool
true  or _ = true
false or b = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

infixl 60 _*_
infixl 40 _+_
infixr 20 _or_
infix  5 if_then_else_

infixr 40 _::_
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

_∘_ : {A : Set} -> {B : A -> Set} -> {C : (x : A) -> B x -> Set} ->
      (f : {x : A} -> (y : B x) -> C x y) -> (g : (x : A) -> B x) ->
      (x : A) -> C x (g x)
_∘_ f g a = f (g a)

plus-two = S ∘ S

map : {A B : Set} -> (A -> B) -> List A -> List B
map f []        = []
map f (x :: xs) = f x :: map f xs

_++_ : {A : Set} -> List A -> List A -> List A
[]      ++ ys = ys
x :: xs ++ ys = x :: (xs ++ ys)

data Vec (A : Set) : ℕ -> Set where
  nil  : Vec A O
  cons : (n : ℕ) -> A -> Vec A n -> Vec A (S n)

head : {A : Set} {n : ℕ} -> Vec A (S n) -> A
head (cons n v vs) = v

vmap : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap .O f nil = nil
vmap .(S n) f (cons n x xs) = cons n (f x) (vmap n f xs)

vmap′ : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap′ O f nil = nil
vmap′ (S n) f (cons .n x xs) = cons n (f x) (vmap n f xs)

data Fin : ℕ -> Set where
  fzero : {n : ℕ} -> Fin (S n)
  fsuc  : {n : ℕ} -> Fin n -> Fin (S n)

_!_ : {n : ℕ}{A : Set} -> Vec A n -> Fin n -> A
nil ! ()
cons n x a ! fzero = x
cons n x a ! fsuc b = a ! b

tabulate : {n : ℕ}{A : Set} -> (Fin n -> A) -> Vec A n
tabulate {O} f = nil
tabulate {S n} f = cons n (f fzero) (tabulate (f ∘ fsuc))

data   False : Set where
record True  : Set where

trivial : True
trivial = _

isTrue : Bool -> Set
isTrue true  = True
isTrue false = False

_<_ : ℕ -> ℕ -> Bool
_   < O   = false
O   < S n = true
S m < S n = m < n

length : {A : Set} -> List A -> ℕ
length [] = O
length (x :: xs) = S (length xs)

lookup : {A : Set}(xs : List A)(n : ℕ) -> isTrue (n < length xs) -> A
lookup (x :: xs) O b = x
lookup (x :: xs) (S n) b = lookup xs n b
lookup [] a ()

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

data _≤_ : ℕ -> ℕ -> Set where
  ≤O : {m n : ℕ} -> m == n -> m ≤ n
  ≤I : {m n : ℕ} -> m ≤  n -> m ≤ S n

leq-trans : {l m n : ℕ} -> l ≤ m -> m ≤ n -> l ≤ n
leq-trans a (≤O refl) = a
leq-trans a (≤I b)    = ≤I (leq-trans a b)

data Bool : Set where
  true  : Bool
  false : Bool

not : Bool → Bool
not true = false
not false = true

data ℕ : Set where
  O : ℕ
  S : ℕ → ℕ

_+_ : ℕ → ℕ → ℕ
O   + a = a
S a + b = S (a + b)

_*_ : ℕ → ℕ → ℕ
O   * a = O
S a * b = a + (a * b)

_or_ : Bool → Bool → Bool
true  or _ = true
false or b = b

if_then_else_ : {A : Set} → Bool → A → A → A
if true  then x else y = x
if false then x else y = y

infixl 60 _*_
infixl 40 _+_
infixr 20 _or_
infix  5 if_then_else_

infixr 40 _::_
data List (A : Set) : Set where
  []   : List A
  _::_ : A -> List A -> List A

_∘_ : {A : Set} -> {B : A -> Set} -> {C : (x : A) -> B x -> Set} ->
      (f : {x : A} -> (y : B x) -> C x y) -> (g : (x : A) -> B x) ->
      (x : A) -> C x (g x)
_∘_ f g a = f (g a)

plus-two = S ∘ S

map : {A B : Set} -> (A -> B) -> List A -> List B
map f []        = []
map f (x :: xs) = f x :: map f xs

_++_ : {A : Set} -> List A -> List A -> List A
[]      ++ ys = ys
x :: xs ++ ys = x :: (xs ++ ys)

data Vec (A : Set) : ℕ -> Set where
  nil  : Vec A O
  cons : (n : ℕ) -> A -> Vec A n -> Vec A (S n)

head : {A : Set} {n : ℕ} -> Vec A (S n) -> A
head (cons n v vs) = v

vmap : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap .O f nil = nil
vmap .(S n) f (cons n x xs) = cons n (f x) (vmap n f xs)

vmap′ : {A B : Set} (n : ℕ) -> (A -> B) -> Vec A n -> Vec B n
vmap′ O f nil = nil
vmap′ (S n) f (cons .n x xs) = cons n (f x) (vmap n f xs)

data Fin : ℕ -> Set where
  fzero : {n : ℕ} -> Fin (S n)
  fsuc  : {n : ℕ} -> Fin n -> Fin (S n)

_!_ : {n : ℕ}{A : Set} -> Vec A n -> Fin n -> A
nil ! ()
cons n x a ! fzero = x
cons n x a ! fsuc b = a ! b

tabulate : {n : ℕ}{A : Set} -> (Fin n -> A) -> Vec A n
tabulate {O} f = nil
tabulate {S n} f = cons n (f fzero) (tabulate (f ∘ fsuc))

data   False : Set where
record True  : Set where

trivial : True
trivial = _

isTrue : Bool -> Set
isTrue true  = True
isTrue false = False

_<_ : ℕ -> ℕ -> Bool
_   < O   = false
O   < S n = true
S m < S n = m < n

length : {A : Set} -> List A -> ℕ
length [] = O
length (x :: xs) = S (length xs)

lookup : {A : Set}(xs : List A)(n : ℕ) -> isTrue (n < length xs) -> A
lookup (x :: xs) O b = x
lookup (x :: xs) (S n) b = lookup xs n b
lookup [] a ()

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

data _≤_ : ℕ -> ℕ -> Set where
  ≤O : {m n : ℕ} -> m == n -> m ≤ n
  ≤I : {m n : ℕ} -> m ≤  n -> m ≤ S n

leq-trans : {l m n : ℕ} -> l ≤ m -> m ≤ n -> l ≤ n
leq-trans (≤O refl) b = b
leq-trans a (≤O refl) = a
leq-trans (≤I a) (≤I b) = ≤I (leq-trans (≤I a) b)


Fixed a misplaced importation.

Fixed a misplaced importation.

Ignore-this: f44340563188fa12e9b79aed8492deab

darcs-hash:20120228152056-3bd4e-143ebb2d8b0da74339da12c68888ca6a759c6afe.gz

------------------------------------------------------------------------------
-- FOL (without equality)
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- This module exported all the logical constants and the
-- propositional equality. This module is re-exported by the "base"
-- modules whose theories are defined on FOL (without equality)

module FOL.FOL where

------------------------------------------------------------------------------
-- The propositional logical connectives

-- 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.
open import FOL.Data.Empty public using ( ⊥ ; ⊥-elim )
open import FOL.Data.Product public using ( _∧_ ; _,_ ; ∧-proj₁ ; ∧-proj₂ )
open import FOL.Data.Sum public using ( _∨_ ; [_,_] ; inj₁ ; inj₂ )
open import FOL.Data.Unit public using ( ⊤ )
open import FOL.Relation.Nullary public using ( ¬_ )

infixr 2 _↔_

_↔_ : Set → Set → Set
P ↔ Q = (P → Q) ∧ (Q → P)

------------------------------------------------------------------------------
-- The quantifiers

-- The existential quantifier
-- The existential quantifier is hard-coded in our translation,
-- i.e. the symbol ∃ must be used.

open import FOL.Data.Product public using ( _,,_ ; ∃ ; ∃-elim )

-- The universal quantifier
-- N.B. For the universal quantifier we use the Agda (dependent)
-- function type.

------------------------------------------------------------------------------
-- FOL (without equality)
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- This module exported all the logical constants and the
-- propositional equality. This module is re-exported by the "base"
-- modules whose theories are defined on FOL (without equality)

module FOL.FOL where

------------------------------------------------------------------------------
-- The propositional logical connectives

-- 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.
open import FOL.Data.Empty public using ( ⊥ ; ⊥-elim )
open import FOL.Data.Product public using ( _∧_ ; _,_ ; _,,_ ; ∧-proj₁ ; ∧-proj₂ )
open import FOL.Data.Sum public using ( _∨_ ; [_,_] ; inj₁ ; inj₂ )
open import FOL.Data.Unit public using ( ⊤ )
open import FOL.Relation.Nullary public using ( ¬_ )

infixr 2 _↔_

_↔_ : Set → Set → Set
P ↔ Q = (P → Q) ∧ (Q → P)

------------------------------------------------------------------------------
-- The quantifiers

-- The existential quantifier
-- The existential quantifier is hard-coded in our translation,
-- i.e. the symbol ∃ must be used.

open import FOL.Data.Product public using ( _,_ ; ∃ ; ∃-elim )

-- The universal quantifier
-- N.B. For the universal quantifier we use the Agda (dependent)
-- function type.


Example 3 works noŵ¹.
̂¹ Other than that the `Bag` type is an abstract postulate.

A presentation of example 3 starts from line 297.

The optimized derivation `derive2` considers the derivative of
a term to be the nil change only if it is closed. Should we have
β-equivalence test or some inherited description of whether the
argument to an abs-term may change, we could handle more examples.

Old-commit-hash: 6488c110b93dc4c760ddc61feef198b55ab4940d

{-
Communicate to derivatives that changes to certain arguments
are always nil (i. e., certain arguments are stable).
-}

module ExplicitNil where

open import TaggedDeltaTypes

open import Data.Nat
open import Data.Bool
open import Data.Sum hiding (map)
open import Data.Product hiding (map)
open import Data.Unit using (⊤ ; tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
open import Relation.Binary.Core using (Decidable)
open import Relation.Nullary.Core using (yes ; no)

ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))
  where ext = extensionality

proj-H : ∀ {Γ : Context} {ρ : ΔEnv Γ} {us vs} →
  Honest ρ (FV-union us vs) → Honest ρ us × Honest ρ vs
proj-H {∅} {us = ∅} {vs = ∅} clearly = clearly , clearly
proj-H {us = alter us} {alter vs} (alter H) =
  let uss , vss = proj-H H in alter uss , alter vss
proj-H {us = alter us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  alter uss , abide eq vss
proj-H {us = abide us} {alter vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , alter vss
proj-H {us = abide us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , abide eq vss

-- Equivalence proofs are unique
equivalence-unique : ∀ {A : Set} {a b : A} → ∀ {p q : a ≡ b} → p ≡ q
equivalence-unique {p = refl} {refl} = refl

-- Product of singletons are singletons (for example)
product-unique : ∀ {A : Set} {B : A → Set} →
  (∀ {a b : A} → a ≡ b) →
  (∀ {a : A} {c d : B a} → c ≡ d) →
  (∀ {p q : Σ A B} → p ≡ q)
product-unique {A} {B} lhs rhs {a , c} {b , d}
  rewrite lhs {a} {b} = cong (_,_ b) rhs

-- Validity proofs are (extensionally) unique (as functions)
validity-unique : ∀ {τ} {v : ⟦ τ ⟧} {dv : ΔVal τ} →
  ∀ {p q : valid v dv} → p ≡ q
validity-unique {nats} = equivalence-unique
validity-unique {bags} = refl
validity-unique {σ ⇒ τ} =  ext³ (λ v dv R[v,dv] →
  product-unique validity-unique equivalence-unique)

stabilityVar : ∀ {τ Γ} {x : Var Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (select-just x)) →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (ignore ρ)

stabilityVar {x = this} (abide proof _) = proof
stabilityVar {x = that y} (alter H) = stabilityVar {x = y} H

stability : ∀ {τ Γ} {t : Term Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV t)) →
    ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted t)
  ≡ ⟦ t ⟧ (ignore ρ)

-- Boilerplate begins
stabilityAbs : ∀ {σ τ Γ} {t : Term (σ • Γ) τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV (abs t))) →
  (v : ⟦ σ ⟧) →
    ⟦ t ⟧ (v • ignore ρ) ⊕
    ⟦ derive t ⟧Δ (cons v (v ⊝ v) R[v,u⊝v] ρ) (unrestricted t)
  ≡ ⟦ t ⟧ (v • ignore ρ)
stabilityAbs {t = t} {ρ} H v with FV t | inspect FV t
... | abide vars | [ case0 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case0 = abide v⊕[u⊝v]=u H
... | alter vars | [ case1 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case1 = alter H
-- Boilerplate ends

stability {t = nat n} H = refl
stability {t = bag b} H = b++∅=b
stability {t = var x} H = stabilityVar H
stability {t = abs t} {ρ} H = extensionality (stabilityAbs {t = t} H)
stability {t = app s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    v = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
  in
    begin
      f v ⊕ df v dv (validity {t = t})
    ≡⟨ sym (corollary s t) ⟩
      (f ⊕ df) (v ⊕ dv)
    ≡⟨ stability {t = s} Hs ⟨$⟩ stability {t = t} Ht ⟩
      f v
    ∎ where open ≡-Reasoning
stability {t = add s t} H =
  let Hs , Ht = proj-H H
  in cong₂ _+_ (stability {t = s} Hs) (stability {t = t} Ht)
stability {t = map s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
    map = mapBag
  in
  begin
    map f b ⊕ (map (f ⊕ df) (b ⊕ db) ⊝ map f b)
  ≡⟨ b++[d\\b]=d ⟩
    map (f ⊕ df) (b ⊕ db)
  ≡⟨ cong₂ map (stability {t = s} Hs) (stability {t = t} Ht) ⟩
    map f b
  ∎ where open ≡-Reasoning

eq-map : ∀ {Γ}
  (s    : Term Γ (nats ⇒ nats))
  (t    : Term Γ bags)
  (ρ    : ΔEnv Γ)
  (H    : Honest ρ (FV s)) →
    ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
  ≡ ⟦ Δmap₀ s (derive s) t (derive t) ⟧Δ ρ (unrestricted (map s t))

eq-map s t ρ H =
  let
    ds = derive s
    dt = derive t
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ (unrestricted s)
    dv = ⟦ dt ⟧Δ ρ (unrestricted t)

    eq1 : ⟦ Δmap₀ s ds t dt ⟧Δ ρ (unrestricted (map s t))
        ≡ mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
    eq1 = refl

    eq2 : mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
        ≡ mapBag f dv
    eq2 = trans
      (cong (λ hole → hole ⊝ mapBag f v) (trans
        (cong (λ hole → mapBag hole (v ⊕ dv)) (stability {t = s} H))
        map-over-++))
      [b++d]\\b=d

    eq3 : mapBag f dv
        ≡ ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
    eq3 = refl

  in sym (trans eq1 (trans eq2 eq3))

-- Vars test
none-selected? : ∀ {Γ} → (vs : Vars Γ) → (vs ≡ select-none) ⊎ ⊤
none-selected? ∅ = inj₁ refl
none-selected? (abide vs) = inj₂ tt
none-selected? (alter vs) with none-selected? vs
... | inj₁ vs=∅ rewrite vs=∅ = inj₁ refl
... | inj₂ _ = inj₂ tt

closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ select-none) ⊎ ⊤
closed? t = none-selected? (FV t)

vacuous-honesty : ∀ {Γ} {ρ : ΔEnv Γ} → Honest ρ select-none
vacuous-honesty {∅} {∅} = clearly
vacuous-honesty {τ • Γ} {cons _ _ _ ρ} = alter (vacuous-honesty {ρ = ρ})

-- Immunity of closed terms to dishonest environments
immune : ∀ {τ Γ} {t : Term Γ τ} →
  (FV t ≡ select-none) → ∀ {ρ} → Honest ρ (FV t)
immune {t = t} eq rewrite eq = vacuous-honesty

-- Ineffectual first optimization step
derive1 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive1 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive t)
... | inj₂ tt = derive (map s t)
derive1 others = derive others

valid1 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive1 t is-valid-for ρ
valid1 (nat n) = tt
valid1 (bag b) = tt
valid1 (var x) = tt
valid1 (abs t) = λ _ _ _ → unrestricted t
valid1 (app s t) =
  cons (unrestricted s) (unrestricted t) (validity {t = t}) tt
valid1 (add s t) =
  cons (unrestricted s) (unrestricted t) tt tt
valid1 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (unrestricted s) (unrestricted t) tt tt
... | inj₁ if-closed =
  cons (unrestricted t) (immune {t = s} if-closed) tt tt

correct1 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive1 t ⟧Δ ρ (valid1 t) ≡ ⟦ derive t ⟧Δ ρ (unrestricted t)

correct1 {t = nat n} = refl
correct1 {t = bag b} = refl
correct1 {t = var x} = refl
correct1 {t = abs t} = refl
correct1 {t = app s t} = refl
correct1 {t = add s t} = refl
correct1 {t = map s t} {ρ} with closed? s
... | inj₂ tt = refl
... | inj₁ if-closed = eq-map s t ρ (immune {t = s} if-closed)

-- derive2 = derive1 + congruence
derive2 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive2 (abs t) = Δabs (derive2 t)
derive2 (app s t) = Δapp (derive2 s) t (derive2 t)
derive2 (add s t) = Δadd (derive2 s) (derive2 t)
derive2 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive2 t)
... | inj₂ tt = Δmap₀ s (derive2 s) t (derive2 t)
derive2 others = derive others

valid2 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive2 t is-valid-for ρ
correct2 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive2 t ⟧Δ ρ (valid2 t) ≡ ⟦ derive t ⟧Δ ρ (unrestricted t)

valid2 (nat n) = tt
valid2 (bag b) = tt
valid2 (var x) = tt
valid2 (abs t) = λ _ _ _ → valid2 t
valid2 (app s t) {ρ} = cons (valid2 s) (valid2 t) V tt
  where
  V : valid (⟦ t ⟧ (ignore ρ)) (⟦ derive2 t ⟧Δ ρ (valid2 t))
  V rewrite correct2 {t = t} {ρ} = validity {t = t} {ρ}
valid2 (add s t) = cons (valid2 s) (valid2 t) tt tt
valid2 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (valid2 s) (valid2 t) tt tt
... | inj₁ if-closed =
  cons (valid2 t) (immune {t = s} if-closed) tt tt

correct2 {t = nat n} = refl
correct2 {t = bag b} = refl
correct2 {t = var x} = refl
correct2 {t = abs t} = ext³ (λ _ _ _ → correct2 {t = t})
correct2 {t = app {σ} {τ} s t} {ρ} = ≅-to-≡ eq-all where
  open import Relation.Binary.HeterogeneousEquality hiding (cong₂)
  import Relation.Binary.HeterogeneousEquality as HET
  df0 : ΔVal (σ ⇒ τ)
  df0 = ⟦ derive s ⟧Δ ρ (unrestricted s)
  df2 : ΔVal (σ ⇒ τ)
  df2 = ⟦ derive2 s ⟧Δ ρ (valid2 s)
  dv0 : ΔVal σ
  dv0 = ⟦ derive t ⟧Δ ρ (unrestricted t)
  dv2 : ΔVal σ
  dv2 = ⟦ derive2 t ⟧Δ ρ (valid2 t)
  v   : ⟦ σ ⟧
  v   = ⟦ t ⟧ (ignore ρ)
  eq-df : df2 ≡ df0
  eq-df = correct2 {t = s}
  eq-dv : dv2 ≡ dv0
  eq-dv = correct2 {t = t}
  eq-all : df2 v dv2 (caddr (valid2 (app s t) {ρ}))
         ≅ df0 v dv0 (validity {t = t} {ρ})
  eq-all rewrite eq-dv = HET.cong
    (λ hole → hole v dv0 (validity {t = t} {ρ})) (≡-to-≅ eq-df)
    -- found without intuition by trial-and-error
correct2 {t = add s t} {ρ} =
  let
    cs = correct2 {t = s} {ρ}
    ct = correct2 {t = t} {ρ}
  in cong₂ _,_ (cong₂ _+_ (cong proj₁ cs) (cong proj₁ ct))
               (cong₂ _+_ (cong proj₂ cs) (cong proj₂ ct))
correct2 {t = map s t} {ρ} with closed? s
... | inj₂ tt =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
  in
    cong₂ (λ h1 h2 → mapBag (f ⊕ h1) (b ⊕ h2) \\ mapBag f b)
    (correct2 {t = s}) (correct2 {t = t})
... | inj₁ if-closed = trans
  (cong (mapBag (⟦ s ⟧ (ignore ρ))) (correct2 {t = t}))
  (eq-map s t ρ (immune {t = s} if-closed))

---------------
-- Example 3 --
---------------

-- [+1] = λ x → x + 1
[+1] : ∀ {Γ} → Term Γ (nats ⇒ nats)
[+1] = (abs (add (var this) (nat 1)))

-- inc = λ bag → map [+1] bag
inc : Term ∅ (bags ⇒ bags)
inc = abs (map [+1] (var this))

-- Program transformation in example 3
-- Sadly, `inc` is not executable, for `Bag` is an abstract type
-- whose existence we postulated.
--
-- derive2 inc = λ bag dbag → map [+1] dbag
example-3 : derive2 inc ≡ Δabs (Δmap₁ [+1] (Δvar this))
example-3 = refl

-- Correctness of optimized derivation on `inc`
--
-- ⟦ derive2 inc ⟧ <embedded-proof> = ⟦ derive inc ⟧ <another-proof>
example-3-correct :
  ⟦ derive2 inc ⟧Δ ∅ (valid2 inc) ≡ ⟦ derive inc ⟧Δ ∅ (unrestricted inc)
example-3-correct = correct2 {t = inc} {∅}

{-
Communicate to derivatives that changes to certain arguments
are always nil (i. e., certain arguments are stable).
-}

module ExplicitNil where

open import TaggedDeltaTypes

open import Data.Nat
open import Data.Bool
open import Data.Sum hiding (map)
open import Data.Product hiding (map)
open import Data.Unit using (⊤ ; tt)
open import Relation.Binary.PropositionalEquality
open import Relation.Binary using
  (Reflexive ; Transitive ; Preorder ; IsPreorder)
open import Relation.Binary.Core using (Decidable)
open import Relation.Nullary.Core using (yes ; no)

ext³ : ∀
  {A : Set}
  {B : A → Set}
  {C : (a : A) → B a → Set }
  {D : (a : A) → (b : B a) → C a b → Set}
  {f g : (a : A) → (b : B a) → (c : C a b) → D a b c} →
  ((a : A) (b : B a) (c : C a b) → f a b c ≡ g a b c) → f ≡ g

ext³ fabc=gabc = ext (λ a → ext (λ b → ext (λ c → fabc=gabc a b c)))
  where ext = extensionality

proj-H : ∀ {Γ : Context} {ρ : ΔEnv Γ} {us vs} →
  Honest ρ (FV-union us vs) → Honest ρ us × Honest ρ vs
proj-H {∅} {us = ∅} {vs = ∅} clearly = clearly , clearly
proj-H {us = alter us} {alter vs} (alter H) =
  let uss , vss = proj-H H in alter uss , alter vss
proj-H {us = alter us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  alter uss , abide eq vss
proj-H {us = abide us} {alter vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , alter vss
proj-H {us = abide us} {abide vs} (abide eq H) =
  let uss , vss = proj-H H in
  abide eq uss , abide eq vss

stabilityVar : ∀ {τ Γ} {x : Var Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (select-just x)) →
  ⟦ x ⟧ (ignore ρ) ⊕ ⟦ x ⟧ΔVar ρ ≡ ⟦ x ⟧ (ignore ρ)

stabilityVar {x = this} (abide proof _) = proof
stabilityVar {x = that y} (alter H) = stabilityVar {x = y} H

stability : ∀ {τ Γ} {t : Term Γ τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV t)) →
    ⟦ t ⟧ (ignore ρ) ⊕ ⟦ derive t ⟧Δ ρ (unrestricted t)
  ≡ ⟦ t ⟧ (ignore ρ)

-- Boilerplate begins
stabilityAbs : ∀ {σ τ Γ} {t : Term (σ • Γ) τ} →
  ∀ {ρ : ΔEnv Γ} (H : Honest ρ (FV (abs t))) →
  (v : ⟦ σ ⟧) →
    ⟦ t ⟧ (v • ignore ρ) ⊕
    ⟦ derive t ⟧Δ (cons v (v ⊝ v) R[v,u⊝v] ρ) (unrestricted t)
  ≡ ⟦ t ⟧ (v • ignore ρ)
stabilityAbs {t = t} {ρ} H v with FV t | inspect FV t
... | abide vars | [ case0 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case0 = abide v⊕[u⊝v]=u H
... | alter vars | [ case1 ] = stability {t = t} Ht
  where
  Ht : Honest (cons v (v ⊝ v) R[v,u⊝v] ρ) (FV t)
  Ht rewrite case1 = alter H
-- Boilerplate ends

stability {t = nat n} H = refl
stability {t = bag b} H = b++∅=b
stability {t = var x} H = stabilityVar H
stability {t = abs t} {ρ} H = extensionality (stabilityAbs {t = t} H)
stability {t = app s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    v = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    dv = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
  in
    begin
      f v ⊕ df v dv (validity {t = t})
    ≡⟨ sym (corollary s t) ⟩
      (f ⊕ df) (v ⊕ dv)
    ≡⟨ stability {t = s} Hs ⟨$⟩ stability {t = t} Ht ⟩
      f v
    ∎ where open ≡-Reasoning
stability {t = add s t} H =
  let Hs , Ht = proj-H H
  in cong₂ _+_ (stability {t = s} Hs) (stability {t = t} Ht)
stability {t = map s t} {ρ} H =
  let
    f = ⟦ s ⟧ (ignore ρ)
    b = ⟦ t ⟧ (ignore ρ)
    df = ⟦ derive s ⟧Δ ρ (unrestricted s)
    db = ⟦ derive t ⟧Δ ρ (unrestricted t)
    Hs , Ht = proj-H H
    map = mapBag
  in
  begin
    map f b ⊕ (map (f ⊕ df) (b ⊕ db) ⊝ map f b)
  ≡⟨ b++[d\\b]=d ⟩
    map (f ⊕ df) (b ⊕ db)
  ≡⟨ cong₂ map (stability {t = s} Hs) (stability {t = t} Ht) ⟩
    map f b
  ∎ where open ≡-Reasoning

eq-map : ∀ {Γ}
  (s    : Term Γ (nats ⇒ nats))
  (t    : Term Γ bags)
  (ρ    : ΔEnv Γ)
  (H    : Honest ρ (FV s)) →
    ⟦ Δmap₀ s (derive s) t (derive t) ⟧Δ ρ (unrestricted (map s t))
  ≡ ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)

eq-map s t ρ H =
  let
    ds = derive s
    dt = derive t
    f  = ⟦ s ⟧ (ignore ρ)
    v  = ⟦ t ⟧ (ignore ρ)
    df = ⟦ ds ⟧Δ ρ (unrestricted s)
    dv = ⟦ dt ⟧Δ ρ (unrestricted t)

    eq1 : ⟦ Δmap₀ s ds t dt ⟧Δ ρ (unrestricted (map s t))
        ≡ mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
    eq1 = refl

    eq2 : mapBag (f ⊕ df) (v ⊕ dv) ⊝ mapBag f v
        ≡ mapBag f dv
    eq2 = trans
      (cong (λ hole → hole ⊝ mapBag f v) (trans
        (cong (λ hole → mapBag hole (v ⊕ dv)) (stability {t = s} H))
        map-over-++))
      [b++d]\\b=d

    eq3 : mapBag f dv
        ≡ ⟦ Δmap₁ s (derive t) ⟧Δ ρ (cons (unrestricted t) H tt tt)
    eq3 = refl

  in trans eq1 (trans eq2 eq3)

-- Vars test
none-selected? : ∀ {Γ} → (vs : Vars Γ) → (vs ≡ select-none) ⊎ ⊤
none-selected? ∅ = inj₁ refl
none-selected? (abide vs) = inj₂ tt
none-selected? (alter vs) with none-selected? vs
... | inj₁ vs=∅ rewrite vs=∅ = inj₁ refl
... | inj₂ _ = inj₂ tt

closed? : ∀ {τ Γ} → (t : Term Γ τ) → (FV t ≡ select-none) ⊎ ⊤
closed? t = none-selected? (FV t)

vacuous-honesty : ∀ {Γ} {ρ : ΔEnv Γ} → Honest ρ select-none
vacuous-honesty {∅} {∅} = clearly
vacuous-honesty {τ • Γ} {cons _ _ _ ρ} = alter (vacuous-honesty {ρ = ρ})

-- Immunity of closed terms to dishonest environments
immune : ∀ {τ Γ} {t : Term Γ τ} →
  (FV t ≡ select-none) → ∀ {ρ} → Honest ρ (FV t)
immune {t = t} eq rewrite eq = vacuous-honesty

-- Ineffectual first optimization step
derive1 : ∀ {τ Γ} → Term Γ τ → ΔTerm Γ τ
derive1 (map s t) with closed? s
... | inj₁ is-closed = Δmap₁ s (derive t)
... | inj₂ tt = derive (map s t)
derive1 others = derive others

valid1 : ∀ {τ Γ} (t : Term Γ τ) {ρ : ΔEnv Γ} → derive1 t is-valid-for ρ
valid1 (nat n) = tt
valid1 (bag b) = tt
valid1 (var x) = tt
valid1 (abs t) = λ _ _ _ → unrestricted t
valid1 (app s t) =
  cons (unrestricted s) (unrestricted t) (validity {t = t}) tt
valid1 (add s t) =
  cons (unrestricted s) (unrestricted t) tt tt
valid1 (map s t) {ρ} with closed? s
... | inj₂ tt = cons (unrestricted s) (unrestricted t) tt tt
... | inj₁ if-closed =
  cons (unrestricted t) (immune {t = s} if-closed) tt tt

correct1 : ∀ {τ Γ} {t : Term Γ τ} {ρ : ΔEnv Γ} →
  ⟦ derive t ⟧Δ ρ (unrestricted t) ≡ ⟦ derive1 t ⟧Δ ρ (valid1 t)

correct1 {t = nat n} = refl
correct1 {t = bag b} = refl
correct1 {t = var x} = refl
correct1 {t = abs t} = refl
correct1 {t = app s t} = refl
correct1 {t = add s t} = refl
correct1 {t = map s t} {ρ} with closed? s
... | inj₂ tt = refl
... | inj₁ if-closed = eq-map s t ρ (immune {t = s} if-closed)


Boring.

Boring.

Ignore-this: c710f736c882ebdb2b00863199903eef

darcs-hash:20100412130736-3bd4e-4a089904a683c9be05ed341034af47ec1e08c49c.gz

------------------------------------------------------------------------------
-- Testing the translation of function, predicates and variables names
------------------------------------------------------------------------------

-- From the technical manual of TPTP
-- (http://www.cs.miami.edu/~tptp/TPTP/TR/TPTPTR.shtml)

-- ... variables start with upper case letters, ... predicates and
-- functors either start with lower case and contain alphanumerics and
-- underscore ...

module Test.Succeed.Names where

infix 4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set

-- A funny function name.
postulate
  FUN! : D → D

postulate
  -- Using a funny function and variable name
  a₁ : (nx∎ : D) → FUN! nx∎ ≡ nx∎
{-# ATP axiom a₁ #-}

postulate
  foo : (n : D) → FUN! n ≡ n
{-# ATP prove foo #-}

-- A funny predicate name
data PRED! : D → Set where

postulate
  a₂ : (n : D) → PRED! n
{-# ATP axiom a₂ #-}

postulate
  bar : (n : D) → PRED! n
{-# ATP prove bar #-}

------------------------------------------------------------------------------
-- Testing the translation of function, predicates and variables names
------------------------------------------------------------------------------

-- From the technical manual of TPTP
-- http://www.cs.miami.edu/~tptp/TPTP/TR/TPTPTR.shtml

-- variables start with upper case letters, ... predicates and
-- functors either start with lower case and contain alphanumerics and
-- underscore ...

module Test.Succeed.Names where

infix 4 _≡_

postulate
  D   : Set
  _≡_ : D → D → Set

-- A funny function name.
postulate
  FUN! : D → D

postulate
  -- Using a funny function and variable name
  a₁ : (nx∎ : D) → FUN! nx∎ ≡ nx∎
{-# ATP axiom a₁ #-}

postulate
  foo : (n : D) → FUN! n ≡ n
{-# ATP prove foo #-}

-- A funny predicate name
data PRED! : D → Set where

postulate
  a₂ : (n : D) → PRED! n
{-# ATP axiom a₂ #-}

postulate
  bar : (n : D) → PRED! n
{-# ATP prove bar #-}


Boring.

Boring.

Ignore-this: afd837a76a16677be82e439fbd3f3052

darcs-hash:20100812142917-3bd4e-3afcc41d73968067a6626fddc35217ec3888a7a8.gz

------------------------------------------------------------------------------
-- Agda as a logical framework for LTC
------------------------------------------------------------------------------
{-

LTC                              Agda
* Logical constants              * Curry-Howard isomorphism
* Equality                       * Identity type
* Term language                  * Postulates
* Inductive predicates           * Inductive families
-}

module LTC.Minimal where

infixl 6 _∙_
infix  5 if_then_else_
infix  4 _≡_

------------------------------------------------------------------------------
-- The universal domain.
-- N.B. The following module is exported by this module.
open import LTC.Minimal.Core public

------------------------------------------------------------------------------
-- The term language of LTC correspond to the PCF terms

--   t ::= x | t t | \x -> t
--           | true | false | if t then t else t
--           | 0 | succ t | pred t | isZero t
--           | error
--           | fix t

postulate

  -- LTC partial booleans.
  true          : D
  false         : D
  if_then_else_ : D → D → D → D
  -- LTC partial natural numbers.
  zero   : D
  succ   : D → D
  pred   : D → D
  isZero : D → D
  -- LTC abstraction.
  lam    : (D → D) → D
  -- LTC application
  -- Left associative aplication operator
  -- The Agda application has higher precedence level than LTC application
  _∙_    : D → D → D
  -- LTC error
  error  : D
  -- LTC fixed point operator
  fix    : (D → D) → D
  -- fixFO  : D

------------------------------------------------------------------------------
-- The LTC's equality is the propositional identity on 'D'.

-- The identity type on D.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- Identity properties.

-- The substitution is defined in LTC.MinimalER

sym : {x y : D} → x ≡ y → y ≡ x
sym refl = refl

trans : {x y z : D} → x ≡ y → y ≡ z → x ≡ z
trans refl y≡z = y≡z

------------------------------------------------------------------------------
-- Logical constants: Curry-Howard isomorphism

-- The LTC's logical constants are the type theory's logical
-- constants via the Curry-Howard isomorphism.
-- For the implication and the universal quantifier
-- we use Agda (dependent) function type.

-- N.B. The following modules are exported by this module.
open import LTC.Data.Empty public
open import LTC.Data.Product public
open import LTC.Data.Sum public
open import LTC.Data.Unit public
open import LTC.Relation.Nullary public

------------------------------------------------------------------------------
-- Conversion rules

postulate
  -- Conversion rules for booleans.
  cB₁ : (d₁ : D){d₂ : D} → if true  then d₁ else d₂ ≡ d₁
  cB₂ : {d₁ : D}(d₂ : D) → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom cB₁ #-}
{-# ATP axiom cB₂ #-}

postulate
  -- Conversion rules for pred.
  cP₁ : pred zero               ≡ zero
  cP₂ : (n : D) → pred (succ n) ≡ n
{-# ATP axiom cP₁ #-}
{-# ATP axiom cP₂ #-}

postulate
  -- Conversion rules for isZero
  cZ₁ : isZero zero               ≡ true
  cZ₂ : (n : D) → isZero (succ n) ≡ false
{-# ATP axiom cZ₁ #-}
{-# ATP axiom cZ₂ #-}

postulate
  -- Conversion rule for the abstraction and the application.
  cBeta : (f : D → D) → (a : D) → (lam f) ∙ a ≡ f a
{-# ATP axiom cBeta #-}

postulate
  -- Conversion rule for the fixed pointed operator.
  cFix   : (f : D → D) → fix f ≡ f (fix  f)
  -- cFixFO : (f : D) → fixFO ∙ f  ≡ f ∙ (fixFO ∙ f)
{-# ATP axiom cFix #-}

------------------------------------------------------------------------------
-- Discrimination rules

postulate
  true≠false : ¬ (true ≡ false)
  0≠S        : {d : D} → ¬ (zero ≡ succ d)
{-# ATP axiom true≠false #-}
{-# ATP axiom 0≠S #-}

------------------------------------------------------------------------------
-- Agda as a logical framework for LTC
------------------------------------------------------------------------------
{-

LTC                              Agda
* Logical constants              * Curry-Howard isomorphism
* Equality                       * Identity type
* Term language                  * Postulates
* Inductive predicates           * Inductive families
-}

module LTC.Minimal where

infixl 6 _∙_
infix  5 if_then_else_
infix  4 _≡_

------------------------------------------------------------------------------
-- The universal domain.
-- N.B. The following module is exported by this module.
open import LTC.Minimal.Core public

------------------------------------------------------------------------------
-- The term language of LTC correspond to the PCF terms

--   t ::= x | t t | \x -> t
--           | true | false | if t then t else t
--           | 0 | succ t | pred t | isZero t
--           | error
--           | fix t

postulate

  -- LTC partial booleans.
  true          : D
  false         : D
  if_then_else_ : D → D → D → D
  -- LTC partial natural numbers.
  zero   : D
  succ   : D → D
  pred   : D → D
  isZero : D → D
  -- LTC abstraction.
  lam    : (D → D) → D
  -- LTC application
  -- Left associative aplication operator
  -- The Agda application has higher precedence level than LTC application
  _∙_    : D → D → D
  -- LTC error
  error  : D
  -- LTC fixed point operator
  fix    : (D → D) → D
  -- fixFO  : D

------------------------------------------------------------------------------
-- The LTC's equality is the propositional identity on 'D'.

-- The identity type.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- Identity properties.

-- The substitution is defined in LTC.MinimalER

sym : {x y : D} → x ≡ y → y ≡ x
sym refl = refl

trans : {x y z : D} → x ≡ y → y ≡ z → x ≡ z
trans refl y≡z = y≡z

------------------------------------------------------------------------------
-- Logical constants: Curry-Howard isomorphism

-- The LTC's logical constants are the type theory's logical
-- constants via the Curry-Howard isomorphism.
-- For the implication and the universal quantifier
-- we use Agda (dependent) function type.

-- N.B. The following modules are exported by this module.
open import LTC.Data.Empty public
open import LTC.Data.Product public
open import LTC.Data.Sum public
open import LTC.Data.Unit public
open import LTC.Relation.Nullary public

------------------------------------------------------------------------------
-- Conversion rules

postulate
  -- Conversion rules for booleans.
  cB₁ : (d₁ : D){d₂ : D} → if true  then d₁ else d₂ ≡ d₁
  cB₂ : {d₁ : D}(d₂ : D) → if false then d₁ else d₂ ≡ d₂
{-# ATP axiom cB₁ #-}
{-# ATP axiom cB₂ #-}

postulate
  -- Conversion rules for pred.
  cP₁ : pred zero               ≡ zero
  cP₂ : (n : D) → pred (succ n) ≡ n
{-# ATP axiom cP₁ #-}
{-# ATP axiom cP₂ #-}

postulate
  -- Conversion rules for isZero
  cZ₁ : isZero zero               ≡ true
  cZ₂ : (n : D) → isZero (succ n) ≡ false
{-# ATP axiom cZ₁ #-}
{-# ATP axiom cZ₂ #-}

postulate
  -- Conversion rule for the abstraction and the application.
  cBeta : (f : D → D) → (a : D) → (lam f) ∙ a ≡ f a
{-# ATP axiom cBeta #-}

postulate
  -- Conversion rule for the fixed pointed operator.
  cFix   : (f : D → D) → fix f ≡ f (fix  f)
  -- cFixFO : (f : D) → fixFO ∙ f  ≡ f ∙ (fixFO ∙ f)
{-# ATP axiom cFix #-}

------------------------------------------------------------------------------
-- Discrimination rules

postulate
  true≠false : ¬ (true ≡ false)
  0≠S        : {d : D} → ¬ (zero ≡ succ d)
{-# ATP axiom true≠false #-}
{-# ATP axiom 0≠S #-}


Added missing --without-K option

Added missing --without-K option

------------------------------------------------------------------------------
-- Testing subst using an implicit arguments for the propositional function.
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas              #-}
{-# OPTIONS --no-sized-types                    #-}
{-# OPTIONS --no-universe-polymorphism          #-}
{-# OPTIONS --schematic-propositional-functions #-}
{-# OPTIONS --without-K                         #-}

module FOT.FOL.ImplicitArgumentSubst where

infix 7 _≡_

postulate
  D              : Set
  _·_            : D → D → D
  zero succ pred : D

succ₁ : D → D
succ₁ n = succ · n

pred₁ : D → D
pred₁ n = pred · n

-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- The propositional function is not an implicit argument.
subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
subst A refl Ax = Ax

-- The propositional formula is an implicit argument.
subst' : {A : D → Set} → ∀ {x y} → x ≡ y → A x → A y
subst' refl Ax = Ax

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

-- Conversion rules.
postulate
  pred-0 : pred₁ zero            ≡ zero
  pred-S : ∀ n → pred₁ (succ₁ n) ≡ n

-- The FOTC natural numbers type.
data N : D → Set where
  nzero :               N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Works using subst.
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

-- Fails using subst'.
pred-N' : ∀ {n} → N n → N (pred₁ n)
pred-N' nzero          = subst' (sym pred-0) nzero
pred-N' (nsucc {n} Nn) = subst' (sym (pred-S n)) Nn

------------------------------------------------------------------------------
-- Testing subst using an implicit arguments for the propositional function.
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas              #-}
{-# OPTIONS --no-sized-types                    #-}
{-# OPTIONS --no-universe-polymorphism          #-}
{-# OPTIONS --schematic-propositional-functions #-}

module FOT.FOL.ImplicitArgumentSubst where

infix 7 _≡_

postulate
  D              : Set
  _·_            : D → D → D
  zero succ pred : D

succ₁ : D → D
succ₁ n = succ · n

pred₁ : D → D
pred₁ n = pred · n

-- The identity type on the universe of discourse.
data _≡_ (x : D) : D → Set where
  refl : x ≡ x

-- The propositional function is not an implicit argument.
subst : (A : D → Set) → ∀ {x y} → x ≡ y → A x → A y
subst A refl Ax = Ax

-- The propositional formula is an implicit argument.
subst' : {A : D → Set} → ∀ {x y} → x ≡ y → A x → A y
subst' refl Ax = Ax

sym : ∀ {x y} → x ≡ y → y ≡ x
sym refl = refl

-- Conversion rules.
postulate
  pred-0 : pred₁ zero            ≡ zero
  pred-S : ∀ n → pred₁ (succ₁ n) ≡ n

-- The FOTC natural numbers type.
data N : D → Set where
  nzero :               N zero
  nsucc : ∀ {n} → N n → N (succ₁ n)

-- Works using subst.
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

-- Fails using subst'.
pred-N' : ∀ {n} → N n → N (pred₁ n)
pred-N' nzero          = subst' (sym pred-0) nzero
pred-N' (nsucc {n} Nn) = subst' (sym (pred-S n)) Nn


some stuff now works...possibly subject expansion

module ITyping where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Product
-- open import Data.Maybe
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Core

open import Core
open import Core-Lemmas
open import Typing
open import Reduction

data IType : Set where
  o : IType
  _~>_ : IType -> IType -> IType
  ∩ : List IType -> IType

ω = ∩ []

∩' : IType -> IType
∩' x = ∩ (x ∷ [])

~>-inj-l : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₁ ≡ τ₂₁
~>-inj-l refl = refl

~>-inj-r : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₂ ≡ τ₂₂
~>-inj-r refl = refl

∩-inj-cons : ∀ {x y τᵢ τⱼ} -> ∩ (x ∷ τᵢ) ≡ ∩ (y ∷ τⱼ) -> ∩ τᵢ ≡ ∩ τⱼ
∩-inj-cons refl = refl

∩-inj : ∀ {x y τᵢ τⱼ} -> ∩ (x ∷ τᵢ) ≡ ∩ (y ∷ τⱼ) -> x ≡ y
∩-inj refl = refl

_≟TI_ : Decidable {A = IType} _≡_
o ≟TI o = yes refl
o ≟TI (_ ~> _) = no (λ ())
o ≟TI (∩ _) = no (λ ())

(_ ~> _) ≟TI o = no (λ ())
(_ ~> _) ≟TI (∩ _) = no (λ ())
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) with τ₁₁ ≟TI τ₂₁ | τ₁₂ ≟TI τ₂₂
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> .τ₁₂) | yes refl | yes refl = yes refl
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> τ₂₂) | yes refl | no τ₁₂≠τ₂₂ = no (λ eq → τ₁₂≠τ₂₂ (~>-inj-r eq))
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) | no τ₁₁≠τ₂₁ | _ = no (λ eq → τ₁₁≠τ₂₁ (~>-inj-l eq))

(∩ _) ≟TI o = no (λ ())
(∩ _) ≟TI (_ ~> _) = no (λ ())
∩ [] ≟TI ∩ [] = yes refl
∩ [] ≟TI ∩ (x ∷ τⱼ) = no (λ ())
∩ (x ∷ τᵢ) ≟TI ∩ [] = no (λ ())
∩ (x ∷ τᵢ) ≟TI ∩ (y ∷ τⱼ) with x ≟TI y | (∩ τᵢ) ≟TI (∩ τⱼ)
∩ (x ∷ τᵢ) ≟TI ∩ (.x ∷ .τᵢ) | yes refl | yes refl = yes refl
∩ (x ∷ τᵢ) ≟TI ∩ (.x ∷ τⱼ) | yes refl | no τᵢ≠τⱼ = no (λ ∩x∷τᵢ≡∩x∷τⱼ → τᵢ≠τⱼ (∩-inj-cons ∩x∷τᵢ≡∩x∷τⱼ))
∩ (x ∷ τᵢ) ≟TI ∩ (y ∷ τⱼ) | no x≠y | _ = no (λ ∩x∷τᵢ≡∩y∷τⱼ → x≠y (∩-inj ∩x∷τᵢ≡∩y∷τⱼ))

ICtxt = List (Atom × IType)

data Wf-ICtxt : ICtxt -> Set where
  nil : Wf-ICtxt []
  cons : ∀ {Γ x τ} -> (x∉ : x ∉ dom Γ) -> Wf-ICtxt Γ ->
    Wf-ICtxt ((x , τ) ∷ Γ)

data _∷'_ : IType -> Type -> Set where
  base : o ∷' σ
  arr : ∀ {δ τ A B} -> δ ∷' A -> τ ∷' B -> (δ ~> τ) ∷' (A ⟶ B)
  ∩-nil : ∀ {A} ->  ω ∷' A
  ∩-cons : ∀ {τᵢ τ A} ->  τ ∷' A -> ∩ τᵢ ∷' A -> ∩ (τ ∷ τᵢ) ∷' A

data _≤∩_ : IType -> IType -> Set where
  base : o ≤∩ o
  arr : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> τ₁₂ ≤∩ τ₂₂ -> τ₂₁ ≤∩ τ₁₁ -> (τ₁₁ ~> τ₁₂) ≤∩ (τ₂₁ ~> τ₂₂)
  ∩-∈ : ∀ {τ τᵢ} -> τ ∈ τᵢ -> ∩ τᵢ ≤∩ τ
  ∩-nil : ∀ {τ} -> τ ≤∩ ω
  ∩-cons : ∀ {τ τ' τᵢ} -> τ ≤∩ τ' -> τ ≤∩ ∩ τᵢ -> τ ≤∩ ∩ (τ' ∷ τᵢ)
  -- ∩-trans : ∀ {τ₁ τ₂ τ₃} -> τ₁ ≤∩ τ₂ -> τ₂ ≤∩ τ₃ -> τ₁ ≤∩ τ₃

∩τⱼ≤∩τᵢ : ∀ {τᵢ τⱼ} -> τᵢ ⊆ τⱼ -> ∩ τⱼ ≤∩ ∩ τᵢ
∩τⱼ≤∩τᵢ {[]} τᵢ⊆τⱼ = ∩-nil
∩τⱼ≤∩τᵢ {x ∷ τᵢ} τᵢ⊆τⱼ = ∩-cons (∩-∈ (τᵢ⊆τⱼ (here refl))) (∩τⱼ≤∩τᵢ (λ {x₁} z → τᵢ⊆τⱼ (there z)))

≤∩-refl : ∀ {τ} -> τ ≤∩ τ
≤∩-refl {o} = base
≤∩-refl {τ ~> τ₁} = arr ≤∩-refl ≤∩-refl
≤∩-refl {∩ []} = ∩-nil
≤∩-refl {∩ (x ∷ x₁)} = ∩τⱼ≤∩τᵢ (λ {x₂} z → z)

data Λ : Type -> Set where
  bv : ∀ {A} -> (i : ℕ) -> Λ A
  fv : ∀ {A} -> (x : Atom) -> Λ A
  lam : ∀ {B} -> (A : Type) -> (e : Λ B) -> Λ (A ⟶ B)
  app : ∀ {A B} -> (e₁ : Λ (A ⟶ B)) -> (e₂ : Λ A) -> Λ B
  Y : (t : Type) -> Λ ((t ⟶ t) ⟶ t)

-- _∈?_ : ∀ {a} {A : Set a} -> Atom -> List (Atom × A) -> Maybe A
-- a ∈? [] = nothing
-- a ∈? (l ∷ ist) with a ≟ proj₁ l
-- ... | yes _ = just (proj₂ l)
-- a ∈? (l ∷ ist) | no _ = a ∈? ist

-- ⊢->Λ : ∀ {Γ m t} -> (List (Atom × ℕ)) -> Γ ⊢ m ∶ t -> Λ t
-- ⊢->Λ {m = bv i} _ ()
-- ⊢->Λ {m = fv x} bound Γ⊢m∶t with x ∈? bound
-- ⊢->Λ {m = fv x} {t} bound Γ⊢m∶t | just i = bv {t} i
-- ⊢->Λ {m = fv x} bound Γ⊢m∶t | nothing = fv x
-- ⊢->Λ {m = lam m} bound (abs {_} {τ₁} {τ₂} L cf) = lam τ₁ (⊢->Λ ((x , 0) ∷ bound') (cf (∉-cons-l _ _ x∉)))
--   where
--   x = ∃fresh (L ++ FV m)
--   x∉ : x ∉ (L ++ FV m)
--   x∉ = ∃fresh-spec (L ++ FV m)
--
--   bound' : List (Atom × ℕ)
--   bound' = Data.List.map (λ a,i → (proj₁ a,i) , suc (proj₂ a,i)) bound
--
-- ⊢->Λ {m = app t1 t} bound (app Γ⊢s Γ⊢t) = app (⊢->Λ bound Γ⊢s) (⊢->Λ bound Γ⊢t)
-- ⊢->Λ {m = Y τ} bound (Y x) = Y τ
--
-- ⊢->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
-- ⊢->Λ = ⊢->Λ []

data _~_ : ∀{t} -> Λ t -> PTerm -> Set where
  bv : ∀ {t i} -> (bv {t} i) ~ (bv i)
  fv : ∀ {t x} -> (fv {t} x) ~ (fv x)
  lam : ∀ {t s m m'} -> m ~ m' -> (lam {s} t m) ~ (lam m')
  app : ∀ {t s m n m' n'} -> m ~ m' -> n ~ n' -> (app {t} {s} m n) ~ (app m' n')
  Y : ∀ {t} -> (Y t) ~ (Y t)

Λ[_<<_] : ∀ {t} -> ℕ -> Atom -> Λ t -> Λ t
Λ[ k << x ] (bv i) = bv i
Λ[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
Λ[ k << x ] (lam t m) = lam t (Λ[ (suc k) << x ] m)
Λ[ k << x ] (app t1 t2) = app (Λ[ k << x ] t1) (Λ[ k << x ] t2)
Λ[ k << x ] (Y t) = Y t

⊢->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
⊢->Λ {m = bv i} ()
⊢->Λ {m = fv x} {t} Γ⊢m∶t = fv {t} x
⊢->Λ {m = lam m} (abs {_} {τ₁} {τ₂} L cf) =
  lam τ₁ ( Λ[ 0 << ∃fresh (L ++ FV m) ] (⊢->Λ (cf (∉-cons-l _ _ (∃fresh-spec (L ++ FV m)) ))) )
⊢->Λ {m = app t1 t} (app Γ⊢s Γ⊢t) = app (⊢->Λ Γ⊢s) (⊢->Λ Γ⊢t)
⊢->Λ {m = Y τ} (Y x) = Y τ

⊢->Λ≡ : ∀ {Γ m n t} -> m ≡ n -> {Γ⊢m : Γ ⊢ m ∶ t} -> {Γ⊢n : Γ ⊢ n ∶ t} -> (⊢->Λ Γ⊢m) ≡ (⊢->Λ Γ⊢m)
⊢->Λ≡ refl = λ {Γ⊢m} {Γ⊢n} → refl

Λ*^-*^~ : ∀ {τ x k} t t' -> _~_ {τ} t t' -> Λ[ k << x ] t ~ ([ k << x ] t')
Λ*^-*^~ _ _ bv = bv
Λ*^-*^~ {x = x} (fv y) _ fv with x ≟ y
Λ*^-*^~ (fv x) .(fv x) fv | yes _ = bv
Λ*^-*^~ (fv y) .(fv y) fv | no _ = fv
Λ*^-*^~ _ _ (lam {m = m} {m'} t~t') = lam (Λ*^-*^~ m m' t~t')
Λ*^-*^~ _ _ (app {m = m} {n} {m'} {n'} t~t' t~t'') = app (Λ*^-*^~ m m' t~t') (Λ*^-*^~ n n' t~t'')
Λ*^-*^~ _ _ Y = Y

⊢->Λ~ : ∀ {Γ t τ} -> (Γ⊢t : Γ ⊢ t ∶ τ) -> (⊢->Λ Γ⊢t) ~ t
⊢->Λ~ {t = bv i} ()
⊢->Λ~ {t = fv x} (var _ _) = fv
⊢->Λ~ {t = lam t} (abs {τ₁ = τ₁} {τ₂} L cf) = lam ih
  where
  x = ∃fresh (L ++ FV t)
  x∉ = ∃fresh-spec (L ++ FV t)
  x∷Γ⊢t^'x = cf (∉-cons-l _ _ x∉)

  sub : ∀ {τ x m} -> x ∉ FV t -> _~_ {τ} m t ≡ m ~ (* x ^ (t ^' x))
  sub {_} {x} x∉ rewrite fv-^-*^-refl x t {0} x∉ = refl

  ih : Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x) ~ t
  ih rewrite sub {_} {x} {Λ[ 0 << x ] (⊢->Λ x∷Γ⊢t^'x)} (∉-cons-r L _ x∉) =
    Λ*^-*^~ (⊢->Λ x∷Γ⊢t^'x) (t ^' x) (⊢->Λ~ (cf (∉-cons-l _ _ x∉)))
⊢->Λ~ {t = app t t₁} (app Γ⊢t Γ⊢t₁) = app (⊢->Λ~ Γ⊢t) (⊢->Λ~ Γ⊢t₁)
⊢->Λ~ {t = Y t₁} (Y x) = Y

-- ers : ∀ {t} -> Λ t -> PTerm
-- ers (bv i) = bv i
-- ers (fv x) = fv x
-- ers (lam A Λt) = lam (ers Λt)
-- ers (app Λs Λt) = app (ers Λs) (ers Λt)
-- ers (Y t) = Y t

-- data ITypeₛ : IType -> Set where
--   o : ITypeₛ o
--   arr : ∀ {τ τ'} -> ITypeₛ τ -> ITypeₛ τ' -> ITypeₛ (τ ~> τ')
--
-- data ITypeₛₛ : IType -> Set where
--   o : ITypeₛₛ o
--   arr :  ∀ {τ τ'} -> ITypeₛₛ τ -> ITypeₛₛ τ' -> ITypeₛₛ (τ ~> τ')
--   ∩-nil : ITypeₛₛ ω
--   ∩-cons : ∀ {τ τᵢ} -> ITypeₛ τ ->  ITypeₛₛ (∩ τᵢ) -> ITypeₛₛ (∩ (τ ∷ τᵢ))
--
-- τₛ->τₛₛ : ∀ {τ} -> ITypeₛ τ -> ITypeₛₛ τ
-- τₛ->τₛₛ o = o
-- τₛ->τₛₛ (arr τₛ τₛ₁) = arr (τₛ->τₛₛ τₛ) (τₛ->τₛₛ τₛ₁)

Λ[_>>_] : ∀ {τ τ'} -> ℕ -> Λ τ' -> Λ τ -> Λ τ
Λ[_>>_] {τ} {τ'} k u (bv i) with k ≟ i | τ ≟T τ'
Λ[ k >> u ] (bv i) | yes _ | yes refl = u
... | yes _ | no _ = bv i
... | no _ | _ = bv i
Λ[ k >> u ] (fv x) = fv x
Λ[ k >> u ] (lam A t) = lam A (Λ[ (suc k) >> u ] t)
Λ[ k >> u ] (app t1 t2) = app (Λ[ k >> u ] t1) (Λ[ k >> u ] t2)
Λ[ k >> u ] (Y t) = Y t

data Y-shape : ∀ {τ} -> Λ τ -> Set where
  intro₁ : ∀ {A m} -> Y-shape (app (Y A) m)
  intro₂ : ∀ {A m} -> Y-shape (app m (app (Y A) m))

data _⊩_∶_ : ∀ {A} -> ICtxt -> Λ A -> IType -> Set where
  var : ∀ {A Γ x τ} {τᵢ : List IType} -> (wf-Γ : Wf-ICtxt Γ) -> (τᵢ∈Γ : (x , (∩ τᵢ)) ∈ Γ) -> (τᵢ≤∩τ : ∩ τᵢ ≤∩ τ) ->
    τ ∷' A -> Γ ⊩ fv {A} x ∶ τ
  app : ∀ {A B Γ s t τ₁ τ₂} -> Γ ⊩ s ∶ (τ₁ ~> τ₂) -> Γ ⊩ t ∶ τ₁ -> (τ₁ ~> τ₂) ∷' (A ⟶ B) -> τ₁ ∷' A ->
    Γ ⊩ (app {A} {B} s t) ∶ τ₂
  ∩-nil : ∀ {A Γ} {m : Λ A} -> (¬Y-shape : ¬ Y-shape m) -> (wf-Γ : Wf-ICtxt Γ) -> Γ ⊩ m  ∶ ω
  ∩-cons : ∀ {A Γ τ τᵢ} {m : Λ A} -> (¬Y-shape : ¬ Y-shape m) -> (wf-Γ : Wf-ICtxt Γ) ->
    Γ ⊩ m  ∶ τ -> Γ ⊩ m  ∶ (∩ τᵢ) -> Γ ⊩ m  ∶ (∩ (τ ∷ τᵢ))
  abs : ∀ {A B Γ τᵢ τ} (L : FVars) -> ∀ {t : Λ B} ->
    ( cf : ∀ {x} -> (x∉L : x ∉ L) -> ((x , ∩ τᵢ) ∷ Γ) ⊩ Λ[ 0 >> fv {A} x ] t ∶ τ ) -> ∩ τᵢ ∷' A -> τ ∷' B ->
    Γ ⊩ lam A t ∶ (∩ τᵢ ~> τ)
  Y : ∀ {Γ A τ τ₁ τ₂} -> Wf-ICtxt Γ -> τ ∷' A -> τ₁ ∷' A -> τ₂ ∷' A ->
    Γ ⊩ Y A ∶ ((τ ~> τ₁) ~> τ₂)

data ΛTerm : ∀ {τ} -> Λ τ -> Set where
  var : ∀ {A x} -> ΛTerm (fv {A} x)
  lam : ∀ {A B} (L : FVars) -> ∀ {e : Λ B} ->
    (cf : ∀ {x} -> (x∉L : x ∉ L) -> ΛTerm (Λ[ 0 >> fv {A} x ] e)) -> ΛTerm (lam A e)
  app : ∀ {A B} {e₁ : Λ (A ⟶ B)} {e₂ : Λ A} -> ΛTerm e₁ -> ΛTerm e₂ -> ΛTerm (app e₁ e₂)
  Y : ∀ {t} -> ΛTerm (Y t)

-- ⊢->Λ-ΛTerm : ∀ {Γ t τ} -> {Γ⊢t : Γ ⊢ t ∶ τ} -> (ΛTerm (⊢->Λ Γ⊢t))
-- ⊢->Λ-ΛTerm {Γ⊢t = var x₁ x₂} = var
-- ⊢->Λ-ΛTerm {Γ⊢t = app Γ⊢t Γ⊢t₁} = app ⊢->Λ-ΛTerm ⊢->Λ-ΛTerm
-- ⊢->Λ-ΛTerm {Γ⊢t = abs L cf} = {!   !}
-- ⊢->Λ-ΛTerm {Γ⊢t = Y x} = Y

data _->Λβ_ : ∀ {τ} -> Λ τ ↝ Λ τ where
  redL : ∀ {A B} {n : Λ A} {m m' : Λ (A ⟶ B)} -> ΛTerm n -> m ->Λβ m' -> app m n ->Λβ app m' n
  redR : ∀ {A B} {m : Λ (A ⟶ B)} {n n' : Λ A} -> ΛTerm m -> n ->Λβ n' -> app m n ->Λβ app m n'
  abs : ∀ L {A B} {m m' : Λ B} -> ( ∀ {x} -> x ∉ L -> Λ[ 0 >> fv {A} x ] m ->Λβ Λ[ 0 >> fv {A} x ] m' ) ->
    lam A m ->Λβ lam A m'
  beta : ∀ {A B} {m : Λ (A ⟶ B)} {n : Λ A} -> ΛTerm (lam A m) -> ΛTerm n -> app (lam A m) n ->Λβ (Λ[ 0 >> n ] m)
  Y : ∀ {A} {m : Λ (A ⟶ A)} -> ΛTerm m -> app (Y A) m ->Λβ app m (app (Y A) m)

⊩->β : ∀ {A Γ} {m m' : Λ A} {τ} -> Γ ⊩ m' ∶ τ -> m ->Λβ m' -> Γ ⊩ m ∶ τ
⊩->β Γ⊩m'∶τ (redL trm-n m->βm') = {!   !}
⊩->β Γ⊩m'∶τ (redR trm-m n->βn') = {!   !}
⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
⊩->β (app {s = m} Γ⊩m∶τ₁~>τ (app (Y wf-Γ τ₂∷A τ₃∷A τ₁∷A) Γ⊩m x τ₂~>τ₃∷A) (arr {A = A} _ τ∷A) _) (Y trm-m) =
  app {A = A ⟶ A} (Y wf-Γ τ₁∷A τ∷A τ∷A) Γ⊩m∶τ₁~>τ (arr (arr τ₁∷A τ∷A) τ∷A) (arr τ₁∷A τ∷A)
⊩->β (app Γ⊩m∶τ~>τ' (∩-nil ¬Y-shape wf-Γ) x τ∷A) (Y trm-m) = ⊥-elim (¬Y-shape intro₁)
⊩->β (app Γ⊩m∶τ~>τ' (∩-cons ¬Y-shape wf-Γ Γ⊩Ym∶τ' Γ⊩Ym∶τ'') x τ∷A) (Y trm-m) = ⊥-elim (¬Y-shape intro₁)
⊩->β (∩-nil ¬Y-shape wf-Γ) (Y x) = ⊥-elim (¬Y-shape intro₂)
⊩->β (∩-cons ¬Y-shape wf-Γ Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x) = ⊥-elim (¬Y-shape intro₂)

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = ⊩->β-redL Γ⊩m'∶τ m->βm'
--   where
--   ⊩->β-redL : ∀ {Γ m m' n τ} -> Γ ⊩ app m' n ∶ τ -> m ->β m' -> Γ ⊩ app m n ∶ τ
--   ⊩->β-redL = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β {τ = τ} (app Γ⊩m∶τ'~>τ (app (Y {τ = τ'} wf-Γ τ∷ τ₁∷ τ₂∷) Γ⊩m∶τ'~>τ')) (Y trm-m) =
--     app (Y wf-Γ τ∷ τ₁∷ {!   !}) Γ⊩m∶τ'~>τ'
--
-- ⊩->β (app Γ⊩m'∶τ (∩-nil ¬Y-shape wf-Γ trm-m)) (Y x) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (app Γ⊩m'∶τ (∩-cons ¬Y-shape wf-Γ trm-m Γ⊩m'∶τ₁ Γ⊩m'∶τ₂)) (Y x₁) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (∩-nil ¬Y-shape wf-Γ trm-m) (Y x) = ⊥-elim (¬Y-shape intro₂)
-- ⊩->β (∩-cons ¬Y-shape wf-Γ trm-m Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x₁) = ⊥-elim (¬Y-shape intro₂)
--
--

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = ⊩->β-redL Γ⊩m'∶τ m->βm'
--   where
--   ⊩->β-redL : ∀ {Γ m m' n τ} -> Γ ⊩ app m' n ∶ τ -> m ->β m' -> Γ ⊩ app m n ∶ τ
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (redL x₁ m->βm'') = app (⊩->β-redL Γ⊩m'n∶τ m->βm'') Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m''n₁n₂∶τᵢ wf-Γ (app _ trm-n₂)) (redL trm-n₁ m->βm'') =
--     ∩-intro (λ τ∈τᵢ → ⊩->β-redL (Γ⊩m''n₁n₂∶τᵢ τ∈τᵢ) (redL trm-n₁ m->βm'')) wf-Γ (app (app (->β-Term-l m->βm'') trm-n₁) trm-n₂)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (redR x₁ m->βm'') = app (⊩->β Γ⊩m'n∶τ (redR x₁ m->βm'')) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m₁e₂n₂∶τᵢ wf-Γ (app (app _ trm-e₂) trm-n₂)) (redR trm-m₁ n₁->e₂) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩m₁e₂n₂∶τᵢ τ∈τᵢ) (redL trm-n₂ (redR trm-m₁ n₁->e₂))) wf-Γ (app (app trm-m₁ (->β-Term-l n₁->e₂)) trm-n₂)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (abs L cf) = app (⊩->β Γ⊩m'n∶τ (abs L cf)) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩lam-m''n₁∶τᵢ wf-Γ (app trm-lam-m'' trm-n₁)) (abs L cf) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩lam-m''n₁∶τᵢ τ∈τᵢ) (redL trm-n₁ (abs L cf))) wf-Γ (app (lam L (λ x∉L → ->β-Term-l (cf x∉L))) trm-n₁)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (beta trm-lam-m₁ trm-n₁) = app (⊩->β Γ⊩m'n∶τ (beta trm-lam-m₁ trm-n₁)) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m₁^n₁n₂∶τ₁ wf-Γ (app trm-m₁^n₁ trm-n₂)) (beta trm-lam-m₁ trm-n₁) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩m₁^n₁n₂∶τ₁ τ∈τᵢ) (redL trm-n₂ (beta trm-lam-m₁ trm-n₁))) wf-Γ (app (app trm-lam-m₁ trm-n₁) trm-n₂)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (Y trm-m₁) = app (⊩->β Γ⊩m'n∶τ (Y trm-m₁)) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m₁Ym₁n₁∶τᵢ wf-Γ (app (app _ trm-Ym₁) trm-n₁)) (Y trm-m₁) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩m₁Ym₁n₁∶τᵢ τ∈τᵢ) (redL trm-n₁ (Y trm-m₁))) wf-Γ (app trm-Ym₁ trm-n₁)
--
-- ⊩->β (app Γ⊩m'∶τ Γ⊩m'∶τ₁) (redR trm-n m->βm') = app Γ⊩m'∶τ (⊩->β Γ⊩m'∶τ₁ m->βm')
-- ⊩->β (∩-intro Γ⊩mn'∶τᵢ wf-Γ trm-mn') (redR trm-m n->βn') =
--   ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩mn'∶τᵢ τ∈τᵢ) (redR trm-m n->βn')) wf-Γ (app trm-m (->β-Term-l n->βn'))
-- ⊩->β (∩-intro Γ⊩lam-m'∶τᵢ wf-Γ trm-lam-x) (abs L x₂) =
--   ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩lam-m'∶τᵢ τ∈τᵢ) (abs L x₂)) wf-Γ (lam L (λ x∉L → ->β-Term-l (x₂ x∉L)))
-- ⊩->β (abs L cf) (abs L₁ x) = abs (L ++ L₁) (λ x∉L → ⊩->β (cf (∉-cons-l _ _ x∉L)) (x (∉-cons-r L _ x∉L)))
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β (app Γ⊩m'∶τ'~>τ (app Γ⊩Ym∶τ' Γ⊩Ym∶τ'')) (Y trm-m) = {!   !}
-- ⊩->β (app Γ⊩m'∶τ'~>τ (∩-intro {τᵢ = []} Γ⊩Ym∶τᵢ wf-Γ trm-Ym)) (Y trm-m) = {!   !}
-- ⊩->β {Γ} (app {s = m} Γ⊩m'∶τ'~>τ (∩-intro {τᵢ = x ∷ τᵢ} Γ⊩Ym∶τᵢ wf-Γ trm-Ym)) (Y trm-m) = {!   !}
--   where
--   Γ⊩m∶x~>x : Γ ⊩ m ∶ (x ~> x)
--   Γ⊩m∶x~>x = {!   !}
-- ⊩->β (∩-intro Γ⊩mYm∶τᵢ wf-Γ (app _ trm-Ym)) (Y trm-m) =
--   ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩mYm∶τᵢ τ∈τᵢ) (Y trm-m)) wf-Γ trm-Ym

module ITyping where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Product
-- open import Data.Maybe
open import Data.List.Any as LAny
open LAny.Membership-≡
open import Relation.Nullary
open import Relation.Binary.PropositionalEquality
open import Relation.Binary.Core

open import Core
open import Core-Lemmas
open import Typing
open import Reduction

data IType : Set where
  o : IType
  _~>_ : IType -> IType -> IType
  ∩ : List IType -> IType

ω = ∩ []

∩' : IType -> IType
∩' x = ∩ (x ∷ [])

~>-inj-l : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₁ ≡ τ₂₁
~>-inj-l refl = refl

~>-inj-r : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> (τ₁₁ ~> τ₁₂) ≡ (τ₂₁ ~> τ₂₂) -> τ₁₂ ≡ τ₂₂
~>-inj-r refl = refl

∩-inj-cons : ∀ {x y τᵢ τⱼ} -> ∩ (x ∷ τᵢ) ≡ ∩ (y ∷ τⱼ) -> ∩ τᵢ ≡ ∩ τⱼ
∩-inj-cons refl = refl

∩-inj : ∀ {x y τᵢ τⱼ} -> ∩ (x ∷ τᵢ) ≡ ∩ (y ∷ τⱼ) -> x ≡ y
∩-inj refl = refl

_≟TI_ : Decidable {A = IType} _≡_
o ≟TI o = yes refl
o ≟TI (_ ~> _) = no (λ ())
o ≟TI (∩ _) = no (λ ())

(_ ~> _) ≟TI o = no (λ ())
(_ ~> _) ≟TI (∩ _) = no (λ ())
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) with τ₁₁ ≟TI τ₂₁ | τ₁₂ ≟TI τ₂₂
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> .τ₁₂) | yes refl | yes refl = yes refl
(τ₁₁ ~> τ₁₂) ≟TI (.τ₁₁ ~> τ₂₂) | yes refl | no τ₁₂≠τ₂₂ = no (λ eq → τ₁₂≠τ₂₂ (~>-inj-r eq))
(τ₁₁ ~> τ₁₂) ≟TI (τ₂₁ ~> τ₂₂) | no τ₁₁≠τ₂₁ | _ = no (λ eq → τ₁₁≠τ₂₁ (~>-inj-l eq))

(∩ _) ≟TI o = no (λ ())
(∩ _) ≟TI (_ ~> _) = no (λ ())
∩ [] ≟TI ∩ [] = yes refl
∩ [] ≟TI ∩ (x ∷ τⱼ) = no (λ ())
∩ (x ∷ τᵢ) ≟TI ∩ [] = no (λ ())
∩ (x ∷ τᵢ) ≟TI ∩ (y ∷ τⱼ) with x ≟TI y | (∩ τᵢ) ≟TI (∩ τⱼ)
∩ (x ∷ τᵢ) ≟TI ∩ (.x ∷ .τᵢ) | yes refl | yes refl = yes refl
∩ (x ∷ τᵢ) ≟TI ∩ (.x ∷ τⱼ) | yes refl | no τᵢ≠τⱼ = no (λ ∩x∷τᵢ≡∩x∷τⱼ → τᵢ≠τⱼ (∩-inj-cons ∩x∷τᵢ≡∩x∷τⱼ))
∩ (x ∷ τᵢ) ≟TI ∩ (y ∷ τⱼ) | no x≠y | _ = no (λ ∩x∷τᵢ≡∩y∷τⱼ → x≠y (∩-inj ∩x∷τᵢ≡∩y∷τⱼ))

ICtxt = List (Atom × IType)

data Wf-ICtxt : ICtxt -> Set where
  nil : Wf-ICtxt []
  cons : ∀ {Γ x τ} -> (x∉ : x ∉ dom Γ) -> Wf-ICtxt Γ ->
    Wf-ICtxt ((x , τ) ∷ Γ)

data _∷'_ : IType -> Type -> Set where
  base : o ∷' σ
  arr : ∀ {δ τ A B} -> δ ∷' A -> τ ∷' B -> (δ ~> τ) ∷' (A ⟶ B)
  ∩-nil : ∀ {A} ->  ω ∷' A
  ∩-cons : ∀ {τᵢ τ A} ->  τ ∷' A -> ∩ τᵢ ∷' A -> ∩ (τ ∷ τᵢ) ∷' A

data _≤∩_ : IType -> IType -> Set where
  base : o ≤∩ o
  arr : ∀ {τ₁₁ τ₁₂ τ₂₁ τ₂₂} -> τ₁₂ ≤∩ τ₂₂ -> τ₂₁ ≤∩ τ₁₁ -> (τ₁₁ ~> τ₁₂) ≤∩ (τ₂₁ ~> τ₂₂)
  ∩-∈ : ∀ {τ τᵢ} -> τ ∈ τᵢ -> ∩ τᵢ ≤∩ τ
  ∩-nil : ∀ {τ} -> τ ≤∩ ω
  ∩-cons : ∀ {τ τ' τᵢ} -> τ ≤∩ τ' -> τ ≤∩ ∩ τᵢ -> τ ≤∩ ∩ (τ' ∷ τᵢ)
  -- ∩-trans : ∀ {τ₁ τ₂ τ₃} -> τ₁ ≤∩ τ₂ -> τ₂ ≤∩ τ₃ -> τ₁ ≤∩ τ₃

∩τⱼ≤∩τᵢ : ∀ {τᵢ τⱼ} -> τᵢ ⊆ τⱼ -> ∩ τⱼ ≤∩ ∩ τᵢ
∩τⱼ≤∩τᵢ {[]} τᵢ⊆τⱼ = ∩-nil
∩τⱼ≤∩τᵢ {x ∷ τᵢ} τᵢ⊆τⱼ = ∩-cons (∩-∈ (τᵢ⊆τⱼ (here refl))) (∩τⱼ≤∩τᵢ (λ {x₁} z → τᵢ⊆τⱼ (there z)))

≤∩-refl : ∀ {τ} -> τ ≤∩ τ
≤∩-refl {o} = base
≤∩-refl {τ ~> τ₁} = arr ≤∩-refl ≤∩-refl
≤∩-refl {∩ []} = ∩-nil
≤∩-refl {∩ (x ∷ x₁)} = ∩τⱼ≤∩τᵢ (λ {x₂} z → z)

data Λ : Type -> Set where
  bv : ∀ {A} -> (i : ℕ) -> Λ A
  fv : ∀ {A} -> (x : Atom) -> Λ A
  lam : ∀ {B} -> (A : Type) -> (e : Λ B) -> Λ (A ⟶ B)
  app : ∀ {A B} -> (e₁ : Λ (A ⟶ B)) -> (e₂ : Λ A) -> Λ B
  Y : (t : Type) -> Λ ((t ⟶ t) ⟶ t)

-- _∈?_ : ∀ {a} {A : Set a} -> Atom -> List (Atom × A) -> Maybe A
-- a ∈? [] = nothing
-- a ∈? (l ∷ ist) with a ≟ proj₁ l
-- ... | yes _ = just (proj₂ l)
-- a ∈? (l ∷ ist) | no _ = a ∈? ist

-- PTerm->Λ : ∀ {Γ m t} -> (List (Atom × ℕ)) -> Γ ⊢ m ∶ t -> Λ t
-- PTerm->Λ {m = bv i} _ ()
-- PTerm->Λ {m = fv x} bound Γ⊢m∶t with x ∈? bound
-- PTerm->Λ {m = fv x} {t} bound Γ⊢m∶t | just i = bv {t} i
-- PTerm->Λ {m = fv x} bound Γ⊢m∶t | nothing = fv x
-- PTerm->Λ {m = lam m} bound (abs {_} {τ₁} {τ₂} L cf) = lam τ₁ (PTerm->Λ ((x , 0) ∷ bound') (cf (∉-cons-l _ _ x∉)))
--   where
--   x = ∃fresh (L ++ FV m)
--   x∉ : x ∉ (L ++ FV m)
--   x∉ = ∃fresh-spec (L ++ FV m)
--
--   bound' : List (Atom × ℕ)
--   bound' = Data.List.map (λ a,i → (proj₁ a,i) , suc (proj₂ a,i)) bound
--
-- PTerm->Λ {m = app t1 t} bound (app Γ⊢s Γ⊢t) = app (PTerm->Λ bound Γ⊢s) (PTerm->Λ bound Γ⊢t)
-- PTerm->Λ {m = Y τ} bound (Y x) = Y τ
--
-- PTerm->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
-- PTerm->Λ = PTerm->Λ []

data _~_ : ∀{t} -> Λ t -> PTerm -> Set where
  bv : ∀ {t i} -> (bv {t} i) ~ (bv i)
  fv : ∀ {t x} -> (fv {t} x) ~ (fv x)
  lam : ∀ {t s m m'} -> m ~ m' -> (lam {s} t m) ~ (lam m')
  app : ∀ {t s m n m' n'} -> m ~ m' -> n ~ n' -> (app {t} {s} m n) ~ (app m' n')
  Y : ∀ {t} -> (Y t) ~ (Y t)

Λ[_<<_] : ∀ {t} -> ℕ -> Atom -> Λ t -> Λ t
Λ[ k << x ] (bv i) = bv i
Λ[ k << x ] (fv y) with x ≟ y
... | yes _ = bv k
... | no _ = fv y
Λ[ k << x ] (lam t m) = lam t (Λ[ (suc k) << x ] m)
Λ[ k << x ] (app t1 t2) = app (Λ[ k << x ] t1) (Λ[ k << x ] t2)
Λ[ k << x ] (Y t) = Y t

PTerm->Λ : ∀ {Γ m t} -> Γ ⊢ m ∶ t -> Λ t
PTerm->Λ {m = bv i} ()
PTerm->Λ {m = fv x} {t} Γ⊢m∶t = fv {t} x
PTerm->Λ {m = lam m} (abs {_} {τ₁} {τ₂} L cf) =
  lam τ₁ ( Λ[ 0 << ∃fresh (L ++ FV m) ]
    (PTerm->Λ (cf (∉-cons-l _ _ (∃fresh-spec (L ++ FV m)) ))) )
PTerm->Λ {m = app t1 t} (app Γ⊢s Γ⊢t) = app (PTerm->Λ Γ⊢s) (PTerm->Λ Γ⊢t)
PTerm->Λ {m = Y τ} (Y x) = Y τ

Λ*^-*^~ : ∀ {τ x k} t t' -> _~_ {τ} t t' -> Λ[ k << x ] t ~ ([ k << x ] t')
Λ*^-*^~ _ _ bv = bv
Λ*^-*^~ {x = x} (fv y) _ fv with x ≟ y
Λ*^-*^~ (fv x) .(fv x) fv | yes _ = bv
Λ*^-*^~ (fv y) .(fv y) fv | no _ = fv
Λ*^-*^~ _ _ (lam {m = m} {m'} t~t') = lam (Λ*^-*^~ m m' t~t')
Λ*^-*^~ _ _ (app {m = m} {n} {m'} {n'} t~t' t~t'') = app (Λ*^-*^~ m m' t~t') (Λ*^-*^~ n n' t~t'')
Λ*^-*^~ _ _ Y = Y

Λ*^-*^-swap : ∀ {t : Type} k n x y m -> ¬(k ≡ n) -> ¬(x ≡ y) -> Λ[_<<_] {t} k x (Λ[ n << y ] m) ≡ Λ[ n << y ] (Λ[ k << x ] m)
Λ*^-*^-swap k n x y (bv i) k≠n x≠y = refl
Λ*^-*^-swap k n x y (fv z) k≠n x≠y = {!   !}
Λ*^-*^-swap k n x y (lam A m) k≠n x≠y =
  cong (lam A) (Λ*^-*^-swap (suc k) (suc n) x y m (λ x₁ → k≠n (≡-suc x₁)) x≠y)
Λ*^-*^-swap k n x y (app m m') k≠n x≠y rewrite
  Λ*^-*^-swap k n x y m k≠n x≠y | Λ*^-*^-swap k n x y m' k≠n x≠y = refl
Λ*^-*^-swap k n x y (Y t) k≠n x≠y = refl

fv-^-Λ*^-refl : ∀ x t {k Γ τ} -> x ∉ FV t -> (Γ⊢t^x : Γ ⊢ [ k >> fv x ] t ∶ τ) -> (Λ[ k << x ] (PTerm->Λ Γ⊢t^x) ) ~ t
fv-^-Λ*^-refl x (bv n) x∉FVt ()
fv-^-Λ*^-refl x (fv y) x∉FVt Γ⊢t^x with x ≟ y
fv-^-Λ*^-refl x (fv .x) x∉FVt Γ⊢t^x | yes refl = ⊥-elim (x∉FVt (here refl))
fv-^-Λ*^-refl x (fv y) x∉FVt Γ⊢t^x | no x≠y = fv
fv-^-Λ*^-refl x (lam t) {k} {Γ} x∉FVt (abs {τ₁ = τ₁} {τ₂} L cf) = lam {!   !}
  --
  -- where
  -- x' = ∃fresh ( L ++ FV ([ suc k >> fv x ] t) )
  -- x'∉ = ∃fresh-spec ( L ++ FV ([ suc k >> fv x ] t) )
  --
  -- x'Γ⊢[suc-k>>x]t^'x' : ((x' , τ₁) ∷ Γ) ⊢ ([ suc k >> fv x ] t) ^' x' ∶ τ₂
  -- x'Γ⊢[suc-k>>x]t^'x' = cf (∉-cons-l L (FV ([ suc k >> fv x ] t)) (∃fresh-spec (L ++ FV ([ suc k >> fv x ] t))))
  --
  --
  -- x'Γ⊢[suc-k>>x]t^'x'≡ : ((x' , τ₁) ∷ Γ) ⊢ [ suc k >> fv x ] (t ^' x') ∶ τ₂ ≡
  --   ((x' , τ₁) ∷ Γ) ⊢ ([ suc k >> fv x ] t) ^' x' ∶ τ₂
  -- x'Γ⊢[suc-k>>x]t^'x'≡ rewrite ^-^-swap (suc k) 0 x x' t (λ ()) (λ x≡x' → {!   !}) = refl
  --
  -- x'Γ⊢[suc-k>>x]t^'x'' : ((x' , τ₁) ∷ Γ) ⊢ [ suc k >> fv x ] (t ^' x') ∶ τ₂
  -- x'Γ⊢[suc-k>>x]t^'x'' rewrite x'Γ⊢[suc-k>>x]t^'x'≡ = x'Γ⊢[suc-k>>x]t^'x'
  --
  -- ih'' : Λ[ (suc k) << x ] (PTerm->Λ x'Γ⊢[suc-k>>x]t^'x'') ~ (t ^' x')
  -- ih'' = fv-^-Λ*^-refl x ([ 0 >> fv x' ] t) {!   !} x'Γ⊢[suc-k>>x]t^'x''
  --
  -- -- ih' : Λ[ 0 << x' ] ( Λ[ (suc k) << x ] (PTerm->Λ x'Γ⊢[suc-k>>x]t^'x') ) ~ t
  -- -- ih' rewrite x'Γ⊢[suc-k>>x]t^'x'≡ = {!   !}
  --
  -- ih : Λ[ (suc k) << x ] ( Λ[ 0 << x' ] (PTerm->Λ x'Γ⊢[suc-k>>x]t^'x') ) ~ t
  -- ih rewrite
  --   Λ*^-*^-swap {τ₂} (suc k) 0 x x' (PTerm->Λ x'Γ⊢[suc-k>>x]t^'x') {!   !} {!   !} |
  --   x'Γ⊢[suc-k>>x]t^'x'≡ = {!   !}

fv-^-Λ*^-refl x (app s t) x∉FVt (app Γ⊢s^x Γ⊢t^x) = app
  (fv-^-Λ*^-refl x s (∉-cons-l _ _ x∉FVt) Γ⊢s^x)
  (fv-^-Λ*^-refl x t (∉-cons-r (FV s) _ x∉FVt) Γ⊢t^x)
fv-^-Λ*^-refl x (Y τ) x∉FVt (Y x₁) = Y

PTerm->Λ~ : ∀ {Γ t τ} -> {Γ⊢t : Γ ⊢ t ∶ τ} -> (PTerm->Λ Γ⊢t) ~ t
PTerm->Λ~ {t = bv i} = λ {τ} → λ {}
PTerm->Λ~ {t = fv x} = λ {τ} {Γ⊢t} → fv
PTerm->Λ~ {t = lam t} {Γ⊢t = abs {τ₁ = τ₁} {τ₂} L cf} =
  lam (fv-^-Λ*^-refl (∃fresh (L ++ FV t)) t (∉-cons-r L _ (∃fresh-spec (L ++ FV t))) (cf (∉-cons-l L (FV t) (∃fresh-spec (L ++ FV t)))))
  -- where
  -- x' = ∃fresh (L ++ FV t)
  -- x'∷Γ⊢t^'x' = cf (∉-cons-l L (FV t) (∃fresh-spec (L ++ FV t)))
  --
  -- ih' : Λ[ 0 << x' ] (PTerm->Λ x'∷Γ⊢t^'x') ~ (* x' ^ (t ^' x'))
  -- ih' = {!   !}
  --
  -- sub : ∀ {τ x m} -> x ∉ FV t -> _~_ {τ} m t ≡ m ~ (* x ^ (t ^' x))
  -- sub {_} {x} x∉ rewrite fv-^-*^-refl x t {0} x∉ = refl
  --
  -- ih : Λ[ 0 << x' ] (PTerm->Λ x'∷Γ⊢t^'x') ~ t
  -- ih rewrite sub {_} {x'} {Λ[ 0 << x' ] (PTerm->Λ x'∷Γ⊢t^'x')} {!   !} = ih'
PTerm->Λ~ {t = app t t₁} {Γ⊢t = app Γ⊢t Γ⊢t₁} = app PTerm->Λ~ PTerm->Λ~
PTerm->Λ~ {t = Y t₁} {Γ⊢t = Y x} = Y

Λ->PTerm : ∀ {t} -> Λ t -> PTerm
Λ->PTerm (bv i) = bv i
Λ->PTerm (fv x) = fv x
Λ->PTerm (lam A Λt) = lam (Λ->PTerm Λt)
Λ->PTerm (app Λs Λt) = app (Λ->PTerm Λs) (Λ->PTerm Λt)
Λ->PTerm (Y t) = Y t

-- data ITypeₛ : IType -> Set where
--   o : ITypeₛ o
--   arr : ∀ {τ τ'} -> ITypeₛ τ -> ITypeₛ τ' -> ITypeₛ (τ ~> τ')
--
-- data ITypeₛₛ : IType -> Set where
--   o : ITypeₛₛ o
--   arr :  ∀ {τ τ'} -> ITypeₛₛ τ -> ITypeₛₛ τ' -> ITypeₛₛ (τ ~> τ')
--   ∩-nil : ITypeₛₛ ω
--   ∩-cons : ∀ {τ τᵢ} -> ITypeₛ τ ->  ITypeₛₛ (∩ τᵢ) -> ITypeₛₛ (∩ (τ ∷ τᵢ))
--
-- τₛ->τₛₛ : ∀ {τ} -> ITypeₛ τ -> ITypeₛₛ τ
-- τₛ->τₛₛ o = o
-- τₛ->τₛₛ (arr τₛ τₛ₁) = arr (τₛ->τₛₛ τₛ) (τₛ->τₛₛ τₛ₁)

Λ[_>>_] : ∀ {τ τ'} -> ℕ -> Λ τ' -> Λ τ -> Λ τ
Λ[_>>_] {τ} {τ'} k u (bv i) with k ≟ i | τ ≟T τ'
Λ[ k >> u ] (bv i) | yes _ | yes refl = u
... | yes _ | no _ = bv i
... | no _ | _ = bv i
Λ[ k >> u ] (fv x) = fv x
Λ[ k >> u ] (lam A t) = lam A (Λ[ (suc k) >> u ] t)
Λ[ k >> u ] (app t1 t2) = app (Λ[ k >> u ] t1) (Λ[ k >> u ] t2) -- app (Λ[ k >> u ] t1) (Λ[ k >> u ] t2)
Λ[ k >> u ] (Y t) = Y t

data Y-shape : ∀ {τ} -> Λ τ -> Set where
  intro₁ : ∀ {A m} -> Y-shape (app (Y A) m)
  intro₂ : ∀ {A m} -> Y-shape (app m (app (Y A) m))

data _⊩_∶_ : ∀ {A} -> ICtxt -> Λ A -> IType -> Set where
  var : ∀ {A Γ x τ} {τᵢ : List IType} -> (wf-Γ : Wf-ICtxt Γ) -> (τᵢ∈Γ : (x , (∩ τᵢ)) ∈ Γ) -> (τᵢ≤∩τ : ∩ τᵢ ≤∩ τ) -> τ ∷' A ->
    Γ ⊩ fv {A} x ∶ τ
  app : ∀ {A B Γ s t τ₁ τ₂} -> Γ ⊩ s ∶ (τ₁ ~> τ₂) -> Γ ⊩ t ∶ τ₁ -> (τ₁ ~> τ₂) ∷' (A ⟶ B) -> τ₁ ∷' B ->
    Γ ⊩ (app {A} {B} s t) ∶ τ₂
  ∩-nil : ∀ {A Γ} {m : Λ A} -> (¬Y-shape : ¬ Y-shape m) -> (wf-Γ : Wf-ICtxt Γ) -> Γ ⊩ m  ∶ ω
  ∩-cons : ∀ {A Γ τ τᵢ} {m : Λ A} -> (¬Y-shape : ¬ Y-shape m) -> (wf-Γ : Wf-ICtxt Γ) ->
    Γ ⊩ m  ∶ τ -> Γ ⊩ m  ∶ (∩ τᵢ) -> Γ ⊩ m  ∶ (∩ (τ ∷ τᵢ))
  abs : ∀ {A B Γ τᵢ τ} (L : FVars) -> ∀ {t : Λ B} ->
    ( cf : ∀ {x} -> (x∉L : x ∉ L) -> ((x , ∩ τᵢ) ∷ Γ) ⊩ Λ[ 0 >> fv {A} x ] t ∶ τ ) -> ∩ τᵢ ∷' A -> τ ∷' B -> Γ ⊩ lam A t ∶ (∩ τᵢ ~> τ)
  Y : ∀ {Γ A τ τ₁ τ₂} -> Wf-ICtxt Γ -> τ ∷' A -> τ₁ ∷' A -> τ₂ ∷' A ->
    Γ ⊩ Y A ∶ ((τ ~> τ₁) ~> τ₂)

-- ⊩->β : ∀ {Γ m m' τ} -> Γ ⊩ m' ∶ τ -> m ->β m' -> Γ ⊩ m ∶ τ
-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = ⊩->β-redL Γ⊩m'∶τ m->βm'
--   where
--   ⊩->β-redL : ∀ {Γ m m' n τ} -> Γ ⊩ app m' n ∶ τ -> m ->β m' -> Γ ⊩ app m n ∶ τ
--   ⊩->β-redL = {!   !}
-- ⊩->β Γ⊩m'∶τ (redR x m->βm') = {!   !}
-- ⊩->β Γ⊩m'∶τ (abs L x) = {!   !}
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β {τ = τ} (app Γ⊩m∶τ'~>τ (app (Y {τ = τ'} wf-Γ τ∷ τ₁∷ τ₂∷) Γ⊩m∶τ'~>τ')) (Y trm-m) =
--     app (Y wf-Γ τ∷ τ₁∷ {!   !}) Γ⊩m∶τ'~>τ'
--
-- ⊩->β (app Γ⊩m'∶τ (∩-nil ¬Y-shape wf-Γ trm-m)) (Y x) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (app Γ⊩m'∶τ (∩-cons ¬Y-shape wf-Γ trm-m Γ⊩m'∶τ₁ Γ⊩m'∶τ₂)) (Y x₁) = ⊥-elim (¬Y-shape intro₁)
-- ⊩->β (∩-nil ¬Y-shape wf-Γ trm-m) (Y x) = ⊥-elim (¬Y-shape intro₂)
-- ⊩->β (∩-cons ¬Y-shape wf-Γ trm-m Γ⊩m'∶τ Γ⊩m'∶τ₁) (Y x₁) = ⊥-elim (¬Y-shape intro₂)
--
--

-- ⊩->β Γ⊩m'∶τ (redL x m->βm') = ⊩->β-redL Γ⊩m'∶τ m->βm'
--   where
--   ⊩->β-redL : ∀ {Γ m m' n τ} -> Γ ⊩ app m' n ∶ τ -> m ->β m' -> Γ ⊩ app m n ∶ τ
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (redL x₁ m->βm'') = app (⊩->β-redL Γ⊩m'n∶τ m->βm'') Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m''n₁n₂∶τᵢ wf-Γ (app _ trm-n₂)) (redL trm-n₁ m->βm'') =
--     ∩-intro (λ τ∈τᵢ → ⊩->β-redL (Γ⊩m''n₁n₂∶τᵢ τ∈τᵢ) (redL trm-n₁ m->βm'')) wf-Γ (app (app (->β-Term-l m->βm'') trm-n₁) trm-n₂)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (redR x₁ m->βm'') = app (⊩->β Γ⊩m'n∶τ (redR x₁ m->βm'')) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m₁e₂n₂∶τᵢ wf-Γ (app (app _ trm-e₂) trm-n₂)) (redR trm-m₁ n₁->e₂) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩m₁e₂n₂∶τᵢ τ∈τᵢ) (redL trm-n₂ (redR trm-m₁ n₁->e₂))) wf-Γ (app (app trm-m₁ (->β-Term-l n₁->e₂)) trm-n₂)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (abs L cf) = app (⊩->β Γ⊩m'n∶τ (abs L cf)) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩lam-m''n₁∶τᵢ wf-Γ (app trm-lam-m'' trm-n₁)) (abs L cf) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩lam-m''n₁∶τᵢ τ∈τᵢ) (redL trm-n₁ (abs L cf))) wf-Γ (app (lam L (λ x∉L → ->β-Term-l (cf x∉L))) trm-n₁)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (beta trm-lam-m₁ trm-n₁) = app (⊩->β Γ⊩m'n∶τ (beta trm-lam-m₁ trm-n₁)) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m₁^n₁n₂∶τ₁ wf-Γ (app trm-m₁^n₁ trm-n₂)) (beta trm-lam-m₁ trm-n₁) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩m₁^n₁n₂∶τ₁ τ∈τᵢ) (redL trm-n₂ (beta trm-lam-m₁ trm-n₁))) wf-Γ (app (app trm-lam-m₁ trm-n₁) trm-n₂)
--   ⊩->β-redL (app Γ⊩m'n∶τ Γ⊩m'n∶τ₁) (Y trm-m₁) = app (⊩->β Γ⊩m'n∶τ (Y trm-m₁)) Γ⊩m'n∶τ₁
--   ⊩->β-redL (∩-intro Γ⊩m₁Ym₁n₁∶τᵢ wf-Γ (app (app _ trm-Ym₁) trm-n₁)) (Y trm-m₁) =
--     ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩m₁Ym₁n₁∶τᵢ τ∈τᵢ) (redL trm-n₁ (Y trm-m₁))) wf-Γ (app trm-Ym₁ trm-n₁)
--
-- ⊩->β (app Γ⊩m'∶τ Γ⊩m'∶τ₁) (redR trm-n m->βm') = app Γ⊩m'∶τ (⊩->β Γ⊩m'∶τ₁ m->βm')
-- ⊩->β (∩-intro Γ⊩mn'∶τᵢ wf-Γ trm-mn') (redR trm-m n->βn') =
--   ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩mn'∶τᵢ τ∈τᵢ) (redR trm-m n->βn')) wf-Γ (app trm-m (->β-Term-l n->βn'))
-- ⊩->β (∩-intro Γ⊩lam-m'∶τᵢ wf-Γ trm-lam-x) (abs L x₂) =
--   ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩lam-m'∶τᵢ τ∈τᵢ) (abs L x₂)) wf-Γ (lam L (λ x∉L → ->β-Term-l (x₂ x∉L)))
-- ⊩->β (abs L cf) (abs L₁ x) = abs (L ++ L₁) (λ x∉L → ⊩->β (cf (∉-cons-l _ _ x∉L)) (x (∉-cons-r L _ x∉L)))
-- ⊩->β Γ⊩m'∶τ (beta x x₁) = {!   !}
-- ⊩->β (app Γ⊩m'∶τ'~>τ (app Γ⊩Ym∶τ' Γ⊩Ym∶τ'')) (Y trm-m) = {!   !}
-- ⊩->β (app Γ⊩m'∶τ'~>τ (∩-intro {τᵢ = []} Γ⊩Ym∶τᵢ wf-Γ trm-Ym)) (Y trm-m) = {!   !}
-- ⊩->β {Γ} (app {s = m} Γ⊩m'∶τ'~>τ (∩-intro {τᵢ = x ∷ τᵢ} Γ⊩Ym∶τᵢ wf-Γ trm-Ym)) (Y trm-m) = {!   !}
--   where
--   Γ⊩m∶x~>x : Γ ⊩ m ∶ (x ~> x)
--   Γ⊩m∶x~>x = {!   !}
-- ⊩->β (∩-intro Γ⊩mYm∶τᵢ wf-Γ (app _ trm-Ym)) (Y trm-m) =
--   ∩-intro (λ τ∈τᵢ → ⊩->β (Γ⊩mYm∶τᵢ τ∈τᵢ) (Y trm-m)) wf-Γ trm-Ym


Some changes to a note on co-inductive natural numbers.

------------------------------------------------------------------------------
-- Definition of FOTC Conat using Agda's co-inductive combinators
------------------------------------------------------------------------------

{-# OPTIONS --allow-unsolved-metas #-}
{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOT.FOTC.Data.Conat.ConatSL where

open import FOTC.Base
open import Coinduction

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

data Conat : D → Set where
  cozero : Conat zero
  cosucc : ∀ {n} → (∞ (Conat n)) → Conat (succ₁ n)

Conat-unf : ∀ {n} → Conat n → n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')
Conat-unf cozero          = inj₁ refl
Conat-unf (cosucc {n} Cn) = inj₂ (n , ♭ Cn , refl)

Conat-pre-fixed : ∀ {n} →
                  (n ≡ zero ∨ (∃[ n' ] Conat n' ∧ n ≡ succ₁ n')) →
                  Conat n
Conat-pre-fixed (inj₁ h) = subst Conat (sym h) cozero
Conat-pre-fixed (inj₂ (n , Cn , h)) = subst Conat (sym h) (cosucc (♯ Cn))

Conat-coind : ∀ (A : D → Set) {n} →
              (A n → n ≡ zero ∨ (∃[ n' ] A n' ∧ n ≡ succ₁ n')) →
              A n → Conat n
Conat-coind A h An = {!!}

postulate
  inf    : D
  inf-eq : inf ≡ succ₁ inf
{-# ATP axiom inf-eq #-}

{-# NO_TERMINATION_CHECK #-}
inf-Conat : Conat inf
inf-Conat = subst Conat (sym inf-eq) (cosucc (♯ inf-Conat))


improved proof that double is even

improved proof that double is even

open import Base

module GoaTest where

data Bool : Type where -- finite type
  true : Bool
  false : Bool

idBool : Bool → Bool -- lambda
idBool x = x

alwaysTrue : Bool → Bool
alwaysTrue x = true

not : Bool → Bool -- case defn
not true = false
not false = true

notnot : Bool → Bool -- lambda
notnot x = not(not(x))

_&_ : Bool → Bool → Bool --curried function
true & x = x
false & _ = false

data ℕ : Type where -- infinite type
  zero : ℕ
  succ : ℕ → ℕ

even : ℕ → Bool -- recursive definition
even zero = true
even (succ x) = not (even x)

_+_ : ℕ → ℕ → ℕ
zero + y = y
succ x + y = x + succ y

{-# BUILTIN NATURAL ℕ #-}

data ℕList : Type where --list type
  [] : ℕList -- empty list
  _::_ : ℕ → ℕList → ℕList -- add number to head of list

mylist : ℕList
mylist = 3 :: (4 :: (2 :: [])) -- the list [3, 4, 2]

data Vector : ℕ → Type where -- type family
  [] : Vector 0
  _::_ : {n : ℕ} → ℕ → Vector n → Vector (succ n)

sum : {n : ℕ} → Vector n → ℕ
sum [] = 0
sum (x :: l) = x + sum l

countdown : (n : ℕ) → Vector n -- dependent function
countdown 0 = []
countdown (succ n) = (succ n) :: (countdown n)

sumToN : ℕ → ℕ -- calculation
sumToN n = sum(countdown n)

data isEven : ℕ → Type where
  0even : isEven 0
  +2even : (n : ℕ) → isEven n → isEven (succ(succ(n)))

4even : isEven 4
4even = +2even _ (+2even _ 0even)

data False : Type where

1odd : isEven 1 → False
1odd ()

3odd : isEven 3 → False
3odd (+2even .1 ())

half : (n : ℕ) → isEven n → ℕ
half .0 0even = 0
half .(succ (succ n)) (+2even n pf) = half n pf

double : (n : ℕ) → ℕ
double 0 = 0
double (succ n) = succ(succ(double(n)))

thm : (n  : ℕ) → isEven (double n)
thm zero = 0even
thm (succ n) = +2even _ (thm n)

halfOfDouble : ℕ → ℕ
halfOfDouble n = half (double n) (thm n)

open import Base

module GoaTest where

data Bool : Type where -- finite type
  true : Bool
  false : Bool

idBool : Bool → Bool -- lambda
idBool x = x

alwaysTrue : Bool → Bool
alwaysTrue x = true

not : Bool → Bool -- case defn
not true = false
not false = true

notnot : Bool → Bool -- lambda
notnot x = not(not(x))

_&_ : Bool → Bool → Bool --curried function
true & x = x
false & _ = false

data ℕ : Type where -- infinite type
  zero : ℕ
  succ : ℕ → ℕ

even : ℕ → Bool -- recursive definition
even zero = true
even (succ x) = not (even x)

_+_ : ℕ → ℕ → ℕ
zero + y = y
succ x + y = x + succ y

{-# BUILTIN NATURAL ℕ #-}

data ℕList : Type where --list type
  [] : ℕList -- empty list
  _::_ : ℕ → ℕList → ℕList -- add number to head of list

mylist : ℕList
mylist = 3 :: (4 :: (2 :: [])) -- the list [3, 4, 2]

data Vector : ℕ → Type where -- type family
  [] : Vector 0
  _::_ : {n : ℕ} → ℕ → Vector n → Vector (succ n)

sum : {n : ℕ} → Vector n → ℕ
sum [] = 0
sum (x :: l) = x + sum l

countdown : (n : ℕ) → Vector n -- dependent function
countdown 0 = []
countdown (succ n) = (succ n) :: (countdown n)

sumToN : ℕ → ℕ -- calculation
sumToN n = sum(countdown n)

data isEven : ℕ → Type where
  0even : isEven 0
  +2even : (n : ℕ) → isEven n → isEven (succ(succ(n)))

4even : isEven 4
4even = +2even _ (+2even _ 0even)

data False : Type where

1odd : isEven 1 → False
1odd ()

3odd : isEven 3 → False
3odd (+2even .1 ())

half : (n : ℕ) → isEven n → ℕ
half .0 0even = 0
half .(succ (succ n)) (+2even n pf) = half n pf

double : (n : ℕ) → ℕ
double 0 = 0
double (succ n) = succ(succ(double(n)))

step : (n : ℕ) → (isEven (double n)) → isEven (double(succ(n)))
step n pf = +2even _ pf

thm : (n  : ℕ) → isEven (double n)
thm zero = 0even
thm (succ n) = step _ (thm n)

halfOfDouble : ℕ → ℕ
halfOfDouble n = half (double n) (thm n)


Added doc (the bisimilarity relation _≈_ is on unbounded lists).

Ignore-this: dbbdf0d52a1b6a25c1ae4a742876f1b0

darcs-hash:20120322232946-3bd4e-379500496257d6c261ce7494f21a26034b65f876.gz

------------------------------------------------------------------------------
-- Bisimilarity relation on unbounded lists
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Relation.Binary.Bisimilarity where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infix 7 _≈_

------------------------------------------------------------------------------
-- The bisimilarity relation _≈_ on unbounded lists is the greatest
-- fixed point (by ≈-gfp₁ and ≈-gfp₂) of the bisimulation functional
-- (see below).

-- The bisimilarity relation on unbounded lists.
postulate
  _≈_ : D → D → Set

-- The bisimilarity relation _≈_ on unbounded lists is a post-fixed
-- point of the bisimulation functional (see below).
postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- The bisimilarity relation _≈_ on unbounded lists is the greatest
-- post-fixed point of the bisimulation functional (see below).
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-gfp₂ : (_R_ : D → D → Set) →
           -- R is a post-fixed point of the bisimulation functional.
           (∀ {xs ys} → xs R ys →
            ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
            xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
           -- _≈_ is greater than R.
           ∀ {xs ys} → xs R ys → xs ≈ ys

-- Because a greatest post-fixed point is a fixed-point, the
-- bisimilarity relation _≈_ on unbounded lists is also a pre-fixed
-- point of the bisimulation functional (see below).
≈-gfp₃ : ∀ {xs ys} →
         (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
          xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
         xs ≈ ys
≈-gfp₃ h = ≈-gfp₂ _R_ helper h
  where
  _R_ : D → D → Set
  _R_ xs ys = ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  helper : ∀ {xs ys} → xs R ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper (_ , _ , _ , xs'≈ys' , prf) = _ , _ , _ , ≈-gfp₁ xs'≈ys' , prf

private
  module Bisimulation where
  -- In FOTC we won't use the bisimulation functional on unbounded
  -- lists. This module is only for illustrative purposes.

  -- References:
  --
  -- • Peter Dybjer and Herbert Sander. A functional programming
  --   approach to the specification and verification of concurrent
  --   systems. Formal Aspects of Computing, 1:303–319, 1989.
  --
  -- • Bart Jacobs and Jan Rutten. (Co)algebras and
  --   (co)induction. EATCS Bulletin, 62:222–259, 1997.

  ----------------------------------------------------------------------------
  -- The bisimilarity relation _≈_ on unbounded lists is the greatest
  -- post-fixed point of Bisimulation (by post-fp and gpfp).

  -- The bisimulation functional on unbounded lists (adapted from
  -- Dybjer and Sander 1989, p. 310, and Jacobs and Rutten 1997,
  -- p. 30).
  BisimulationF : (D → D → Set) → D → D → Set
  BisimulationF _R_ xs ys =
    ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  -- The bisimilarity relation _≈_ on unbounded lists is a post-fixed
  -- point of Bisimulation, i.e,
  --
  -- _≈_ ≤ Bisimulation _≈_.
  post-fp : ∀ {xs ys} → xs ≈ ys → BisimulationF _≈_ xs ys
  post-fp = ≈-gfp₁

  -- The bisimilarity relation _≈_ on unbounded lists is the greatest
  -- post-fixed point of Bisimulation, i.e
  --
  -- ∀ R. R ≤ Bisimulation R ⇒ R ≤ _≈_.
  gpfp : (_R_ : D → D → Set) →
         -- R is a post-fixed point of Bisimulation.
         (∀ {xs ys} → xs R ys → BisimulationF _R_ xs ys) →
         -- _≈_ is greater than R.
         ∀ {xs ys} → xs R ys → xs ≈ ys
  gpfp = ≈-gfp₂

  -- Because a greatest post-fixed point is a fixed-point, the
  -- bisimilarity relation _≈_ on unbounded lists is also a pre-fixed
  -- point of Bisimulation, i.e.
  --
  -- Bisimulation _≈_ ≤ _≈_.
  pre-fp : ∀ {xs ys} → BisimulationF _≈_ xs ys → xs ≈ ys
  pre-fp = ≈-gfp₃

------------------------------------------------------------------------------
-- Bisimilarity relation
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

module FOTC.Relation.Binary.Bisimilarity where

open import FOTC.Base

-- We add 3 to the fixities of the standard library.
infix 7 _≈_

------------------------------------------------------------------------------
-- The bisimilarity relation _≈_ is the greatest fixed point (by
-- ≈-gfp₁ and ≈-gfp₂) of the bisimulation functional (see below).

-- The bisimilarity relation.
postulate
  _≈_ : D → D → Set

-- The bisimilarity relation _≈_ is a post-fixed point of the
-- bisimulation functional (see below).
postulate
  ≈-gfp₁ : ∀ {xs ys} → xs ≈ ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
{-# ATP axiom ≈-gfp₁ #-}

-- The bisimilarity relation _≈_ is the greatest post-fixed point of
-- the bisimulation functional (see below).
--
-- N.B. This is an axiom schema. Because in the automatic proofs we
-- *must* use an instance, we do not add this postulate as an ATP
-- axiom.
postulate
  ≈-gfp₂ : (_R_ : D → D → Set) →
           -- R is a post-fixed point of the bisimulation functional.
           (∀ {xs ys} → xs R ys →
            ∃[ x' ] ∃[ xs' ] ∃[ ys' ]
            xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
           -- _≈_ is greater than R.
           ∀ {xs ys} → xs R ys → xs ≈ ys

-- Because a greatest post-fixed point is a fixed-point, the
-- bisimilarity relation _≈_ is also a pre-fixed point of the
-- bisimulation functional (see below).
≈-gfp₃ : ∀ {xs ys} →
         (∃[ x' ]  ∃[ xs' ] ∃[ ys' ]
          xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys') →
         xs ≈ ys
≈-gfp₃ h = ≈-gfp₂ _R_ helper h
  where
  _R_ : D → D → Set
  _R_ xs ys = ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  helper : ∀ {xs ys} → xs R ys →
           ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'
  helper (_ , _ , _ , xs'≈ys' , prf) = _ , _ , _ , ≈-gfp₁ xs'≈ys' , prf

private
  module Bisimulation where
  -- In FOTC we won't use the bisimulation functional. This module is
  -- only for illustrative purposes.

  -- References:
  --
  -- • Peter Dybjer and Herbert Sander. A functional programming
  --   approach to the specification and verification of concurrent
  --   systems. Formal Aspects of Computing, 1:303–319, 1989.
  --
  -- • Bart Jacobs and Jan Rutten. (Co)algebras and
  --   (co)induction. EATCS Bulletin, 62:222–259, 1997.

  ----------------------------------------------------------------------------
  -- Adapted from (Dybjer and Sander 1989, p. 310). In this paper, the
  -- authors use the name

  -- as (R :: R') bs'

  -- for the bisimulation functional.

  -- The bisimilarity relation _≈_ is the greatest post-fixed point of
  -- Bisimulation (by post-fp and gpfp).

  -- The bisimulation functional (Jacobs and Rutten 1997, p. 30).
  BisimulationF : (D → D → Set) → D → D → Set
  BisimulationF _R_ xs ys =
    ∃[ x' ] ∃[ xs' ] ∃[ ys' ] xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys'

  -- The bisimilarity relation _≈_ is a post-fixed point of
  -- Bisimulation, i.e,
  --
  -- _≈_ ≤ Bisimulation _≈_.
  post-fp : ∀ {xs ys} → xs ≈ ys → BisimulationF _≈_ xs ys
  post-fp = ≈-gfp₁

  -- The bisimilarity relation _≈_ is the greatest post-fixed point of
  -- Bisimulation, i.e
  --
  -- ∀ R. R ≤ Bisimulation R ⇒ R ≤ _≈_.
  gpfp : (_R_ : D → D → Set) →
         -- R is a post-fixed point of Bisimulation.
         (∀ {xs ys} → xs R ys → BisimulationF _R_ xs ys) →
         -- _≈_ is greater than R.
         ∀ {xs ys} → xs R ys → xs ≈ ys
  gpfp = ≈-gfp₂

  -- Because a greatest post-fixed point is a fixed-point, the
  -- bisimilarity relation _≈_ is also a pre-fixed point of
  -- Bisimulation, i.e.
  --
  -- Bisimulation _≈_ ≤ _≈_.
  pre-fp : ∀ {xs ys} → BisimulationF _≈_ xs ys → xs ≈ ys
  pre-fp = ≈-gfp₃


Added two automatic proofs.

Added two automatic proofs.

------------------------------------------------------------------------------
-- Conat properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- References:
--
-- • Herbert P. Sander. A logic of functional programs with an
--   application to concurrency. PhD thesis, Chalmers University of
--   Technology and University of Gothenburg, Department of Computer
--   Sciences, 1992.

module FOTC.Data.Conat.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Nat

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

0-Conat : Conat zero
0-Conat = Conat-coind P h refl
  where
  P : D → Set
  P n = n ≡ zero
  {-# ATP definition P #-}

  postulate h : ∀ {n} → P n → n ≡ zero ∨ (∃[ n' ] P n' ∧ n ≡ succ₁ n')
  {-# ATP prove h #-}

-- Adapted from (Sander 1992, p. 57).
∞-Conat : Conat ∞
∞-Conat = Conat-coind P h refl
  where
  P : D → Set
  P n = n ≡ ∞
  {-# ATP definition P #-}

  postulate h : ∀ {n} → P n → n ≡ zero ∨ (∃[ n' ] P n' ∧ n ≡ succ₁ n')
  {-# ATP prove h #-}

N→Conat : ∀ {n} → N n → Conat n
N→Conat Nn = Conat-coind N h Nn
  where
  h : ∀ {m} → N m → m ≡ zero ∨ ∃ (λ m' → N m' ∧ m ≡ succ₁ m')
  h nzero = prf
    where postulate prf : zero ≡ zero ∨ ∃ (λ m' → N m' ∧ zero ≡ succ₁ m')
          {-# ATP prove prf #-}
  h (nsucc {m} Nm) = prf
    where postulate prf : succ₁ m ≡ zero ∨ ∃ (λ m' → N m' ∧ succ₁ m ≡ succ₁ m')
          {-# ATP prove prf #-}

------------------------------------------------------------------------------
-- Conat properties
------------------------------------------------------------------------------

{-# OPTIONS --no-universe-polymorphism #-}
{-# OPTIONS --without-K #-}

-- References:
--
-- • Herbert P. Sander. A logic of functional programs with an
--   application to concurrency. PhD thesis, Chalmers University of
--   Technology and University of Gothenburg, Department of Computer
--   Sciences, 1992.

module FOTC.Data.Conat.PropertiesATP where

open import FOTC.Base
open import FOTC.Data.Conat
open import FOTC.Data.Nat

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

0-Conat : Conat zero
0-Conat = Conat-coind P h refl
  where
  P : D → Set
  P n = n ≡ zero
  {-# ATP definition P #-}

  postulate h : ∀ {n} → P n → n ≡ zero ∨ (∃[ n' ] P n' ∧ n ≡ succ₁ n')
  {-# ATP prove h #-}

-- Adapted from (Sander 1992, p. 57).
∞-Conat : Conat ∞
∞-Conat = Conat-coind P h refl
  where
  P : D → Set
  P n = n ≡ ∞
  {-# ATP definition P #-}

  postulate h : ∀ {n} → P n → n ≡ zero ∨ (∃[ n' ] P n' ∧ n ≡ succ₁ n')
  {-# ATP prove h #-}

N→Conat : ∀ {n} → N n → Conat n
N→Conat Nn = Conat-coind N h Nn
  where
  h : ∀ {m} → N m → m ≡ zero ∨ ∃ (λ m' → N m' ∧ m ≡ succ₁ m')
  h nzero          = inj₁ refl
  h (nsucc {m} Nm) = inj₂ (m , Nm , refl)