[ test-suite ] Fixed withespace issues.

[ test-suite ] Fixed withespace issues.

------------------------------------------------------------------------------
-- Testing the translation of the logical constants
------------------------------------------------------------------------------

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

module LogicalConstants where

infix  5 ¬_
infixr 4 _∧_
infixr 3 _∨_
infixr 2 _⇒_
infixr 1 _↔_ _⇔_

------------------------------------------------------------------------------
-- Propositional logic

-- The logical constants

-- The logical constants are hard-coded in our implementation,
-- i.e. the following symbols must be used (it is possible to use Agda
-- non-dependent function space → instead of ⇒).
postulate
  ⊥ ⊤         : Set -- N.B. the name of the tautology symbol is "\top" not T.
  ¬_          : Set → Set -- N.B. the right hole.
  _∧_ _∨_     : Set → Set → Set
  _⇒_ _↔_ _⇔_ : Set → Set → Set

-- We postulate some formulae (which are translated as 0-ary
-- predicates).
postulate A B C : Set

-- Testing the conditional using the non-dependent function type.
postulate A→A : A → A
{-# ATP prove A→A #-}

-- The introduction and elimination rules for the propositional
-- connectives are theorems.
postulate
  →I  : (A → B) → A ⇒ B
  →E  : (A ⇒ B) → A → B
  ∧I  : A → B → A ∧ B
  ∧E₁ : A ∧ B → A
  ∧E₂ : A ∧ B → B
  ∨I₁ : A → A ∨ B
  ∨I₂ : B → A ∨ B
  ∨E  : (A ⇒ C) → (B ⇒ C) → A ∨ B → C
  ⊥E  : ⊥ → A
  ¬E : (¬ A → ⊥) → A
{-# ATP prove →I #-}
{-# ATP prove →E #-}
{-# ATP prove ∧I #-}
{-# ATP prove ∧E₁ #-}
{-# ATP prove ∧E₂ #-}
{-# ATP prove ∨I₁ #-}
{-# ATP prove ∨I₂ #-}
{-# ATP prove ∨E #-}
{-# ATP prove ⊥E #-}
{-# ATP prove ¬E #-}

-- Testing other logical constants.
postulate
  thm₁ : A ∧ ⊤ → A
  thm₂ : A ∨ ⊥ → A
  thm₃ : A ↔ A
  thm₄ : A ⇔ A
{-# ATP prove thm₁ #-}
{-# ATP prove thm₂ #-}
{-# ATP prove thm₃ #-}
{-# ATP prove thm₄ #-}

------------------------------------------------------------------------------
-- Predicate logic

--- The universe of discourse.
postulate D : Set

-- The propositional equality is hard-coded in our implementation, i.e. the
-- following symbol must be used.
postulate _≡_ : D → D → Set

-- Testing propositional equality.
postulate refl : ∀ {x} → x ≡ x
{-# ATP prove refl #-}

-- The quantifiers are hard-coded in our implementation, i.e. the
-- following symbols must be used (it is possible to use Agda
-- dependent function space ∀ x → A instead of ⋀).
postulate
  ∃ : (A : D → Set) → Set
  ⋀ : (A : D → Set) → Set

-- We postulate some formulae and propositional functions.
postulate
  A¹ B¹ : D → Set
  A²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are
-- theorems.
postulate
  ∀I₁ : ((x : D) → A¹ x) → ⋀ A¹
  ∀I₂ : ((x : D) → A¹ x) → ∀ x → A¹ x
  ∀E₁ : (t : D) → ⋀ A¹ → A¹ t
  ∀E₂ : (t : D) → (∀ x → A¹ x) → A¹ t
{-# ATP prove ∀I₁ #-}
{-# ATP prove ∀I₂ #-}
{-# ATP prove ∀E₁ #-}
{-# ATP prove ∀E₂ #-}

postulate ∃I : (t : D) → A¹ t → ∃ A¹
{-# ATP prove ∃I #-}

postulate ∃E : ∃ A¹ → ((x : D) → A¹ x → A) → A
{-# ATP prove ∃E #-}

------------------------------------------------------------------------------
-- Testing the translation of the logical constants
------------------------------------------------------------------------------

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

module LogicalConstants where

infix  5 ¬_
infixr 4 _∧_
infixr 3 _∨_
infixr 2 _⇒_
infixr 1 _↔_ _⇔_

------------------------------------------------------------------------------
-- Propositional logic

-- The logical constants

-- The logical constants are hard-coded in our implementation,
-- i.e. the following symbols must be used (it is possible to use Agda
-- non-dependent function space → instead of ⇒).
postulate
  ⊥ ⊤         : Set -- N.B. the name of the tautology symbol is "\top" not T.
  ¬_          : Set → Set -- N.B. the right hole.
  _∧_ _∨_     : Set → Set → Set
  _⇒_ _↔_ _⇔_ : Set → Set → Set

-- We postulate some formulae (which are translated as 0-ary
-- predicates).
postulate A B C : Set

-- Testing the conditional using the non-dependent function type.
postulate A→A : A → A
{-# ATP prove A→A #-}

-- The introduction and elimination rules for the propositional
-- connectives are theorems.
postulate
  →I  : (A → B) → A ⇒ B
  →E  : (A ⇒ B) → A → B
  ∧I  : A → B → A ∧ B
  ∧E₁ : A ∧ B → A
  ∧E₂ : A ∧ B → B
  ∨I₁ : A → A ∨ B
  ∨I₂ : B → A ∨ B
  ∨E  : (A ⇒ C) → (B ⇒ C) → A ∨ B → C
  ⊥E  : ⊥ → A
  ¬E : (¬ A → ⊥ ) → A
{-# ATP prove →I #-}
{-# ATP prove →E #-}
{-# ATP prove ∧I #-}
{-# ATP prove ∧E₁ #-}
{-# ATP prove ∧E₂ #-}
{-# ATP prove ∨I₁ #-}
{-# ATP prove ∨I₂ #-}
{-# ATP prove ∨E #-}
{-# ATP prove ⊥E #-}
{-# ATP prove ¬E #-}

-- Testing other logical constants.
postulate
  thm₁ : A ∧ ⊤ → A
  thm₂ : A ∨ ⊥ → A
  thm₃ : A ↔ A
  thm₄ : A ⇔ A
{-# ATP prove thm₁ #-}
{-# ATP prove thm₂ #-}
{-# ATP prove thm₃ #-}
{-# ATP prove thm₄ #-}

------------------------------------------------------------------------------
-- Predicate logic

--- The universe of discourse.
postulate D : Set

-- The propositional equality is hard-coded in our implementation, i.e. the
-- following symbol must be used.
postulate _≡_ : D → D → Set

-- Testing propositional equality.
postulate refl : ∀ {x} → x ≡ x
{-# ATP prove refl #-}

-- The quantifiers are hard-coded in our implementation, i.e. the
-- following symbols must be used (it is possible to use Agda
-- dependent function space ∀ x → A instead of ⋀).
postulate
  ∃ : (A : D → Set) → Set
  ⋀ : (A : D → Set) → Set

-- We postulate some formulae and propositional functions.
postulate
  A¹ B¹ : D → Set
  A²    : D → D → Set

-- The introduction and elimination rules for the quantifiers are theorems.

postulate
  ∀I₁ : ((x : D) → A¹ x) → ⋀ A¹
  ∀I₂ : ((x : D) → A¹ x) → ∀ x → A¹ x
  ∀E₁ : (t : D) → ⋀ A¹ → A¹ t
  ∀E₂ : (t : D) → (∀ x → A¹ x) → A¹ t
{-# ATP prove ∀I₁ #-}
{-# ATP prove ∀I₂ #-}
{-# ATP prove ∀E₁ #-}
{-# ATP prove ∀E₂ #-}

postulate ∃I : (t : D) → A¹ t → ∃ A¹
{-# ATP prove ∃I #-}

postulate ∃E : ∃ A¹ → ((x : D) → A¹ x → A) → A
{-# ATP prove ∃E #-}


Better information in the types of some postulates.

Ignore-this: 8be0603121976d97c85d4ff3f9d0d846

darcs-hash:20100518143526-3bd4e-b3ea6d1272f6f65ce69c749ab34c168758fa6526.gz

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<0 (sN Nn) Sn<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf x≥0 #-}

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 Sd≤0 = ⊥-elim prf
  where
    -- The proof uses the axiom true≠false
    postulate prf : ⊥
    {-# ATP prove prf #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
    postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
    postulate prf : ¬ (LT m m) → ⊥
    {-# ATP prove prf #-}

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn)          _     = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE m n →
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

trans-LT : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
trans-LT zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
trans-LT zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
trans-LT zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
trans-LT (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
trans-LT (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
trans-LT (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  prf (trans-LT Nm Nn No m<n n<o)

  where
    postulate prf : LT m o → LT (succ m) (succ o)
    {-# ATP prove prf #-}

    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate n<o : LT n o
    {-# ATP prove n<o #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
    postulate prf : LE m (m + n) → LE (succ m) (succ m + n)
    {-# ATP prove prf #-}

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
    postulate prf : LT (m - zero) (succ m)
    {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : LT (zero - succ n) (succ zero)
    {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
    postulate prf : LT (m - n) (succ m) →
                    LT (succ m - succ n) (succ (succ m))
    {-# ATP prove prf trans-LT minus-N x<Sx sN #-}

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m - zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m - n) + n ≡ m →
                    (succ m - succ n) + succ n ≡ succ m
    {-# ATP prove prf +-comm minus-N sN #-}

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n - zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity minus-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y-x+x≡y Nm Nn m≤n )
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n - m) + m ≡ n →
                    (succ n - succ m) + succ m ≡ succ n
    {-# ATP prove prf +-comm minus-N sN #-}

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

------------------------------------------------------------------------------
-- Properties of the inequalities
------------------------------------------------------------------------------

module LTC.Relation.Inequalities.Properties where

open import LTC.Minimal

open import LTC.Data.N
open import LTC.Function.Arithmetic
open import LTC.Function.Arithmetic.Properties
open import LTC.Relation.Inequalities

open import MyStdLib.Data.Sum
open import MyStdLib.Function

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

-- TODO: Why the ATP couldn't prove it?
-- postulate
--   x≥0 : (n : D) → N n → GE n zero
-- {-# ATP prove x≥0 zN sN #-}

x≥0 : {n : D} → N n → GE n zero
x≥0 zN          = lt-00
x≥0 (sN {n} Nn) = lt-S0 n
-- {-# ATP hint x≥0 #-}

¬x<0 : {n : D} → N n → ¬ (LT n zero)
¬x<0 zN 0<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<0 (sN Nn) Sn<0 = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}

¬0>x : {n : D} → N n → ¬ (GT zero n)
¬0>x Nn 0>n = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf x≥0 #-}

¬S≤0 : {d : D} → ¬ (LE (succ d) zero)
¬S≤0 Sd≤0 = ⊥-elim prf
  where
    -- The proof uses the axiom true≠false
    postulate prf : ⊥
    {-# ATP prove prf #-}

x<Sx : {n : D} → N n → LT n (succ n)
x<Sx zN          = lt-0S zero
x<Sx (sN {n} Nn) = prf (x<Sx Nn)
  where
    postulate prf : LT n (succ n) → LT (succ n) (succ (succ n))
    {-# ATP prove prf #-}

x>y∨x≤y : {m n : D} → N m → N n → GT m n ∨ LE m n
x>y∨x≤y zN          Nn          = inj₂ $ x≥0 Nn
x>y∨x≤y (sN {m} Nm) zN          = inj₁ $ lt-0S m
x>y∨x≤y (sN {m} Nm) (sN {n} Nn) = prf $ x>y∨x≤y Nm Nn
  where
    postulate
      prf : (GT m n) ∨ (LE m n) →
            GT (succ m) (succ n) ∨ LE (succ m) (succ n)
    {-# ATP prove prf #-}

¬x<x : {m : D} → N m → ¬ (LT m m)
¬x<x zN _ = ⊥-elim prf
  where
    postulate prf : ⊥
    {-# ATP prove prf #-}
¬x<x (sN {m} Nm) _ = ⊥-elim (prf (¬x<x Nm))
  where
    postulate prf : ¬ (LT m m) → ⊥
    {-# ATP prove prf #-}

x<y→x≤y : {m n : D} → N m → N n → LT m n → LE m n
x<y→x≤y Nm zN          m<0            = ⊥-elim (¬x<0 Nm m<0)
x<y→x≤y zN (sN {n} Nn)          _     = lt-S0 n
x<y→x≤y (sN {m} Nm) (sN {n} Nn) Sm<Sn = prf (x<y→x≤y Nm Nn m<n)
  where
    postulate m<n : LT m n
    {-# ATP prove m<n #-}

    postulate prf : LE m n →
                    LE (succ m) (succ n)
    {-# ATP prove prf #-}

trans-LT : {m n o : D} → N m → N n → N o → LT m n → LT n o → LT m o
trans-LT zN          zN           _          0<0   _    = ⊥-elim (¬x<0 zN 0<0)
trans-LT zN          (sN Nn)     zN          _     Sn<0 = ⊥-elim (¬x<0 (sN Nn) Sn<0)
trans-LT zN          (sN Nn)     (sN {o} No) _     _    = lt-0S o
trans-LT (sN Nm)     Nn          zN          _     n<0  = ⊥-elim (¬x<0 Nn n<0)
trans-LT (sN Nm)     zN          (sN No)     Sm<0  _    = ⊥-elim (¬x<0 (sN Nm) Sm<0)
trans-LT (sN {m} Nm) (sN {n} Nn) (sN {o} No) Sm<Sn Sn<So =
  prf (trans-LT Nm Nn No m<n n<o)

  where
    postulate prf : lt m o ≡ true →
                    lt (succ m) (succ o) ≡ true
    {-# ATP prove prf #-}

    postulate m<n : lt m n ≡ true
    {-# ATP prove m<n #-}

    postulate n<o : lt n o ≡ true
    {-# ATP prove n<o #-}

x≤x+y : {m n : D} → N m → N n → LE m (m + n)
x≤x+y         zN          Nn = x≥0 (+-N zN Nn)
x≤x+y {n = n} (sN {m} Nm) Nn = prf (x≤x+y Nm Nn)
  where
    postulate prf : lt (m + n) m ≡ false →
                    lt (succ m + n) (succ m) ≡ false
    {-# ATP prove prf #-}

x-y<Sx : {m n : D} → N m → N n → LT (m - n) (succ m)
x-y<Sx {m} Nm zN = prf
  where
    postulate prf : lt (m - zero) (succ m) ≡ true
    {-# ATP prove prf x<Sx #-}

x-y<Sx zN (sN {n} Nn) = prf
  where
    postulate prf : lt (zero - succ n) (succ zero) ≡ true
    {-# ATP prove prf #-}

x-y<Sx (sN {m} Nm) (sN {n} Nn) = prf (x-y<Sx Nm Nn)
  where
    postulate prf : lt (m - n) (succ m) ≡ true →
                    lt (succ m - succ n) (succ (succ m)) ≡ true
    {-# ATP prove prf trans-LT minus-N x<Sx sN #-}

x>y→x-y+y≡x : {m n : D} → N m → N n → GT m n → (m - n) + n ≡ m
x>y→x-y+y≡x zN Nn 0>n = ⊥-elim (¬0>x Nn 0>n)
x>y→x-y+y≡x (sN {m} Nm) zN Sm>0 = prf
  where
    postulate prf : (succ m - zero) + zero ≡ succ m
    {-# ATP prove prf +-rightIdentity minus-N #-}

x>y→x-y+y≡x (sN {m} Nm) (sN {n} Nn) Sm>Sn = prf (x>y→x-y+y≡x Nm Nn m>n )
  where
    postulate m>n : GT m n
    {-# ATP prove m>n #-}

    postulate prf : (m - n) + n ≡ m →
                    (succ m - succ n) + succ n ≡ succ m
    {-# ATP prove prf +-comm minus-N sN #-}

x≤y→y-x+x≡y : {m n : D} → N m → N n → LE m n → (n - m) + m ≡ n
x≤y→y-x+x≡y {n = n} zN Nn 0≤n  = prf
  where
    postulate prf : (n - zero) + zero ≡ n
    {-# ATP prove prf +-rightIdentity minus-N #-}

x≤y→y-x+x≡y (sN Nm) zN Sm≤0 = ⊥-elim (¬S≤0 Sm≤0)

x≤y→y-x+x≡y (sN {m} Nm) (sN {n} Nn) Sm≤Sn = prf (x≤y→y-x+x≡y Nm Nn m≤n )
  where
    postulate m≤n : LE m n
    {-# ATP prove m≤n #-}

    postulate prf : (n - m) + m ≡ n →
                    (succ n - succ m) + succ m ≡ succ n
    {-# ATP prove prf +-comm minus-N sN #-}

[Sx-Sy,Sy]<[Sx,Sy] :
  {m n : D} → N m → N n →
  LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
[Sx-Sy,Sy]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m - succ n) (succ n) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}

[Sx,Sy-Sx]<[Sx,Sy] : {m n : D} → N m → N n →
                     LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
[Sx,Sy-Sx]<[Sx,Sy] {m} {n} Nm Nn = prf
  where
    postulate prf : LT₂ (succ m) (succ n - succ m) (succ m) (succ n)
    {-# ATP prove prf sN x-y<Sx #-}


⊤-U is uniq

⊤-U is uniq

module universe where

import Level as L
import Relation.Binary.PropositionalEquality as ≡
open ≡ using (_≡_)
open import Function
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (Σ; _×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

-- An interface for small, finite & discrete universes of types.
record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

-- In Set-U, types are simply represented by Agda types (Set).
Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

-- In Bits-U, a type is represented by a natural number
-- representing the width of the type in a binary representation.
-- A natural embedding in Set is the Bits type (aka Vec Bool).
Bits-U : Universe ℕ
Bits-U = mk 0 1 _+_ (flip _*_)

-- In Fin-U, a type is represented by a natural number
-- representing the cardinality of the type.
-- A natural embedding in Set is the Fin type.
Fin-U : Universe ℕ
Fin-U = mk 1 2 _*_ _^_

-- In ⊤-U, there is only one possible type.
⊤-U : Universe ⊤
⊤-U = _ -- Agda figures out that there is only one such universe

⊤-U-uniq : {U₀ U₁ : Universe ⊤} → U₀ ≡ U₁
⊤-U-uniq = ≡.refl

-- Take the product of two universes. All types have two components, one from
-- each of the forming universes.
×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

-- Sym-U is a “symantic” (a mix of syntax and semantics) representation
-- for types. Symantic types are those defined only in term of the
-- Universe interface. [See the “Finally Tagless” approach by Oleg Kiselyov.]
Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T → T

-- Abstract syntax tree from types.
data Ty : Set where
  ⊤′ Bit′ : Ty
  _×′_    : Ty → Ty → Ty
  _^′_    : Ty → ℕ → Ty

-- Ty-U is the universe of the syntactic represented types.
Ty-U : Universe Ty
Ty-U = mk ⊤′ Bit′ _×′_ _^′_

-- Turn a syntactic type into a symantic one.
-- Alternatively:
--   * a syntactic type is turned into a type of any $given universe.
--   * the catamorphism for syntactic types.
fold-U : ∀ {t} → Ty → Sym-U t
fold-U u₀ {T} uni = go u₀
  where open Universe uni
        go : Ty → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

{-
Σ-U : ∀ {t} {T : Set t} → Universe T → (P : T → Set) → Universe (Σ T P)
Σ-U T-U P = mk (`⊤ , {!!}) {!!} {!!} {!!}
  where open Universe T-U
-}

-- The type of universe unary operators or universe transformers.
UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

-- The type of universe binary operators.
UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T

module universe where

import Level as L
open import Function
open import Data.Nat.NP using (ℕ; _+_; _*_; _^_)
open import Data.Bits using (Bit)
open import Data.Unit using (⊤)
open import Data.Product using (Σ; _×_; _,_) renaming (zip to ×-zip)
open import Data.Vec using (Vec)

-- An interface for small, finite & discrete universes of types.
record Universe {t} (T : Set t) : Set t where
  constructor mk
  field
    `⊤    : T
    `Bit  : T
    _`×_  : T → T → T
    _`^_  : T → ℕ → T

  `Vec : T → ℕ → T
  `Vec A n = A `^ n

  `Bits : ℕ → T
  `Bits n = `Bit `^ n

  infixr 2 _`×_
  infixl 2 _`^_

-- In Set-U, types are simply represented by Agda types (Set).
Set-U : Universe Set
Set-U = mk ⊤ Bit _×_ Vec

-- In Bits-U, a type is represented by a natural number
-- representing the width of the type in a binary representation.
-- A natural embedding in Set is the Bits type (aka Vec Bool).
Bits-U : Universe ℕ
Bits-U = mk 0 1 _+_ (flip _*_)

-- In Fin-U, a type is represented by a natural number
-- representing the cardinality of the type.
-- A natural embedding in Set is the Fin type.
Fin-U : Universe ℕ
Fin-U = mk 1 2 _*_ _^_

-- In ⊤-U, there is only one possible type.
⊤-U : Universe ⊤
⊤-U = mk _ _ _ _

-- Take the product of two universes. All types have two components, one from
-- each of the forming universes.
×-U : ∀ {s t} {S : Set s} {T : Set t} → Universe S → Universe T → Universe (S × T)
×-U S-U T-U = mk (S.`⊤ , T.`⊤) (S.`Bit , T.`Bit) (×-zip S._`×_ T._`×_)
                 (λ { (A₀ , A₁) n → S.`Vec A₀ n , T.`Vec A₁ n })
  where module S = Universe S-U
        module T = Universe T-U

-- Sym-U is a “symantic” (a mix of syntax and semantics) representation
-- for types. Symantic types are those defined only in term of the
-- Universe interface. [See the “Finally Tagless” approach by Oleg Kiselyov.]
Sym-U : ∀ t → Set (L.suc t)
Sym-U t = ∀ {T : Set t} → Universe T → T

-- Abstract syntax tree from types.
data Ty : Set where
  ⊤′ Bit′ : Ty
  _×′_    : Ty → Ty → Ty
  _^′_    : Ty → ℕ → Ty

-- Ty-U is the universe of the syntactic represented types.
Ty-U : Universe Ty
Ty-U = mk ⊤′ Bit′ _×′_ _^′_

-- Turn a syntactic type into a symantic one.
-- Alternatively:
--   * a syntactic type is turned into a type of any $given universe.
--   * the catamorphism for syntactic types.
fold-U : ∀ {t} → Ty → Sym-U t
fold-U u₀ {T} uni = go u₀
  where open Universe uni
        go : Ty → T
        go ⊤′         = `⊤
        go Bit′       = `Bit
        go (t₀ ×′ t₁) = go t₀ `× go t₁
        go (t ^′ n)   = go t `^ n

{-
Σ-U : ∀ {t} {T : Set t} → Universe T → (P : T → Set) → Universe (Σ T P)
Σ-U T-U P = mk (`⊤ , {!!}) {!!} {!!} {!!}
  where open Universe T-U
-}

-- The type of universe unary operators or universe transformers.
UniOp : ∀ {s t} (S : Set s) (T : Set t) → Set _
UniOp S T = Universe S → Universe T

-- The type of universe binary operators.
UniOp₂ : ∀ {r s t} (R : Set r) (S : Set s) (T : Set t) → Set _
UniOp₂ R S T = Universe R → Universe S → Universe T


typo in nu

typo in nu

{-# OPTIONS --copatterns #-}
open import Function
open import Data.Product hiding (zip)
                         renaming (_,_ to ⟨_,_⟩; proj₁ to fst; proj₂ to snd;
                                   map to ×map)
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum
open import Data.Nat
{-
open import Data.Vec
open import Data.Fin
-}
-- open import Data.List

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP hiding ([_]; J)
open import partensor.Shallow.Dom
import partensor.Shallow.Session as Session
import partensor.Shallow.Map as Map
import partensor.Shallow.Env as Env
import partensor.Shallow.Proto as Proto
open Session hiding (Ended)
open Env     hiding (_/₀_; _/₁_; _/_; Ended)
open Proto   hiding ()
open import partensor.Shallow.Equiv

module partensor.Shallow.Term where

data ⟨_⟩ {δI}(I : Proto δI) : Set₁ where
  end :
    Ended I
    → ⟨ I ⟩

  ⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I )
      (P : ∀ c₀ c₁ → ⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → ⟨ I ⟩

  ⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (P : ∀ c₀ c₁ → ⟨ I [/…] l ,[ E/ l , c₀ ↦ S₀ , c₁ ↦ S₁ ] ⟩)
    → ⟨ I ⟩

  split :
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : ⟨ I /₀ σs ⟩)
      (P₁ : ⟨ I /₁ σs ⟩)
    → ⟨ I ⟩

  nu :
    ∀ {S₀ S₁}
      (D : Dual S₀ S₁)
      (P : ∀ c₀ c₁ → ⟨ I ,[ ε , c₀ ↦ S₀ , c₁ ↦ S₁ ] ⟩)
    → ⟨ I ⟩

{-
  module _ {δF}(F : Env δF) where
    ⊗-split : ∀ {δ δs}{I : Proto δs}{E : Env δ}
                 (l : Doms'.[ δ ]∈ δs)
                 -- (l : [ E ]∈ I)
                 -- {c S}(l' : c ↦ S ∈ E)
                 (P : ⟨ I ⟩)
                 (κ : ∀ {c S}
                        -- E
                        (l' : c ↦ S ∈ E)
                        {J : Proto δs}
                        (σs : Selections δs)
                        (A0 : AtMost 0 σs)
                        (P₀ : ⟨ J /₀ σs ,[ (E Env./ l' , c ↦ end) ] ,[ F ] ⟩)
                        (P₁ : ⟨ J /₁ σs ,[ (E Env./*   , c ↦   S) ] ,[ F ] ⟩)
                      → T⟨ J {-/ l-} ,[ F ] ⟩)
              → T⟨ I / l ,[ F ] ⟩
    ⊗-split l (end x) κ = {!!} -- elim
    ⊗-split l (⅋-inp l₁ P) κ = T-⅋-inp {!l₁!} {!!}
    ⊗-split l (⊗-out l₁ l₁' P) κ = {!!}
    ⊗-split l (split Z A1 P P₁) κ = {!!}
    ⊗-split l (nu D P) κ = {!!}
-}

data T⟨_⟩ {δI}(I : Proto δI) : Set₁ where
 T-⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

 T-⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → T⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

 T-end : ∀ (E : Ended I) → T⟨ I ⟩

 T-cut :
    ∀ {S₀ S₁}
      (D : Dual S₀ S₁)
      (σs : Selections δI)
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I /₀ σs ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I /₁ σs ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

 T-split :
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : T⟨ I /₀ σs ⟩)
      (P₁ : T⟨ I /₁ σs ⟩)
    → T⟨ I ⟩

data TC⟨_⟩ {δI}(I : Proto δI) : Set₁ where
 TC-⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → TC⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → TC⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ S₁ ] ⟩)
    → TC⟨ I ⟩

 TC-⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → TC⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → TC⟨ I ⟩

 TC-end : ∀ (E : Ended I) → TC⟨ I ⟩

 TC-split :
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : TC⟨ I /₀ σs ⟩)
      (P₁ : TC⟨ I /₁ σs ⟩)
    → TC⟨ I ⟩

{-
cut : ∀ {δI}{I : Proto δI} → T⟨ I ⟩ → TC⟨ I ⟩
cut (T-⊗-out l σs σE A0 P₀ P₁) = TC-⊗-out l σs σE A0 (λ c₀ → cut (P₀ c₀)) (λ c₁ → cut (P₁ c₁))
cut (T-⅋-inp l P) = TC-⅋-inp l (λ c₀ c₁ → cut (P c₀ c₁))
cut (T-end E) = TC-end E
cut (T-cut D σs A0 P₀ P₁) = {! TC-cut D σs A0 {!λ c₀ → ? !} {!!} !}
cut (T-split σs A1 P P₁) = {!!}

{-
-- no split version,
data TNS⟨_⟩ {δI}(I : Proto δI) : Set₁ where
 T-⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
←      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → TNS⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → TNS⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ S₁ ] ⟩)
   → TNS⟨ I ⟩

 T-⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → TNS⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → TNS⟨ I ⟩

 T-end : ∀ (E : Ended I) → TNS⟨ I ⟩

 T-cut :
    ∀ {S₀ S₁}
      (D : Dual S₀ S₁)
      (σs : Selections δI)
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → TNS⟨ I /₀ σs ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → TNS⟨ I /₁ σs ,[ c₁ ↦ S₁ ] ⟩)
    → TNS⟨ I ⟩
-}

{-
data T⟨_⟩ {δs}(I : Proto δs) : Set₁ where
  ⊗ :
    ∀ {c S₀ S₁}
      (l  : [ c ↦ S₀ ⊗ S₁ ]∈ I)
      (σs : Selections δs)
      (P₀ : ∀ c₀ → T⟨ I / l /₀ σ ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I / l /₁ σ ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

  ⅋ :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → T⟨ I / l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

  end :
    Ended I
    → T⟨ I ⟩

  cut :
    ∀ {S₀ S₁}
      (σs : Selections δs)
      (P₀ : ∀ c₀ → T⟨ I /₀ σ ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I /₁ σ ,[ c₁ ↦ S₁ ] ⟩)
      (D : Dual S₀ S₁)
    → T⟨ I ⟩

{-
data T⟨_⟩ {δ} (E : Env δ) : Set₁ where
  ⊗ :
    ∀ {c S₀ S₁}
      (l  : c ↦ (S₀ ⊗ S₁) ∈ E)
      (σ  : Selection δ)
      (P₀ : ∀ c₀ → T⟨ (E Env./ l) /₀ σ , c₀ ↦ S₀ ⟩)
      (P₁ : ∀ c₁ → T⟨ (E Env./ l) /₁ σ , c₁ ↦ S₁ ⟩)
    → T⟨ E ⟩

  ⅋ :
    ∀ {c S₀ S₁}
      (l : c ↦ (S₀ ⅋ S₁) ∈ E)
      (P : ∀ c₀ c₁ → T⟨ (E / l) , c₀ ↦ S₀ , c₁ ↦ S₁ ⟩)
    → T⟨ E ⟩

  end :
    Env.Ended E
    → T⟨ E ⟩

  cut :
    ∀ {S₀ S₁}
      (σ  : Selection δ)
      (P₀ : ∀ c₀ → T⟨ E /₀ σ , c₀ ↦ S₀ ⟩)
      (P₁ : ∀ c₁ → T⟨ E /₁ σ , c₁ ↦ S₁ ⟩)
      (D : Dual S₀ S₁)
    → T⟨ E ⟩

{-
data Env : Dom → Set₁ where
  ε     : Env ε
  _,_↦_ : ∀ {δ} (E : Env δ) c (S : Session) → Env (δ , c)
-}

{-

{-

{-
Dom = ℕ
Env : Dom → Set₁
Env n = Vec Session n

Layout : Dom → Set
Layout n = Vec 𝟚 n

projLayout : ∀ {n} (f : Session → 𝟚 → Session) (Δ : Env n) → Layout n → Env n
projLayout f = zipWith f

_/₀_ : ∀ {n} (Δ : Env n) → Layout n → Env n
_/₀_ = projLayout (λ S → [0: S 1: end ])

_/₁_ : ∀ {n} (Δ : Env n) → Layout n → Env n
_/₁_ = projLayout (λ S → [0: end 1: S ])

data ⟨_⟩ {n} (Δ : Env n) : Set₁ where
  ⊗ :
    ∀ {c S₀ S₁}
      (l  : Δ [ c ]= S₀ ⊗ S₁)
      (L  : Layout n)
      (P₀ : ⟨ Δ /₀ L [ c ]≔ S₀ ⟩)
      (P₁ : ⟨ Δ /₁ L [ c ]≔ S₁ ⟩)
    → ⟨ Δ ⟩
  ⅋ :
    ∀ {c S₀ S₁}
      (l : Δ [ c ]= S₀ ⅋ S₁)
      (P : Δ [ c ]=* (S₀ ∷ S₁ ∷ []))
    → ⟨ Δ ⟩
    -}

{-
data Layout : Env → Set where
  ε : Layout ε
  _,_↦_ : ∀ {σ} (L : Layout σ) c {S} (b : 𝟚) → Layout (σ , c ↦ S)

projLayout : (f : 𝟚 → Session → Session) (Δ : Env) → Layout Δ → Env
projLayout f ε ε = ε
projLayout f (Δ , .c ↦ S) (L , c ↦ b) = projLayout f Δ L , c ↦ f b S

_/₀_ : (Δ : Env) → Layout Δ → Env
_/₀_ = projLayout (λ b S → [0: S 1: end ] b)

_/₁_ : (Δ : Env) → Layout Δ → Env
_/₁_ = projLayout (λ b S → [0: end 1: S ] b)

data ⟨_⟩ (Δ : Env) : Set₁ where
{-
  ⅋-in :
    ∀ {c S T}
      (l : [ c ↦ (⅋ S T) ]∈ Δ )
      (P : ∀ d e → ⟨ Δ [ l ≔* · ,[ d ↦ S ] ,[ e ↦ T ] ] ⟩)
    → ⟨ Δ ⟩
-}
  ⊗-out :
    ∀ {c S T}
      (l : c ↦ ⊗ S T ∈ Δ)
      (L : Layout
      (P : ∀ d → ⟨ Δ [ l ≔ S ] /₀ L ⟩)
      (Q : ∀ e → ⟨ Δ [ l ≔ T ] /₁ L ⟩)
    → ⟨ Δ ⟩

{-
  split :
    ∀ {Δ₀ Δ₁}
    → ZipP 1 Δ Δ₀ Δ₁ → ⟨ Δ₀ ⟩ → ⟨ Δ₁ ⟩ → ⟨ Δ ⟩

  end :
    EndedProto Δ
    → ⟨ Δ ⟩

  nu : ∀ {Δ' S T}
       → (l : []∈ Δ')
       → (∀ c d → ⟨ Δ' [ l ≔* (· ,[ c ↦ S ] ,[ d ↦ T ]) ]' ⟩)
       → Dual S T
       → Δ ≡ Δ' [ l ≔* · ]'
       → ⟨ Δ ⟩

{-
data ⟨_⟩ (Δ : Proto) : Set₁ where
  ⅋-in :
    ∀ {c S T}
      (l : [ c ↦ (⅋ S T) ]∈ Δ )
      (P : ∀ d e → ⟨ Δ [ l ≔* · ,[ d ↦ S ] ,[ e ↦ T ] ] ⟩)
    → ⟨ Δ ⟩

  ⊗-out :
    ∀ {c S T η}
      (l : [ η ]∈ Δ)
      (l' : c ↦ ⊗ S T ∈ η)
      (P : ∀ d e → ⟨ Δ [ l ≔* · ,[ η [ l' += ε , d ↦ S , e ↦ T ]η ] ] ⟩)
    → ⟨ Δ ⟩

  split :
    ∀ {Δ₀ Δ₁}
    → ZipP 1 Δ Δ₀ Δ₁ → ⟨ Δ₀ ⟩ → ⟨ Δ₁ ⟩ → ⟨ Δ ⟩

  end :
    EndedProto Δ
    → ⟨ Δ ⟩

  nu : ∀ {Δ' S T}
       → (l : []∈ Δ')
       → (∀ c d → ⟨ Δ' [ l ≔* (· ,[ c ↦ S ] ,[ d ↦ T ]) ]' ⟩)
       → Dual S T
       → Δ ≡ Δ' [ l ≔* · ]'
       → ⟨ Δ ⟩

{-
-- cut₁ : ∀ {Δ Δ' S}(l : S ∈ Δ)(l' : dual S ∈ Δ') → ⟨ Δ ⟩ → ⟨ Δ' ⟩ → ⟨ Δ [ l ≔ end ] ⅋ Δ' [ l' ≔ end ] ⟩
cut₁ : ∀ {Δ Δ' S}(l : S ∈ Δ)(l' : dual S ∈ Δ')
      → ⟨ Δ ⟩ → ⟨ Δ' ⟩ → ⟨ Δ [ l ≔ end ] ⅋ Δ' [ l' ≔ end ] ⟩
cut₁
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --copatterns #-}
open import Function
open import Data.Product hiding (zip)
                         renaming (_,_ to ⟨_,_⟩; proj₁ to fst; proj₂ to snd;
                                   map to ×map)
open import Data.Zero
open import Data.One
open import Data.Two
open import Data.Sum
open import Data.Nat
{-
open import Data.Vec
open import Data.Fin
-}
-- open import Data.List

open import Relation.Nullary
open import Relation.Binary.PropositionalEquality.NP hiding ([_]; J)
open import partensor.Shallow.Dom
import partensor.Shallow.Session as Session
import partensor.Shallow.Map as Map
import partensor.Shallow.Env as Env
import partensor.Shallow.Proto as Proto
open Session hiding (Ended)
open Env     hiding (_/₀_; _/₁_; _/_; Ended)
open Proto   hiding ()
open import partensor.Shallow.Equiv

module partensor.Shallow.Term where

data ⟨_⟩ {δI}(I : Proto δI) : Set₁ where
  end :
    Ended I
    → ⟨ I ⟩

  ⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I )
      (P : ∀ c₀ c₁ → ⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → ⟨ I ⟩

  ⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (P : ∀ c₀ c₁ → ⟨ I [/…] l ,[ E/ l , c₀ ↦ S₀ , c₁ ↦ S₁ ] ⟩)
    → ⟨ I ⟩

  split :
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : ⟨ I /₀ σs ⟩)
      (P₁ : ⟨ I /₁ σs ⟩)
    → ⟨ I ⟩

  nu :
    ∀ {S₀ S₁}
      (D : Dual S₀ S₁)
      (P : ∀ c₀ c₁ → ⟨ I ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → ⟨ I ⟩

{-
  module _ {δF}(F : Env δF) where
    ⊗-split : ∀ {δ δs}{I : Proto δs}{E : Env δ}
                 (l : Doms'.[ δ ]∈ δs)
                 -- (l : [ E ]∈ I)
                 -- {c S}(l' : c ↦ S ∈ E)
                 (P : ⟨ I ⟩)
                 (κ : ∀ {c S}
                        -- E
                        (l' : c ↦ S ∈ E)
                        {J : Proto δs}
                        (σs : Selections δs)
                        (A0 : AtMost 0 σs)
                        (P₀ : ⟨ J /₀ σs ,[ (E Env./ l' , c ↦ end) ] ,[ F ] ⟩)
                        (P₁ : ⟨ J /₁ σs ,[ (E Env./*   , c ↦   S) ] ,[ F ] ⟩)
                      → T⟨ J {-/ l-} ,[ F ] ⟩)
              → T⟨ I / l ,[ F ] ⟩
    ⊗-split l (end x) κ = {!!} -- elim
    ⊗-split l (⅋-inp l₁ P) κ = T-⅋-inp {!l₁!} {!!}
    ⊗-split l (⊗-out l₁ l₁' P) κ = {!!}
    ⊗-split l (split Z A1 P P₁) κ = {!!}
    ⊗-split l (nu D P) κ = {!!}
-}

data T⟨_⟩ {δI}(I : Proto δI) : Set₁ where
 T-⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

 T-⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → T⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

 T-end : ∀ (E : Ended I) → T⟨ I ⟩

 T-cut :
    ∀ {S₀ S₁}
      (D : Dual S₀ S₁)
      (σs : Selections δI)
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → T⟨ I /₀ σs ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I /₁ σs ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

 T-split :
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : T⟨ I /₀ σs ⟩)
      (P₁ : T⟨ I /₁ σs ⟩)
    → T⟨ I ⟩

data TC⟨_⟩ {δI}(I : Proto δI) : Set₁ where
 TC-⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → TC⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → TC⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ S₁ ] ⟩)
    → TC⟨ I ⟩

 TC-⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → TC⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → TC⟨ I ⟩

 TC-end : ∀ (E : Ended I) → TC⟨ I ⟩

 TC-split :
      (σs : Selections δI)
      (A1 : AtMost 1 σs)
      (P₀ : TC⟨ I /₀ σs ⟩)
      (P₁ : TC⟨ I /₁ σs ⟩)
    → TC⟨ I ⟩

{-
cut : ∀ {δI}{I : Proto δI} → T⟨ I ⟩ → TC⟨ I ⟩
cut (T-⊗-out l σs σE A0 P₀ P₁) = TC-⊗-out l σs σE A0 (λ c₀ → cut (P₀ c₀)) (λ c₁ → cut (P₁ c₁))
cut (T-⅋-inp l P) = TC-⅋-inp l (λ c₀ c₁ → cut (P c₀ c₁))
cut (T-end E) = TC-end E
cut (T-cut D σs A0 P₀ P₁) = {! TC-cut D σs A0 {!λ c₀ → ? !} {!!} !}
cut (T-split σs A1 P P₁) = {!!}

{-
-- no split version,
data TNS⟨_⟩ {δI}(I : Proto δI) : Set₁ where
 T-⊗-out :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⊗ S₁ …]∈ I)
←      (σs : Selections δI)
      (σE : Selection ([↦…]∈.δE l))
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → TNS⟨ I [/…] l /₀ σs ,[ E/ l Env./₀ σE , c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → TNS⟨ I [/…] l /₁ σs ,[ E/ l Env./₁ σE , c₁ ↦ S₁ ] ⟩)
   → TNS⟨ I ⟩

 T-⅋-inp :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → TNS⟨ I [/] l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → TNS⟨ I ⟩

 T-end : ∀ (E : Ended I) → TNS⟨ I ⟩

 T-cut :
    ∀ {S₀ S₁}
      (D : Dual S₀ S₁)
      (σs : Selections δI)
      (A0 : AtMost 0 σs)
      (P₀ : ∀ c₀ → TNS⟨ I /₀ σs ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → TNS⟨ I /₁ σs ,[ c₁ ↦ S₁ ] ⟩)
    → TNS⟨ I ⟩
-}

{-
data T⟨_⟩ {δs}(I : Proto δs) : Set₁ where
  ⊗ :
    ∀ {c S₀ S₁}
      (l  : [ c ↦ S₀ ⊗ S₁ ]∈ I)
      (σs : Selections δs)
      (P₀ : ∀ c₀ → T⟨ I / l /₀ σ ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I / l /₁ σ ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

  ⅋ :
    ∀ {c S₀ S₁}
      (l : [ c ↦ S₀ ⅋ S₁ ]∈ I)
      (P : ∀ c₀ c₁ → T⟨ I / l ,[ c₀ ↦ S₀ ] ,[ c₁ ↦ S₁ ] ⟩)
    → T⟨ I ⟩

  end :
    Ended I
    → T⟨ I ⟩

  cut :
    ∀ {S₀ S₁}
      (σs : Selections δs)
      (P₀ : ∀ c₀ → T⟨ I /₀ σ ,[ c₀ ↦ S₀ ] ⟩)
      (P₁ : ∀ c₁ → T⟨ I /₁ σ ,[ c₁ ↦ S₁ ] ⟩)
      (D : Dual S₀ S₁)
    → T⟨ I ⟩

{-
data T⟨_⟩ {δ} (E : Env δ) : Set₁ where
  ⊗ :
    ∀ {c S₀ S₁}
      (l  : c ↦ (S₀ ⊗ S₁) ∈ E)
      (σ  : Selection δ)
      (P₀ : ∀ c₀ → T⟨ (E Env./ l) /₀ σ , c₀ ↦ S₀ ⟩)
      (P₁ : ∀ c₁ → T⟨ (E Env./ l) /₁ σ , c₁ ↦ S₁ ⟩)
    → T⟨ E ⟩

  ⅋ :
    ∀ {c S₀ S₁}
      (l : c ↦ (S₀ ⅋ S₁) ∈ E)
      (P : ∀ c₀ c₁ → T⟨ (E / l) , c₀ ↦ S₀ , c₁ ↦ S₁ ⟩)
    → T⟨ E ⟩

  end :
    Env.Ended E
    → T⟨ E ⟩

  cut :
    ∀ {S₀ S₁}
      (σ  : Selection δ)
      (P₀ : ∀ c₀ → T⟨ E /₀ σ , c₀ ↦ S₀ ⟩)
      (P₁ : ∀ c₁ → T⟨ E /₁ σ , c₁ ↦ S₁ ⟩)
      (D : Dual S₀ S₁)
    → T⟨ E ⟩

{-
data Env : Dom → Set₁ where
  ε     : Env ε
  _,_↦_ : ∀ {δ} (E : Env δ) c (S : Session) → Env (δ , c)
-}

{-

{-

{-
Dom = ℕ
Env : Dom → Set₁
Env n = Vec Session n

Layout : Dom → Set
Layout n = Vec 𝟚 n

projLayout : ∀ {n} (f : Session → 𝟚 → Session) (Δ : Env n) → Layout n → Env n
projLayout f = zipWith f

_/₀_ : ∀ {n} (Δ : Env n) → Layout n → Env n
_/₀_ = projLayout (λ S → [0: S 1: end ])

_/₁_ : ∀ {n} (Δ : Env n) → Layout n → Env n
_/₁_ = projLayout (λ S → [0: end 1: S ])

data ⟨_⟩ {n} (Δ : Env n) : Set₁ where
  ⊗ :
    ∀ {c S₀ S₁}
      (l  : Δ [ c ]= S₀ ⊗ S₁)
      (L  : Layout n)
      (P₀ : ⟨ Δ /₀ L [ c ]≔ S₀ ⟩)
      (P₁ : ⟨ Δ /₁ L [ c ]≔ S₁ ⟩)
    → ⟨ Δ ⟩
  ⅋ :
    ∀ {c S₀ S₁}
      (l : Δ [ c ]= S₀ ⅋ S₁)
      (P : Δ [ c ]=* (S₀ ∷ S₁ ∷ []))
    → ⟨ Δ ⟩
    -}

{-
data Layout : Env → Set where
  ε : Layout ε
  _,_↦_ : ∀ {σ} (L : Layout σ) c {S} (b : 𝟚) → Layout (σ , c ↦ S)

projLayout : (f : 𝟚 → Session → Session) (Δ : Env) → Layout Δ → Env
projLayout f ε ε = ε
projLayout f (Δ , .c ↦ S) (L , c ↦ b) = projLayout f Δ L , c ↦ f b S

_/₀_ : (Δ : Env) → Layout Δ → Env
_/₀_ = projLayout (λ b S → [0: S 1: end ] b)

_/₁_ : (Δ : Env) → Layout Δ → Env
_/₁_ = projLayout (λ b S → [0: end 1: S ] b)

data ⟨_⟩ (Δ : Env) : Set₁ where
{-
  ⅋-in :
    ∀ {c S T}
      (l : [ c ↦ (⅋ S T) ]∈ Δ )
      (P : ∀ d e → ⟨ Δ [ l ≔* · ,[ d ↦ S ] ,[ e ↦ T ] ] ⟩)
    → ⟨ Δ ⟩
-}
  ⊗-out :
    ∀ {c S T}
      (l : c ↦ ⊗ S T ∈ Δ)
      (L : Layout
      (P : ∀ d → ⟨ Δ [ l ≔ S ] /₀ L ⟩)
      (Q : ∀ e → ⟨ Δ [ l ≔ T ] /₁ L ⟩)
    → ⟨ Δ ⟩

{-
  split :
    ∀ {Δ₀ Δ₁}
    → ZipP 1 Δ Δ₀ Δ₁ → ⟨ Δ₀ ⟩ → ⟨ Δ₁ ⟩ → ⟨ Δ ⟩

  end :
    EndedProto Δ
    → ⟨ Δ ⟩

  nu : ∀ {Δ' S T}
       → (l : []∈ Δ')
       → (∀ c d → ⟨ Δ' [ l ≔* (· ,[ c ↦ S ] ,[ d ↦ T ]) ]' ⟩)
       → Dual S T
       → Δ ≡ Δ' [ l ≔* · ]'
       → ⟨ Δ ⟩

{-
data ⟨_⟩ (Δ : Proto) : Set₁ where
  ⅋-in :
    ∀ {c S T}
      (l : [ c ↦ (⅋ S T) ]∈ Δ )
      (P : ∀ d e → ⟨ Δ [ l ≔* · ,[ d ↦ S ] ,[ e ↦ T ] ] ⟩)
    → ⟨ Δ ⟩

  ⊗-out :
    ∀ {c S T η}
      (l : [ η ]∈ Δ)
      (l' : c ↦ ⊗ S T ∈ η)
      (P : ∀ d e → ⟨ Δ [ l ≔* · ,[ η [ l' += ε , d ↦ S , e ↦ T ]η ] ] ⟩)
    → ⟨ Δ ⟩

  split :
    ∀ {Δ₀ Δ₁}
    → ZipP 1 Δ Δ₀ Δ₁ → ⟨ Δ₀ ⟩ → ⟨ Δ₁ ⟩ → ⟨ Δ ⟩

  end :
    EndedProto Δ
    → ⟨ Δ ⟩

  nu : ∀ {Δ' S T}
       → (l : []∈ Δ')
       → (∀ c d → ⟨ Δ' [ l ≔* (· ,[ c ↦ S ] ,[ d ↦ T ]) ]' ⟩)
       → Dual S T
       → Δ ≡ Δ' [ l ≔* · ]'
       → ⟨ Δ ⟩

{-
-- cut₁ : ∀ {Δ Δ' S}(l : S ∈ Δ)(l' : dual S ∈ Δ') → ⟨ Δ ⟩ → ⟨ Δ' ⟩ → ⟨ Δ [ l ≔ end ] ⅋ Δ' [ l' ≔ end ] ⟩
cut₁ : ∀ {Δ Δ' S}(l : S ∈ Δ)(l' : dual S ∈ Δ')
      → ⟨ Δ ⟩ → ⟨ Δ' ⟩ → ⟨ Δ [ l ≔ end ] ⅋ Δ' [ l' ≔ end ] ⟩
cut₁
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}
-- -}


Drop more dead code

Drop more dead code

module Thesis.BigStep where

open import Thesis.Syntax hiding (suc)
open import Thesis.Lang hiding (⟦_⟧Context; ⟦_⟧Var; suc)

open import Relation.Binary.PropositionalEquality

-- open import Base.Syntax.Context Type public
-- open import Base.Syntax.Vars Type public

-- data Const : (τ : Type) → Set where
--   lit : ℤ → Const int
--   -- succ : Const (int ⇒ int)

-- data Term (Γ : Context) :
--   (τ : Type) → Set where
--   -- constants aka. primitives
--   const : ∀ {τ} →
--     (c : Const τ) →
--     Term Γ τ
--   var : ∀ {τ} →
--     (x : Var Γ τ) →
--     Term Γ τ
--   app : ∀ {σ τ}
--     (s : Term Γ (σ ⇒ τ)) →
--     (t : Term Γ σ) →
--     Term Γ τ
--   -- we use de Bruijn indices, so we don't need binding occurrences.
--   abs : ∀ {σ τ}
--     (t : Term (σ • Γ) τ) →
--     Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public
open import Data.Nat.Base using (ℕ; zero; suc)

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℤ) → Val int
  -- prim : ∀ {σ τ} → (f : Val σ → Val τ) → Val (σ ⇒ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⇒ τ ⟧Type) → Val (σ ⇒ τ)
  pairV : ∀ {σ τ} → Val σ → Val τ → Val (pair σ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⟧Type → Val τ) → Val (σ ⇒ τ)

-- TODO: add defunctionalized interpretations for primitives. Yes, annoying but mechanical.

-- Doesn't work
-- data Val2 : ℕ → Type → Set where
--   prim : ∀ {σ τ n} → (f : Val2 n σ → Val2 n τ) → Val2 (ℕ.suc n) (σ ⇒ τ)

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ intV n ⟧Val = n
-- ⟦ prim f ⟧Val = λ v → ⟦ f v ⟧Val
⟦ pairV a b ⟧Val = (⟦ a ⟧Val , ⟦ b ⟧Val)
-- ⟦ true ⟧Val = true
-- ⟦ false ⟧Val = false

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)
evalConst c n = {!!}

-- evalConst plus n = Done (prim (λ a → prim (λ b → intV (a + b))))
-- evalConst minus n = Done (prim (λ a → prim (λ b → intV (a - b))))
-- evalConst cons n = Done (prim (λ a → prim (λ b → {!pairV !})))
-- evalConst fst n = {!!}
-- evalConst snd n = {!!}
-- evalConst linj n = {!!}
-- evalConst rinj n = {!!}
-- evalConst match n = {!!}
-- evalConst zero = intV (+ 0)
-- evalConst succ = {!!}

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n
-- apply (prim f) a n = Done (f ⟦ a ⟧Val)

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut
-- eval t0 ρ (suc n) with t0
-- ... | const c = evalConst c n
-- ... | var x = Done (⟦ x ⟧Var ρ)
-- ... | abs t = Done (closure t ρ)
-- ... | app s t with eval s ρ n | eval t ρ n
-- ... | Done f | Done a = apply f a n
-- ... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool!
eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
  eval t ρ n ≡ Done v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
  ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
  apply f a n ≡ Done v →
  ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

eval-sound ρ v zero t ()
eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
  let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}

-- Next, we can try defining change structures and validity.

dapply : ∀ {σ τ} → Val (Δt (σ ⇒ τ)) → Val σ → Val (Δt σ) → Res (Δt τ)
dapply df a1 da zero = TimeOut
dapply df a1 da (suc zero) = TimeOut
dapply df a1 da (suc (suc n)) with apply df a1 n
... | Done dfa = apply dfa da (suc n)
... | TimeOut = TimeOut

-- apply (closure (abs (derive t)) dρ) a1 (suc (suc n))
-- eval (derive (abs t)) dρ (suc n) ≡
-- dapply-sound-0
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) n

dapply' : ∀ {σ τ} → ErrVal (Δt (σ ⇒ τ)) → ErrVal σ → ErrVal (Δt σ) → Res (Δt τ)
dapply' (Done df) (Done v) (Done dv) n = dapply df v dv n
dapply' _ _ _ _ = TimeOut

-- Which step-indexes should we use in dapply's specification and
-- implementation? That's highly non-obvious. To come up with them, I had to
-- step through the evaluation of eval (app (app ds t) dt), and verify that I
-- never invoke eval or apply on the same inputs at different step-indexes.
--
-- However, I expect I wouldn't be able to get a working proof if I got the
-- indexes wrong.
dapply-sound : ∀ {Γ σ τ} n ρ (ds : Term Γ (Δt (σ ⇒ τ))) t dt →
    eval (app (app ds t) dt) ρ (suc (suc n))
  ≡
    dapply' (eval ds ρ n) (eval t ρ n) (eval dt ρ (suc n)) (suc (suc n))
dapply-sound zero ρ ds t dt = refl
dapply-sound (suc n) ρ ds t dt with
  eval ds ρ (suc n) | eval t ρ (suc n) | eval dt ρ (suc (suc n))
dapply-sound (suc n) ρ ds t dt | Done df | Done v | Done dv with apply df v (suc n)
... | Done dfv = refl
... | TimeOut  = refl
dapply-sound (suc n) ρ ds t dt | Done df | Done v | TimeOut with apply df v (suc n)
... | Done dfv = refl
... | TimeOut = refl
dapply-sound (suc n) ρ ds t dt | Done df | TimeOut | dv = refl
dapply-sound (suc n) ρ ds t dt | TimeOut | v | dv = refl

open import Data.Empty
open import Data.Unit

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
deriveConst = {!!}

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (ΔΓ Γ) (Δt τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

-- open import Thesis.Derive
Chτ : Type → Set
Chτ τ = Val (Δt τ)

deval : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → Res (Δt τ)
deval t ρ dρ = eval (derive t) dρ

dapply-equiv : ∀ {Γ σ τ} n
  (t : Term (σ • Γ) τ)
  (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 : Val σ) →
  dapply (closure (abs (derive t)) dρ) a1 da (suc (suc (suc n))) ≡
  eval (derive t) (da • a1 • dρ) (suc (suc n))
dapply-equiv n t dρ ρ1 da a1 = refl

-- Target statement:

_[_]τ_from_to_ : (n : ℕ) → ∀ τ → Val (Δt τ) → Val τ → Val τ → Set
_[_]τ'_from_to_ : (n : ℕ) → ∀ τ → ErrVal (Δt τ) → ErrVal τ → ErrVal τ → Set
n [ τ ]τ' Done dv from Done v1 to Done v2 = n [ τ ]τ dv from v1 to v2
n [ τ ]τ' TimeOut from Done v1 to Done v2 = ⊥
n [ τ ]τ' dv from _ to _ = ⊤

_[_]τ'_fromToTimeOut : ∀ n τ edv → n [ τ ]τ' edv from TimeOut to TimeOut ≡ ⊤
n [ τ ]τ' Done v fromToTimeOut = refl
n [ τ ]τ' TimeOut fromToTimeOut = refl
-- n [ τ ]τ' dv from Done v1 to TimeOut = ⊤
-- n [ τ ]τ' dv from TimeOut to Done v2 = ⊤
-- n [ τ ]τ' dv from TimeOut to TimeOut = ⊤

-- In the static-caching paper, the specification we use is similar to this one:
-- n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
--    Σ[ dv ∈ Val (Δt τ) ]
--        dapply df a1 da n ≡ Done dv
--      × n [ τ ]τ dv from v1 to v2
-- I defined _[_]τ'_from_to_ to be able to write an equivalent (hopefully) specification more quickly.

zero [ τ ]τ dv from v1 to v2 = ⊤
-- suc n [ σ ⇒ τ ]τ df from f1 to f2 =
--   ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    n [ τ ]τ' dapply df a1 da n from apply f1 a1 n to apply f2 a2 n

suc n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
   n [ σ ]τ da from a1 to a2 →
   ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
   Σ[ dv ∈ Val (Δt τ) ]
       dapply df a1 da (suc (suc n)) ≡ Done dv
     × n [ τ ]τ dv from v1 to v2

suc n [ int ]τ intV dn from intV n1 to intV n2 = n1 + dn ≡ n2
suc n [ pair σ τ ]τ pairV da db from pairV a1 b1 to pairV a2 b2 =
  suc n [ σ ]τ da from a1 to a2 × suc n [ τ ]τ db from b1 to b2
suc n [ sum σ τ ]τ () from v1 to v2

data _[_]Γ_from_to_ : ∀ ℕ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : ∀ {n} → n [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {n τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : n [ τ ]τ dv from v1 to v2) →
    (dρρ : n [ Γ ]Γ dρ from ρ1 to ρ2) →
    n [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

fromtoDeriveVar : ∀ {Γ} τ n → (x : Var Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ (⟦ deriveVar x ⟧Var dρ) from ⟦ x ⟧Var ρ1 to ⟦ x ⟧Var ρ2
fromtoDeriveVar τ n this (dv • .(v1 • _)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = dvv
fromtoDeriveVar τ n (that x) (dv • (.v1 • dρ)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = fromtoDeriveVar τ n x dρ ρ1 ρ2 dρρ

fromtoDerive : ∀ {Γ} τ n → (t : Term Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ' (deval t ρ1 dρ n) from eval t ρ1 n to eval t ρ2 n
fromtoDerive τ zero t dρ ρ1 ρ2 dρρ rewrite zero [ τ ]τ' (deval t ρ1 dρ (suc zero)) fromToTimeOut = tt
fromtoDerive τ (suc n) (const c) dρ ρ1 ρ2 dρρ = {!!}
fromtoDerive τ (suc n) (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar τ (suc n) x dρ ρ1 ρ2 dρρ
fromtoDerive τ (suc n) (app s t) dρ ρ1 ρ2 dρρ = {!!}
-- fromtoDerive (σ ⇒ τ) (suc n) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   rewrite dapply-equiv n t dρ ρ1 da a1 =
--   fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ)

fromtoDerive (σ ⇒ τ) (suc zero) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 () eqv2
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 = {!fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) ?!}

-- fromtoDerive (σ ⇒ τ) (suc (suc zero)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa = {!!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   with eval (abs (derive t)) (a1 • dρ) n | inspect (eval (abs (derive t)) (a1 • dρ)) n
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | Done v | [ eq ] = {!fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) _!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | TimeOut | _ = {!!}
-- --   fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• ?)
-- -- fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}
--   -- fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}

module Thesis.BigStep where

open import Thesis.Syntax hiding (suc)
open import Thesis.Lang hiding (⟦_⟧Context; ⟦_⟧Var; suc)

open import Relation.Binary.PropositionalEquality

-- open import Base.Syntax.Context Type public
-- open import Base.Syntax.Vars Type public

-- data Const : (τ : Type) → Set where
--   lit : ℤ → Const int
--   -- succ : Const (int ⇒ int)

-- data Term (Γ : Context) :
--   (τ : Type) → Set where
--   -- constants aka. primitives
--   const : ∀ {τ} →
--     (c : Const τ) →
--     Term Γ τ
--   var : ∀ {τ} →
--     (x : Var Γ τ) →
--     Term Γ τ
--   app : ∀ {σ τ}
--     (s : Term Γ (σ ⇒ τ)) →
--     (t : Term Γ σ) →
--     Term Γ τ
--   -- we use de Bruijn indices, so we don't need binding occurrences.
--   abs : ∀ {σ τ}
--     (t : Term (σ • Γ) τ) →
--     Term Γ (σ ⇒ τ)

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public
open import Data.Nat.Base using (ℕ; zero; suc)

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℤ) → Val int
  -- prim : ∀ {σ τ} → (f : Val σ → Val τ) → Val (σ ⇒ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⇒ τ ⟧Type) → Val (σ ⇒ τ)
  pairV : ∀ {σ τ} → Val σ → Val τ → Val (pair σ τ)
  -- prim : ∀ {σ τ} → (f : ⟦ σ ⟧Type → Val τ) → Val (σ ⇒ τ)

-- TODO: add defunctionalized interpretations for primitives. Yes, annoying but mechanical.

-- Doesn't work
-- data Val2 : ℕ → Type → Set where
--   prim : ∀ {σ τ n} → (f : Val2 n σ → Val2 n τ) → Val2 (ℕ.suc n) (σ ⇒ τ)

import Base.Denotation.Environment
-- Den stands for Denotational semantics.
module Den = Base.Denotation.Environment Type ⟦_⟧Type

⟦_⟧Val : ∀ {τ} → Val τ → ⟦ τ ⟧Type
⟦_⟧Env : ∀ {Γ} → ⟦ Γ ⟧Context → Den.⟦ Γ ⟧Context

⟦ ∅ ⟧Env = ∅
⟦ v • ρ ⟧Env = ⟦ v ⟧Val • ⟦ ρ ⟧Env

⟦ closure t ρ ⟧Val = λ v → (⟦ t ⟧Term) (v • ⟦ ρ ⟧Env)
⟦ intV n ⟧Val = n
-- ⟦ prim f ⟧Val = λ v → ⟦ f v ⟧Val
⟦ pairV a b ⟧Val = (⟦ a ⟧Val , ⟦ b ⟧Val)
-- ⟦ true ⟧Val = true
-- ⟦ false ⟧Val = false

↦-sound : ∀ {Γ τ} ρ (x : Var Γ τ) →
  Den.⟦ x ⟧Var ⟦ ρ ⟧Env ≡ ⟦ ⟦ x ⟧Var ρ ⟧Val
↦-sound (px • ρ) this = refl
↦-sound (px • ρ) (that x) = ↦-sound ρ x

--
-- Functional big-step semantics
--

-- Termination is far from obvious to Agda once we use closures. So we use
-- step-indexing with a fuel value, following "Type Soundness Proofs with
-- Definitional Interpreters". Since we focus for now on STLC, unlike that
-- paper, we can avoid error values by keeping types.
--
-- One could drop types and add error values, to reproduce what they do.

data ErrVal (τ : Type) : Set where
  Done : (v : Val τ) → ErrVal τ
  TimeOut : ErrVal τ

Res : Type → Set
Res τ = ℕ → ErrVal τ

evalConst : ∀ {τ} → Const τ → Res τ
evalConst (lit v) n = Done (intV v)
evalConst c n = {!!}

-- evalConst plus n = Done (prim (λ a → prim (λ b → intV (a + b))))
-- evalConst minus n = Done (prim (λ a → prim (λ b → intV (a - b))))
-- evalConst cons n = Done (prim (λ a → prim (λ b → {!pairV !})))
-- evalConst fst n = {!!}
-- evalConst snd n = {!!}
-- evalConst linj n = {!!}
-- evalConst rinj n = {!!}
-- evalConst match n = {!!}
-- evalConst zero = intV (+ 0)
-- evalConst succ = {!!}

eval : ∀ {Γ τ} → Term Γ τ → ⟦ Γ ⟧Context → Res τ

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n
-- apply (prim f) a n = Done (f ⟦ a ⟧Val)

eval t ρ zero = TimeOut
eval (const c) ρ (suc n) = evalConst c n
eval (var x) ρ (suc n) = Done (⟦ x ⟧Var ρ)
eval (abs t) ρ (suc n) = Done (closure t ρ)
eval (app s t) ρ (suc n) with eval s ρ n | eval t ρ n
... | Done f | Done a = apply f a n
... | _ | _ = TimeOut
-- eval t0 ρ (suc n) with t0
-- ... | const c = evalConst c n
-- ... | var x = Done (⟦ x ⟧Var ρ)
-- ... | abs t = Done (closure t ρ)
-- ... | app s t with eval s ρ n | eval t ρ n
-- ... | Done f | Done a = apply f a n
-- ... | _ | _ = TimeOut

-- Can we prove eval sound wrt. our reference denotational semantics? Yes! Very
-- cool!
eval-sound : ∀ {Γ τ} ρ v n (t : Term Γ τ) →
  eval t ρ n ≡ Done v →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ v ⟧Val

apply-sound : ∀ {Γ σ τ} ρ v f a n (s : Term Γ (σ ⇒ τ)) t →
  ⟦ s ⟧Term ⟦ ρ ⟧Env ≡ ⟦ f ⟧Val →
  ⟦ t ⟧Term ⟦ ρ ⟧Env ≡ ⟦ a ⟧Val →
  apply f a n ≡ Done v →
  ⟦ s ⟧Term ⟦ ρ ⟧Env (⟦ t ⟧Term ⟦ ρ ⟧Env) ≡ ⟦ v ⟧Val
apply-sound _ v (closure ft ρ) a n s t feq aeq eq rewrite feq | aeq = eval-sound (a • ρ) v n ft eq

eval-sound ρ v zero t ()
eval-sound ρ v (ℕ.suc n) (const c) eq = {!!}
eval-sound ρ v (ℕ.suc n) (var x) refl = ↦-sound ρ x
eval-sound ρ v (ℕ.suc n) (abs t) refl = refl
eval-sound ρ v (ℕ.suc n) (app s t) eq with eval s ρ n | inspect (eval s ρ) n | eval t ρ n | inspect (eval t ρ) n
eval-sound ρ v (ℕ.suc n) (app s t) eq | Done f | [ feq ] | Done a | [ aeq ] =
  let feq = eval-sound ρ f n s feq; aeq = eval-sound ρ a n t aeq in apply-sound ρ v f a n s t feq aeq eq
eval-sound ρ v (ℕ.suc n) (app s t) () | Done f | _ | TimeOut | _
eval-sound ρ v (ℕ.suc n) (app s t) () | TimeOut | _ | _ | _
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}
-- eval-sound n (const c) eq = {!!}
-- eval-sound n (var x) eq = {!!}
-- eval-sound n (app s t) eq = {!!} -- with eval s ρ n
-- eval-sound n (abs t) eq = {!!}

-- Next, we can try defining change structures and validity.

dapply : ∀ {σ τ} → Val (Δt (σ ⇒ τ)) → Val σ → Val (Δt σ) → Res (Δt τ)
dapply df a1 da zero = TimeOut
dapply df a1 da (suc zero) = TimeOut
dapply df a1 da (suc (suc n)) with apply df a1 n
... | Done dfa = apply dfa da (suc n)
... | TimeOut = TimeOut

-- apply (closure (abs (derive t)) dρ) a1 (suc (suc n))
-- eval (derive (abs t)) dρ (suc n) ≡
-- dapply-sound-0
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) n

dapply' : ∀ {σ τ} → ErrVal (Δt (σ ⇒ τ)) → ErrVal σ → ErrVal (Δt σ) → Res (Δt τ)
dapply' (Done df) (Done v) (Done dv) n = dapply df v dv n
dapply' _ _ _ _ = TimeOut

-- Which step-indexes should we use in dapply's specification and
-- implementation? That's highly non-obvious. To come up with them, I had to
-- step through the evaluation of eval (app (app ds t) dt), and verify that I
-- never invoke eval or apply on the same inputs at different step-indexes.
--
-- However, I expect I wouldn't be able to get a working proof if I got the
-- indexes wrong.
dapply-sound : ∀ {Γ σ τ} n ρ (ds : Term Γ (Δt (σ ⇒ τ))) t dt →
    eval (app (app ds t) dt) ρ (suc (suc n))
  ≡
    dapply' (eval ds ρ n) (eval t ρ n) (eval dt ρ (suc n)) (suc (suc n))
dapply-sound zero ρ ds t dt = refl
dapply-sound (suc n) ρ ds t dt with
  eval ds ρ (suc n) | eval t ρ (suc n) | eval dt ρ (suc (suc n))
dapply-sound (suc n) ρ ds t dt | Done df | Done v | Done dv with apply df v (suc n)
... | Done dfv = refl
... | TimeOut  = refl
dapply-sound (suc n) ρ ds t dt | Done df | Done v | TimeOut with apply df v (suc n)
... | Done dfv = refl
... | TimeOut = refl
dapply-sound (suc n) ρ ds t dt | Done df | TimeOut | dv = refl
dapply-sound (suc n) ρ ds t dt | TimeOut | v | dv = refl

open import Data.Empty
open import Data.Unit

ΔΓ : Context → Context
ΔΓ ∅ = ∅
ΔΓ (τ • Γ) = Δt τ • τ • ΔΓ Γ

ChΓ : ∀ (Γ : Context) → Set
ChΓ Γ = ⟦ ΔΓ Γ ⟧Context
Γ≼ΔΓ : ∀ {Γ} → Γ ≼ ΔΓ Γ
Γ≼ΔΓ {∅} = ∅
Γ≼ΔΓ {τ • Γ} = drop Δt τ • keep τ • Γ≼ΔΓ

fit : ∀ {τ Γ} → Term Γ τ → Term (ΔΓ Γ) τ
fit = weaken Γ≼ΔΓ

deriveConst : ∀ {τ} →
  Const τ →
  Term ∅ (Δt τ)
deriveConst = {!!}

deriveVar : ∀ {Γ τ} → Var Γ τ → Var (ΔΓ Γ) (Δt τ)
deriveVar this = this
deriveVar (that x) = that (that (deriveVar x))

derive : ∀ {Γ τ} → Term Γ τ → Term (ΔΓ Γ) (Δt τ)
derive (const c) = weaken (∅≼Γ {ΔΓ _}) (deriveConst c)
derive (var x) = var (deriveVar x)
derive (app s t) = app (app (derive s) (fit t)) (derive t)
derive (abs t) = abs (abs (derive t))

-- open import Thesis.Derive
Chτ : Type → Set
Chτ τ = Val (Δt τ)

deval : ∀ {Γ τ} → (t : Term Γ τ) → (ρ : ⟦ Γ ⟧Context) (dρ : ChΓ Γ) → Res (Δt τ)
deval t ρ dρ = eval (derive t) dρ

dapply-equiv : ∀ {Γ σ τ} n
  (t : Term (σ • Γ) τ)
  (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
  (da : Val (Δt σ)) (a1 : Val σ) →
  dapply (closure (abs (derive t)) dρ) a1 da (suc (suc (suc n))) ≡
  eval (derive t) (da • a1 • dρ) (suc (suc n))
dapply-equiv n t dρ ρ1 da a1 = refl

-- Failed variants, the step-indexes are wrong:
-- dapply-equiv-2 : ∀ {Γ σ τ} n
--   (t : Term (σ • Γ) τ)
--   (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
--   (da : Val (Δt σ)) (a1 : Val σ) →
--   dapply (closure (abs (derive t)) dρ) a1 da (suc (suc n)) ≡
--   eval (derive t) (da • a1 • dρ) (suc n)
-- dapply-equiv-2 zero t dρ ρ1 da a1 = {!!}
-- dapply-equiv-2 (suc n) t dρ ρ1 da a1 = refl
-- -- dapply-equiv-2 zero t dρ ρ1 da a1 = refl
-- -- dapply-equiv-2 (suc zero) (const c) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc zero) (var x) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc zero) (app t t₁) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc zero) (abs t) dρ ρ1 da a1 = {!!}
-- -- dapply-equiv-2 (suc (suc n)) t dρ ρ1 da a1 = refl

-- Worse:
-- dapply-equiv-0 : ∀ {Γ σ τ} n
--   (t : Term (σ • Γ) τ)
--   (dρ : ChΓ Γ) (ρ1 : ⟦ Γ ⟧Context)
--   (da : Val (Δt σ)) (a1 : Val σ) →
--   dapply (closure (abs (derive t)) dρ) a1 da (suc n) ≡
--   eval (derive t) (da • a1 • dρ) (suc n)
-- dapply-equiv-0 zero t dρ ρ1 da a1 = {!!}
-- dapply-equiv-0 (suc zero) t dρ ρ1 da a1 = {!!}
-- dapply-equiv-0 (suc (suc n)) t dρ ρ1 da a1 = {!!}

-- Target statement:

_[_]τ_from_to_ : (n : ℕ) → ∀ τ → Val (Δt τ) → Val τ → Val τ → Set
_[_]τ'_from_to_ : (n : ℕ) → ∀ τ → ErrVal (Δt τ) → ErrVal τ → ErrVal τ → Set
n [ τ ]τ' Done dv from Done v1 to Done v2 = n [ τ ]τ dv from v1 to v2
n [ τ ]τ' TimeOut from Done v1 to Done v2 = ⊥
n [ τ ]τ' dv from _ to _ = ⊤

_[_]τ'_fromToTimeOut : ∀ n τ edv → n [ τ ]τ' edv from TimeOut to TimeOut ≡ ⊤
n [ τ ]τ' Done v fromToTimeOut = refl
n [ τ ]τ' TimeOut fromToTimeOut = refl
-- n [ τ ]τ' dv from Done v1 to TimeOut = ⊤
-- n [ τ ]τ' dv from TimeOut to Done v2 = ⊤
-- n [ τ ]τ' dv from TimeOut to TimeOut = ⊤

-- In the static-caching paper, the specification we use is similar to this one:
-- n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
--    Σ[ dv ∈ Val (Δt τ) ]
--        dapply df a1 da n ≡ Done dv
--      × n [ τ ]τ dv from v1 to v2
-- I defined _[_]τ'_from_to_ to be able to write an equivalent (hopefully) specification more quickly.

zero [ τ ]τ dv from v1 to v2 = ⊤
-- suc n [ σ ⇒ τ ]τ df from f1 to f2 =
--   ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
--    n [ σ ]τ da from a1 to a2 →
--    n [ τ ]τ' dapply df a1 da n from apply f1 a1 n to apply f2 a2 n

suc n [ σ ⇒ τ ]τ df from f1 to f2 = ∀ (da : Val (Δt σ)) → (a1 a2 : Val σ) →
   n [ σ ]τ da from a1 to a2 →
   ∀ v1 v2 → apply f1 a1 n ≡ Done v1 → apply f2 a2 n ≡ Done v2 →
   Σ[ dv ∈ Val (Δt τ) ]
       dapply df a1 da (suc (suc n)) ≡ Done dv
     × n [ τ ]τ dv from v1 to v2

suc n [ int ]τ intV dn from intV n1 to intV n2 = n1 + dn ≡ n2
suc n [ pair σ τ ]τ pairV da db from pairV a1 b1 to pairV a2 b2 =
  suc n [ σ ]τ da from a1 to a2 × suc n [ τ ]τ db from b1 to b2
suc n [ sum σ τ ]τ () from v1 to v2

data _[_]Γ_from_to_ : ∀ ℕ Γ → ChΓ Γ → (ρ1 ρ2 : ⟦ Γ ⟧Context) → Set where
  v∅ : ∀ {n} → n [ ∅ ]Γ ∅ from ∅ to ∅
  _v•_ : ∀ {n τ Γ dv v1 v2 dρ ρ1 ρ2} →
    (dvv : n [ τ ]τ dv from v1 to v2) →
    (dρρ : n [ Γ ]Γ dρ from ρ1 to ρ2) →
    n [ τ • Γ ]Γ (dv • v1 • dρ) from (v1 • ρ1) to (v2 • ρ2)

fromtoDeriveVar : ∀ {Γ} τ n → (x : Var Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ (⟦ deriveVar x ⟧Var dρ) from ⟦ x ⟧Var ρ1 to ⟦ x ⟧Var ρ2
fromtoDeriveVar τ n this (dv • .(v1 • _)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = dvv
fromtoDeriveVar τ n (that x) (dv • (.v1 • dρ)) (v1 • ρ1) (v2 • ρ2) (dvv v• dρρ) = fromtoDeriveVar τ n x dρ ρ1 ρ2 dρρ

fromtoDerive : ∀ {Γ} τ n → (t : Term Γ τ) →
  (dρ : ChΓ Γ) (ρ1 ρ2 : ⟦ Γ ⟧Context) → n [ Γ ]Γ dρ from ρ1 to ρ2 →
    n [ τ ]τ' (deval t ρ1 dρ n) from eval t ρ1 n to eval t ρ2 n
fromtoDerive τ zero t dρ ρ1 ρ2 dρρ rewrite zero [ τ ]τ' (deval t ρ1 dρ (suc zero)) fromToTimeOut = tt
fromtoDerive τ (suc n) (const c) dρ ρ1 ρ2 dρρ = {!!}
fromtoDerive τ (suc n) (var x) dρ ρ1 ρ2 dρρ = fromtoDeriveVar τ (suc n) x dρ ρ1 ρ2 dρρ
fromtoDerive τ (suc n) (app s t) dρ ρ1 ρ2 dρρ = {!!}
-- fromtoDerive (σ ⇒ τ) (suc n) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   rewrite dapply-equiv n t dρ ρ1 da a1 =
--   fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• dρρ)

fromtoDerive (σ ⇒ τ) (suc zero) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 () eqv2
fromtoDerive (σ ⇒ τ) (suc (suc n)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa v1 v2 eqv1 eqv2 = {!fromtoDerive τ (suc n) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) ?!}

-- fromtoDerive (σ ⇒ τ) (suc (suc zero)) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa = {!!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa
--   with eval (abs (derive t)) (a1 • dρ) n | inspect (eval (abs (derive t)) (a1 • dρ)) n
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | Done v | [ eq ] = {!fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) _!}
-- fromtoDerive (σ ⇒ τ) (suc (suc (suc n))) (abs t) dρ ρ1 ρ2 dρρ da a1 a2 daa | TimeOut | _ = {!!}
-- --   fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) (daa v• ?)
-- -- fromtoDerive τ (suc (suc n)) t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}
--   -- fromtoDerive τ n t (da • a1 • dρ) (a1 • ρ1) (a2 • ρ2) {! daa v• dρρ!}


Changed doc.

Changed doc.

Ignore-this: 366baccf864db612a0e4c1ad19b9e50f

darcs-hash:20101102155907-3bd4e-75efa3d253c4d85ec08a05b10b7573ff46f349fe.gz

-----------------------------------------------------------------------------
-- Equality reasoning
-----------------------------------------------------------------------------

module Lib.Relation.Binary.EqReasoning
  {A     : Set}
  ( _≡_  : A → A → Set)
  (refl  : {x : A} → x ≡ x)
  (trans : {x y z : A} → x ≡ y → y ≡ z → x ≡ z)
  where

infix 4 _≃_

private
  data _≃_ (x y : A) : Set where
    prf : x ≡ y → x ≃ y

------------------------------------------------------------------------------
-- From the Ulf's thesis.

module Original where

  infix  2 chain>_
  infixl 2 _===_by_
  infix  1 _qed

  chain>_ : (x : A) → x ≃ x
  chain> x = prf (refl {x})

  _===_by_ : {x y : A} → x ≃ y → (z : A) → y ≡ z → x ≃ z
  prf p === z by q = prf (trans {_} {_} {_} p q)

  _qed : {x y : A} → x ≃ y → x ≡ y
  prf p qed = p

------------------------------------------------------------------------------
-- From the standard library (Relation.Binary.PreorderReasoning).

module StdLib where

  infix  1 begin_
  infixr 2 _≡⟨_⟩_
  infix  2 _∎

  begin_ : {x y : A} → x ≃ y → x ≡ y
  begin prf x≡y = x≡y

  _≡⟨_⟩_ : (x : A){y z : A} → x ≡ y → y ≃ z → x ≃ z
  _ ≡⟨ x≡y ⟩ prf y≡z = prf (trans x≡y y≡z)

  _∎ : (x : A) → x ≃ x
  _∎ _ = prf refl

-----------------------------------------------------------------------------
-- Equality reasoning
-----------------------------------------------------------------------------

module Lib.Relation.Binary.EqReasoning
  {A     : Set}
  ( _≡_  : A → A → Set)
  (refl  : {x : A} → x ≡ x)
  (trans : {x y z : A} → x ≡ y → y ≡ z → x ≡ z)
  where

infix 4 _≃_

private
  data _≃_ (x y : A) : Set where
    prf : x ≡ y → x ≃ y

------------------------------------------------------------------------------
-- A version from Ulf's thesis.
module Original where

  infix  2 chain>_
  infixl 2 _===_by_
  infix  1 _qed

  chain>_ : (x : A) → x ≃ x
  chain> x = prf (refl {x})

  _===_by_ : {x y : A} → x ≃ y → (z : A) → y ≡ z → x ≃ z
  prf p === z by q = prf (trans {_} {_} {_} p q)

  _qed : {x y : A} → x ≃ y → x ≡ y
  prf p qed = p

------------------------------------------------------------------------------
-- A version from the standard library (Relation.Binary.PreorderReasoning).
module StdLib where

  infix  1 begin_
  infixr 2 _≡⟨_⟩_
  infix  2 _∎

  begin_ : {x y : A} → x ≃ y → x ≡ y
  begin prf x≡y = x≡y

  _≡⟨_⟩_ : (x : A){y z : A} → x ≡ y → y ≃ z → x ≃ z
  _ ≡⟨ x≡y ⟩ prf y≡z = prf (trans x≡y y≡z)

  _∎ : (x : A) → x ≃ x
  _∎ _ = prf refl


add trace to Choreography

add trace to Choreography


≡: Hide subst, expose tr...

≡: Hide subst, expose tr...

{-# OPTIONS --without-K #-}
-- move this to propeq
module Relation.Binary.PropositionalEquality.NP where

open import Type hiding (★)
open import Data.One using (𝟙)
open import Data.Product using (Σ; _,_)
open import Relation.Binary.PropositionalEquality public hiding (module ≡-Reasoning; subst)
open import Relation.Binary.NP
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
open import Relation.Nullary

private
  module Dummy {a} {A : ★ a} where
    open IsEquivalence (isEquivalence {a} {A}) public hiding (refl; sym; trans)
open Dummy public

PathOver : ∀ {i j} {A : ★ i} (B : A → ★ j)
  {x y : A} (p : x ≡ y) (u : B x) (v : B y) → ★ j
PathOver B refl u v = (u ≡ v)

syntax PathOver B p u v =
  u ≡ v [ B ↓ p ]

{- one day this will work -}
-- pattern idp = refl

-- Some definitions with the names from Agda-HoTT
-- this is only a temporary state of affairs...
module _ {a} {A : ★ a} where

    idp : {x : A} → x ≡ x
    idp = refl

    infixr 8 _∙_ _∙'_

    _∙_ _∙'_ : {x y z : A} → (x ≡ y → y ≡ z → x ≡ z)

    refl ∙ q  = q
    q ∙' refl = q

    !_ : {x y : A} → (x ≡ y → y ≡ x)
    !_ refl = refl

ap↓ : ∀ {i j k} {A : ★ i} {B : A → ★ j} {C : A → ★ k}
  (g : {a : A} → B a → C a) {x y : A} {p : x ≡ y}
  {u : B x} {v : B y}
  → (u ≡ v [ B ↓ p ] → g u ≡ g v [ C ↓ p ])
ap↓ g {p = refl} refl = refl

ap : ∀ {i j} {A : ★ i} {B : ★ j} (f : A → B) {x y : A}
  → (x ≡ y → f x ≡ f y)
ap f p = ap↓ {A = 𝟙} f {p = refl} p

apd : ∀ {i j} {A : ★ i} {B : A → ★ j} (f : (a : A) → B a) {x y : A}
  → (p : x ≡ y) → f x ≡ f y [ B ↓ p ]
apd f refl = refl

coe : ∀ {i} {A B : ★ i} (p : A ≡ B) → A → B
coe refl x = x

coe! : ∀ {i} {A B : ★ i} (p : A ≡ B) → B → A
coe! p = coe (! p)

module _ {ℓ ℓp}
         {A : Set ℓ}
         (P : A → Set ℓp)
         {x y : A}
         (p : x ≡ y)
         where
    tr : P x → P y
    tr = coe (ap P p)

cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {a₀ a₁ b₀ b₁ c₀ c₁}
        → a₀ ≡ a₁ → b₀ ≡ b₁ → c₀ ≡ c₁ → f a₀ b₀ c₀ ≡ f a₁ b₁ c₁
cong₃ f refl refl refl = refl

_≗₂_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} (f g : A → B → C) → ★ _
f ≗₂ g = ∀ x y → f x y ≡ g x y

module _ {a} {A : ★ a} where
  J-orig : ∀ {b} (P : (x y : A) → x ≡ y → ★_ b) → (∀ x → P x x refl) → ∀ {x y} (p : x ≡ y) → P x y p
  J-orig P p refl = p _

  -- This version is better suited to our identity type which has the first argument as a parameter.
  -- (due to Paulin-Mohring)
  J : ∀ {b} {x : A} (P : (y : A) → x ≡ y → ★_ b) → P x refl → ∀ {y} (p : x ≡ y) → P y p
  J P p refl = p

  injective : InjectiveRel A _≡_
  injective p q = p ∙ ! q

  surjective : SurjectiveRel A _≡_
  surjective p q = ! p ∙ q

  bijective : BijectiveRel A _≡_
  bijective = record { injectiveREL = injective; surjectiveREL = surjective }

  Equalizer : ∀ {b} {B : A → ★ b} (f g : (x : A) → B x) → ★ _
  Equalizer f g = Σ A (λ x → f x ≡ g x)
  {- In a category theory context this type would the object 'E'
     and 'proj₁' would be the morphism 'eq : E → A' such that
     given any object O, and morphism 'm : O → A', there exists
     a unique morphism 'u : O → E' such that 'eq ∘ u ≡ m'.
  -}

  Pullback : ∀ {b c} {B : ★ b} {C : ★ c} (f : A → C) (g : B → C) → ★ _
  Pullback {B = B} f g = Σ A (λ x → Σ B (λ y → f x ≡ g y))

module ≡-Reasoning {a} {A : ★ a} where
  open Setoid-Reasoning (setoid A) public
    renaming (_≈⟨_⟩_ to _≡⟨_⟩_;
                    _≈⟨by-definition⟩_ to _≡⟨by-definition⟩_)

module ≗-Reasoning {a b} {A : ★ a} {B : ★ b} where
  open Setoid-Reasoning (A →-setoid B) public
    renaming (_≈⟨_⟩_ to _≗⟨_⟩_;
                    _≈⟨by-definition⟩_ to _≗⟨by-definition⟩_)

data ⟦≡⟧ {a₀ a₁ aᵣ}
         {A₀ A₁} (Aᵣ : ⟦★⟧ {a₀} {a₁} aᵣ A₀ A₁)
         {x₀ x₁} (xᵣ : Aᵣ x₀ x₁)
       : (Aᵣ ⟦→⟧ ⟦★⟧ aᵣ) (_≡_ x₀) (_≡_ x₁) where
    -- : ∀ {y₀ y₁} (yᵣ : Aᵣ y₀ y₁) → x₀ ≡ y₀ → x₁ ≡ y₁ → ★
  ⟦refl⟧ : ⟦≡⟧ Aᵣ xᵣ xᵣ refl refl

-- Double checking level 0 with a direct ⟦_⟧ encoding
private
  ⟦≡⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦★₀⟧) _≡_ _≡_
  ⟦≡⟧′ = ⟦≡⟧

  ⟦refl⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟦≡⟧ Aᵣ xᵣ xᵣ) refl refl
  ⟦refl⟧′ _ _ = ⟦refl⟧

{-# OPTIONS --without-K #-}
-- move this to propeq
module Relation.Binary.PropositionalEquality.NP where

open import Type hiding (★)
open import Data.One using (𝟙)
open import Data.Product using (Σ; _,_)
open import Relation.Binary.PropositionalEquality public hiding (module ≡-Reasoning)
open import Relation.Binary.NP
open import Relation.Binary.Bijection
open import Relation.Binary.Logical
open import Relation.Nullary

private
  module Dummy {a} {A : ★ a} where
    open IsEquivalence (isEquivalence {a} {A}) public hiding (refl; sym; trans)
open Dummy public

PathOver : ∀ {i j} {A : ★ i} (B : A → ★ j)
  {x y : A} (p : x ≡ y) (u : B x) (v : B y) → ★ j
PathOver B refl u v = (u ≡ v)

syntax PathOver B p u v =
  u ≡ v [ B ↓ p ]

{- one day this will work -}
-- pattern idp = refl

-- Some definitions with the names from Agda-HoTT
-- this is only a temporary state of affairs...
module _ {a} {A : ★ a} where

    idp : {x : A} → x ≡ x
    idp = refl

    infixr 8 _∙_ _∙'_

    _∙_ _∙'_ : {x y z : A} → (x ≡ y → y ≡ z → x ≡ z)

    refl ∙ q  = q
    q ∙' refl = q

    !_ : {x y : A} → (x ≡ y → y ≡ x)
    !_ refl = refl

ap↓ : ∀ {i j k} {A : ★ i} {B : A → ★ j} {C : A → ★ k}
  (g : {a : A} → B a → C a) {x y : A} {p : x ≡ y}
  {u : B x} {v : B y}
  → (u ≡ v [ B ↓ p ] → g u ≡ g v [ C ↓ p ])
ap↓ g {p = refl} refl = refl

ap : ∀ {i j} {A : ★ i} {B : ★ j} (f : A → B) {x y : A}
  → (x ≡ y → f x ≡ f y)
ap f p = ap↓ {A = 𝟙} f {p = refl} p

apd : ∀ {i j} {A : ★ i} {B : A → ★ j} (f : (a : A) → B a) {x y : A}
  → (p : x ≡ y) → f x ≡ f y [ B ↓ p ]
apd f refl = refl

coe : ∀ {i} {A B : ★ i} (p : A ≡ B) → A → B
coe refl x = x

coe! : ∀ {i} {A B : ★ i} (p : A ≡ B) → B → A
coe! p x = coe (! p) x

cong₃ : ∀ {a b c d} {A : Set a} {B : Set b} {C : Set c} {D : Set d}
          (f : A → B → C → D) {a₁ a₂ b₁ b₂ c₁ c₂}
        → a₁ ≡ a₂ → b₁ ≡ b₂ → c₁ ≡ c₂ → f a₁ b₁ c₁ ≡ f a₂ b₂ c₂
cong₃ f refl refl refl = refl

_≗₂_ : ∀ {a b c} {A : ★ a} {B : ★ b} {C : ★ c} (f g : A → B → C) → ★ _
f ≗₂ g = ∀ x y → f x y ≡ g x y

module _ {a} {A : ★ a} where
  J-orig : ∀ {b} (P : {x y : A} → x ≡ y → ★_ b) → (∀ {x} → P {x} {x} refl) → ∀ {x y} (p : x ≡ y) → P p
  J-orig P p refl = p

  -- This version is better suited to our identity type which has the first argument as a parameter.
  -- (due to Paulin-Mohring)
  J : ∀ {b} {x : A} (P : {y : A} → x ≡ y → ★_ b) → P {x} refl → ∀ {y} (p : x ≡ y) → P p
  J P p refl = p

  injective : InjectiveRel A _≡_
  injective p q = p ∙ ! q

  surjective : SurjectiveRel A _≡_
  surjective p q = ! p ∙ q

  bijective : BijectiveRel A _≡_
  bijective = record { injectiveREL = injective; surjectiveREL = surjective }

  Equalizer : ∀ {b} {B : A → ★ b} (f g : (x : A) → B x) → ★ _
  Equalizer f g = Σ A (λ x → f x ≡ g x)
  {- In a category theory context this type would the object 'E'
     and 'proj₁' would be the morphism 'eq : E → A' such that
     given any object O, and morphism 'm : O → A', there exists
     a unique morphism 'u : O → E' such that 'eq ∘ u ≡ m'.
  -}

  Pullback : ∀ {b c} {B : ★ b} {C : ★ c} (f : A → C) (g : B → C) → ★ _
  Pullback {B = B} f g = Σ A (λ x → Σ B (λ y → f x ≡ g y))

module ≡-Reasoning {a} {A : ★ a} where
  open Setoid-Reasoning (setoid A) public
    renaming (_≈⟨_⟩_ to _≡⟨_⟩_;
                    _≈⟨-by-definition-⟩_ to _≡⟨-by-definition-⟩_)

module ≗-Reasoning {a b} {A : ★ a} {B : ★ b} where
  open Setoid-Reasoning (A →-setoid B) public
    renaming (_≈⟨_⟩_ to _≗⟨_⟩_;
                    _≈⟨-by-definition-⟩_ to _≗⟨-by-definition-⟩_)

data ⟦≡⟧ {a₁ a₂ aᵣ}
         {A₁ A₂} (Aᵣ : ⟦★⟧ {a₁} {a₂} aᵣ A₁ A₂)
         {x₁ x₂} (xᵣ : Aᵣ x₁ x₂)
       : (Aᵣ ⟦→⟧ ⟦★⟧ aᵣ) (_≡_ x₁) (_≡_ x₂) where
    -- : ∀ {y₁ y₂} (yᵣ : Aᵣ y₁ y₂) → x₁ ≡ y₁ → x₂ ≡ y₂ → ★
  ⟦refl⟧ : ⟦≡⟧ Aᵣ xᵣ xᵣ refl refl

-- Double checking level 0 with a direct ⟦_⟧ encoding
private
  ⟦≡⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ Aᵣ ⟦→⟧ Aᵣ ⟦→⟧ ⟦★₀⟧) _≡_ _≡_
  ⟦≡⟧′ = ⟦≡⟧

  ⟦refl⟧′ : (∀⟨ Aᵣ ∶ ⟦★₀⟧ ⟩⟦→⟧ ∀⟨ xᵣ ∶ Aᵣ ⟩⟦→⟧ ⟦≡⟧ Aᵣ xᵣ xᵣ) refl refl
  ⟦refl⟧′ _ _ = ⟦refl⟧


[ quicksort ] Improved test.

[ quicksort ] Improved test.

------------------------------------------------------------------------------
-- Quicksort using the Bove-Capretta method
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.QuickSort.QuickSortBC where

open import Data.Bool.Base
open import Data.List
open import Data.Nat
open import Data.Nat.Properties
open import Data.Sum

open import Induction
open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Relation.Nullary
open import Relation.Nullary.Decidable

module InvImg =
  Induction.WellFounded.Inverse-image {A = List ℕ} {ℕ} {_<′_} length

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

_≤′?_ : Decidable _≤′_
m ≤′? n with m ≤? n
... | yes p = yes (≤⇒≤′ p)
... | no ¬p = no (λ m≤′n → ¬p (≤′⇒≤ m≤′n))

-- Non-terminating quicksort.

{-# TERMINATING #-}
qsNT : List ℕ → List ℕ
qsNT []       = []
qsNT (x ∷ xs) = qsNT (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) ++
                x ∷ qsNT (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs)

-- Domain predicate for quicksort.
data QSDom : List ℕ → Set where
  qsDom-[] : QSDom []
  qsDom-∷  : ∀ {x xs} →
             (QSDom (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs)) →
             (QSDom (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs)) →
             QSDom (x ∷ xs)

-- Induction principle associated to the domain predicate of quicksort.
-- (It was not necessary).
QSDom-ind : (P : List ℕ → Set) →
            P [] →
            (∀ {x xs} → QSDom (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) →
                        P (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) →
                        QSDom (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                        P (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                        P (x ∷ xs)) →
            (∀ {xs} → QSDom xs → P xs)
QSDom-ind P P[] ih qsDom-[]        = P[]
QSDom-ind P P[] ih (qsDom-∷ h₁ h₂) =
  ih h₁ (QSDom-ind P P[] ih h₁) h₂ (QSDom-ind P P[] ih h₂)

-- Well-founded relation on lists.
_⟪′_ : {A : Set} → List A → List A → Set
xs ⟪′ ys = length xs <′ length ys

wf-⟪′ : Well-founded _⟪′_
wf-⟪′ = InvImg.well-founded <′-well-founded

-- The well-founded induction principle on _⟪′_.
-- postulate wfi-⟪′ : (P : List ℕ → Set) →
--                    (∀ xs → (∀ ys → ys ⟪′ xs → P ys) → P xs) →
--                    ∀ xs → P xs

-- The quicksort algorithm is total.

filter-length : {A : Set}(P : A → Bool) → ∀ xs →
                length (boolFilter P xs) ≤′ length xs
filter-length P []       = ≤′-refl
filter-length P (x ∷ xs) with P x
... | true  = ≤⇒≤′ (s≤s (≤′⇒≤ (filter-length P xs)))
... | false = ≤′-step (filter-length P xs)

module AllWF = Induction.WellFounded.All wf-⟪′

allQSDom : ∀ xs → QSDom xs
-- If we use wfi-⟪′ then allQSDom =  wfi-⟪′ P ih
allQSDom = build (AllWF.wfRec-builder _) P ih
  where
  P : List ℕ → Set
  P = QSDom

  -- If we use wfi-⟪′ then
  -- ih : ∀ zs → (∀ ys → ys ⟪′ zs → P ys) → P zs
  ih :  ∀ zs → WfRec _⟪′_ P zs → P zs
  ih []       h = qsDom-[]
  ih (z ∷ zs) h = qsDom-∷ prf₁ prf₂
    where
    c₁ : ℕ → Bool
    c₁ = λ y → ⌊ y ≤′? z ⌋

    c₂ : ℕ → Bool
    c₂ = λ y → not ⌊ y ≤′? z ⌋

    f₁ : List ℕ
    f₁ = boolFilter c₁ zs

    f₂ : List ℕ
    f₂ = boolFilter c₂ zs

    prf₁ : QSDom (boolFilter (λ y → ⌊ y ≤′? z ⌋) zs)
    prf₁ = h f₁ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₁ zs))))

    prf₂ : QSDom (boolFilter (λ y → not ⌊ y ≤′? z ⌋) zs)
    prf₂ = h f₂ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₂ zs))))

-- Quicksort algorithm by structural recursion on the domain predicate.
qsDom : ∀ xs → QSDom xs → List ℕ
qsDom .[]      qsDom-[]        = []
qsDom (x ∷ xs) (qsDom-∷ h₁ h₂) =
  qsDom (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) h₁ ++
  x ∷ qsDom (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs) h₂

-- The quicksort algorithm.
qs : List ℕ → List ℕ
qs xs = qsDom xs (allQSDom xs)

-- Testing.
l₁ : List ℕ
l₁ = []
l₂ = 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ []
l₃ = 5 ∷ 4 ∷ 3 ∷ 2 ∷ 1 ∷ []
l₄ = 4 ∷ 1 ∷ 3 ∷ 5 ∷ 2 ∷ []

t₁ : qs l₁ ≡ l₁
t₁ = refl

t₂ : qs l₂ ≡ l₂
t₂ = refl

t₃ : qs l₃ ≡ l₂
t₃ = refl

t₄ : qs l₄ ≡ l₂
t₄ = refl

------------------------------------------------------------------------------
-- Quicksort using the Bove-Capretta method
------------------------------------------------------------------------------

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

module FOT.FOTC.Program.QuickSort.QuickSortBC where

open import Data.Bool.Base
open import Data.List
open import Data.Nat
open import Data.Nat.Properties
open import Data.Sum

open import Induction
open import Induction.Nat
open import Induction.WellFounded

open import Relation.Binary
open import Relation.Nullary
open import Relation.Nullary.Decidable

module InvImg =
  Induction.WellFounded.Inverse-image {A = List ℕ} {ℕ} {_<′_} length

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

_≤′?_ : Decidable _≤′_
m ≤′? n with m ≤? n
... | yes p = yes (≤⇒≤′ p)
... | no ¬p = no (λ m≤′n → ¬p (≤′⇒≤ m≤′n))

-- Non-terminating quicksort.

{-# TERMINATING #-}
qsNT : List ℕ → List ℕ
qsNT []       = []
qsNT (x ∷ xs) = qsNT (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) ++
                x ∷ qsNT (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs)

-- Domain predicate for quicksort.
data QSDom : List ℕ → Set where
  qsDom-[] : QSDom []
  qsDom-∷  : ∀ {x xs} →
             (QSDom (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs)) →
             (QSDom (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs)) →
             QSDom (x ∷ xs)

-- Induction principle associated to the domain predicate of quicksort.
-- (It was not necessary).
QSDom-ind : (P : List ℕ → Set) →
            P [] →
            (∀ {x xs} → QSDom (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) →
                        P (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) →
                        QSDom (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                        P (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs) →
                        P (x ∷ xs)) →
            (∀ {xs} → QSDom xs → P xs)
QSDom-ind P P[] ih qsDom-[]        = P[]
QSDom-ind P P[] ih (qsDom-∷ h₁ h₂) =
  ih h₁ (QSDom-ind P P[] ih h₁) h₂ (QSDom-ind P P[] ih h₂)

-- Well-founded relation on lists.
_⟪′_ : {A : Set} → List A → List A → Set
xs ⟪′ ys = length xs <′ length ys

wf-⟪′ : Well-founded _⟪′_
wf-⟪′ = InvImg.well-founded <′-well-founded

-- The well-founded induction principle on _⟪′_.
-- postulate wfi-⟪′ : (P : List ℕ → Set) →
--                    (∀ xs → (∀ ys → ys ⟪′ xs → P ys) → P xs) →
--                    ∀ xs → P xs

-- The quicksort algorithm is total.

filter-length : {A : Set}(P : A → Bool) → ∀ xs →
                length (boolFilter P xs) ≤′ length xs
filter-length P []       = ≤′-refl
filter-length P (x ∷ xs) with P x
... | true  = ≤⇒≤′ (s≤s (≤′⇒≤ (filter-length P xs)))
... | false = ≤′-step (filter-length P xs)

module AllWF = Induction.WellFounded.All wf-⟪′

allQSDom : ∀ xs → QSDom xs
-- If we use wfi-⟪′ then allQSDom =  wfi-⟪′ P ih
allQSDom = build (AllWF.wfRec-builder _) P ih
  where
  P : List ℕ → Set
  P = QSDom

  -- If we use wfi-⟪′ then
  -- ih : ∀ zs → (∀ ys → ys ⟪′ zs → P ys) → P zs
  ih :  ∀ zs → WfRec _⟪′_ P zs → P zs
  ih []       h = qsDom-[]
  ih (z ∷ zs) h = qsDom-∷ prf₁ prf₂
    where
    c₁ : ℕ → Bool
    c₁ = λ y → ⌊ y ≤′? z ⌋

    c₂ : ℕ → Bool
    c₂ = λ y → not ⌊ y ≤′? z ⌋

    f₁ : List ℕ
    f₁ = boolFilter c₁ zs

    f₂ : List ℕ
    f₂ = boolFilter c₂ zs

    prf₁ : QSDom (boolFilter (λ y → ⌊ y ≤′? z ⌋) zs)
    prf₁ = h f₁ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₁ zs))))

    prf₂ : QSDom (boolFilter (λ y → not ⌊ y ≤′? z ⌋) zs)
    prf₂ = h f₂ (≤⇒≤′ (s≤s (≤′⇒≤ (filter-length c₂ zs))))

-- Quicksort algorithm by structural recursion on the domain predicate.
qsDom : ∀ xs → QSDom xs → List ℕ
qsDom .[]      qsDom-[]        = []
qsDom (x ∷ xs) (qsDom-∷ h₁ h₂) =
  qsDom (boolFilter (λ y → ⌊ y ≤′? x ⌋) xs) h₁ ++
  x ∷ qsDom (boolFilter (λ y → not ⌊ y ≤′? x ⌋) xs) h₂

-- The quicksort algorithm.
qs : List ℕ → List ℕ
qs xs = qsDom xs (allQSDom xs)

-- Testing.
l₁ : List ℕ
l₁ = []
l₂ = 1 ∷ 2 ∷ 3 ∷ 4 ∷ 5 ∷ []
l₃ = 5 ∷ 4 ∷ 3 ∷ 2 ∷ 1 ∷ []
l₄ = 4 ∷ 1 ∷ 3 ∷ 5 ∷ 2 ∷ []

t₁ = qs l₁
t₂ = qs l₂
t₃ = qs l₃
t₄ = qs l₄