Desc stratified model: I hate yellow. Almost done with the proof, but stuck on yellow.

{-# 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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- 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 m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (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 m : Level}{A : Set l}{B : Set m}(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 I = sigma DescDConst (descDChoice I)

IDescl0 : {l : Level}(I : Set l) -> Unit -> Set (suc l)
IDescl0 I = IMu (\_ -> descD I)

IDescl : {l : Level}(I : Set l) -> Set (suc l)
IDescl I = IDescl0 I Void

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

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

prodl : {l : Level}{I : Set l}(D D' : IDescl I) -> IDescl I
prodl {x} 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 I) -> IDescl I
pil {x} S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl _
          Tl (lifter s) = T s

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

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

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

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

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

psi : {l : Level}{I : Set l} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set l} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

proof-psi-phi : {l : Level}(I : Set l) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> descD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
                where P : Sigma Unit (IMu (\ x -> descD I)) -> Set (suc x)
                      P ( Void , D ) = psi (phi D) == D
                      lvar' : DescDConst {l = suc x}
                      lvar' = lvar
                      lpi' : DescDConst {l = suc x}
                      lpi' = lpi
                      lsigma' : DescDConst {l = suc x}
                      lsigma' = lsigma
                      proof-psi-phi-cases : (i : Unit)
                                            (xs : desc (descD I) (IDescl0 I))
                                            (hs : desc (box (descD I) (IDescl0 I) xs) P)
                                            -> P (i , con xs)
                      proof-psi-phi-cases Void (lvar , i) hs = cong (\t -> con (lvar' , t))
                                                                    (proof-lift-unlift-eq i)
                      proof-psi-phi-cases Void (lconst , x) hs = refl
                      proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
                      proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\t ->  con ((lpi' , ((S , \ s -> t s)))))
                                                                          (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs)
                      proof-psi-phi-cases Void (lsigma , ( S , T )) hs = {!!} {- cong (\t -> con (lsigma' , ( S , \s -> t (unlift s) )))
                                                                              (reflFun (\s -> psi (phi (T (lifter s))))
                                                                                (\s -> T (lifter s))
                                                                                (\s -> hs (lifter s))) -}

{-# 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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- 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 I = sigma DescDConst (descDChoice I)

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

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

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

prodl : {l : Level}{I : Set l}(D D' : IDescl I) -> IDescl I
prodl {x} 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 I) -> IDescl I
pil {x} S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl _
          Tl (lifter s) = T s

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

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

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

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

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

psi : {l : Level}{I : Set l} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))


IDesc stratified model: GOT IT! The proof type-checks with no fancy color: the embedded IDescl is isomorph to the host IDesc. Fully stratified, on any universe you want my Lord.

{-# 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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- 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 m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (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

trans : {l : Level}{A : Set l}{x y z : A} -> x == y -> y == z -> x == z
trans refl refl = refl

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

-- Intensionally extensional
postulate
  reflFun : {l m : Level}{A : Set l}{B : Set m}(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 I = sigma DescDConst (descDChoice I)

IDescl0 : {l : Level}(I : Set l) -> Unit -> Set (suc l)
IDescl0 I = IMu (\_ -> descD I)

IDescl : {l : Level}(I : Set l) -> Set (suc l)
IDescl I = IDescl0 I Void

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

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

prodl : {l : Level}{I : Set l}(D D' : IDescl I) -> IDescl I
prodl {x} 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 I) -> IDescl I
pil {x} S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl _
          Tl (lifter s) = T s

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

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

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

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

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

psi : {l : Level}{I : Set l} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set l} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

proof-psi-phi : {l : Level}(I : Set l) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> descD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
                where P : Sigma Unit (IMu (\ x -> descD I)) -> Set (suc x)
                      P ( Void , D ) = psi (phi D) == D
                      proof-psi-phi-cases : (i : Unit)
                                            (xs : desc (descD I) (IDescl0 I))
                                            (hs : desc (box (descD I) (IDescl0 I) xs) P)
                                            -> P (i , con xs)
                      proof-psi-phi-cases Void (lvar , i) hs = cong (\t -> con (lvar' , t))
                                                                    (proof-lift-unlift-eq i)
                      proof-psi-phi-cases Void (lconst , x) hs = refl
                      proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
                      proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\T -> con (lpi {l = suc x} , ( S , T ) ))
                                                                           (trans (reflFun (λ s → psi (phi (T (lifter (unlift s)))))
                                                                                (λ s → psi (phi (T (s))))
                                                                                (\s -> cong (λ s → psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                                (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))
                      proof-psi-phi-cases Void (lsigma , ( S , T )) hs = cong (\T -> con (lsigma {l = suc x} , ( S , T ) ))
                                                                              (trans (reflFun (λ s → psi (phi (T (lifter (unlift s)))))
                                                                                (λ s → psi (phi (T (s))))
                                                                                (\s -> cong (λ s → psi (phi (T (s))))
                                                                                (proof-lift-unlift-eq s)))
                                                                                (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs))

{-# 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

unlift : {l : Level}{A : Set l} -> Lifted A -> A
unlift (lifter a) = a

--****************
-- 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 m : Level}{A : Set l}{B : Set m}
       (f : A -> B){x y : A} -> x == y -> f x == f y
cong f refl = refl

cong2 : {l m n : Level}{A : Set l}{B : Set m}{C : Set n}
        (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 m : Level}{A : Set l}{B : Set m}(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 I = sigma DescDConst (descDChoice I)

IDescl0 : {l : Level}(I : Set l) -> Unit -> Set (suc l)
IDescl0 I = IMu (\_ -> descD I)

IDescl : {l : Level}(I : Set l) -> Set (suc l)
IDescl I = IDescl0 I Void

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

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

prodl : {l : Level}{I : Set l}(D D' : IDescl I) -> IDescl I
prodl {x} 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 I) -> IDescl I
pil {x} S T = con (lp , ( S , Tl))
    where lp : DescDConst {l = suc x}
          lp = lpi
          Tl : Lifted S -> IDescl _
          Tl (lifter s) = T s

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

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

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

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

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

psi : {l : Level}{I : Set l} -> IDesc I -> IDescl I
psi (var i) = varl i
psi (const X) = constl X
psi (prod D D') = prodl (psi D) (psi D')
psi (pi S T) = pil S (\s -> psi (T s))
psi (sigma S T) = sigmal S (\s -> psi (T s))

--********************************************
-- Isomorphism proof
--********************************************

-- From host to host

proof-phi-psi : {l : Level}{I : Set l} -> (D : IDesc I) -> phi (psi D) == D
proof-phi-psi (var i) = refl
proof-phi-psi (const x) = refl
proof-phi-psi (prod D D') with proof-phi-psi D | proof-phi-psi D'
...  | p | q = cong2 prod p q
proof-phi-psi {x} (pi S T) = cong (pi S)
                                  (reflFun (\s -> phi (psi (T s)))
                                           T
                                           (\s -> proof-phi-psi (T s)))
proof-phi-psi (sigma S T) = cong (sigma S)
                                 (reflFun (\ s -> phi (psi (T s)))
                                          T
                                          (\s -> proof-phi-psi (T s)))

-- From embedding to embedding

proof-lift-unlift-eq : {l : Level}{A : Set l}(x : Lifted A) -> lifter (unlift x) == x
proof-lift-unlift-eq (lifter a) = refl

proof-psi-phi : {l : Level}(I : Set l) -> (D : IDescl I) -> psi (phi D) == D
proof-psi-phi {x} I D =  induction (\ _ -> descD I)
                               P
                               proof-psi-phi-cases
                               Void
                               D
                where P : Sigma Unit (IMu (\ x -> descD I)) -> Set (suc x)
                      P ( Void , D ) = psi (phi D) == D
                      lvar' : DescDConst {l = suc x}
                      lvar' = lvar
                      lpi' : DescDConst {l = suc x}
                      lpi' = lpi
                      lsigma' : DescDConst {l = suc x}
                      lsigma' = lsigma
                      proof-psi-phi-cases : (i : Unit)
                                            (xs : desc (descD I) (IDescl0 I))
                                            (hs : desc (box (descD I) (IDescl0 I) xs) P)
                                            -> P (i , con xs)
                      proof-psi-phi-cases Void (lvar , i) hs = cong (\t -> con (lvar' , t))
                                                                    (proof-lift-unlift-eq i)
                      proof-psi-phi-cases Void (lconst , x) hs = refl
                      proof-psi-phi-cases Void (lprod , ( D , D' )) ( p , q ) = cong2 prodl p q
                      proof-psi-phi-cases Void (lpi , ( S , T )) hs = cong (\t ->  con ((lpi' , ((S , \ s -> t s)))))
                                                                          (reflFun (\s -> psi (phi (T s)))
                                                                                T
                                                                                hs)
                      proof-psi-phi-cases Void (lsigma , ( S , T )) hs = {!!} {- cong (\t -> con (lsigma' , ( S , \s -> t (unlift s) )))
                                                                              (reflFun (\s -> psi (phi (T (lifter s))))
                                                                                (\s -> T (lifter s))
                                                                                (\s -> hs (lifter s))) -}


Fixed wrong url.

Fixed wrong url.

Ignore-this: 1efade942b0f368001984228e770b4fe

darcs-hash:20111225145504-3bd4e-972ef6455283a5402d7c404e4be1e74d685fec7c.gz

------------------------------------------------------------------------------
-- FOT (First Order Theories)
------------------------------------------------------------------------------

-- Code accompanying the paper Combining Interactive and Automatic
-- Reasoning in First Order Theories of Functional Programs by Ana
-- Bove, Peter Dybjer, and Andrés Sicard-Ramírez (FoSSaCS 2012).

-- The code presented here does not match the paper exactly.

module README where

------------------------------------------------------------------------------
-- Description

-- Examples of the formalization of first order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Prerequisites and use

-- See http://www1.eafit.edu.co/asicard/code/fossacs-2012/.

------------------------------------------------------------------------------
-- Conventions

-- The following modules show the formalization of some first order
-- theories. If the module's name ends in 'I' the module contains
-- interactive proofs, if it ends in 'ATP' the module contains
-- combined proofs, otherwise the module contains definions and/or
-- interactive proofs that are used by the interactive and combined
-- proofs.

------------------------------------------------------------------------------
-- First order theories
------------------------------------------------------------------------------

-- 1. Predicate logic

-- 1.1 Definition of the connectives and quantifiers
open import Common.LogicalConstants
open import PredicateLogic.Constants

-- 1.2 Propositional logic theorems
open import PredicateLogic.Propositional.TheoremsATP
open import PredicateLogic.Propositional.TheoremsI

-- 1.3 Predicate logic theorems
open import PredicateLogic.TheoremsATP
open import PredicateLogic.TheoremsI

-- 1.4 Logical schemas
open import PredicateLogic.SchemasATP

-- 1.5 Non-empty domains
open import PredicateLogic.NonEmptyDomain.TheoremsATP
open import PredicateLogic.NonEmptyDomain.TheoremsI

-- 1.6 Classical predicate logic theorems
open import PredicateLogic.ClassicalATP
open import PredicateLogic.ClassicalI

------------------------------------------------------------------------------
-- 2. Equality

-- 2.1 Definition of equality and some properties about it
open import Common.Relation.Binary.PropositionalEquality

-- 2.2 The equality reasoning
open import Common.Relation.Binary.PreorderReasoning

------------------------------------------------------------------------------
-- 3. Group theory

-- 3.1 The axioms
open import GroupTheory.Base

-- 3.2 Basic properties
open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI

-- 3.3 Commutator properties
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

-- 3.4 Abelian groups
open import GroupTheory.AbelianGroup.PropertiesATP

------------------------------------------------------------------------------
-- 4. Stanovský example (distributive laws on a binary operation)

-- We prove the proposition 2 (task B) of [1]. Let _·_ be a
-- left-associative binary operation, the task B consist in given the
-- left and right distributive axioms

--   ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
--   ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z)

-- to prove the theorem

--   ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
--               (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
--               x ∙ z ∙ (y ∙ u)

-- [1] David Stanovský. Distributive groupoids are symmetrical-by-medial:
--     An elementary proof. Commentations Mathematicae Universitatis
--     Carolinae, 49(4):541–546, 2008.

-- 4.1 The ATPs could not prove the theorem
open import DistributiveLaws.TaskB-ATP

-- 4.2 The interactive and combined proofs
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP

------------------------------------------------------------------------------
-- 5. Peano arithmetic (PA)

-- We write two formalizations of PA. In the axiomatic formalization
-- we use Agda postulates for Peano's axioms. In the inductive
-- formalization, we use Agda data types and primitive recursive
-- functions.

-- 5.1 Axiomatic PA
-- 5.1.1 The axioms
open import PA.Axiomatic.Base

-- 5.1.2 Some properties
open import PA.Axiomatic.PropertiesATP
open import PA.Axiomatic.PropertiesI

open import PA.Axiomatic.Relation.Binary.PropositionalEqualityATP
open import PA.Axiomatic.Relation.Binary.PropositionalEqualityI

-- 5.2. Inductive PA
-- 5.2.1 Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI

------------------------------------------------------------------------------
-- 6. FOTC

-- Formalization of (a version of) Azcel's First Order Theory of Combinators.

-- 6.1 The axioms
open import FOTC.Base

-- 6.2 Booleans

-- 6.2.1 The axioms
open import FOTC.Data.Bool

-- 6.2.2 The inductive predicate
open import FOTC.Data.Bool.Type

-- 6.2.3 Properties
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI

-- 6.3. Natural numbers

-- 6.3.1 The axioms
open import FOTC.Data.Nat

-- 6.3.2 The inductive predicate
open import FOTC.Data.Nat.Type

-- 6.3.3 Properties
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesI

open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI

-- 6.3.4 Divisibility relation
open import FOTC.Data.Nat.Divisibility.By0.Properties
open import FOTC.Data.Nat.Divisibility.By0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.By0.PropertiesI
open import FOTC.Data.Nat.Divisibility.NotBy0.Properties
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 6.3.5 Induction
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI

-- 6.3.6 Inequalites
open import FOTC.Data.Nat.Inequalities.Properties
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI

-- 6.3.7 Unary numbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

-- 6.4 Lists

-- 6.4.1 The axioms
open import FOTC.Data.List

-- 6.4.2 The inductive predicate
open import FOTC.Data.List.Type

-- 6.4.3 Properties
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesI

-- 6.4.4 Well-founded induction
open import FOTC.Data.List.LT-Cons.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Cons.PropertiesI
open import FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Length.PropertiesI

-- 6.4.5 Lists of natural numbers

-- 6.4.5.1 The inductive predicate
open import FOTC.Data.Nat.List.Type

-- 6.4.5.2 Properties
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI

-- 6.5 Coinductive natural numbers

-- 6.5.1 The coinductive predicate
open import FOTC.Data.Conat

-- 6.5.2 Equality on coinductive natural numbers
open import FOTC.Data.Conat.Equality

-- 6.5.3 Properties
open import FOTC.Data.Conat.PropertiesI

-- 6.6 Streams

-- 6.6.1 The coinductive predicate (axioms)
open import FOTC.Data.Stream

-- 6.6.2 Equality on streams
open import FOTC.Data.Stream.Equality
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Data.Stream.Equality.PropertiesI

-- 6.6.3 Properties
open import FOTC.Data.Stream.PropertiesATP
open import FOTC.Data.Stream.PropertiesI

-- 6.7 Programs

-- 6.7.1 The Collatz function: A function without a termination proof
open import FOTC.Program.Collatz.PropertiesATP
open import FOTC.Program.Collatz.PropertiesI

-- 6.7.2 The GCD algorithm: A non-structurally recursive algorithm
open import FOTC.Program.GCD.Partial.ProofSpecificationATP
open import FOTC.Program.GCD.Partial.ProofSpecificationI
open import FOTC.Program.GCD.Total.ProofSpecificationATP
open import FOTC.Program.GCD.Total.ProofSpecificationI

-- 6.7.3 The McCarthy 91 function: A function with nested recursion
open import FOTC.Program.McCarthy91.Properties.MainATP

-- 6.7.4 The mirror function: A function with higher-order recursion
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI

-- 6.7.5 Burstall's sort list algorithm: A structurally recursive algorithm
open import FOTC.Program.SortList.ProofSpecificationATP
open import FOTC.Program.SortList.ProofSpecificationI

-- 6.7.6 The division algorithm: A non-structurally recursive algorithm
open import FOTC.Program.Division.ProofSpecificationATP
open import FOTC.Program.Division.ProofSpecificationI

-- 6.7.7 The map-iterate property: A property using coinduction
open import FOTC.Program.MapIterate.MapIterateATP

-- 6.7.8 The alternating bit protocol: A program using co-inductive types
open import FOTC.Program.ABP.ProofSpecificationATP
open import FOTC.Program.ABP.ProofSpecificationI

-- 6.8 Other modules
-- (These modules are not imported from any module).
open import FOTC.Program.Division.EquationsATP
open import FOTC.Program.GCD.Partial.EquationsATP
open import FOTC.Program.GCD.Total.EquationsATP

------------------------------------------------------------------------------
-- LTC-PCF (Almost a first order theory)

-- Formalization of (a version of) Azcel's Logical Theory of Constructions.
-- N.B. This was the theory shown in our PLPV'09 paper.

-- 7.1. The axioms
open import LTC-PCF.Base

-- 7.2. Natural numberes

-- 7.2.1 The axioms
open import LTC-PCF.Data.Nat

-- 7.2.2 The inductive predicate
open import LTC-PCF.Data.Nat.Type

-- 7.2.3 Properties
open import LTC-PCF.Data.Nat.PropertiesATP
open import LTC-PCF.Data.Nat.PropertiesI

-- 7.2.4 Divisibility relation
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.Properties
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 7.2.5 Induction
open import LTC-PCF.Data.Nat.Induction.NonAcc.LexicographicI
open import LTC-PCF.Data.Nat.Induction.NonAcc.WellFoundedInductionI

-- 7.2.6 Inequalites
open import LTC-PCF.Data.Nat.Inequalities.PropertiesATP
open import LTC-PCF.Data.Nat.Inequalities.PropertiesI

-- 7.2.7 The recursive operator
open import LTC-PCF.Data.Nat.Rec.EquationsATP
open import LTC-PCF.Data.Nat.Rec.EquationsI

-- 7.2.8 A looping combinator
open import LTC-PCF.Loop

-- 7.3 Programs

-- 7.3.1 The division algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.Division.ProofSpecificationATP
open import LTC-PCF.Program.Division.ProofSpecificationI

-- 7.3.2 The GCD algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationATP
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationI

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis, SPASS and Vampire) could not prove some
-- theorems.

open import DistributiveLaws.TaskB-ATP
open import FOTC.Program.ABP.MayorPremiseATP
open import PA.Axiomatic.PropertiesATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see src/Agsy/README.txt

------------------------------------------------------------------------------
-- FOT (First Order Theories)
------------------------------------------------------------------------------

-- Code accompanying the paper Combining Interactive and Automatic
-- Reasoning in First Order Theories of Functional Programs by Ana
-- Bove, Peter Dybjer, and Andrés Sicard-Ramírez (FoSSaCS 2012).

-- The code presented here does not match the paper exactly.

module README where

------------------------------------------------------------------------------
-- Description

-- Examples of the formalization of first order theories showing the
-- combination of interactive proofs with automatics proofs carried
-- out by first order automatic theorem provers (ATPs).

------------------------------------------------------------------------------
-- Prerequisites and use

-- See http://www1.eafit.edu.co/asicard/code/fotc/.

------------------------------------------------------------------------------
-- Conventions

-- The following modules show the formalization of some first order
-- theories. If the module's name ends in 'I' the module contains
-- interactive proofs, if it ends in 'ATP' the module contains
-- combined proofs, otherwise the module contains definions and/or
-- interactive proofs that are used by the interactive and combined
-- proofs.

------------------------------------------------------------------------------
-- First order theories
------------------------------------------------------------------------------

-- 1. Predicate logic

-- 1.1 Definition of the connectives and quantifiers
open import Common.LogicalConstants
open import PredicateLogic.Constants

-- 1.2 Propositional logic theorems
open import PredicateLogic.Propositional.TheoremsATP
open import PredicateLogic.Propositional.TheoremsI

-- 1.3 Predicate logic theorems
open import PredicateLogic.TheoremsATP
open import PredicateLogic.TheoremsI

-- 1.4 Logical schemas
open import PredicateLogic.SchemasATP

-- 1.5 Non-empty domains
open import PredicateLogic.NonEmptyDomain.TheoremsATP
open import PredicateLogic.NonEmptyDomain.TheoremsI

-- 1.6 Classical predicate logic theorems
open import PredicateLogic.ClassicalATP
open import PredicateLogic.ClassicalI

------------------------------------------------------------------------------
-- 2. Equality

-- 2.1 Definition of equality and some properties about it
open import Common.Relation.Binary.PropositionalEquality

-- 2.2 The equality reasoning
open import Common.Relation.Binary.PreorderReasoning

------------------------------------------------------------------------------
-- 3. Group theory

-- 3.1 The axioms
open import GroupTheory.Base

-- 3.2 Basic properties
open import GroupTheory.PropertiesATP
open import GroupTheory.PropertiesI

-- 3.3 Commutator properties
open import GroupTheory.Commutator.PropertiesATP
open import GroupTheory.Commutator.PropertiesI

-- 3.4 Abelian groups
open import GroupTheory.AbelianGroup.PropertiesATP

------------------------------------------------------------------------------
-- 4. Stanovský example (distributive laws on a binary operation)

-- We prove the proposition 2 (task B) of [1]. Let _·_ be a
-- left-associative binary operation, the task B consist in given the
-- left and right distributive axioms

--   ∀ x y z → x ∙ (y ∙ z) ≡ (x ∙ y) ∙ (x ∙ z)
--   ∀ x y z → (x ∙ y) ∙ z ≡ (x ∙ z) ∙ (y ∙ z)

-- to prove the theorem

--   ∀ u x y z → (x ∙ y ∙ (z ∙ u)) ∙
--               (( x ∙ y ∙ ( z ∙ u)) ∙ (x ∙ z ∙ (y ∙ u))) ≡
--               x ∙ z ∙ (y ∙ u)

-- [1] David Stanovský. Distributive groupoids are symmetrical-by-medial:
--     An elementary proof. Commentations Mathematicae Universitatis
--     Carolinae, 49(4):541–546, 2008.

-- 4.1 The ATPs could not prove the theorem
open import DistributiveLaws.TaskB-ATP

-- 4.2 The interactive and combined proofs
open import DistributiveLaws.TaskB-HalvedStepsATP
open import DistributiveLaws.TaskB-I
open import DistributiveLaws.TaskB-TopDownATP

------------------------------------------------------------------------------
-- 5. Peano arithmetic (PA)

-- We write two formalizations of PA. In the axiomatic formalization
-- we use Agda postulates for Peano's axioms. In the inductive
-- formalization, we use Agda data types and primitive recursive
-- functions.

-- 5.1 Axiomatic PA
-- 5.1.1 The axioms
open import PA.Axiomatic.Base

-- 5.1.2 Some properties
open import PA.Axiomatic.PropertiesATP
open import PA.Axiomatic.PropertiesI

open import PA.Axiomatic.Relation.Binary.PropositionalEqualityATP
open import PA.Axiomatic.Relation.Binary.PropositionalEqualityI

-- 5.2. Inductive PA
-- 5.2.1 Some properties
open import PA.Inductive.Properties
open import PA.Inductive.PropertiesATP
open import PA.Inductive.PropertiesI

open import PA.Inductive.PropertiesByInduction
open import PA.Inductive.PropertiesByInductionATP
open import PA.Inductive.PropertiesByInductionI

------------------------------------------------------------------------------
-- 6. FOTC

-- Formalization of (a version of) Azcel's First Order Theory of Combinators.

-- 6.1 The axioms
open import FOTC.Base

-- 6.2 Booleans

-- 6.2.1 The axioms
open import FOTC.Data.Bool

-- 6.2.2 The inductive predicate
open import FOTC.Data.Bool.Type

-- 6.2.3 Properties
open import FOTC.Data.Bool.PropertiesATP
open import FOTC.Data.Bool.PropertiesI

-- 6.3. Natural numbers

-- 6.3.1 The axioms
open import FOTC.Data.Nat

-- 6.3.2 The inductive predicate
open import FOTC.Data.Nat.Type

-- 6.3.3 Properties
open import FOTC.Data.Nat.PropertiesATP
open import FOTC.Data.Nat.PropertiesI

open import FOTC.Data.Nat.PropertiesByInductionATP
open import FOTC.Data.Nat.PropertiesByInductionI

-- 6.3.4 Divisibility relation
open import FOTC.Data.Nat.Divisibility.By0.Properties
open import FOTC.Data.Nat.Divisibility.By0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.By0.PropertiesI
open import FOTC.Data.Nat.Divisibility.NotBy0.Properties
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import FOTC.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 6.3.5 Induction
open import FOTC.Data.Nat.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.Nat.Induction.NonAcc.LexicographicI

-- 6.3.6 Inequalites
open import FOTC.Data.Nat.Inequalities.Properties
open import FOTC.Data.Nat.Inequalities.PropertiesATP
open import FOTC.Data.Nat.Inequalities.PropertiesI

-- 6.3.7 Unary numbers
open import FOTC.Data.Nat.UnaryNumbers.Inequalities.PropertiesATP
open import FOTC.Data.Nat.UnaryNumbers.TotalityATP

-- 6.4 Lists

-- 6.4.1 The axioms
open import FOTC.Data.List

-- 6.4.2 The inductive predicate
open import FOTC.Data.List.Type

-- 6.4.3 Properties
open import FOTC.Data.List.PropertiesATP
open import FOTC.Data.List.PropertiesI

-- 6.4.4 Well-founded induction
open import FOTC.Data.List.LT-Cons.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Cons.PropertiesI
open import FOTC.Data.List.LT-Length.Induction.Acc.WellFoundedInductionI
open import FOTC.Data.List.LT-Length.PropertiesI

-- 6.4.5 Lists of natural numbers

-- 6.4.5.1 The inductive predicate
open import FOTC.Data.Nat.List.Type

-- 6.4.5.2 Properties
open import FOTC.Data.Nat.List.PropertiesATP
open import FOTC.Data.Nat.List.PropertiesI

-- 6.5 Coinductive natural numbers

-- 6.5.1 The coinductive predicate
open import FOTC.Data.Conat

-- 6.5.2 Equality on coinductive natural numbers
open import FOTC.Data.Conat.Equality

-- 6.5.3 Properties
open import FOTC.Data.Conat.PropertiesI

-- 6.6 Streams

-- 6.6.1 The coinductive predicate (axioms)
open import FOTC.Data.Stream

-- 6.6.2 Equality on streams
open import FOTC.Data.Stream.Equality
open import FOTC.Data.Stream.Equality.PropertiesATP
open import FOTC.Data.Stream.Equality.PropertiesI

-- 6.6.3 Properties
open import FOTC.Data.Stream.PropertiesATP
open import FOTC.Data.Stream.PropertiesI

-- 6.7 Programs

-- 6.7.1 The Collatz function: A function without a termination proof
open import FOTC.Program.Collatz.PropertiesATP
open import FOTC.Program.Collatz.PropertiesI

-- 6.7.2 The GCD algorithm: A non-structurally recursive algorithm
open import FOTC.Program.GCD.Partial.ProofSpecificationATP
open import FOTC.Program.GCD.Partial.ProofSpecificationI
open import FOTC.Program.GCD.Total.ProofSpecificationATP
open import FOTC.Program.GCD.Total.ProofSpecificationI

-- 6.7.3 The McCarthy 91 function: A function with nested recursion
open import FOTC.Program.McCarthy91.Properties.MainATP

-- 6.7.4 The mirror function: A function with higher-order recursion
open import FOTC.Program.Mirror.PropertiesATP
open import FOTC.Program.Mirror.PropertiesI

-- 6.7.5 Burstall's sort list algorithm: A structurally recursive algorithm
open import FOTC.Program.SortList.ProofSpecificationATP
open import FOTC.Program.SortList.ProofSpecificationI

-- 6.7.6 The division algorithm: A non-structurally recursive algorithm
open import FOTC.Program.Division.ProofSpecificationATP
open import FOTC.Program.Division.ProofSpecificationI

-- 6.7.7 The map-iterate property: A property using coinduction
open import FOTC.Program.MapIterate.MapIterateATP

-- 6.7.8 The alternating bit protocol: A program using co-inductive types
open import FOTC.Program.ABP.ProofSpecificationATP
open import FOTC.Program.ABP.ProofSpecificationI

-- 6.8 Other modules
-- (These modules are not imported from any module).
open import FOTC.Program.Division.EquationsATP
open import FOTC.Program.GCD.Partial.EquationsATP
open import FOTC.Program.GCD.Total.EquationsATP

------------------------------------------------------------------------------
-- LTC-PCF (Almost a first order theory)

-- Formalization of (a version of) Azcel's Logical Theory of Constructions.
-- N.B. This was the theory shown in our PLPV'09 paper.

-- 7.1. The axioms
open import LTC-PCF.Base

-- 7.2. Natural numberes

-- 7.2.1 The axioms
open import LTC-PCF.Data.Nat

-- 7.2.2 The inductive predicate
open import LTC-PCF.Data.Nat.Type

-- 7.2.3 Properties
open import LTC-PCF.Data.Nat.PropertiesATP
open import LTC-PCF.Data.Nat.PropertiesI

-- 7.2.4 Divisibility relation
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.Properties
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesATP
open import LTC-PCF.Data.Nat.Divisibility.NotBy0.PropertiesI

-- 7.2.5 Induction
open import LTC-PCF.Data.Nat.Induction.NonAcc.LexicographicI
open import LTC-PCF.Data.Nat.Induction.NonAcc.WellFoundedInductionI

-- 7.2.6 Inequalites
open import LTC-PCF.Data.Nat.Inequalities.PropertiesATP
open import LTC-PCF.Data.Nat.Inequalities.PropertiesI

-- 7.2.7 The recursive operator
open import LTC-PCF.Data.Nat.Rec.EquationsATP
open import LTC-PCF.Data.Nat.Rec.EquationsI

-- 7.2.8 A looping combinator
open import LTC-PCF.Loop

-- 7.3 Programs

-- 7.3.1 The division algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.Division.ProofSpecificationATP
open import LTC-PCF.Program.Division.ProofSpecificationI

-- 7.3.2 The GCD algorithm: A non-structurally recursive algorithm
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationATP
open import LTC-PCF.Program.GCD.Partial.ProofSpecificationI

------------------------------------------------------------------------------
-- ATPs failures
------------------------------------------------------------------------------

-- The ATPs (E, Equinox, Metis, SPASS and Vampire) could not prove some
-- theorems.

open import DistributiveLaws.TaskB-ATP
open import FOTC.Program.ABP.MayorPremiseATP
open import PA.Axiomatic.PropertiesATP

------------------------------------------------------------------------------
-- Agsy examples
------------------------------------------------------------------------------

-- We cannot import the Agsy examples because some modules contain
-- unsolved metas, therefore see src/Agsy/README.txt


cleaning up some scraps and easy holes from last night


Alternate definition of relT

Alternate definition of relT

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by Dargaye and Leroy (2010), "A
-- verified framework for higher-order uncurrying optimizations" (and a bit by
-- "Functional Big-Step Semantics"), though I deviate somewhere.
module Thesis.FunBigStepSILR where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

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

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

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

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

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

--
-- Functional big-step semantics
--

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

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

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

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

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

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

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

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

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

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

relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

-- Indexing not according to source. But I can't quite write the correct
-- indexing without changing the definitions a lot.
relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
relT {τ} t1 t2 ρ1 ρ2 n =
  (v1 : Val τ) →
  eval t1 ρ1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (eval t2 ρ2 n ≡ Done v2 × relV τ v1 v2 n)

import Data.Fin as F
open F using (Fin; _ℕ-_)

-- This is closer to what's used in Dargaye and Leroy, but not the same.

relT2 : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
relT2 {τ} t1 t2 ρ1 ρ2 n =
  (v1 : Val τ) →
  ∀ (j : Fin (suc n)) →
  eval t1 ρ1 (F.toℕ j) ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] eval t2 ρ2 (F.toℕ j) ≡ Done v2 × relV τ v1 v2 (F.toℕ (n F.ℕ- j))

relV τ v1 v2 zero = ⊤
relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) =
  ∀ (k : ℕ) (k≤n : k ≤ n) →
  ∀ v1 v2 → relV σ v1 v2 k → relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
relV nat v1 v2 (suc n) = v1 ≡ v2

open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl)

relV-apply-go : ∀ {σ τ} sv1 sv2 tv1 tv2
  n
  (svv : relV (σ ⇒ τ) sv1 sv2 n)
  (tvv : relV σ tv1 tv2 n)
  v1 →
  apply sv1 tv1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (apply sv2 tv2 n ≡ Done v2 × relV τ v1 v2 (suc n))
relV-apply-go (closure st1 ρ1) (closure st2 ρ2) tv1 tv2 zero svv tvv v1 ()
relV-apply-go (closure st1 ρ1) (closure st2 ρ2) tv1 tv2 (suc n) svv tvv v1 eqv1 with svv n ≤-refl tv1 tv2 {! tvv !} v1 {! eqv1 !}
... | v2 , eqv2 , final-v = v2 , {! eqv2 !} , {! final-v !}

relV-apply : ∀ {σ τ sv1 sv2 tv1 tv2}
  n
  (svv : relV (σ ⇒ τ) sv1 sv2 n)
  (tvv : relV σ tv1 tv2 n)
  {v1} →
  apply sv1 tv1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (apply sv2 tv2 n ≡ Done v2 × relV τ v1 v2 (suc n))
relV-apply n svv tvv eqv1 = relV-apply-go _ _ _ _ n svv tvv _ eqv1

open import Data.Nat.Properties

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono zero n m≤n τ v1 v2 vv = tt
relV-mono (suc m) zero () τ v1 v2 vv
relV-mono (suc m) (suc n) m≤n nat v1 v2 vv = vv
relV-mono (suc m) (suc n) (_≤_.s≤s m≤n) (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) vv k k≤m = vv k (DecTotalOrder.trans decTotalOrder k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

-- relV-mono τ v1 v2 vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k ?

-- relV-mono : ∀ τ v1 v2 n → relV τ v1 v2 (suc n) → relV τ v1 v2 n
-- relV-mono τ v1 v2 zero vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k (≤-step k≤n)

-- fundamental lemma of logical relations.
fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero _ _ _ _ ()
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 refl = v2 , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ v ()
-- XXX trivial case for constants.
fundamental (const (lit nv)) (suc n) ρ1 ρ2 ρρ .(intV nv) refl = intV nv , refl , refl
fundamental (var x) (suc n) ρ1 ρ2 ρρ v1 refl = fundamentalV x (suc n) ρ1 ρ2 ρρ (⟦ x ⟧Var ρ1) refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ (closure .t .ρ1) refl =
  closure t ρ2 , refl , λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k _ (≤-step k≤n) _ _ _ ρρ)
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 with eval s ρ1 n | inspect (eval s ρ1) n | eval t ρ1 n | inspect (eval t ρ1) n
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 seq1 | fundamental t n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) tv1 teq1
fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] | Done sv2 | [ seq2 ] | Done tv2 | (.sv2 , refl , svv) | (.tv2 , refl , tvv) = relV-apply n svv tvv tρ1↓v1
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv1 | [ seq1 ] | TimeOut | [ teq1 ]
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | [ seq1 ] | tv1 | [ teq1 ]

-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 seq1
--... | sv2 | [ seq2 ] | tv2 | (sv2' , sρ2↓sv2 , svv) = ?

-- TODO: match sv2 before matching on fundamental s.
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) | [ teq1 ] | (sv2' , sρ2↓sv2 , svv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | TimeOut | [ teq1 ] | (sv2' , sρ2↓sv2 , svv) with fundamental t n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) tv1 {!teq1!}
-- ... | (tv2' , tρ2↓tv2 , tvv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | TimeOut | [ eq2 ] | b | [ teq1 ] | (sv2' , () , svv)

-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) | (sv2' , sρ2↓sv2 , svv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | TimeOut = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | TimeOut | [ eq2 ] | tv2 = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 | (sv2 , sρ2↓sv2 , svv) = v2 , {!!}
--   where
--     v2 : Val τ
--     v2 = {!!}
--     -- tρ2↓v2 : apply sv2 tv2 n ≡ Done v1
--     -- tρ2↓v2 = ?
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv | _ | TimeOut
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | Done tv1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | TimeOut

-- Step-indexed logical relations based on functional big-step semantics.
--
-- Goal for now: just prove the fundamental theorem of logical relations,
-- relating a term to itself in a different environments.
--
-- Because of closures, we need relations across different terms with different
-- contexts and environments.
--
-- This development is strongly inspired by Dargaye and Leroy (2010), "A
-- verified framework for higher-order uncurrying optimizations" (and a bit by
-- "Functional Big-Step Semantics"), though I deviate somewhere.
module Thesis.FunBigStepSILR where

open import Data.Empty
open import Data.Unit.Base hiding (_≤_)
open import Data.Product
open import Relation.Binary.PropositionalEquality
open import Relation.Binary hiding (_⇒_)
open import Data.Nat using (ℕ; zero; suc; decTotalOrder; _<_; _≤_)

data Type : Set where
  _⇒_ : (σ τ : Type) → Type
  nat : Type

⟦_⟧Type : Type → Set
⟦ σ ⇒ τ ⟧Type = ⟦ σ ⟧Type → ⟦ τ ⟧Type
⟦ nat ⟧Type = ℕ

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

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

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

data Val : Type → Set
open import Base.Denotation.Environment Type Val public
open import Base.Data.DependentList public

data Val where
  closure : ∀ {Γ σ τ} → (t : Term (σ • Γ) τ) → (ρ : ⟦ Γ ⟧Context) → Val (σ ⇒ τ)
  intV : ∀ (n : ℕ) → Val nat

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

--
-- Functional big-step semantics
--

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

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

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

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

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

apply : ∀ {σ τ} → Val (σ ⇒ τ) → Val σ → Res τ
apply (closure t ρ) a n = eval t (a • ρ) n

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

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

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

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

relV : ∀ τ (v1 v2 : Val τ) → ℕ → Set
relρ : ∀ Γ (ρ1 ρ2 : ⟦ Γ ⟧Context) → ℕ → Set
relρ ∅ ∅ ∅ n = ⊤
relρ (τ • Γ) (v1 • ρ1) (v2 • ρ2) n = relV τ v1 v2 n × relρ Γ ρ1 ρ2 n

-- Indexing not according to source. But I can't quite write the correct
-- indexing without changing the definitions a lot.
relT : ∀ {τ Γ1 Γ2} (t1 : Term Γ1 τ) (t2 : Term Γ2 τ) (ρ1 : ⟦ Γ1 ⟧Context) (ρ2 : ⟦ Γ2 ⟧Context) → ℕ → Set
relT {τ} t1 t2 ρ1 ρ2 n =
  (v1 : Val τ) →
  eval t1 ρ1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (eval t2 ρ2 n ≡ Done v2 × relV τ v1 v2 n)

relV τ v1 v2 zero = ⊤
relV (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) =
  ∀ (k : ℕ) (k≤n : k ≤ n) →
  ∀ v1 v2 → relV σ v1 v2 k → relT t1 t2 (v1 • ρ1) (v2 • ρ2) k
relV nat v1 v2 (suc n) = v1 ≡ v2

open DecTotalOrder Data.Nat.decTotalOrder using () renaming (refl to ≤-refl)

relV-apply-go : ∀ {σ τ} sv1 sv2 tv1 tv2
  n
  (svv : relV (σ ⇒ τ) sv1 sv2 n)
  (tvv : relV σ tv1 tv2 n)
  v1 →
  apply sv1 tv1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (apply sv2 tv2 n ≡ Done v2 × relV τ v1 v2 (suc n))
relV-apply-go (closure st1 ρ1) (closure st2 ρ2) tv1 tv2 zero svv tvv v1 ()
relV-apply-go (closure st1 ρ1) (closure st2 ρ2) tv1 tv2 (suc n) svv tvv v1 eqv1 with svv n ≤-refl tv1 tv2 {! tvv !} v1 {! eqv1 !}
... | v2 , eqv2 , final-v = v2 , {! eqv2 !} , {! final-v !}

relV-apply : ∀ {σ τ sv1 sv2 tv1 tv2}
  n
  (svv : relV (σ ⇒ τ) sv1 sv2 n)
  (tvv : relV σ tv1 tv2 n)
  {v1} →
  apply sv1 tv1 n ≡ Done v1 →
  Σ[ v2 ∈ Val τ ] (apply sv2 tv2 n ≡ Done v2 × relV τ v1 v2 (suc n))
relV-apply n svv tvv eqv1 = relV-apply-go _ _ _ _ n svv tvv _ eqv1

open import Data.Nat.Properties

relV-mono : ∀ m n → m ≤ n → ∀ τ v1 v2 → relV τ v1 v2 n → relV τ v1 v2 m
relV-mono zero n m≤n τ v1 v2 vv = tt
relV-mono (suc m) zero () τ v1 v2 vv
relV-mono (suc m) (suc n) m≤n nat v1 v2 vv = vv
relV-mono (suc m) (suc n) (_≤_.s≤s m≤n) (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) vv k k≤m = vv k (DecTotalOrder.trans decTotalOrder k≤m m≤n)

relρ-mono : ∀ m n → m ≤ n → ∀ Γ ρ1 ρ2 → relρ Γ ρ1 ρ2 n → relρ Γ ρ1 ρ2 m
relρ-mono m n m≤n ∅ ∅ ∅ tt = tt
relρ-mono m n m≤n (τ • Γ) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = relV-mono m n m≤n _ v1 v2 vv , relρ-mono m n m≤n Γ ρ1 ρ2 ρρ

-- relV-mono τ v1 v2 vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k ?

-- relV-mono : ∀ τ v1 v2 n → relV τ v1 v2 (suc n) → relV τ v1 v2 n
-- relV-mono τ v1 v2 zero vv = tt
-- relV-mono nat v1 v2 (suc n) vv = vv
-- relV-mono (σ ⇒ τ) (closure t1 ρ1) (closure t2 ρ2) (suc n) vv k k≤n = vv k (≤-step k≤n)

-- fundamental lemma of logical relations.
fundamentalV : ∀ {Γ τ} (x : Var Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT (var x) (var x) ρ1 ρ2 n
fundamentalV x zero _ _ _ _ ()
fundamentalV this (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) .v1 refl = v2 , refl , vv
fundamentalV (that x) (suc n) (v1 • ρ1) (v2 • ρ2) (vv , ρρ) = fundamentalV x (suc n) ρ1 ρ2 ρρ

fundamental : ∀ {Γ τ} (t : Term Γ τ) → (n : ℕ) → (ρ1 ρ2 : ⟦ Γ ⟧Context) (ρρ : relρ Γ ρ1 ρ2 n) → relT t t ρ1 ρ2 n
fundamental t zero ρ1 ρ2 ρρ v ()
-- XXX trivial case for constants.
fundamental (const (lit nv)) (suc n) ρ1 ρ2 ρρ .(intV nv) refl = intV nv , refl , refl
fundamental (var x) (suc n) ρ1 ρ2 ρρ v1 refl = fundamentalV x (suc n) ρ1 ρ2 ρρ (⟦ x ⟧Var ρ1) refl
fundamental (abs t) (suc n) ρ1 ρ2 ρρ (closure .t .ρ1) refl =
  closure t ρ2 , refl , λ k k≤n v1 v2 vv → fundamental t k (v1 • ρ1) (v2 • ρ2) (vv , relρ-mono k _ (≤-step k≤n) _ _ _ ρρ)
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 with eval s ρ1 n | inspect (eval s ρ1) n | eval t ρ1 n | inspect (eval t ρ1) n
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 seq1 | fundamental t n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) tv1 teq1
fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] | Done sv2 | [ seq2 ] | Done tv2 | (.sv2 , refl , svv) | (.tv2 , refl , tvv) = relV-apply n svv tvv tρ1↓v1
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv1 | [ seq1 ] | TimeOut | [ teq1 ]
fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | [ seq1 ] | tv1 | [ teq1 ]

-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ seq1 ] | Done tv1 | [ teq1 ] with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 seq1
--... | sv2 | [ seq2 ] | tv2 | (sv2' , sρ2↓sv2 , svv) = ?

-- TODO: match sv2 before matching on fundamental s.
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 with eval s ρ2 n | inspect (eval s ρ2) n | eval t ρ2 n | fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) | [ teq1 ] | (sv2' , sρ2↓sv2 , svv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | TimeOut | [ teq1 ] | (sv2' , sρ2↓sv2 , svv) with fundamental t n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) tv1 {!teq1!}
-- ... | (tv2' , tρ2↓tv2 , tvv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | TimeOut | [ eq2 ] | b | [ teq1 ] | (sv2' , () , svv)

-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | (Done tv2) | (sv2' , sρ2↓sv2 , svv) = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | (Done sv2) | [ eq2 ] | TimeOut = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | (Done tv1) | TimeOut | [ eq2 ] | tv2 = {!!}
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 with fundamental s n ρ1 ρ2 (relρ-mono n _ (n≤1+n n) _ _ _ ρρ) sv1 eq1
-- fundamental {τ = τ} (app s t) (suc n) ρ1 ρ2 ρρ v1 tρ1↓v1 | Done sv1 | [ eq1 ] | Done tv1 | (sv2 , sρ2↓sv2 , svv) = v2 , {!!}
--   where
--     v2 : Val τ
--     v2 = {!!}
--     -- tρ2↓v2 : apply sv2 tv2 n ≡ Done v1
--     -- tρ2↓v2 = ?
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | Done sv | _ | TimeOut
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | Done tv1
-- fundamental (app s t) (suc n) ρ1 ρ2 ρρ v1 () | TimeOut | _ | TimeOut


Data.LR: +[L:_R:_]′ +isL?-is-equiv

Data.LR: +[L:_R:_]′ +isL?-is-equiv

{-# OPTIONS --without-K #-}
module Data.LR where

open import Type
open import Function.NP
open import HoTT
open import Relation.Binary.PropositionalEquality.NP using () renaming (refl to idp)
open import Data.Two
open Equivalences

data LR : ★ where
  `L `R : LR

[L:_R:_] : ∀ {ℓ}{C : LR → ★_ ℓ}(l : C `L)(r : C `R)(lr : LR) → C lr
[L: l R: r ] `L = l
[L: l R: r ] `R = r

[L:_R:_]′ : ∀ {ℓ}{C : ★_ ℓ}(l : C)(r : C)(lr : LR) → C
[L:_R:_]′ = [L:_R:_]

LR! : LR → LR
LR! `L = `R
LR! `R = `L

LR!-equiv : LR ≃ LR
LR!-equiv = equiv LR! LR! [L: idp R: idp ] [L: idp R: idp ]

isR? : LR → 𝟚
isR? `L = 0₂
isR? `R = 1₂

isL? : LR → 𝟚
isL? = not ∘ isR?

isR?-is-equiv : Is-equiv isR?
isR?-is-equiv = is-equiv [0: `L 1: `R ] [0: idp 1: idp ] [L: idp R: idp ]

isL?-is-equiv : Is-equiv isL?
isL?-is-equiv = is-equiv [0: `R 1: `L ] [0: idp 1: idp ] [L: idp R: idp ]

{-# OPTIONS --without-K #-}
module Data.LR where

open import Type
open import Function.NP
open import HoTT
open import Relation.Binary.PropositionalEquality.NP using () renaming (refl to idp)
open import Data.Two
open Equivalences

data LR : ★ where
  `L `R : LR

[L:_R:_] : ∀ {ℓ}{C : LR → ★_ ℓ}(l : C `L)(r : C `R)(lr : LR) → C lr
[L: l R: r ] `L = l
[L: l R: r ] `R = r

LR! : LR → LR
LR! `L = `R
LR! `R = `L

LR!-equiv : LR ≃ LR
LR!-equiv = equiv LR! LR! [L: idp R: idp ] [L: idp R: idp ]

isR? : LR → 𝟚
isR? `L = 0₂
isR? `R = 1₂

isL? : LR → 𝟚
isL? = not ∘ isR?

isR?-is-equiv : Is-equiv isR?
isR?-is-equiv = is-equiv [0: `L 1: `R ] [0: idp 1: idp ] [L: idp R: idp ]