Removed unnecessary local hypothesis (by Ana Bove).

Ignore-this: c5e32af0a034aa3e43d885358595e928

darcs-hash:20110406205609-3bd4e-8dbd2fef9ac0b9955b0b19782da6b97a5ec0dc81.gz

------------------------------------------------------------------------------
-- Auxiliary properties of the McCarthy 91 function
------------------------------------------------------------------------------

module FOTC.Program.McCarthy91.Properties.AuxiliaryATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.IsN-ATP
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP

open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.McCarthy91

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

--- Auxiliary properties

---- Case n > 100
postulate
  Nmc91>100      : ∀ {n} → N n → GT n one-hundred → N (mc91 n)
  x<mc91x+11>100 : ∀ {n} → N n → GT n one-hundred →
                           LT n (mc91 n + eleven)
{-# ATP prove Nmc91>100 10-N ∸-N #-}
{-# ATP prove x<mc91x+11>100 +-N ∸-N x<y→y≤z→x<z x<x+1 x+1≤x∸10+11 #-}

-- Most of them not needed
-- Case n ≡ 100 can be proved automatically
postulate
  Nmc91≡100     : N (mc91 one-hundred)
  mc91-res-100  : mc91 one-hundred ≡ ninety-one
  mc91-res-100' : ∀ {n} → n ≡ one-hundred → mc91 n ≡ ninety-one
  mc91<mc91+11  : LT  one-hundred (mc91 one-hundred + eleven)
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100' mc91-res-100 #-}
{-# ATP prove mc91<mc91+11 mc91-res-100 102≡91+11 100<102 #-}

---- Case n ≤ 100

postulate
  -- Here we only reduce the definition of mc91
  Nmc91≤100'        : ∀ n → LE n one-hundred → N (mc91 (mc91 (n + eleven))) →
                      N (mc91 n)
  x<mc91x+11≤100'   : ∀ n → LE n one-hundred →
                      LT n (mc91 (mc91 (n + eleven)) + eleven) →
                      LT n (mc91 n + eleven)
  mc91x+11<mc91x+11 : ∀ n → LE n one-hundred →
                      LT (mc91 (n + eleven)) (mc91 (mc91 (n + eleven)) + eleven) →
                      LT (mc91 (n + eleven)) (mc91 n + eleven)
{-# ATP prove Nmc91≤100' #-}
{-# ATP prove x<mc91x+11≤100' #-}
{-# ATP prove mc91x+11<mc91x+11 #-}

postulate
  mc91x-res≤100     : ∀ m n → LE m one-hundred →
                      mc91 (m + eleven) ≡ n → mc91 n ≡ ninety-one →
                      mc91 m ≡ ninety-one
{-# ATP prove mc91x-res≤100 #-}

postulate
  mc91-res-110 : mc91 (ninety-nine + eleven)  ≡ one-hundred
  mc91-res-109 : mc91 (ninety-eight + eleven) ≡ ninety-nine
  mc91-res-108 : mc91 (ninety-seven + eleven) ≡ ninety-eight
  mc91-res-107 : mc91 (ninety-six + eleven)   ≡ ninety-seven
  mc91-res-106 : mc91 (ninety-five + eleven)  ≡ ninety-six
  mc91-res-105 : mc91 (ninety-four + eleven)  ≡ ninety-five
  mc91-res-104 : mc91 (ninety-three + eleven) ≡ ninety-four
  mc91-res-103 : mc91 (ninety-two + eleven)   ≡ ninety-three
  mc91-res-102 : mc91 (ninety-one + eleven)   ≡ ninety-two
  mc91-res-101 : mc91 (ninety + eleven)       ≡ ninety-one
{-# ATP prove mc91-res-110 99+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-109 98+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-108 97+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-107 96+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-106 95+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-105 94+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-104 93+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-103 92+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-102 91+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-101 90+11>100 x+11∸10≡Sx #-}

postulate
  mc91-res-99 : mc91 ninety-nine  ≡ ninety-one
  mc91-res-98 : mc91 ninety-eight ≡ ninety-one
  mc91-res-97 : mc91 ninety-seven ≡ ninety-one
  mc91-res-96 : mc91 ninety-six   ≡ ninety-one
  mc91-res-95 : mc91 ninety-five  ≡ ninety-one
  mc91-res-94 : mc91 ninety-four  ≡ ninety-one
  mc91-res-93 : mc91 ninety-three ≡ ninety-one
  mc91-res-92 : mc91 ninety-two   ≡ ninety-one
  mc91-res-91 : mc91 ninety-one   ≡ ninety-one
  mc91-res-90 : mc91 ninety       ≡ ninety-one
{-# ATP prove mc91-res-99 mc91x-res≤100 mc91-res-110 mc91-res-100 #-}
{-# ATP prove mc91-res-98 mc91x-res≤100 mc91-res-109 mc91-res-99 #-}
{-# ATP prove mc91-res-97 mc91x-res≤100 mc91-res-108 mc91-res-98 #-}
{-# ATP prove mc91-res-96 mc91x-res≤100 mc91-res-107 mc91-res-97 #-}
{-# ATP prove mc91-res-95 mc91x-res≤100 mc91-res-106 mc91-res-96 #-}
{-# ATP prove mc91-res-94 mc91x-res≤100 mc91-res-105 mc91-res-95 #-}
{-# ATP prove mc91-res-93 mc91x-res≤100 mc91-res-104 mc91-res-94 #-}
{-# ATP prove mc91-res-92 mc91x-res≤100 mc91-res-103 mc91-res-93 #-}
{-# ATP prove mc91-res-91 mc91x-res≤100 mc91-res-102 mc91-res-92 #-}
{-# ATP prove mc91-res-90 mc91x-res≤100 mc91-res-101 mc91-res-91 #-}

mc91-res-99' : ∀ {n} → n ≡ ninety-nine → mc91 n ≡ ninety-one
mc91-res-99' refl = mc91-res-99

mc91-res-98' : ∀ {n} → n ≡ ninety-eight → mc91 n ≡ ninety-one
mc91-res-98' refl = mc91-res-98

mc91-res-97' : ∀ {n} → n ≡ ninety-seven → mc91 n ≡ ninety-one
mc91-res-97' refl = mc91-res-97

mc91-res-96' : ∀ {n} → n ≡ ninety-six → mc91 n ≡ ninety-one
mc91-res-96' refl = mc91-res-96

mc91-res-95' : ∀ {n} → n ≡ ninety-five → mc91 n ≡ ninety-one
mc91-res-95' refl = mc91-res-95

mc91-res-94' : ∀ {n} → n ≡ ninety-four → mc91 n ≡ ninety-one
mc91-res-94' refl = mc91-res-94

mc91-res-93' : ∀ {n} → n ≡ ninety-three → mc91 n ≡ ninety-one
mc91-res-93' refl = mc91-res-93

mc91-res-92' : ∀ {n} → n ≡ ninety-two → mc91 n ≡ ninety-one
mc91-res-92' refl = mc91-res-92

mc91-res-91' : ∀ {n} → n ≡ ninety-one → mc91 n ≡ ninety-one
mc91-res-91' refl = mc91-res-91

mc91-res-90' : ∀ {n} → n ≡ ninety → mc91 n ≡ ninety-one
mc91-res-90' refl = mc91-res-90

------------------------------------------------------------------------------
-- Auxiliary properties of the McCarthy 91 function
------------------------------------------------------------------------------

module FOTC.Program.McCarthy91.Properties.AuxiliaryATP where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers
open import FOTC.Data.Nat.UnaryNumbers.IsN-ATP
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP

open import FOTC.Program.McCarthy91.ArithmeticATP
open import FOTC.Program.McCarthy91.McCarthy91

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

--- Auxiliary properties

---- Case n > 100
postulate
  Nmc91>100      : ∀ {n} → N n → GT n one-hundred → N (mc91 n)
  x<mc91x+11>100 : ∀ {n} → N n → GT n one-hundred →
                           LT n (mc91 n + eleven)
{-# ATP prove Nmc91>100 10-N ∸-N #-}
{-# ATP prove x<mc91x+11>100 +-N ∸-N 10-N 11-N x<y→y≤z→x<z x<x+1 x+1≤x∸10+11
                             +-comm
#-}

-- Most of them not needed
-- Case n ≡ 100 can be proved automatically
postulate
  Nmc91≡100     : N (mc91 one-hundred)
  mc91-res-100  : mc91 one-hundred ≡ ninety-one
  mc91-res-100' : ∀ {n} → n ≡ one-hundred → mc91 n ≡ ninety-one
  mc91<mc91+11  : LT  one-hundred (mc91 one-hundred + eleven)
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10
                        Nmc91>100 111-N 101-N
#-}
{-# ATP prove mc91-res-100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 #-}
{-# ATP prove mc91-res-100' mc91-res-100 #-}
{-# ATP prove Nmc91≡100 111>100 101>100 101≡100+11-10 91≡[100+11∸10]∸10 91-N #-}
{-# ATP prove mc91<mc91+11 mc91-res-100 102≡91+11 100<102 #-}

---- Case n ≤ 100

postulate
  Nmc91≤100'        : ∀ n → LE n one-hundred → N (mc91 (mc91 (n + eleven))) →
                      N (mc91 n)
  x<mc91x+11≤100'   : ∀ n → LE n one-hundred →
                      LT n (mc91 (mc91 (n + eleven)) + eleven) →
                      LT n (mc91 n + eleven)
  mc91x+11<mc91x+11 : ∀ n → LE n one-hundred →
                      LT (mc91 (n + eleven)) (mc91 (mc91 (n + eleven)) + eleven) →
                      LT (mc91 (n + eleven)) (mc91 n + eleven)
  mc91x-res≤100     : ∀ m n → LE m one-hundred →
                      mc91 (m + eleven) ≡ n → mc91 n ≡ ninety-one →
                      mc91 m ≡ ninety-one
{-# ATP prove Nmc91≤100' #-}
{-# ATP prove x<mc91x+11≤100' #-}
{-# ATP prove mc91x+11<mc91x+11 #-}
{-# ATP prove mc91x-res≤100 #-}

postulate
  mc91-res-110 : mc91 (ninety-nine + eleven)  ≡ one-hundred
  mc91-res-109 : mc91 (ninety-eight + eleven) ≡ ninety-nine
  mc91-res-108 : mc91 (ninety-seven + eleven) ≡ ninety-eight
  mc91-res-107 : mc91 (ninety-six + eleven)   ≡ ninety-seven
  mc91-res-106 : mc91 (ninety-five + eleven)  ≡ ninety-six
  mc91-res-105 : mc91 (ninety-four + eleven)  ≡ ninety-five
  mc91-res-104 : mc91 (ninety-three + eleven) ≡ ninety-four
  mc91-res-103 : mc91 (ninety-two + eleven)   ≡ ninety-three
  mc91-res-102 : mc91 (ninety-one + eleven)   ≡ ninety-two
  mc91-res-101 : mc91 (ninety + eleven)       ≡ ninety-one
{-# ATP prove mc91-res-110 99+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-109 98+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-108 97+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-107 96+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-106 95+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-105 94+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-104 93+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-103 92+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-102 91+11>100 x+11∸10≡Sx #-}
{-# ATP prove mc91-res-101 90+11>100 x+11∸10≡Sx #-}

postulate
  mc91-res-99 : mc91 ninety-nine  ≡ ninety-one
  mc91-res-98 : mc91 ninety-eight ≡ ninety-one
  mc91-res-97 : mc91 ninety-seven ≡ ninety-one
  mc91-res-96 : mc91 ninety-six   ≡ ninety-one
  mc91-res-95 : mc91 ninety-five  ≡ ninety-one
  mc91-res-94 : mc91 ninety-four  ≡ ninety-one
  mc91-res-93 : mc91 ninety-three ≡ ninety-one
  mc91-res-92 : mc91 ninety-two   ≡ ninety-one
  mc91-res-91 : mc91 ninety-one   ≡ ninety-one
  mc91-res-90 : mc91 ninety       ≡ ninety-one
{-# ATP prove mc91-res-99 mc91x-res≤100 mc91-res-110 mc91-res-100 #-}
{-# ATP prove mc91-res-98 mc91x-res≤100 mc91-res-109 mc91-res-99 #-}
{-# ATP prove mc91-res-97 mc91x-res≤100 mc91-res-108 mc91-res-98 #-}
{-# ATP prove mc91-res-96 mc91x-res≤100 mc91-res-107 mc91-res-97 #-}
{-# ATP prove mc91-res-95 mc91x-res≤100 mc91-res-106 mc91-res-96 #-}
{-# ATP prove mc91-res-94 mc91x-res≤100 mc91-res-105 mc91-res-95 #-}
{-# ATP prove mc91-res-93 mc91x-res≤100 mc91-res-104 mc91-res-94 #-}
{-# ATP prove mc91-res-92 mc91x-res≤100 mc91-res-103 mc91-res-93 #-}
{-# ATP prove mc91-res-91 mc91x-res≤100 mc91-res-102 mc91-res-92 #-}
{-# ATP prove mc91-res-90 mc91x-res≤100 mc91-res-101 mc91-res-91 #-}

mc91-res-99' : ∀ {n} → n ≡ ninety-nine → mc91 n ≡ ninety-one
mc91-res-99' refl = mc91-res-99

mc91-res-98' : ∀ {n} → n ≡ ninety-eight → mc91 n ≡ ninety-one
mc91-res-98' refl = mc91-res-98

mc91-res-97' : ∀ {n} → n ≡ ninety-seven → mc91 n ≡ ninety-one
mc91-res-97' refl = mc91-res-97

mc91-res-96' : ∀ {n} → n ≡ ninety-six → mc91 n ≡ ninety-one
mc91-res-96' refl = mc91-res-96

mc91-res-95' : ∀ {n} → n ≡ ninety-five → mc91 n ≡ ninety-one
mc91-res-95' refl = mc91-res-95

mc91-res-94' : ∀ {n} → n ≡ ninety-four → mc91 n ≡ ninety-one
mc91-res-94' refl = mc91-res-94

mc91-res-93' : ∀ {n} → n ≡ ninety-three → mc91 n ≡ ninety-one
mc91-res-93' refl = mc91-res-93

mc91-res-92' : ∀ {n} → n ≡ ninety-two → mc91 n ≡ ninety-one
mc91-res-92' refl = mc91-res-92

mc91-res-91' : ∀ {n} → n ≡ ninety-one → mc91 n ≡ ninety-one
mc91-res-91' refl = mc91-res-91

mc91-res-90' : ∀ {n} → n ≡ ninety → mc91 n ≡ ninety-one
mc91-res-90' refl = mc91-res-90


Desc stratified model: descDChoice implicit.

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

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

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set l) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set l} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set l}(R : I -> IDesc I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set l}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const X
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : {l : Level} -> Set l -> DescDConst -> IDesc Unit
descDChoice I lvar = const (lift I)
descDChoice _ lconst = const (Set _)
descDChoice _ lprod = prod (var Void) (var Void)
descDChoice _ lpi = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))
descDChoice _ lsigma = sigma (Set _) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc Unit
descD x I = sigma DescDConst (descDChoice I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst  {l = suc x}
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst {l = suc x}
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst {l = suc x}
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst {l = suc x}
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s

--********************************************
-- From the embedding to the host
--********************************************

-- desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
-- descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
-- IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l

-- cases : (l : Level)
--         (I : Set l)
--         (xs : desc (suc l) (lift I) (descD l I) (IMu (suc l) Unit (\ _ -> descD l I)))
--         (hs : desc l I (box l I (descD l I) (IMu l Unit (λ _ -> descD l I)) xs) (λ _ -> IDesc (suc l) I)) ->
--         IDesc (suc l) I
-- cases x I ( lvar , i ) hs =  var i
-- cases x I ( lconst , X ) hs =  const X
-- cases x I ( lprod , (D , D') ) ( d , d' ) =  prod d d'
-- cases x I ( lpi , ( S , T ) ) hs =  pi S hs
-- cases x I ( lsigma , ( S , T ) ) hs = sigma S hs

-- phi : {I : Set} -> IDescl I -> IDesc I
-- phi {I} d = induction (\_ -> descD I) (\_ -> IDesc I) (\_ -> cases) Void d

{-# OPTIONS --universe-polymorphism #-}

module IDesc where

--********************************************
-- Prelude
--********************************************

-- Some preliminary stuffs, to avoid relying on the stdlib

--****************
-- Universe polymorphism
--****************

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

{-# BUILTIN LEVEL     Level #-}
{-# BUILTIN LEVELZERO zero  #-}
{-# BUILTIN LEVELSUC  suc   #-}

max : Level -> Level -> Level
max  zero    m      = m
max (suc n)  zero   = suc n
max (suc n) (suc m) = suc (max n m)

{-# BUILTIN LEVELMAX max #-}

data Lifted {l : Level} (A : Set l) : Set (suc l) where
       lifter : A → Lifted A

lift : {i : Level} -> Set i -> Set (suc i)
lift x =  Lifted x

--****************
-- Sigma and friends
--****************

data Sigma {i j : Level}(A : Set i) (B : A -> Set j) : Set (max i j) where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : {i j : Level}(A : Set i)(B : Set j) -> Set (max i j)
A * B = Sigma A \_ -> B

fst : {i j : Level}{A : Set i}{B : A -> Set j} -> Sigma A B -> A
fst (a , _) = a

snd : {i j : Level}{A : Set i}{B : A -> Set j} (p : Sigma A B) -> B (fst p)
snd (a , b) = b

data Zero {i : Level} : Set i where
data Unit  {i : Level} : Set i where
  Void : Unit

--****************
-- Sum and friends
--****************

data _+_ {i j : Level}(A : Set i)(B : Set j) : Set (max i j) where
  l : A -> A + B
  r : B -> A + B

--****************
-- Equality
--****************

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

cong : {l : Level}{A B : Set l}(f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l : Level}{A B C : Set l}(f : A -> B -> C){x y : A}{z t : B} ->
        x == y -> z == t -> f x z == f y t
cong2 f refl refl = refl

-- Intensionally extensional
postulate
  reflFun : {l : Level}{A B : Set l}(f : A -> B)(g : A -> B)-> ((a : A) -> f a == g a) -> f == g

--********************************************
-- Desc code
--********************************************

data IDesc {l : Level}(I : Set l) : Set (suc l) where
  var : I -> IDesc I
  const : Set l -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set l) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set l) -> (S -> IDesc I) -> IDesc I

--********************************************
-- Desc interpretation
--********************************************

desc : {l : Level}{I : Set l} -> IDesc I -> (I -> Set l) -> Set l
desc (var i) P = P i
desc (const X) P = X
desc (prod D D') P = desc D P * desc D' P
desc (sigma S T) P = Sigma S (\s -> desc (T s) P)
desc (pi S T) P = (s : S) -> desc (T s) P

--********************************************
-- Fixpoint construction
--********************************************

data IMu {l : Level}{I : Set l}(R : I -> IDesc I)(i : I) : Set l where
  con : desc (R i) (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: Box
--********************************************

box : {l : Level}{I : Set l}(D : IDesc I)(P : I -> Set l) -> desc D P -> IDesc (Sigma I P)
box (var i)     P x        = var (i , x)
box (const X)   P x        = const X
box (prod D D') P (d , d') = prod (box D P d) (box D' P d')
box (sigma S T) P (a , b)  = box (T a) P b
box (pi S T)    P f        = pi S (\s -> box (T s) P (f s))

--********************************************
-- Elimination principle: induction
--********************************************

module Elim {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs ))
       where

  mutual
    induction : (i : I)(x : IMu R i) -> P (i , x)
    induction i (con xs) = m i xs (hyps (R i) xs)

    hyps : (D : IDesc I) ->
           (xs : desc D (IMu R)) ->
           desc (box D (IMu R) xs) P
    hyps (var i) x = induction i x
    hyps (const X) x = x -- ??
    hyps (prod D D') (d , d') =  hyps D d , hyps D' d'
    hyps (pi S R) f = \ s -> hyps (R s) (f s)
    hyps (sigma S R) ( a , b ) = hyps (R a) b

induction : {l : Level}
            {I : Set l}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set l)
            (m : (i : I)
                 (xs : desc (R i) (IMu R))
                 (hs : desc (box (R i) (IMu R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
induction = Elim.induction

--********************************************
-- DescD
--********************************************

data DescDConst {l : Level} : Set l where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

descDChoice : (l : Level) -> Set l -> DescDConst -> IDesc Unit
descDChoice _ I lvar = const (lift I)
descDChoice x _ lconst = const (Set x)
descDChoice _ _ lprod = prod (var Void) (var Void)
descDChoice x _ lpi = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))
descDChoice x _ lsigma = sigma (Set x) (\S -> pi (lift S) (\s -> var Void))

descD : (l : Level)(I : Set l) -> IDesc Unit
descD x I = sigma DescDConst (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (\_ -> descD x I) Void

varl : (l : Level)(I : Set l)(i : I) -> IDescl l I
varl x I i = con (lv , lifter i)
     where lv : DescDConst  {l = suc x}
           lv = lvar

constl : (l : Level)(I : Set l)(X : Set l) -> IDescl l I
constl x I X = con (lc , X)
       where lc : DescDConst {l = suc x}
             lc = lconst

prodl : (l : Level)(I : Set l)(D D' : IDescl l I) -> IDescl l I
prodl x I D D' = con (lp , (D , D'))
      where lp : DescDConst {l = suc x}
            lp = lprod

pil : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
pil x I S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl x I
          Tl (lifter s) = T s

sigmal : (l : Level)(I : Set l)(S : Set l)(T : S -> IDescl l I) -> IDescl l I
sigmal x I S T = con (ls , ( S , Tl))
       where ls : DescDConst {l = suc x}
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s

--********************************************
-- From the embedding to the host
--********************************************

-- desc : (l : Level)(I : Set l) -> IDesc l I -> (I -> Set l) -> Set l
-- descD : (l : Level)(I : Set l) -> IDesc (suc l) Unit
-- IMu (l : Level)(I : Set l)(R : I -> IDesc l I)(i : I) : Set l

-- cases : (l : Level)
--         (I : Set l)
--         (xs : desc (suc l) (lift I) (descD l I) (IMu (suc l) Unit (\ _ -> descD l I)))
--         (hs : desc l I (box l I (descD l I) (IMu l Unit (λ _ -> descD l I)) xs) (λ _ -> IDesc (suc l) I)) ->
--         IDesc (suc l) I
-- cases x I ( lvar , i ) hs =  var i
-- cases x I ( lconst , X ) hs =  const X
-- cases x I ( lprod , (D , D') ) ( d , d' ) =  prod d d'
-- cases x I ( lpi , ( S , T ) ) hs =  pi S hs
-- cases x I ( lsigma , ( S , T ) ) hs = sigma S hs

-- phi : {I : Set} -> IDescl I -> IDesc I
-- phi {I} d = induction (\_ -> descD I) (\_ -> IDesc I) (\_ -> cases) Void d


Drop dead comment

Drop dead comment

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term

import Parametric.Syntax.MType as MType
import Parametric.Syntax.MTerm as MTerm

import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Denotation.MValue as MValue
import Parametric.Denotation.CachingMValue as CachingMValue
import Parametric.Denotation.MEvaluation as MEvaluation

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ValConst : MTerm.ValConstStructure Const)
    (CompConst : MTerm.CompConstStructure Const)
    -- I should really switch to records - can it get sillier than this?
    (⟦_⟧ValBase : MEvaluation.ValStructure Const ⟦_⟧Base ValConst CompConst)
    (⟦_⟧CompBase : MEvaluation.CompStructure Const ⟦_⟧Base ValConst CompConst)
  where

open Type.Structure Base
open Term.Structure Base Const

open MType.Structure Base
open MTerm.Structure Const ValConst CompConst

open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open MValue.Structure Base ⟦_⟧Base
open CachingMValue.Structure Base ⟦_⟧Base
open MEvaluation.Structure Const ⟦_⟧Base ValConst CompConst ⟦_⟧ValBase ⟦_⟧CompBase

open import Base.Denotation.Notation

-- Extension Point: Evaluation of fully applied constants.
ValStructure : Set
ValStructure = ∀ {Σ τ} → ValConst Σ τ → ⟦ Σ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

CompStructure : Set
CompStructure = ∀ {Σ τ} → CompConst Σ τ → ⟦ Σ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache

module Structure
       (⟦_⟧ValBaseTermCache  : ValStructure)
       (⟦_⟧CompBaseTermCache : CompStructure)
    where

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Unit

  -- Defining a caching semantics for Term proves to be hard, requiring to
  -- insert and remove caches where we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache
  ⟦_⟧ValsTermCache : ∀ {Γ Σ} → Vals Γ Σ → ⟦ Γ ⟧ValCtxHidCache → ⟦ Σ ⟧ValCtxHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVarHidCache)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- Copy of ⟦_⟧Vals
  ⟦ ∅ ⟧ValsTermCache ρ = ∅
  ⟦ vt • valtms ⟧ValsTermCache ρ = ⟦ vt ⟧ValTermCache ρ • ⟦ valtms ⟧ValsTermCache ρ

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVarHidCache ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ
  -- No caching, because the arguments are values, so evaluating them does not
  -- produce intermediate results.
  ⟦ vConst c args ⟧ValTermCache ρ = ⟦ c ⟧ValBaseTermCache (⟦ args ⟧ValsTermCache ρ)

  -- The only caching is done by the interpretation of the constant (because the
  -- arguments are values so need no caching).
  ⟦_⟧CompTermCache (cConst c args) ρ = ⟦ c ⟧CompBaseTermCache (⟦ args ⟧ValsTermCache ρ)

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ = λ x → ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

  ⟦_⟧TermCacheCBV : ∀ {τ Γ} → Term Γ τ → ⟦ fromCBVCtx Γ ⟧ValCtxHidCache → ⟦ cbvToCompType τ ⟧CompTypeHidCache
  ⟦ t ⟧TermCacheCBV = ⟦ fromCBV t ⟧CompTermCache

------------------------------------------------------------------------
-- INCREMENTAL λ-CALCULUS
--
-- Caching evaluation
------------------------------------------------------------------------

import Parametric.Syntax.Type as Type
import Parametric.Syntax.Term as Term

import Parametric.Syntax.MType as MType
import Parametric.Syntax.MTerm as MTerm

import Parametric.Denotation.Value as Value
import Parametric.Denotation.Evaluation as Evaluation
import Parametric.Denotation.MValue as MValue
import Parametric.Denotation.CachingMValue as CachingMValue
import Parametric.Denotation.MEvaluation as MEvaluation

module Parametric.Denotation.CachingEvaluation
    {Base : Type.Structure}
    (Const : Term.Structure Base)
    (⟦_⟧Base : Value.Structure Base)
    (⟦_⟧Const : Evaluation.Structure Const ⟦_⟧Base)
    (ValConst : MTerm.ValConstStructure Const)
    (CompConst : MTerm.CompConstStructure Const)
    -- I should really switch to records - can it get sillier than this?
    (⟦_⟧ValBase : MEvaluation.ValStructure Const ⟦_⟧Base ValConst CompConst)
    (⟦_⟧CompBase : MEvaluation.CompStructure Const ⟦_⟧Base ValConst CompConst)
  where

open Type.Structure Base
open Term.Structure Base Const

open MType.Structure Base
open MTerm.Structure Const ValConst CompConst

open Value.Structure Base ⟦_⟧Base
open Evaluation.Structure Const ⟦_⟧Base ⟦_⟧Const
open MValue.Structure Base ⟦_⟧Base
open CachingMValue.Structure Base ⟦_⟧Base
open MEvaluation.Structure Const ⟦_⟧Base ValConst CompConst ⟦_⟧ValBase ⟦_⟧CompBase

open import Base.Denotation.Notation

-- Extension Point: Evaluation of fully applied constants.
ValStructure : Set
ValStructure = ∀ {Σ τ} → ValConst Σ τ → ⟦ Σ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache

CompStructure : Set
CompStructure = ∀ {Σ τ} → CompConst Σ τ → ⟦ Σ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache

module Structure
       (⟦_⟧ValBaseTermCache  : ValStructure)
       (⟦_⟧CompBaseTermCache : CompStructure)
    where

  {-
  -- Prototype here the type-correctness of a simple non-standard semantics.
  -- This describes a simplified version of the transformation by Liu and
  -- Tanenbaum, PEPM 1995 - but for now, instead of producing object language
  -- terms, we produce host language terms to take advantage of the richer type
  -- system of the host language (in particular, here we need the unit type,
  -- product types and *existentials*).
  --
  -- As usual, we'll later switch to a real term transformation.
  -}
  open import Data.Product hiding (map)
  open import Data.Unit

  -- Defining a caching semantics for Term proves to be hard, requiring to
  -- insert and remove caches where we apply constants.

  -- Indeed, our plugin interface is not satisfactory for adding caching. CBPV can help us.

  -- The solution is to distinguish among different kinds of constants. Some are
  -- value constructors (and thus do not return caches), while others are
  -- computation constructors (and thus should return caches). For products, I
  -- believe we will only use the products which are values, not computations
  -- (XXX check CBPV paper for the name).
  ⟦_⟧CompTermCache : ∀ {τ Γ} → Comp Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧CompTypeHidCache
  ⟦_⟧ValTermCache : ∀ {τ Γ} → Val Γ τ → ⟦ Γ ⟧ValCtxHidCache → ⟦ τ ⟧ValTypeHidCache
  ⟦_⟧ValsTermCache : ∀ {Γ Σ} → Vals Γ Σ → ⟦ Γ ⟧ValCtxHidCache → ⟦ Σ ⟧ValCtxHidCache

  open import Base.Denotation.Environment ValType ⟦_⟧ValTypeHidCache public
    using ()
    renaming (⟦_⟧Var to ⟦_⟧ValVarHidCache)

  -- This says that the environment does not contain caches... sounds wrong!
  -- Either we add extra variables for the caches, or we store computations in
  -- the environment (but that does not make sense), or we store caches in
  -- values, by acting not on F but on something else (U?).

  -- Copy of ⟦_⟧Vals
  ⟦ ∅ ⟧ValsTermCache ρ = ∅
  ⟦ vt • valtms ⟧ValsTermCache ρ = ⟦ vt ⟧ValTermCache ρ • ⟦ valtms ⟧ValsTermCache ρ

  -- I suspect the plan was to use extra variables; that's annoying to model in
  -- Agda but easier in implementations.

  ⟦ vVar   x ⟧ValTermCache ρ = ⟦ x ⟧ValVarHidCache ρ
  ⟦ vThunk x ⟧ValTermCache ρ = ⟦ x ⟧CompTermCache ρ
  -- No caching, because the arguments are values, so evaluating them does not
  -- produce intermediate results.
  ⟦ vConst c args ⟧ValTermCache ρ = ⟦ c ⟧ValBaseTermCache (⟦ args ⟧ValsTermCache ρ)

  -- The only caching is done by the interpretation of the constant (because the
  -- arguments are values so need no caching).
  ⟦_⟧CompTermCache (cConst c args) ρ = ⟦ c ⟧CompBaseTermCache (⟦ args ⟧ValsTermCache ρ)

  -- Also, where are introduction forms for pairs and sums among values? With
  -- them, we should see that we can interpret them without adding a cache.

  -- Thunks keep seeming noops.
  ⟦_⟧CompTermCache (cForce x) ρ = ⟦ x ⟧ValTermCache ρ

  -- Here, in an actual implementation, we would return the actual cache with
  -- all variables.
  --
  -- The effect of F is a writer monad of cached values, where the monoid is
  -- (isomorphic to) the free monoid over (∃ τ . τ), but we push the
  -- existentials up when pairing things!

  -- That's what we're interpreting computations in. XXX maybe consider using
  -- monads directly. But that doesn't deal with arity.
  ⟦_⟧CompTermCache (cReturn v) ρ = vUnit , (⟦ v ⟧ValTermCache ρ , tt)

  -- For this to be enough, a lambda needs to return a produce, not to forward
  -- the underlying one (unless there are no intermediate results). The correct
  -- requirements can maybe be enforced through a linear typing discipline.

  {-
  -- Here we'd have a problem with the original into from CBPV, because it does
  -- not require converting expressions to the "CBPV A-normal form".

  ⟦_⟧CompTermCache (v₁ into v₂) ρ =
  -- Sequence commands and combine their caches.
  {-
    let (_ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (_ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in , (r₂ , (c₁ ,′ c₂))
  -}

  -- The code above does not work, because we only guarantee that v₂ is
  -- a computation, not that it's an F-computation - v₂ could also be function
  -- type or a computation product.

  -- We need a restricted CBPV, where these two possibilities are forbidden. If
  -- you want to save something between different lambdas, you need to add an F
  -- U to reflect that. (Double-check the papers which show how to encode arity
  -- using CBPV, it seems that they should find the same problem --- XXX they
  -- don't).

  -- Instead, just drop the first cache (XXX WRONG).
    ⟦ v₂ ⟧CompTermCache (proj₁ (proj₂ (⟦ v₁ ⟧CompTermCache ρ)) • ρ)
  -}

  -- But if we alter _into_ as described above, composing the caches works!
  -- However, we should not forget we also need to save the new intermediate
  -- result, that is the one produced by the first part of the let.
  ⟦_⟧CompTermCache (_into_ {σ} {τ} v₁ v₂) ρ =
    let (τ₁ , (r₁ , c₁)) = ⟦ v₁ ⟧CompTermCache ρ
        (τ₂ , (r₂ , c₂)) = ⟦ v₂ ⟧CompTermCache (r₁ • ρ)
    in  (σ v× τ₁ v× τ₂) , (r₂ ,′ ( r₁  ,′ c₁ ,′ c₂))

  -- Note the compositionality and luck: we don't need to do anything at the
  -- cReturn time, we just need the nested into to do their job, because as I
  -- said intermediate results are a writer monad.
  --
  -- Q: But then, do we still need to do all the other stuff? IOW, do we still
  -- need to forbid (λ x . y <- f args; g args') and replace it with (λ x . y <-
  -- f args; z <- g args'; z)?
  --
  -- A: One thing we still need is using the monadic version of into for the
  -- same reasons - which makes sense, since it has the type of monadic bind.
  --
  -- Maybe not: if we use a monad, which respects left and right identity, the
  -- two above forms are equivalent. But what about associativity? We don't have
  -- associativity with nested tuples in the middle. That's why the monad uses
  -- lists! We can also use nested tuple, as long as in the into case we don't
  -- do (a, b) but append a b (ahem, where?), which decomposes the first list
  -- and prepends it to the second. To this end, we need to know the type of the
  -- first element, or to ensure it's always a pair. Maybe we just want to reuse
  -- an HList.

  -- In abstractions, we should start collecting all variables...

  -- Here, unlike in ⟦_⟧TermCache, we don't need to invent an empty cache,
  -- that's moved into the handling of cReturn. This makes *the* difference for
  -- nested lambdas, where we don't need to create caches multiple times!

  ⟦_⟧CompTermCache (cAbs v) ρ = λ x → ⟦ v ⟧CompTermCache (x • ρ)

  -- Here we see that we are in a sort of A-normal form, because the argument is
  -- a value (not quite ANF though, since values can be thunks - that is,
  -- computations which haven't been run yet, I guess. Do we have an use for
  -- that? That allows passing lambdas as arguments directly - which is fine,
  -- because producing a closure indeed does not have intermediate results!).
  ⟦_⟧CompTermCache (cApp t v) ρ = ⟦ t ⟧CompTermCache ρ (⟦ v ⟧ValTermCache ρ)

  ⟦_⟧TermCacheCBV : ∀ {τ Γ} → Term Γ τ → ⟦ fromCBVCtx Γ ⟧ValCtxHidCache → ⟦ cbvToCompType τ ⟧CompTypeHidCache
  ⟦ t ⟧TermCacheCBV = ⟦ fromCBV t ⟧CompTermCache


Cleaning.

Cleaning.

Ignore-this: a0d11238690f72ea668e358ccc188abd

darcs-hash:20110405150812-3bd4e-afdff1a0cdbd4dc4b3edfee982506c8248779ca5.gz

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 zN      = nest-0
nest-x≡0 (sN {n} Nn) =
  begin
    nest (succ n)
      ≡⟨ nest-S n ⟩
    nest (nest n)
      ≡⟨ subst (λ t → nest (nest n) ≡ nest t)
               (nest-x≡0 Nn)  -- IH.
               refl
      ⟩
    nest zero
      ≡⟨ nest-0 ⟩
    zero
  ∎

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-DN : ∀ {d} → Dom d → N (nest d)
nest-DN dom0           = subst N (sym nest-0) zN
nest-DN (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-DN h₂)

-- The nest function is total.
nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) zN

nest-≤ : ∀ {n} → Dom n → LE (nest n) n
nest-≤ dom0 =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ (domS n h₁ h₂) =
  ≤-trans (nest-N (sN (dom-N n h₁))) (nest-N (dom-N n h₁)) (sN Nn) prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N (dom-N n h₁)) Nn (sN Nn) (nest-≤ h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N Nx ) (x≤y→x<Sy (nest-N Nx) Nx (nest-≤ dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)

------------------------------------------------------------------------------
-- FOTC version of the domain predicate of a nested recursive function
-- given by the Bove-Capretta method
------------------------------------------------------------------------------

-- From: Ana Bove and Venanzio Capretta. Nested general recursion and
-- partiality in type theory. Vol. 2152 of LNCS. 2001

module Draft.FOTC.Program.Nest.DomainPredicate where

open import FOTC.Base

open import FOTC.Data.Nat
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Nat.Inequalities.PropertiesI

open import FOTC.Relation.Binary.EqReasoning

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

postulate
  nest   : D → D
  nest-0 :       nest zero     ≡ zero
  nest-S : ∀ d → nest (succ d) ≡ nest (nest d)

-- The nest function is total (non-terminating version).
-- nest-N : ∀ {n} → N n → N (nest n)
-- nest-N zN          = subst N (sym nest-0) zN
-- nest-N (sN {n} Nn) = subst N (sym (nest-S n)) (nest-N (nest-N Nn))

data Dom : D → Set where
  dom0 :                              Dom zero
  domS : ∀ d → Dom d → Dom (nest d) → Dom (succ d)

-- The domain predicate is total.
dom-N : ∀ d → Dom d → N d
dom-N .zero     dom0           = zN
dom-N .(succ d) (domS d h₁ h₂) = sN (dom-N d h₁)

nest-x≡0 : ∀ {n} → N n → nest n ≡ zero
nest-x≡0 zN      = nest-0
nest-x≡0 (sN {n} Nn) =
  begin
    nest (succ n)
      ≡⟨ nest-S n ⟩
    nest (nest n)
      ≡⟨ subst (λ t → nest (nest n) ≡ nest t)
               (nest-x≡0 Nn)  -- IH.
               refl
      ⟩
    nest zero
      ≡⟨ nest-0 ⟩
    zero
  ∎

-- The nest function is total in its domain (via structural recursion
-- in the domain predicate).
nest-DN : ∀ {d} → Dom d → N (nest d)
nest-DN dom0           = subst N (sym nest-0) zN
nest-DN (domS d h₁ h₂) = subst N (sym (nest-S d)) (nest-DN h₂)

-- The nest function is total.
nest-N : ∀ {n} → N n → N (nest n)
nest-N Nn = subst N (sym (nest-x≡0 Nn)) zN

nest-≤ : ∀ {n} → Dom n → LE (nest n) n
nest-≤ dom0 =
  begin
    nest zero ≤ zero
      ≡⟨ subst (λ t → nest zero ≤ zero ≡ t ≤ zero)
               nest-0
               refl
      ⟩
    zero ≤ zero
      ≡⟨ x≤x zN ⟩
    true
  ∎

nest-≤ (domS n h₁ h₂) =
  ≤-trans (nest-N (sN (dom-N n h₁))) (nest-N (dom-N n h₁)) (sN Nn) prf₁ prf₂
    where
      Nn : N n
      Nn = dom-N n h₁

      prf₁ : LE (nest (succ n)) (nest n)
      prf₁ =
        begin
          nest (succ n) ≤ nest n
            ≡⟨ subst (λ t → nest (succ n) ≤ nest n ≡ t ≤ nest n)
                     (nest-S n)
                     refl
            ⟩
          nest (nest n) ≤ nest n
            ≡⟨ nest-≤ h₂ ⟩
          true
          ∎

      prf₂ : LE (nest n) (succ n)
      prf₂ = ≤-trans (nest-N (dom-N n h₁)) Nn (sN Nn) (nest-≤ h₁) (x≤Sx Nn)

N→Dom : ∀ {n} → N n → Dom n
N→Dom = wfInd-LT P ih
  where
    P : D → Set
    P = Dom

    ih : ∀ {x} → N x → (∀ {y} → N y → LT y x → P y) → P x
    ih zN          h = dom0
    ih (sN {x} Nx) h =
      domS x dn-x (h (nest-N Nx ) (x≤y→x<Sy (nest-N Nx) Nx (nest-≤ dn-x)))
      where
        dn-x : Dom x
        dn-x = h Nx (x<Sx Nx)


working on #2, found bug in syntactic sugar for failed casts

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) (TAAp D1 D2) D3 D4 (FHAp1 D5) = TAAp (pres-lem eps D1 D3 D4 D5) D2
  pres-lem (FHAp2 eps) (TAAp D1 D2) D3 D4 (FHAp2 D5) = TAAp D1 (pres-lem eps D2 D3 D4 D5)
  pres-lem (FHNEHole eps) (TANEHole x D1 x₁) D2 D3 (FHNEHole D4) = TANEHole x (pres-lem eps D1 D2 D3 D4) x₁
  pres-lem (FHCast eps) (TACast D1 x) D2 D3 (FHCast D4) = TACast (pres-lem eps D1 D2 D3 D4) x
  pres-lem (FHFailedCast FHOuter) (TAFailedCast D1 x x₁ x₂) (TACast D2 x₃) D3 (FHFailedCast FHOuter) = {!!}
  pres-lem (FHFailedCast (FHCast eps)) (TAFailedCast D1 x x₁ x₂) D2 D3 (FHFailedCast (FHCast D4)) = TAFailedCast (pres-lem eps D1 D2 D3 D4) x x₁ x₂

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x y z w) (FHFailedCast FHOuter) = _ , TACast x TCHole1
  pres-lem2 (TAFailedCast x y z w) (FHFailedCast (FHCast eps)) = pres-lem2 x eps

  -- this is the literal contents of the hole in lem3; it might not go
  -- through exactly like this.
  lem-subst : ∀{Δ Γ x τ1 d1 τ d2 } →
              Δ , Γ ,, (x , τ1) ⊢ d1 :: τ →
              Δ , Γ ⊢ d2 :: τ1 →
              Δ , Γ ⊢ [ d2 / x ] d1 :: τ
  lem-subst D1 D2 = {!!}

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = lem-subst ta ta₁
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂

open import Nat
open import Prelude
open import List
open import core
open import contexts

open import lemmas-consistency
open import type-assignment-unicity

module preservation where
  -- todo: rename
  pres-lem : ∀{ Δ Γ d ε d1 d2 d3 τ τ1 } →
            d == ε ⟦ d1 ⟧ →
            Δ , Γ ⊢ d :: τ →
            Δ , Γ ⊢ d1 :: τ1 →
            Δ , Γ ⊢ d2 :: τ1 →
            d3 == ε ⟦ d2 ⟧ →
            Δ , Γ ⊢ d3 :: τ
  pres-lem FHOuter D1 D2 D3 FHOuter
    with type-assignment-unicity D1 D2
  ... | refl = D3
  pres-lem (FHAp1 eps) D1 D2 D3 (FHAp1 D4) = TAAp {!!} {!!}
  pres-lem (FHAp2 eps) D1 D2 D3 (FHAp2 D4) = TAAp {!!} {!!}
  pres-lem (FHNEHole eps) D1 D2 D3 (FHNEHole D4) = TANEHole {!!} {!!} {!!}
  pres-lem (FHCast eps) D1 D2 D3 (FHCast D4) = {!!}
  pres-lem (FHFailedCast eps) D1 D2 D3 (FHFailedCast D4) = {!!}

  -- todo: rename
  pres-lem2 : ∀{ ε Δ Γ d τ d' } →
             Δ , Γ ⊢ d :: τ →
             d == ε ⟦ d' ⟧ →
             Σ[ τ' ∈ htyp ] (Δ , Γ ⊢ d' :: τ')
  pres-lem2 TAConst FHOuter = _ , TAConst
  pres-lem2 (TAVar x₁) FHOuter = _ , TAVar x₁
  pres-lem2 (TALam ta) FHOuter = _ , TALam ta

  pres-lem2 (TAAp ta ta₁) FHOuter = _ , TAAp ta ta₁
  pres-lem2 (TAAp ta ta₁) (FHAp1 eps) = pres-lem2 ta eps
  pres-lem2 (TAAp ta ta₁) (FHAp2 eps) = pres-lem2 ta₁ eps

  pres-lem2 (TAEHole x x₁) FHOuter = _ , TAEHole x x₁
  pres-lem2 (TANEHole x ta x₁) FHOuter = _ , TANEHole x ta x₁
  pres-lem2 (TANEHole x ta x₁) (FHNEHole eps) = pres-lem2 ta eps
  pres-lem2 (TACast ta x) FHOuter = _ , TACast ta x
  pres-lem2 (TACast ta x) (FHCast eps) = pres-lem2 ta eps
  pres-lem2 (TAFailedCast x y z w) FHOuter = _ , TAFailedCast x y z w
  pres-lem2 (TAFailedCast x y z w) (FHFailedCast FHOuter) = _ , TACast x TCHole1
  pres-lem2 (TAFailedCast x y z w) (FHFailedCast (FHCast eps)) = pres-lem2 x eps

  -- todo: rename
  pres-lem3 : ∀{ Δ Γ d τ d' } →
            Δ , Γ ⊢ d :: τ →
            d →> d' →
            Δ , Γ ⊢ d' :: τ
  pres-lem3 TAConst ()
  pres-lem3 (TAVar x₁) ()
  pres-lem3 (TALam ta) ()
  pres-lem3 (TAAp (TALam ta) ta₁) ITLam = {!!} -- todo: this is a lemma
  pres-lem3 (TAAp (TACast ta TCRefl) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ TCRefl)) TCRefl
  pres-lem3 (TAAp (TACast ta (TCArr x x₁)) ta₁) ITApCast = TACast (TAAp ta (TACast ta₁ (~sym x))) x₁
  pres-lem3 (TAEHole x x₁) ()
  pres-lem3 (TANEHole x ta x₁) ()
  pres-lem3 (TACast ta x) (ITCastID) = ta
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastSucceed x₂) = ta
  pres-lem3 (TACast ta x) (ITGround (MGArr x₁)) = TACast (TACast ta (TCArr TCHole1 TCHole1)) TCHole1
  pres-lem3 (TACast ta TCHole2) (ITExpand (MGArr x₁)) = TACast (TACast ta TCHole2) (TCArr TCHole2 TCHole2)
  pres-lem3 (TACast (TACast ta x) x₁) (ITCastFail w y z) = TAFailedCast ta w y z
  pres-lem3 (TAFailedCast x y z q) ()

  preservation : {Δ : hctx} {d d' : dhexp} {τ : htyp} →
             Δ , ∅ ⊢ d :: τ →
             d ↦ d' →
             Δ , ∅ ⊢ d' :: τ
  preservation D (Step x x₁ x₂)
    with pres-lem2 D x
  ... | (_ , wt) = pres-lem x D wt (pres-lem3 wt x₁) x₂


FunUniverse.BinTree: without-K

FunUniverse.BinTree: without-K

{-# OPTIONS --without-K #-}
module FunUniverse.BinTree where

open import Type hiding (★)
open import Function
open import Data.Nat.NP using (ℕ; zero; suc; _≤_; s≤s; _+_; module ℕ≤; module ℕ°)
open import Data.Nat.Properties
open import Data.Bool
open import Data.Vec using (_++_)
open import Data.Bits
--import Data.Bits.Search as Search
--open Search.SimpleSearch
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Composition.Horizontal
open import Composition.Vertical
open import Composition.Forkable

data Tree {a} (A : ★ a) : ℕ → ★ a where
  leaf : ∀ {n} → A → Tree A n
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : ★ a} → (Bits n → A) → Tree A n
fromFun {zero}  f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : ★ a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

toFun∘fromFun : ∀ {n a} {A : ★ a} (f : Bits n → A) → toFun (fromFun f) ≗ f
toFun∘fromFun {zero}  f []        = refl
toFun∘fromFun {suc n} f (false {-0b-} ∷ bs) = toFun∘fromFun {n} (f ∘ 0∷_) bs
toFun∘fromFun {suc n} f (true  {-1b-} ∷ bs) = toFun∘fromFun {n} (f ∘ 1∷_) bs

fold : ∀ {n a} {A : ★ a} (op : A → A → A) → Tree A n → A
fold _   (leaf x) = x
fold _·_ (fork t₀ t₁) = fold _·_ t₀ · fold _·_ t₁

{-
search≡fold∘fromFun : ∀ {n a} {A : ★ a} op (f : Bits n → A) → search op f ≡ fold op (fromFun f)
search≡fold∘fromFun {zero}  op f = refl
search≡fold∘fromFun {suc n} op f
  rewrite search≡fold∘fromFun op (f ∘ 0∷_)
        | search≡fold∘fromFun op (f ∘ 1∷_) = refl
-}

leafⁿ : ∀ {n a} {A : ★ a} → A → Tree A n
leafⁿ {zero}  x = leaf x
leafⁿ {suc n} x = fork t t where t = leafⁿ x

expand : ∀ {n a} {A : ★ a} → Tree A n → Tree A n
expand (leaf x) = leafⁿ x
expand (fork t₀ t₁) = fork (expand t₀) (expand t₁)

fromConst≡leafⁿ : ∀ {n a} {A : ★ a} (x : A) → fromFun (const x) ≡ leafⁿ {n} x
fromConst≡leafⁿ {zero}  _ = refl
fromConst≡leafⁿ {suc n} x = cong₂ fork (fromConst≡leafⁿ x) (fromConst≡leafⁿ x)

fromFun∘toFun : ∀ {n a} {A : ★ a} (t : Tree A n) → fromFun (toFun t) ≡ expand t
fromFun∘toFun (leaf x)     = fromConst≡leafⁿ x
fromFun∘toFun (fork t₀ t₁) = cong₂ fork (fromFun∘toFun t₀) (fromFun∘toFun t₁)

lookup : ∀ {n a} {A : ★ a} → Bits n → Tree A n → A
lookup = flip toFun

map : ∀ {n a b} {A : ★ a} {B : ★ b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

weaken≤ : ∀ {m n a} {A : ★ a} → m ≤ n → Tree A m → Tree A n
weaken≤ _       (leaf x)          = leaf x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m n = ℕ≤.trans (m≤m+n m n) (ℕ≤.reflexive (ℕ°.+-comm m n))

weaken+ : ∀ n {m a} {A : ★ a} → Tree A m → Tree A (n + m)
weaken+ n = weaken≤ (m≤n+m _ n)

_>>=_ : ∀ {n₁ n₂ a b} {A : ★ a} {B : ★ b}
        → Tree A n₁ → (A → Tree B n₂) → Tree B (n₁ + n₂)
leaf {n} x >>= f = weaken+ n (f x)
fork ℓ r   >>= f = fork (ℓ >>= f) (r >>= f)

join : ∀ {c₁ c₂ a} {A : ★ a} → Tree (Tree A c₂) c₁ → Tree A (c₁ + c₂)
join t = t >>= id

_→ᵗ_ : (i o : ℕ) → ★₀
i →ᵗ o = Tree (Bits o) i

_>>>_ : ∀ {m n a} {A : ★ a} → Tree (Bits m) n → Tree A m → Tree A n
f >>> g = map (flip lookup g) f

_***_ : ∀ {i₀ i₁ o₀ o₁} → i₀ →ᵗ o₀ → i₁ →ᵗ o₁ → (i₀ + i₁) →ᵗ (o₀ + o₁)
(f *** g) = join (map (λ xs → map (_++_ xs) g) f)

hcomposable : HComposable _→ᵗ_
hcomposable = mk _>>>_

vcomposable : VComposable _+_ _→ᵗ_
vcomposable = mk _***_

forkable : Forkable suc _→ᵗ_
forkable = mk fork

-- This is probably useless by now
data Rot {a} {A : ★ a} : ∀ {n} (left right : Tree A n) → ★ a where
  leaf : ∀ {n} x → Rot {n = n} (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : ★ a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork left right} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : ★ a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

{- with-K
Rot-trans : ∀ {n a} {A : ★ a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
-- -}

-- NOTE with-K
module FunUniverse.BinTree where

open import Type hiding (★)
open import Function
open import Data.Nat.NP using (ℕ; zero; suc; _≤_; s≤s; _+_; module ℕ≤; module ℕ°)
open import Data.Nat.Properties
open import Data.Bool
open import Data.Vec using (_++_)
open import Data.Bits
--import Data.Bits.Search as Search
--open Search.SimpleSearch
open import Relation.Binary
open import Relation.Binary.PropositionalEquality
open import Composition.Horizontal
open import Composition.Vertical
open import Composition.Forkable

data Tree {a} (A : ★ a) : ℕ → ★ a where
  leaf : ∀ {n} → A → Tree A n
  fork : ∀ {n} (left right : Tree A n) → Tree A (suc n)

fromFun : ∀ {n a} {A : ★ a} → (Bits n → A) → Tree A n
fromFun {zero}  f = leaf (f [])
fromFun {suc n} f = fork (fromFun (f ∘ 0∷_)) (fromFun (f ∘ 1∷_))

toFun : ∀ {n a} {A : ★ a} → Tree A n → Bits n → A
toFun (leaf x) _ = x
toFun (fork left right) (b ∷ bs) = toFun (if b then right else left) bs

toFun∘fromFun : ∀ {n a} {A : ★ a} (f : Bits n → A) → toFun (fromFun f) ≗ f
toFun∘fromFun {zero}  f []        = refl
toFun∘fromFun {suc n} f (false {-0b-} ∷ bs) = toFun∘fromFun {n} (f ∘ 0∷_) bs
toFun∘fromFun {suc n} f (true  {-1b-} ∷ bs) = toFun∘fromFun {n} (f ∘ 1∷_) bs

fold : ∀ {n a} {A : ★ a} (op : A → A → A) → Tree A n → A
fold _   (leaf x) = x
fold _·_ (fork t₀ t₁) = fold _·_ t₀ · fold _·_ t₁

{-
search≡fold∘fromFun : ∀ {n a} {A : ★ a} op (f : Bits n → A) → search op f ≡ fold op (fromFun f)
search≡fold∘fromFun {zero}  op f = refl
search≡fold∘fromFun {suc n} op f
  rewrite search≡fold∘fromFun op (f ∘ 0∷_)
        | search≡fold∘fromFun op (f ∘ 1∷_) = refl
-}

leafⁿ : ∀ {n a} {A : ★ a} → A → Tree A n
leafⁿ {zero}  x = leaf x
leafⁿ {suc n} x = fork t t where t = leafⁿ x

expand : ∀ {n a} {A : ★ a} → Tree A n → Tree A n
expand (leaf x) = leafⁿ x
expand (fork t₀ t₁) = fork (expand t₀) (expand t₁)

fromConst≡leafⁿ : ∀ {n a} {A : ★ a} (x : A) → fromFun (const x) ≡ leafⁿ {n} x
fromConst≡leafⁿ {zero}  _ = refl
fromConst≡leafⁿ {suc n} x rewrite fromConst≡leafⁿ {n} x = refl

fromFun∘toFun : ∀ {n a} {A : ★ a} (t : Tree A n) → fromFun (toFun t) ≡ expand t
fromFun∘toFun (leaf x) = fromConst≡leafⁿ x
fromFun∘toFun (fork t₀ t₁) = cong₂ fork (fromFun∘toFun t₀) (fromFun∘toFun t₁)

lookup : ∀ {n a} {A : ★ a} → Bits n → Tree A n → A
lookup = flip toFun

map : ∀ {n a b} {A : ★ a} {B : ★ b} → (A → B) → Tree A n → Tree B n
map f (leaf x) = leaf (f x)
map f (fork t₀ t₁) = fork (map f t₀) (map f t₁)

weaken≤ : ∀ {m n a} {A : ★ a} → m ≤ n → Tree A m → Tree A n
weaken≤ _       (leaf x)          = leaf x
weaken≤ (s≤s p) (fork left right) = fork (weaken≤ p left) (weaken≤ p right)

m≤n+m : ∀ m n → m ≤ n + m
m≤n+m m n = ℕ≤.trans (m≤m+n m n) (ℕ≤.reflexive (ℕ°.+-comm m n))

weaken+ : ∀ n {m a} {A : ★ a} → Tree A m → Tree A (n + m)
weaken+ n = weaken≤ (m≤n+m _ n)

_>>=_ : ∀ {n₁ n₂ a b} {A : ★ a} {B : ★ b}
        → Tree A n₁ → (A → Tree B n₂) → Tree B (n₁ + n₂)
leaf {n} x >>= f = weaken+ n (f x)
fork ℓ r   >>= f = fork (ℓ >>= f) (r >>= f)

join : ∀ {c₁ c₂ a} {A : ★ a} → Tree (Tree A c₂) c₁ → Tree A (c₁ + c₂)
join t = t >>= id

_→ᵗ_ : (i o : ℕ) → ★₀
i →ᵗ o = Tree (Bits o) i

_>>>_ : ∀ {m n a} {A : ★ a} → Tree (Bits m) n → Tree A m → Tree A n
f >>> g = map (flip lookup g) f

_***_ : ∀ {i₀ i₁ o₀ o₁} → i₀ →ᵗ o₀ → i₁ →ᵗ o₁ → (i₀ + i₁) →ᵗ (o₀ + o₁)
(f *** g) = join (map (λ xs → map (_++_ xs) g) f)

hcomposable : HComposable _→ᵗ_
hcomposable = mk _>>>_

vcomposable : VComposable _+_ _→ᵗ_
vcomposable = mk _***_

forkable : Forkable suc _→ᵗ_
forkable = mk fork

-- This is probably useless by now
data Rot {a} {A : ★ a} : ∀ {n} (left right : Tree A n) → ★ a where
  leaf : ∀ {n} x → Rot {n = n} (leaf x) (leaf x)
  fork : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ left₁ →
         Rot right₀ right₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)
  krof : ∀ {n} {left₀ left₁ right₀ right₁ : Tree A n} →
         Rot left₀ right₁ →
         Rot right₀ left₁ →
         Rot (fork left₀ right₀) (fork left₁ right₁)

Rot-refl : ∀ {n a} {A : ★ a} → Reflexive (Rot {A = A} {n})
Rot-refl {x = leaf x} = leaf x
Rot-refl {x = fork left right} = fork Rot-refl Rot-refl

Rot-sym : ∀ {n a} {A : ★ a} → Symmetric (Rot {A = A} {n})
Rot-sym (leaf x) = leaf x
Rot-sym (fork p₀ p₁) = fork (Rot-sym p₀) (Rot-sym p₁)
Rot-sym (krof p₀ p₁) = krof (Rot-sym p₁) (Rot-sym p₀)

Rot-trans : ∀ {n a} {A : ★ a} → Transitive (Rot {A = A} {n})
Rot-trans (leaf x) q = q
Rot-trans (fork p₀ p₁) (fork q₀ q₁) = fork (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (fork p₀ p₁) (krof q₀ q₁) = krof (Rot-trans p₀ q₀) (Rot-trans p₁ q₁)
Rot-trans (krof p₀ p₁) (fork q₀ q₁) = krof (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)
Rot-trans (krof p₀ p₁) (krof q₀ q₁) = fork (Rot-trans p₀ q₁) (Rot-trans p₁ q₀)


nothing works...

nothing works...

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

module ITyping where

open import Data.Empty
open import Data.List
open import Data.Nat
open import Data.Product
open import Data.List.Any as Any
open Any.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
data ITypeₛ : Set

data ITypeₛ where
  o : ITypeₛ
  _~>_ : (s : IType) -> (t : ITypeₛ) -> ITypeₛ

data IType where
   ∩ : 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} _≡_
_≟TIₛ_ : Decidable {A = ITypeₛ} _≡_

∩ [] ≟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∷τⱼ))

o ≟TIₛ o = yes refl
o ≟TIₛ (_ ~> _) = no (λ ())
(_ ~> _) ≟TIₛ o = 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))

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
data _∷'ₛ_ : ITypeₛ -> Type -> Set

data _∷'ₛ_ where
  base : o ∷'ₛ σ
  arr : ∀ {δ τ A B} -> δ ∷' A -> τ ∷'ₛ B -> (δ ~> τ) ∷'ₛ (A ⟶ B)

data _∷'_ where
  int : ∀{τᵢ A} -> (c : ∀ {τ} -> (τ∈τᵢ : τ ∈ τᵢ) -> τ ∷'ₛ A) -> ∩ τᵢ ∷' A

data _⊩_∶_ : ICtxt -> PTerm -> ITypeₛ -> Set where
  var : ∀ {Γ x τ} {τᵢ : List ITypeₛ} -> (wf-Γ : Wf-ICtxt Γ) -> (τᵢ∈Γ : (x , (∩ τᵢ)) ∈ Γ) -> (τ∈τᵢ : τ ∈ τᵢ) ->
    Γ ⊩ fv x ∶ τ
  app : ∀ {Γ s t τᵢ τ} -> Γ ⊩ s ∶ ((∩ τᵢ) ~> τ) -> Term t -> (Γ⊩t∶τᵢ : ∀ {τ'} -> (τ'∈τᵢ : τ' ∈ τᵢ) -> Γ ⊩ t ∶ τ') ->
    Γ ⊩ (app s t) ∶ τ
  abs : ∀ {Γ δ τ} (L : FVars) -> ∀ {t} ->
    ( cf : ∀ {x} -> (x∉L : x ∉ L) -> ((x , δ) ∷ Γ) ⊩ t ^' x ∶ τ ) -> Γ ⊩ lam t ∶ (δ ~> τ)
  Y : ∀ {Γ A τᵢ τ} -> Wf-ICtxt Γ -> (τ∈τᵢ : τ ∈ τᵢ) -> (τᵢ∷ : ∀ {τ} -> τ ∈ τᵢ -> τ ∷'ₛ A) ->
    Γ ⊩ Y A ∶ (∩ (Data.List.map (λ τₖ -> (∩ τᵢ ~> τₖ)) τᵢ) ~> τ)

⊩-term : ∀ {Γ m τ} -> Γ ⊩ m ∶ τ -> Term m
⊩-term (var _ _ _) = var
⊩-term (app Γ⊩m∶τ trm-t c) = app (⊩-term Γ⊩m∶τ) trm-t
⊩-term (abs L cf) = lam L (λ {x} x∉L → ⊩-term (cf x∉L))
⊩-term (Y x τ∈τᵢ x₁) = Y

-- cex : [] ⊩ app (lam (lam (bv 0))) (bv 4) ∶ (∩' o ~> o)

wfI-cons : ∀ {Γ x τ} -> Wf-ICtxt ((x , τ) ∷ Γ) -> Wf-ICtxt Γ
wfI-cons (cons x∉ wf-Γ) = wf-Γ

⊩-imp-wfΓ : ∀ {Γ m τ} -> Γ ⊩ m  ∶ τ -> Wf-ICtxt Γ
⊩-imp-wfΓ (var x₁ x₂ x₃) = x₁
⊩-imp-wfΓ (app Γ⊢m:τ trm-t c) = ⊩-imp-wfΓ Γ⊢m:τ
⊩-imp-wfΓ (abs L cf) = wfI-cons (⊩-imp-wfΓ (cf x∉))
  where
  x = ∃fresh L

  x∉ : x ∉ L
  x∉ = ∃fresh-spec L

⊩-imp-wfΓ (Y x τ∈τᵢ x₁) = x

var-⊩-∈ : ∀ {x y τᵢ τ Γ} -> ((x , ∩ τᵢ) ∷ Γ) ⊩ fv y ∶ τ -> x ≡ y -> τ ∈ τᵢ
var-⊩-∈ {x} {_} {τᵢ} {τ} (var {x = .x} {τᵢ = τⱼ} (cons x∉ wf-Γ) ∩τⱼ∈x∷Γ τ∈τⱼ) refl with (∩ τⱼ) ≟TI (∩ τᵢ)
var-⊩-∈ (var (cons x∉ wf-Γ) ∩τⱼ∈x∷Γ τ∈τⱼ) refl | yes refl = τ∈τⱼ
var-⊩-∈ (var (cons x∉ wf-Γ) ∩τⱼ∈x∷Γ τ∈τⱼ) refl | no ∩τⱼ≠∩τᵢ = ⊥-elim (∉-∷ _ _ (λ x → ∩τⱼ≠∩τᵢ (×-inj-r x)) (∉-dom x∉) ∩τⱼ∈x∷Γ)

-- substitution lemma.

weakening-⊩ : ∀ {Γ Γ' m τ} -> Γ ⊆ Γ' -> Wf-ICtxt Γ' -> Γ ⊩ m ∶ τ -> Γ' ⊩ m ∶ τ
weakening-⊩ Γ⊆Γ' wf-Γ' (var wf-Γ ∩τᵢ∈Γ τ∈τᵢ) = var wf-Γ' (Γ⊆Γ' ∩τᵢ∈Γ) τ∈τᵢ
weakening-⊩ Γ⊆Γ' wf-Γ' (app Γ⊩m∶τ x c) = app (weakening-⊩ Γ⊆Γ' wf-Γ' Γ⊩m∶τ) x
  (λ {τ'} τ'∈τᵢ → weakening-⊩ Γ⊆Γ' wf-Γ' (c τ'∈τᵢ))
weakening-⊩ {Γ} {Γ'} Γ⊆Γ' wf-Γ' (abs {_} {τᵢ} {τ} L {m} cf) =
  abs (L ++ dom Γ') (λ {x} x∉L++Γ' →
    weakening-⊩ {(x , τᵢ) ∷ Γ} {(x , τᵢ) ∷ Γ'} {m ^' x} {τ}
      (cons-⊆ Γ⊆Γ')
      (cons (∉-cons-r L _ x∉L++Γ') wf-Γ')
      (cf (∉-cons-l _ _ x∉L++Γ')))
weakening-⊩ Γ⊆Γ' wf-Γ' (Y x τ∈τᵢ x₁) = Y wf-Γ' τ∈τᵢ x₁

wfI-Γ-exchange : ∀ {Γ x y τ₁ τ₂} -> Wf-ICtxt ((x , τ₁) ∷ (y , τ₂) ∷ Γ) -> Wf-ICtxt ((y , τ₂) ∷ (x , τ₁) ∷ Γ)
wfI-Γ-exchange (cons x∉y∷Γ (cons y∉Γ wf∷Γ)) =
  cons (∉-∷ _ _ (λ y≡x → fv-x≠y _ _ x∉y∷Γ (≡-sym y≡x)) y∉Γ) (cons (∉-∷-elim _ x∉y∷Γ) wf∷Γ)

exchange-⊩ : ∀ {Γ m x y τ₁ τ₂ δ} -> ((x , τ₁) ∷ (y , τ₂) ∷ Γ) ⊩ m ∶ δ -> ((y , τ₂) ∷ (x , τ₁) ∷ Γ) ⊩ m ∶ δ
exchange-⊩ {Γ} {m} {x} {y} {τ₁} {τ₂} x∷y∷Γ⊢m∶δ =
  weakening-⊩ {(x , τ₁) ∷ (y , τ₂) ∷ Γ} {(y , τ₂) ∷ (x , τ₁) ∷ Γ}
    sub (wfI-Γ-exchange (⊩-imp-wfΓ x∷y∷Γ⊢m∶δ)) x∷y∷Γ⊢m∶δ

    where
    sub : (x , τ₁) ∷ (y , τ₂) ∷ Γ ⊆ (y , τ₂) ∷ (x , τ₁) ∷ Γ
    sub (here px) = there (here px)
    sub (there (here px)) = here px
    sub (there (there ∈)) = there (there ∈)

subst-⊩ : ∀ {Γ m n τᵢ τ₂ x} -> Term m -> Term n -> ((x , ∩ τᵢ) ∷ Γ) ⊩ m ∶ τ₂ -> (∀ {τ} -> τ ∈ τᵢ -> Γ ⊩ n ∶ τ) ->
  Γ ⊩ (m [ x ::= n ]) ∶ τ₂
subst-⊩ {x = x} var trm-n (var {x = y} wf-Γ ∩τᵢ∈Γ τ∈τᵢ) Γ⊩n∶τᵢ with x ≟ y
subst-⊩ var trm-n (var wf-Γ ∩τᵢ∈Γ τ∈τᵢ) Γ⊩n∶τᵢ | yes refl =
  Γ⊩n∶τᵢ (var-⊩-∈ (var wf-Γ ∩τᵢ∈Γ τ∈τᵢ) refl)
subst-⊩ {Γ} {x = x} var trm-n (var {x = y} wf-Γ ∩τᵢ∈Γ τ∈τᵢ) Γ⊩n∶τᵢ | no x≠y =
  var {Γ} {y} (wfI-cons wf-Γ) (∈-∷-elim _ _ (λ x∩τᵢ≡y∩τⱼ → x≠y (×-inj-l x∩τᵢ≡y∩τⱼ)) ∩τᵢ∈Γ) τ∈τᵢ
subst-⊩ {Γ} {_} {n} {τᵢ} {_} {x} (lam L cf) trm-n (abs {_} {τᵢ'} {τ₂} L' {m} cf') Γ⊩n∶τᵢ = abs (x ∷ L ++ L' ++ dom Γ) body
  where
  body : ∀ {x' : ℕ} → x' ∉ x ∷ L ++ L' ++ dom Γ → ((x' , τᵢ') ∷ Γ) ⊩ (m [ x ::= n ]) ^' x' ∶ τ₂
  body {x'} x'∉ rewrite
    subst-open-var x' x n m (fv-x≠y _ _ x'∉) trm-n =
      subst-⊩ {(x' , τᵢ') ∷ Γ} {m ^' x'} {n} {τᵢ} {τ₂}
        (cf (∉-∷-elim _ (∉-cons-l _ _ x'∉)))
        trm-n
        (exchange-⊩ (cf' (∉-cons-l _ _ (∉-cons-r L _ (∉-∷-elim _ x'∉)))))
        (λ τ∈τᵢ → weakening-⊩ there (cons (∉-cons-r L' _ (∉-cons-r L _ (∉-∷-elim _ x'∉))) (⊩-imp-wfΓ (Γ⊩n∶τᵢ τ∈τᵢ))) (Γ⊩n∶τᵢ τ∈τᵢ))

subst-⊩ (app trm-m trm-m₁) trm-n (app x∷Γ⊩m∶τ₂ trm-t c) Γ⊩n∶τᵢ =
  app (subst-⊩ trm-m trm-n x∷Γ⊩m∶τ₂ Γ⊩n∶τᵢ) (subst-Term trm-t trm-n) (λ {τ'} τ'∈τᵢ → subst-⊩ trm-m₁ trm-n (c τ'∈τᵢ) Γ⊩n∶τᵢ)
subst-⊩ Y trm-n (Y (cons x∉ wf-Γ) τ∈τᵢ x₂) Γ⊩n∶τᵢ = Y wf-Γ τ∈τᵢ x₂

-- subject Reduction
^-⊩ : ∀ {Γ L m n τᵢ τ₂} -> Term n -> ( cf : ∀ {x} -> (x∉L : x ∉ L) -> ((x , ∩ τᵢ) ∷ Γ) ⊩ m ^' x ∶ τ₂ ) ->
  (∀ {τ} -> τ ∈ τᵢ -> Γ ⊩ n ∶ τ) -> Γ ⊩ m ^ n ∶ τ₂
^-⊩ {Γ} {L} {m} {n} {τᵢ} {τ} trm-n cf Γ⊩n∶τᵢ = body
  where
  x = ∃fresh (L ++ FV m)

  x∉ : x ∉ (L ++ FV m)
  x∉ = ∃fresh-spec (L ++ FV m)

  body : Γ ⊩ m ^ n ∶ τ
  body rewrite
    subst-intro x n m (∉-cons-r L _ x∉) trm-n =
    subst-⊩ (⊩-term (cf (∉-cons-l _ _ x∉))) trm-n (cf (∉-cons-l _ _ x∉)) Γ⊩n∶τᵢ

->β-⊩ : ∀ {Γ m m' τ} -> Γ ⊩ m ∶ τ -> m ->β m' -> Γ ⊩ m' ∶ τ
->β-⊩ (app Γ⊩m∶τ x c) (redL x₁ m->βm') = app (->β-⊩ Γ⊩m∶τ m->βm') x₁ c
->β-⊩ (app Γ⊩m∶τ trm-t c) (redR x₁ m->βm') = app Γ⊩m∶τ (->β-Term-r m->βm') (λ τ'∈τᵢ → ->β-⊩ (c τ'∈τᵢ) m->βm')
->β-⊩ (abs L cf) (abs L₁ cf₁) = abs (L ++ L₁) (λ {x} x∉L → ->β-⊩ (cf (∉-cons-l _ _ x∉L)) (cf₁ (∉-cons-r L _ x∉L)))
->β-⊩ (app (abs L {m} cf) x Γ⊢n∶τᵢ) (beta x₁ trm-n) = ^-⊩ {m = m} trm-n cf Γ⊢n∶τᵢ
->β-⊩ (app (Y {τ = τ} wf-Γ τ∈τᵢ τ∷'ₛσ) _ Γ⊩m∶τᵢ) (Y trm-m) =
  app
    (Γ⊩m∶τᵢ (map-∈ (τ , τ∈τᵢ , refl)))
    (app Y trm-m)
    (λ τ'∈τᵢ → app (Y wf-Γ τ'∈τᵢ (λ τ∈τᵢ → τ∷'ₛσ τ∈τᵢ)) trm-m (λ τ'∈τᵢ₁ → Γ⊩m∶τᵢ τ'∈τᵢ₁))

-- subject expansion


updating all

updating all

open import List
open import Nat
open import Prelude

open import contexts
open import core

open import focus-formation
open import finality

open import lemmas-consistency
open import lemmas-matching
open import synth-unicity
open import htype-decidable

open import correspondence
open import expandability
open import expansion-unicity
open import type-assignment-unicity
-- open import typed-expansion

open import canonical-value-forms
open import canonical-boxed-forms
open import canonical-indeterminate-forms

-- open import progress-checks
-- open import progress
-- open import preservation

open import complete-preservation
-- open import complete-progress

open import List
open import Nat
open import Prelude

open import contexts
open import core

open import focus-formation
open import finality

open import lemmas-consistency
open import lemmas-matching
open import synth-unicity
open import htype-decidable

open import correspondence
open import expandability
open import expansion-unicity
open import type-assignment-unicity

open import canonical-value-forms
open import canonical-boxed-forms
-- open import canonical-indeterminate-forms

-- open import progress-checks

-- open import preservation
-- open import progress
open import complete-preservation
-- open import complete-progress

-- open import typed-expansion


Category.Monad

Category.Monad

{-# OPTIONS --without-K #-}
open import Category.Functor.NP
open import Type
open import Function
open import Level.NP
open import Relation.Binary.PropositionalEquality
open import Data.Vec using (Vec; []; _∷_)

module Category.Monad.NP {ℓ} where

open import Category.Monad public

record IsMonadic {M : Set ℓ → Set ℓ} (rawMonad : RawMonad M) : ★_ (ₛ ℓ) where
  open RawMonad rawMonad

  field
    return->>= : ∀ {A B} (f : A → M B) x → (return x >>= f) ≡ f x
    >>=-return : ∀ {A} (m : M A) → (m >>= return) ≡ m
    >>=-assoc  : ∀ {A B C} (mx : M A) (my : A → M B) (k : B → M C)
                         → (mx >>= λ x → my x >>= k) ≡ (mx >>= my >>= k)

  >>-assoc  : ∀ {A B C} (mx : M A) (my : M B) (mz : M C)
                       → (mx >> (my >> mz)) ≡ ((mx >> my) >> mz)
  >>-assoc mx my mz = >>=-assoc mx (const my) (const mz)

  liftM : ∀ {A B} → (A → B) → M A → M B
  liftM f x = x >>= return ∘ f

  <$>-liftM : ∀ {A B} (f : A → B) x → f <$> x ≡ liftM f x
  <$>-liftM f x = return->>= (λ g → liftM g x) f

  liftM-id : ∀ {A} (mx : M A) → liftM id mx ≡ mx
  liftM-id = >>=-return

  <$>-id : ∀ {A} (mx : M A) → id <$> mx ≡ mx
  <$>-id mx = trans (<$>-liftM id mx) (liftM-id mx)

  {- requires function extensionality
  cong-return-∘ : ∀ {A B : ★_ ℓ} {f g : A → B} → f ≡ g → return ∘ f ≡ return ∘ g
  cong-return-∘ = {!!}

  liftM-∘ : ∀ {A B C} (f : B → C) (g : A → B) x → liftM (f ∘ g) x ≡ liftM f (liftM g x)
  liftM-∘ f g x = trans (cong (_>>=_ x) {!cong-return-∘ {!return->>= (g ?)!}!}) (>>=-assoc x (return ∘ g) (return ∘ f))

  functor : Functor rawFunctor
  functor = record { <$>-id = <$>-id; <$>-∘ = {!!} }
  -}

  vmapM : ∀ {n a}{A : Set a} {B : Set ℓ} → (A → M B) → Vec A n → M (Vec B n)
  vmapM f []       = return []
  vmapM f (x ∷ xs) = _∷_ <$> f x ⊛ vmapM f xs

record Monad (M : Set ℓ → Set ℓ) : ★_ (ₛ ℓ) where
  constructor _,_
  field
    rawMonad  : RawMonad M
    isMonadic : IsMonadic rawMonad

  open RawMonad  rawMonad  public
  open IsMonadic isMonadic public