Desc stratified model: put implicits up to DescDConst. Troubles starting.

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

{-# 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 l I
  const : Set l -> IDesc l I
  prod : IDesc l I -> IDesc l I -> IDesc l I
  sigma : (S : Set l) -> (S -> IDesc l I) -> IDesc l I
  pi : (S : Set l) -> (S -> IDesc l I) -> IDesc l I

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

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

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

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

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

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

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

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

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

    hyps : (D : IDesc l I) ->
           (xs : desc l I D (IMu l I R)) ->
           desc l (Sigma I (IMu l I R)) (box l I D (IMu l I 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 l I)
            (P : Sigma I (IMu l I R) -> Set l)
            (m : (i : I)
                 (xs : desc l I (R i) (IMu l I R))
                 (hs : desc l (Sigma I (IMu l I R)) (box l I (R i) (IMu l I R) xs) P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu l I R i) -> P ( i , x )
induction = Elim.induction

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

data DescDConst (l : Level) : Set l where
  lvar   : DescDConst l
  lconst : DescDConst l
  lprod  : DescDConst l
  lpi    : DescDConst l
  lsigma : DescDConst l

descDChoice : (l : Level) -> Set l -> DescDConst (suc l) -> IDesc (suc l) 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 (suc l) Unit
descD x I = sigma (DescDConst (suc x)) (descDChoice x I)

IDescl : (l : Level)(I : Set l) -> Set (suc l)
IDescl x I = IMu (suc x) Unit (\_ -> 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 (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 (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 (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 (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 (suc x)
             ls = lsigma
             Tl : Lifted S -> IDescl x I
             Tl (lifter s) = T s


Desc@ICFP: update model, adding just Variable from the thing containing Values.

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

module IDescTT where

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

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

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

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

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

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

data Zero : Set where
data Unit  : Set where
  Void : Unit

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

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

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

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

subst : forall {x y} -> x == y -> x -> y
subst refl x = x

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

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

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

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

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

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

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

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

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

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

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

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

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

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    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

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

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

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

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type
  pair : Type -> Type -> Type

--********************************
-- Typed expressions
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool
Val (pair x y) = (Val x) * (Val y)

-- Fix menu:
exprFixMenu : FixMenu Type
exprFixMenu = ( consE (consE nilE) ,
                \ty -> (const (Val ty),                           -- Val t
                       (prod (var bool) (prod (var ty) (var ty)), -- if b then t1 else t2
                       Void)))

-- Indexed menu:
choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE
choiceMenu (pair x y) = nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )
choiceDessert (pair x y) = Void

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

-- Expression:
expr : TagIDesc Type
expr = exprFixMenu , exprSensitiveMenu

exprIDesc : TagIDesc Type -> (Type -> IDesc Type)
exprIDesc D = toIDesc Type D

--********************************
-- Closed terms
--********************************

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc expr

--********************************
-- Closed term evaluation
--********************************

eval : {ty : Type} -> IMu closeTerm ty -> Val ty
eval {ty} term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)
              evalOneStep (pair x y) (ESu (ESu ()) , _)

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

Empty : Type -> Set
Empty _ = Zero

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (expr ** Empty)

--********************************
-- Closed term' evaluation
--********************************

eval' : {ty : Type} -> IMu closeTerm' ty -> Val ty
eval' {ty} term = cata Type closeTerm' Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm' ty |] Val -> Val ty
              evalOneStep _ (EZe , ())
              evalOneStep _ (ESu EZe , t) = t
              evalOneStep _ ((ESu (ESu EZe)) , (true , ( x , _))) = x
              evalOneStep _ ((ESu (ESu EZe)) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu (ESu EZe))) , (x , y)) = plus x y
              evalOneStep nat (((ESu (ESu (ESu (ESu ()))))) , t)
              evalOneStep bool ((ESu (ESu (ESu EZe))) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu (ESu ())))) , _)
              evalOneStep (pair x y) (ESu (ESu (ESu ())) , _)

--********************************
-- Open terms
--********************************

data Vec (A : Set) : Nat -> Set where
   vnil : Vec A ze
   vcons : {n : Nat} -> A -> Vec A n -> Vec A (su n)

data Fin : Nat -> Set where
  fze : {n : Nat} -> Fin (su n)
  fsu : {n : Nat} -> Fin n -> Fin (su n)

Context : Nat -> Set
Context n = Vec (Sigma Type (\ty -> IMu closeTerm' ty)) n

typeAt : {n : Nat}(c : Context n) -> Fin n -> Type
typeAt {ze} c ()
typeAt {.(su n)} (vcons x xs) (fze {n}) = fst x
typeAt {.(su n)} (vcons x xs) (fsu {n} y) = typeAt xs y

lookup : {n : Nat}(c : Context n)(i : Fin n) -> IMu closeTerm' (typeAt c i)
lookup {ze} c ()
lookup {su _} (vcons x _) fze = snd x
lookup {su _} (vcons _ xs) (fsu y) = lookup xs y

Var : {n : Nat} -> Context n -> Type -> Set
Var {n} c ty = Sigma (Fin n) (\i -> typeAt c i == ty)

openTerm : {n : Nat} -> Context n -> Type -> IDesc Type
openTerm c = toIDesc Type (expr ** (Var c))

--********************************
-- Evaluation of open terms
--********************************

discharge : {n : Nat}
             {context : Context n}
             (ty : Type) ->
             Var context ty ->
             IMu closeTerm' ty
discharge {n} {c} ty variable = subst (cong (IMu closeTerm') (snd variable)) (lookup c (fst variable))

substExpr : {n : Nat}
             {ty : Type}
             (context : Context n)
             (sigma : (ty : Type) ->
                      Var context ty ->
                      IMu closeTerm' ty) ->
             IMu (openTerm context) ty ->
             IMu closeTerm' ty
substExpr {n} {ty} c sig term =
    substI (Var c) Empty expr sig ty term

evalOpen : {n : Nat}{ty : Type}
           (context : Context n) ->
           IMu (openTerm context) ty ->
           Val ty
evalOpen context tm = eval' (substExpr context discharge tm)

--********************************
-- Tests
--********************************

-- V 0 :-> true, V 1 :-> 2, V 2 :-> ( false , 1 )
testContext : Context _
testContext =  vcons (bool , con ((ESu EZe) , true ))
              (vcons (nat , con ((ESu EZe) , su (su ze)) )
              (vcons (pair bool nat , con ((ESu EZe) , ( false , su ze )))
               vnil))

-- V 1
test1 : IMu (openTerm testContext) nat
test1 = con (EZe , ( fsu fze , refl ) )

testSubst1 : IMu closeTerm' nat
testSubst1 = substExpr testContext
                       discharge
                       test1
-- = 2
testEval1 : Val nat
testEval1 = evalOpen testContext test1

-- add 1 (V 1)
test2 : IMu (openTerm testContext) nat
test2 = con ((ESu (ESu (ESu EZe))) , (con ((ESu EZe) , (su ze)) , con ( EZe , (fsu fze , refl) )) )

testSubst2 : IMu closeTerm' nat
testSubst2 = substExpr testContext
                        discharge
                        test2

-- = 3
testEval2 : Val nat
testEval2 = evalOpen testContext test2

-- if (V 0) then (V 1) else 0
test3 : IMu (openTerm testContext) nat
test3 = con (ESu (ESu EZe) , (con (EZe , (fze , refl)) ,
                             (con (EZe , (fsu fze , refl)) ,
                              con (ESu EZe , ze))))

testSubst3 : IMu closeTerm' nat
testSubst3 = substExpr testContext
                       discharge
                       test3

-- = 2
testEval3 : Val nat
testEval3 = evalOpen testContext test3

-- V 2
test4 : IMu (openTerm testContext) (pair bool nat)
test4 = con (EZe , ( fsu (fsu fze) , refl ) )

testSubst4 : IMu closeTerm' (pair bool nat)
testSubst4 = substExpr testContext
                       discharge
                       test4
-- = (false , 1)
testEval4 : Val (pair bool nat)
testEval4 = evalOpen testContext test4

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

module IDescTT where

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

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

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

data Sigma (A : Set) (B : A -> Set) : Set where
  _,_ : (x : A) (y : B x) -> Sigma A B

_*_ : (A : Set)(B : Set) -> Set
A * B = Sigma A \_ -> B

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

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

data Zero : Set where
data Unit  : Set where
  Void : Unit

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

data _+_ (A : Set)(B : Set) : Set where
  l : A -> A + B
  r : B -> A + B

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

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

subst : forall {x y} -> x == y -> x -> y
subst refl x = x

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

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

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

--****************
-- Meta-language
--****************

-- Note that we could define Nat, Bool, and the related operations in
-- IDesc. But it is awful to code with them, in Agda.

data Nat : Set where
  ze : Nat
  su : Nat -> Nat

data Bool : Set where
  true : Bool
  false : Bool

plus : Nat -> Nat -> Nat
plus ze n' = n'
plus (su n) n' = su (plus n n')

le : Nat -> Nat -> Bool
le ze _ = true
le (su _) ze = false
le (su n) (su n') = le n n'

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

data IDesc (I : Set) : Set where
  var : I -> IDesc I
  const : Set -> IDesc I
  prod : IDesc I -> IDesc I -> IDesc I
  sigma : (S : Set) -> (S -> IDesc I) -> IDesc I
  pi : (S : Set) -> (S -> IDesc I) -> IDesc I

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

[|_|] : {I : Set} -> IDesc I -> (I -> Set) -> Set
[| var i |] P = P i
[| const X |] P = X
[| prod D D' |] P = [| D |] P * [| D' |] P
[| sigma S T |] P = Sigma S (\s -> [| T s |] P)
[| pi S T |] P = (s : S) -> [| T s |] P

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

data IMu {I : Set}(R : I -> IDesc I)(i : I) : Set where
  con : [| R i |] (\j -> IMu R j) -> IMu R i

--********************************************
-- Predicate: All
--********************************************

All : {I : Set}(D : IDesc I)(P : I -> Set) -> [| D |] P -> IDesc (Sigma I P)
All (var i)     P x        = var (i , x)
All (const X)   P x        = const Unit
All (prod D D') P (d , d') = prod (All D P d) (All D' P d')
All (sigma S T) P (a , b)  = All (T a) P b
All (pi S T)    P f        = pi S (\s -> All (T s) P (f s))

all : {I : Set}(D : IDesc I)(X : I -> Set)
      (R : Sigma I X -> Set)(P : (x : Sigma I X) -> R x) ->
      (xs : [| D |] X) -> [| All D X xs |] R
all (var i) X R P x = P (i , x)
all (const K) X R P k = Void
all (prod D D') X R P (x , y) = ( all D X R P x , all D' X R P y )
all (sigma S T) X R P (a , b) = all (T a) X R P b
all (pi S T) X R P f = \a -> all (T a) X R P (f a)

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

-- One would like to write the following:

{-
indI : {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs)) ->
            (i : I)(x : IMu R i) -> P ( i , x )
indI {I} R P m i (con xs) = m i xs (all (R i) (IMu R) P induct xs)
  where induct : (x : Sigma I (IMu R)) -> P x
        induct (i , xs) = indI R P m i xs
-}

-- But the termination-checker complains, so here we go
-- inductive-recursive:

module Elim {I : Set}
            (R : I -> IDesc I)
            (P : Sigma I (IMu R) -> Set)
            (m : (i : I)
                 (xs : [| R i |] (IMu R))
                 (hs : [| All (R i) (IMu R) xs |] P) ->
                 P ( i , con xs ))
       where

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

    hyps : (D : IDesc I) ->
           (xs : [| D |] (IMu R)) ->
           [| All D (IMu R) xs |] P
    hyps (var i) x = indI i x
    hyps (const X) x = Void
    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

indI : {I : Set}
       (R : I -> IDesc I)
       (P : Sigma I (IMu R) -> Set)
       (m : (i : I)
            (xs : [| R i |] (IMu R))
            (hs : [| All (R i) (IMu R) xs |] P) ->
            P ( i , con xs)) ->
       (i : I)(x : IMu R i) -> P ( i , x )
indI = Elim.indI

--********************************************
-- Examples
--********************************************

--****************
-- Nat
--****************

data NatConst : Set where
  Ze : NatConst
  Su : NatConst

natCases : NatConst -> IDesc Unit
natCases Ze = const Unit
natCases Suc = var Void

NatD : Unit -> IDesc Unit
NatD Void = sigma NatConst  natCases

Natd : Unit -> Set
Natd x = IMu NatD x

zed : Natd Void
zed = con (Ze , Void)

sud : Natd Void -> Natd Void
sud n = con (Su , n)

--****************
-- Desc
--****************

data DescDConst : Set where
  lvar   : DescDConst
  lconst : DescDConst
  lprod  : DescDConst
  lpi    : DescDConst
  lsigma : DescDConst

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

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

IDescl0 : (I : Set) -> Unit -> Set
IDescl0 I = IMu (\_ -> descD I)

IDescl : (I : Set) -> Set
IDescl I = IDescl0 I _

varl : {I : Set}(i : I) -> IDescl I
varl i = con (lvar ,  i)

constl : {I : Set}(X : Set) -> IDescl I
constl X = con (lconst , X)

prodl : {I : Set}(D D' : IDescl I) -> IDescl I
prodl D D' = con (lprod , (D , D'))

pil : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
pil S T = con (lpi , ( S , T))

sigmal : {I : Set}(S : Set)(T : S -> IDescl I) -> IDescl I
sigmal S T = con (lsigma , ( S , T))

--****************
-- Vec (constraints)
--****************

data VecConst : Set where
  Vnil : VecConst
  Vcons : VecConst

vecDChoice : Set -> Nat -> VecConst -> IDesc Nat
vecDChoice X n Vnil = const (n == ze)
vecDChoice X n Vcons = sigma Nat (\m -> prod (var m) (const (n == su m)))

vecD : Set -> Nat -> IDesc Nat
vecD X n = sigma VecConst (vecDChoice X n)

vec : Set -> Nat -> Set
vec X n = IMu (vecD X) n

--****************
-- Vec (de-tagged, forced)
--****************

data VecConst2 : Nat -> Set where
  Vnil : VecConst2 ze
  Vcons : {n : Nat} -> VecConst2 (su n)

vecDChoice2 : Set -> (n : Nat) -> VecConst2 n -> IDesc Nat
vecDChoice2 X ze Vnil = const Unit
vecDChoice2 X (su n) Vcons = prod (const X) (var n)

vecD2 : Set -> Nat -> IDesc Nat
vecD2 X n = sigma (VecConst2 n) (vecDChoice2 X n)

vec2 : Set -> Nat -> Set
vec2 X n = IMu (vecD2 X) n

--****************
-- Fin (de-tagged)
--****************

data FinConst : Nat -> Set where
  Fz : {n : Nat} -> FinConst (su n)
  Fs : {n : Nat} -> FinConst (su n)

finDChoice : (n : Nat) -> FinConst n -> IDesc Nat
finDChoice ze ()
finDChoice (su n) Fz = const Unit
finDChoice (su n) Fs = var n

finD : Nat -> IDesc Nat
finD n = sigma (FinConst n) (finDChoice n)

fin : Nat -> Set
fin n = IMu finD n

--********************************************
-- Enumerations (hard-coded)
--********************************************

-- Unlike in Desc.agda, we don't carry the levitation of finite sets
-- here. We hard-code them and manipulate with standard Agda
-- machinery. Both presentation are isomorph but, in Agda, the coded
-- one quickly gets unusable.

data EnumU : Set where
  nilE : EnumU
  consE : EnumU -> EnumU

data EnumT : (e : EnumU) -> Set where
  EZe : {e : EnumU} -> EnumT (consE e)
  ESu : {e : EnumU} -> EnumT e -> EnumT (consE e)

spi : (e : EnumU)(P : EnumT e -> Set) -> Set
spi nilE P = Unit
spi (consE e) P = P EZe * spi e (\e -> P (ESu e))

switch : (e : EnumU)(P : EnumT e -> Set)(b : spi e P)(x : EnumT e) -> P x
switch nilE P b ()
switch (consE e) P b EZe = fst b
switch (consE e) P b (ESu n) = switch e (\e -> P (ESu e)) (snd b) n

_++_ : EnumU -> EnumU -> EnumU
nilE ++ e' = e'
(consE e) ++ e' = consE (e ++ e')

-- A special switch, for tagged descriptions. Switching on a
-- concatenation of finite sets:
sswitch : (e : EnumU)(e' : EnumU)(P : Set)
       (b : spi e (\_ -> P))(b' : spi e' (\_ -> P))(x : EnumT (e ++ e')) -> P
sswitch nilE nilE P b b' ()
sswitch nilE (consE e') P b b' EZe = fst b'
sswitch nilE (consE e') P b b' (ESu n) = sswitch nilE e' P b (snd b') n
sswitch (consE e) e' P b b' EZe = fst b
sswitch (consE e) e' P b b' (ESu n) = sswitch e e' P (snd b) b' n

--********************************************
-- Tagged indexed description
--********************************************

FixMenu : Set -> Set
FixMenu I = Sigma EnumU (\e -> (i : I) -> spi e (\_ -> IDesc I))

SensitiveMenu : Set -> Set
SensitiveMenu I = Sigma (I -> EnumU) (\F -> (i : I) -> spi (F i) (\_ -> IDesc I))

TagIDesc : Set -> Set
TagIDesc I = FixMenu I * SensitiveMenu I

toIDesc : (I : Set) -> TagIDesc I -> (I -> IDesc I)
toIDesc I ((E , ED) , (F , FD)) i = sigma (EnumT (E ++ F i))
                                          (\x -> sswitch E (F i) (IDesc I) (ED i) (FD i) x)

--********************************************
-- Catamorphism
--********************************************

cata : (I : Set)
       (R : I -> IDesc I)
       (T : I -> Set) ->
       ((i : I) -> [| R i |] T -> T i) ->
       (i : I) -> IMu R i -> T i
cata I R T phi i x = indI R (\it -> T (fst it)) (\i xs ms -> phi i (replace (R i) T xs ms)) i x
  where replace : (D : IDesc I)(T : I -> Set)
                  (xs : [| D |] (IMu R))
                  (ms : [| All D (IMu R) xs |] (\it -> T (fst it))) ->
                  [| D |] T
        replace (var i) T x y = y
        replace (const Z) T z z' = z
        replace (prod D D') T (x , x') (y , y') = replace D T x y , replace D' T x' y'
        replace (sigma A B) T (a , b) t = a , replace (B a) T b t
        replace (pi A B) T f t = \s -> replace (B s) T (f s) (t s)

--********************************************
-- Hutton's razor
--********************************************

--********************************
-- Types code
--********************************

data Type : Set where
  nat : Type
  bool : Type
  pair : Type -> Type -> Type

--********************************
-- Typed expressions
--********************************

-- Fix menu:
exprFixMenu : (Type -> Set) -> FixMenu Type
exprFixMenu constt = ( consE (consE nilE) ,
                       \ty -> (const (constt ty),                        -- Val t
                              (prod (var bool) (prod (var ty) (var ty)), -- if b then t1 else t2
                               Void)))

-- Indexed menu:
choiceMenu : Type -> EnumU
choiceMenu nat = consE nilE
choiceMenu bool = consE nilE
choiceMenu (pair x y) = nilE

choiceDessert : (ty : Type) -> spi (choiceMenu ty) (\ _ -> IDesc Type)
choiceDessert nat = (prod (var nat) (var nat) , Void)
choiceDessert bool = (prod (var nat) (var nat) , Void )
choiceDessert (pair x y) = Void

exprSensitiveMenu : SensitiveMenu Type
exprSensitiveMenu = ( choiceMenu ,  choiceDessert )

-- Expression:
expr : (Type -> Set) -> TagIDesc Type
expr constt = exprFixMenu constt , exprSensitiveMenu

exprIDesc : (Type -> Set) -> ((Type -> Set) -> TagIDesc Type) -> (Type -> IDesc Type)
exprIDesc constt D = toIDesc Type  (D constt)

--********************************
-- Closed terms
--********************************

Val : Type -> Set
Val nat = Nat
Val bool = Bool
Val (pair x y) = (Val x) * (Val y)

closeTerm : Type -> IDesc Type
closeTerm = exprIDesc Val expr

--********************************
-- Closed term evaluation
--********************************

eval : (ty : Type) -> IMu closeTerm ty -> Val ty
eval ty term = cata Type closeTerm Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)
              evalOneStep (pair x y) (ESu (ESu ()) , _)

--********************************************
-- Free monad construction
--********************************************

_**_ : {I : Set} (R : TagIDesc I)(X : I -> Set) -> TagIDesc I
((E , ED) , FFD) ** X = ((( consE E ,  \ i -> ( const (X i) , ED i ))) , FFD)

--********************************************
-- Substitution
--********************************************

apply : {I : Set}
        (R : TagIDesc I)(X Y : I -> Set) ->
        ((i : I) -> X i -> IMu (toIDesc I (R ** Y)) i) ->
        (i : I) ->
        [| toIDesc I (R ** X) i |] (IMu (toIDesc I (R ** Y))) ->
        IMu (toIDesc I (R ** Y)) i
apply (( E , ED) , (F , FD)) X Y sig i (EZe , x) = sig i x
apply (( E , ED) , (F , FD)) X Y sig i (ESu n , t) = con (ESu n , t)

substI : {I : Set} (X Y : I -> Set)(R : TagIDesc I)
         (sigma : (i : I) -> X i -> IMu (toIDesc I (R ** Y)) i)
         (i : I)(D : IMu (toIDesc I (R ** X)) i) ->
         IMu (toIDesc I (R ** Y)) i
substI {I} X Y R sig i term = cata I (toIDesc I (R ** X)) (IMu (toIDesc I (R ** Y))) (apply R X Y sig) i term

--********************************************
-- Hutton's razor is free monad
--********************************************

exprFreeFixMenu : FixMenu Type
exprFreeFixMenu = ( consE nilE ,
                    \ty -> (prod (var bool) (prod (var ty) (var ty)),
                           Void))

choiceFreeMenu : Type -> EnumU
choiceFreeMenu nat = consE nilE
choiceFreeMenu bool = consE nilE
choiceFreeMenu (pair x y) = nilE

choiceFreeDessert : (ty : Type) -> spi (choiceFreeMenu ty) (\ _ -> IDesc Type)
choiceFreeDessert nat = (prod (var nat) (var nat) , Void)
choiceFreeDessert bool = (prod (var nat) (var nat) , Void )
choiceFreeDessert (pair x y) = Void

exprFreeSensitiveMenu : SensitiveMenu Type
exprFreeSensitiveMenu = ( choiceFreeMenu ,  choiceFreeDessert )

exprFree : TagIDesc Type
exprFree = exprFreeFixMenu , exprFreeSensitiveMenu

exprFreeC : (Type -> Set) -> TagIDesc Type
exprFreeC X = exprFree ** X

closeTerm' : Type -> IDesc Type
closeTerm' = toIDesc Type (exprFree ** Val)

--********************************
-- Closed term' evaluation
--********************************

eval' : {ty : Type} -> IMu closeTerm' ty -> Val ty
eval' {ty} term = cata Type closeTerm' Val evalOneStep ty term
        where evalOneStep : (ty : Type) -> [| closeTerm' ty |] Val -> Val ty
              evalOneStep _ (EZe , t) = t
              evalOneStep _ ((ESu EZe) , (true , ( x , _))) = x
              evalOneStep _ ((ESu EZe) , (false , ( _ , y ))) = y
              evalOneStep nat ((ESu (ESu EZe)) , (x , y)) = plus x y
              evalOneStep nat ((ESu (ESu (ESu ()))) , t)
              evalOneStep bool ((ESu (ESu EZe)) , (x , y) ) =   le x y
              evalOneStep bool ((ESu (ESu (ESu ()))) , _)
              evalOneStep (pair x y) (ESu (ESu ()) , _)

--********************************
-- Open terms
--********************************

data Vec (A : Set) : Nat -> Set where
   vnil : Vec A ze
   vcons : {n : Nat} -> A -> Vec A n -> Vec A (su n)

data Fin : Nat -> Set where
  fze : {n : Nat} -> Fin (su n)
  fsu : {n : Nat} -> Fin n -> Fin (su n)

Context : Nat -> Set
Context n = Vec (Sigma Type (\ty -> IMu closeTerm' ty)) n

typeAt : {n : Nat}(c : Context n) -> Fin n -> Type
typeAt {ze} c ()
typeAt {.(su n)} (vcons x xs) (fze {n}) = fst x
typeAt {.(su n)} (vcons x xs) (fsu {n} y) = typeAt xs y

lookup : {n : Nat}(c : Context n)(i : Fin n) -> IMu closeTerm' (typeAt c i)
lookup {ze} c ()
lookup {su _} (vcons x _) fze = snd x
lookup {su _} (vcons _ xs) (fsu y) = lookup xs y

Var : {n : Nat} -> Context n -> Type -> Set
Var {n} c ty = Sigma (Fin n) (\i -> typeAt c i == ty)

openTerm : {n : Nat} -> Context n -> Type -> IDesc Type
openTerm c = toIDesc Type (exprFree ** (\ty -> Val ty + Var c ty))

--********************************
-- Evaluation of open terms
--********************************

discharge : {n : Nat}
             {context : Context n}
             (ty : Type) ->
             (Val ty + Var context ty) ->
             IMu closeTerm' ty
discharge ty (l value) = con (EZe , value)
discharge {n} {c} ty (r variable) = subst (cong (IMu closeTerm') (snd variable)) (lookup c (fst variable))

substExpr : {n : Nat}
             {ty : Type}
             (context : Context n)
             (sigma : (ty : Type) ->
                      (Val ty + Var context ty) ->
                      IMu closeTerm' ty) ->
             IMu (openTerm context) ty ->
             IMu closeTerm' ty
substExpr {n} {ty} c sig term =
    substI (\ty -> Val ty + Var c ty) Val exprFree sig ty term

evalOpen : {n : Nat}{ty : Type}
           (context : Context n) ->
           IMu (openTerm context) ty ->
           Val ty
evalOpen context tm = eval' (substExpr context discharge tm)

--********************************
-- Tests
--********************************

-- V 0 :-> true, V 1 :-> 2, V 2 :-> ( false , 1 )
testContext : Context _
testContext =  vcons (bool , con (EZe , true ))
              (vcons (nat , con (EZe , su (su ze)) )
              (vcons (pair bool nat , con (EZe , ( false , su ze )))
               vnil))

-- V 1
test1 : IMu (openTerm testContext) nat
test1 = con (EZe , r ( fsu fze , refl ) )

testSubst1 : IMu closeTerm' nat
testSubst1 = substExpr testContext
                       discharge
                       test1
-- = 2
testEval1 : Val nat
testEval1 = evalOpen testContext test1

-- add 1 (V 1)
test2 : IMu (openTerm testContext) nat
test2 = con (ESu (ESu EZe) , (con (EZe , l (su ze)) , con ( EZe , r (fsu fze , refl) )) )

testSubst2 : IMu closeTerm' nat
testSubst2 = substExpr testContext
                        discharge
                        test2

-- = 3
testEval2 : Val nat
testEval2 = evalOpen testContext test2

-- if (V 0) then (V 1) else 0
test3 : IMu (openTerm testContext) nat
test3 = con (ESu EZe , (con (EZe , r (fze , refl)) ,
                       (con (EZe , r (fsu fze , refl)) ,
                        con (EZe , l ze))))

testSubst3 : IMu closeTerm' nat
testSubst3 = substExpr testContext
                       discharge
                       test3

-- = 2
testEval3 : Val nat
testEval3 = evalOpen testContext test3

-- V 2
test4 : IMu (openTerm testContext) (pair bool nat)
test4 = con (EZe , r ( fsu (fsu fze) , refl ) )

testSubst4 : IMu closeTerm' (pair bool nat)
testSubst4 = substExpr testContext
                       discharge
                       test4
-- = (false , 1)
testEval4 : Val (pair bool nat)
testEval4 = evalOpen testContext test4


Added doc.

Added doc.

Ignore-this: 364f24408c8fdd04184a133e22e3c7a9

darcs-hash:20101102124050-3bd4e-94a179f58a55dba886d13fbc0b4c89f2d268ef4b.gz

------------------------------------------------------------------------------
-- Bisimilarity relation on LTC streams
------------------------------------------------------------------------------

module LTC.Data.Stream.Bisimilarity where

open import LTC.Minimal

infix 4 _≈_

------------------------------------------------------------------------------
-- Because the LTC is a first-order theory, we define a first-order
-- version of the bisimilarity relation.

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

-- The bisimilarity relation is a post-fixed point of a bisimilar
-- relation BISI (see below).
postulate
  -≈-gfp₁ : {xs ys : D} → xs ≈ ys →
            ∃D (λ x' →
            ∃D (λ xs' →
            ∃D (λ ys' → xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys')))
{-# ATP axiom -≈-gfp₁ #-}

-- The bisimilarity relation is the greatest post-fixed point of a
-- bisimilar relation BISI (see below).

-- N.B. This is a second-order axiom. In the proofs, we *must* use an
-- axiom scheme instead. Therefore, we do not add this postulate as an
-- ATP axiom.
postulate
  -≈-gfp₂ : {_R_ : D → D → Set} →
            -- R is a post-fixed point of BISI.
            ({xs ys : D} → xs R ys →
              ∃D (λ x' →
              ∃D (λ xs' →
              ∃D (λ ys' → xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys')))) →
            -- ≈ is greater than R.
           {xs ys : D} → xs R ys → xs ≈ ys

module Bisimulation where
  -- In LTC we won't use the bisimilar relation BISI. This module is
  -- only for illustrative purposes.

  -- Adapted from [1]. In this paper the authors use the name
  -- 'as (R :: R') bs' (p. 310).
  -- N.B. This definition should work on streams.

  -- [1] Peter Dybjer and Herbert Sander. A functional programming
  -- approach to the specification and verification of concurrent
  -- systems. Formal Aspects of Computing, 1:303–319, 1989.

  -- The bisimilar relation.
  BISI : (D → D → Set) → D → D → Set
  BISI _R_ xs ys =
    ∃D (λ x' →
    ∃D (λ xs' →
    ∃D (λ ys' →
       xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys')))

  -- The bisimilarity relation is a post-fixed point of BISI.
  -≈→BISI≈ : {xs ys : D} → xs ≈ ys → BISI _≈_ xs ys
  -≈→BISI≈ = -≈-gfp₁

  -- The bisimilarity relation is the greatest post-fixed point of BISI.
  R→BISI-R→R→≈ : {_R_ : D → D → Set} →
                 -- R is a post-fixed point of BISI.
                 ({xs ys : D} → xs R ys → BISI _R_ xs ys) →
                 -- ≈ is greater than R.
                 {xs ys : D} → xs R ys → xs ≈ ys
  R→BISI-R→R→≈ = -≈-gfp₂

------------------------------------------------------------------------------
-- Bisimilarity relation on LTC streams
------------------------------------------------------------------------------

module LTC.Data.Stream.Bisimilarity where

open import LTC.Minimal

infix 4 _≈_

------------------------------------------------------------------------------
-- Because the LTC is a first-order theory, we define a first-order
-- version of the bisimilarity relation.

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

-- The bisimilarity relation is a post-fixed point of a bisimilar
-- relation BISI (see below).
postulate
  -≈-gfp₁ : {xs ys : D} → xs ≈ ys →
            ∃D (λ x' →
            ∃D (λ xs' →
            ∃D (λ ys' → xs' ≈ ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys')))
{-# ATP axiom -≈-gfp₁ #-}

-- The bisimilarity relation is the greatest post-fixed point of a
-- bisimilar relation BISI (see below).

-- N.B. This is a second-order axiom. In the proofs, we *must* use an
-- axiom scheme instead. Therefore, we do not add this postulate as an
-- ATP axiom.
postulate
  -≈-gfp₂ : {_R_ : D → D → Set} →
            -- R is a post-fixed point of BISI.
            ({xs ys : D} → xs R ys →
              ∃D (λ x' →
              ∃D (λ xs' →
              ∃D (λ ys' → xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys')))) →
            -- ≈ is the greater than R.
           {xs ys : D} → xs R ys → xs ≈ ys

module Bisimulation where
  -- In LTC we won't use the bisimilar relation BISI. This module is
  -- only for illustrative purposes.

  -- Adapted from [1]. In this paper the authors use the name
  -- 'as (R :: R') bs' (p. 310).
  -- N.B. This definition should work on streams.

  -- [1] Peter Dybjer and Herbert Sander. A functional programming
  -- approach to the specification and verification of concurrent
  -- systems. Formal Aspects of Computing, 1:303–319, 1989.

  -- The bisimilar relation.
  BISI : (D → D → Set) → D → D → Set
  BISI _R_ xs ys =
    ∃D (λ x' →
    ∃D (λ xs' →
    ∃D (λ ys' →
       xs' R ys' ∧ xs ≡ x' ∷ xs' ∧ ys ≡ x' ∷ ys')))

  -- The bisimilarity relation is a post-fixed point of BISI.
  -≈→BISI≈ : {xs ys : D} → xs ≈ ys → BISI _≈_ xs ys
  -≈→BISI≈ = -≈-gfp₁

  -- The bisimilarity relation is the greatest post-fixed point of BISI.
  R→BISI-R→R→≈ : {_R_ : D → D → Set} →
                 ({xs ys : D} → xs R ys → BISI _R_ xs ys) →
                 {xs ys : D} → xs R ys → xs ≈ ys
  R→BISI-R→R→≈ = -≈-gfp₂


Added mirror-Tree.

Added mirror-Tree.

Ignore-this: fa2b49ec2e9ab0b33a40ad384b5817f3

darcs-hash:20110220170905-3bd4e-4e7f837e6d45c5a8ec44cfcf227c9795a5715811.gz

------------------------------------------------------------------------------
-- Properties related with the closures of the tree type
------------------------------------------------------------------------------

{-# OPTIONS --no-termination-check #-}

module LTC.Program.Mirror.Tree.Closures where

open import LTC.Base

open import LTC.Data.List

open import LTC.Program.Mirror.Mirror
open import LTC.Program.Mirror.ListTree.Closures

open import LTC.Relation.Binary.EqReasoning

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

mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
mirror-Tree (treeT d nilLT) =
  subst Tree (sym (mirror-eq d [])) (treeT d helper₂)
    where
      helper₁ : rev (map mirror []) [] ≡ []
      helper₁ =
        begin
          rev (map mirror []) []
          ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
                   (map-[] mirror)
                   refl
          ⟩
          rev [] []
            ≡⟨ rev-[] [] ⟩
          []
        ∎

      helper₂ : ListTree (rev (map mirror []) [])
      helper₂ = subst ListTree (sym helper₁) nilLT

mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
  subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d helper)

  where
    helper : ListTree (reverse (map mirror (t ∷ ts)))
    helper = reverse-ListTree (map-ListTree mirror mirror-Tree (consLT Tt LTts))

------------------------------------------------------------------------------
-- Properties related with the closures of the tree type
------------------------------------------------------------------------------

module LTC.Program.Mirror.Tree.Closures where

open import LTC.Base

open import LTC.Program.Mirror.Mirror

open import LTC.Data.List

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

-- TODO: To remove the postulate
postulate
  mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)

-- mirror-Tree : ∀ {t} → Tree t → Tree (mirror · t)
-- mirror-Tree (treeT d nilLT) =
--   subst Tree (sym (mirror-eq d [])) (treeT d helper₂)
--     where
--       helper₁ : rev (map mirror []) [] ≡ []
--       helper₁ =
--         begin
--           rev (map mirror []) []
--           ≡⟨ subst (λ x → rev (map mirror []) [] ≡ rev x [])
--                    (map-[] mirror)
--                    refl
--           ⟩
--           rev [] []
--             ≡⟨ rev-[] [] ⟩
--           []
--         ∎

--       helper₂ : ListTree (rev (map mirror []) [])
--       helper₂ = subst ListTree (sym helper₁) nilLT

-- mirror-Tree (treeT d (consLT {t} {ts} Tt LTts)) =
--   subst Tree (sym (mirror-eq d (t ∷ ts))) (treeT d helper)

--   where
--     helper : ListTree (reverse (map mirror (t ∷ ts)))
--     helper = rev-ListTree (map-ListTree mirror {!!} (consLT Tt LTts)) nilLT


Cosmetic change.

Cosmetic change.

Ignore-this: a6d436fde1c00a6bec397a3db93e5eb4

darcs-hash:20120208145259-3bd4e-53e88003a7bb73c14766634e95a9aa210713ab4a.gz

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_
infix  7  _≐_

------------------------------------------------------------------------------
-- PA universe
open import Common.Universe public renaming ( D to ℕ )

-- Logical constants
open import Common.LogicalConstants public

-- Non-logical constants
postulate
  zero    : ℕ
  succ    : ℕ → ℕ
  _+_ _*_ : ℕ → ℕ → ℕ

-- The PA equality.
-- N.B. The symbol _≡_ should not be used because it is hard-coded by
-- the program agda2atp as the ATPs equality.
postulate _≐_ : ℕ → ℕ → Set

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- N.B. We make the recursion in the first argument for _+_ and _*_.

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + m
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wf P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≐ n → m ≐ o → n ≐ o
  S₂ : ∀ {m n} → m ≐ n → succ m ≐ succ n
  S₃ : ∀ {n} → ¬ (zero ≐ succ n)
  S₄ : ∀ {m n} → succ m ≐ succ n → m ≐ n
  S₅ : ∀ n → zero + n ≐ n
  S₆ : ∀ m n → succ m + n ≐ succ (m + n)
  S₇ : ∀ n → zero * n ≐ zero
  S₈ : ∀ m n → succ m * n ≐ n + m * n
{-# ATP axiom S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- The axiom S₉ is a higher-order one, therefore we do not translate
-- it as an ATP axiom.
postulate S₉ : (P : ℕ → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n

------------------------------------------------------------------------------
-- Axiomatic Peano arithmetic base
------------------------------------------------------------------------------

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

module PA.Axiomatic.Base where

-- We add 3 to the fixities of the standard library.
infixl 10 _*_
infixl 9  _+_
infix  7  _≐_

------------------------------------------------------------------------------
-- PA universe
open import Common.Universe public renaming ( D to ℕ )

-- Logical constants
open import Common.LogicalConstants public

-- Non-logical constants
postulate
  zero : ℕ
  succ : ℕ → ℕ
  _+_  : ℕ → ℕ → ℕ
  _*_  : ℕ → ℕ → ℕ

-- The PA equality.
-- N.B. The symbol _≡_ should not be used because it is hard-coded by
-- the program agda2atp as the ATPs equality.
postulate _≐_ : ℕ → ℕ → Set

-- Proper axioms
-- (From Elliott Mendelson. Introduction to mathematical
-- logic. Chapman & Hall, 4th edition, 1997, p. 155)

-- N.B. We make the recursion in the first argument for _+_ and _*_.

-- S₁. m = n → m = o → n = o
-- S₂. m = n → succ m = succ n
-- S₃. 0 ≠ succ n
-- S₄. succ m = succ n → m = n
-- S₅. 0 + n = n
-- S₆. succ m + n = succ (m + n)
-- S₇. 0 * n = 0
-- S₈. succ m * n = (m * n) + m
-- S₉. P(0) → (∀n.P(n) → P(succ n)) → ∀n.P(n), for any wf P(n) of PA.

postulate
  S₁ : ∀ {m n o} → m ≐ n → m ≐ o → n ≐ o
  S₂ : ∀ {m n} → m ≐ n → succ m ≐ succ n
  S₃ : ∀ {n} → ¬ (zero ≐ succ n)
  S₄ : ∀ {m n} → succ m ≐ succ n → m ≐ n
  S₅ : ∀ n → zero + n ≐ n
  S₆ : ∀ m n → succ m + n ≐ succ (m + n)
  S₇ : ∀ n → zero * n ≐ zero
  S₈ : ∀ m n → succ m * n ≐ n + m * n
{-# ATP axiom S₁ S₂ S₃ S₄ S₅ S₆ S₇ S₈ #-}

-- The axiom S₉ is a higher-order one, therefore we do not translate
-- it as an ATP axiom.
postulate S₉ : (P : ℕ → Set) → P zero → (∀ n → P n → P (succ n)) → ∀ n → P n


Moved a bug report to the agda2atp tool.

Ignore-this: e1514c644722b889facf44f91ec27a62

darcs-hash:20110322153307-3bd4e-0b07e862cc164decb95313adbe8b811bafa0a08d.gz

module Draft.Bugs.GeneralHints where

open import LTC.Base
open import LTC.Data.Nat

-- TODO: Bug. The agda2atp tool does not translate the general hints

-- {-# ATP hint zN #-}
-- {-# ATP hint sN #-}

-- because they are not defined in the file LTC.Data.Nat.Type.

postulate
 N0 : N zero
{-# ATP prove N0 #-}


Make Syntax.Type.Popl14 use Syntax.Type.Plotkin

Old-commit-hash: 031c97aee2022a85ee855ec3149f0f8cd160d5af

module Syntax.Type.Popl14 where

-- Types of Calculus Popl14

data Popl14-type : Set where
  base-int : Popl14-type
  base-bag : Popl14-type

open import Syntax.Type.Plotkin Popl14-type public

pattern int = base base-int
pattern bag = base base-bag

Popl14-Δbase : Popl14-type → Popl14-type
Popl14-Δbase base-int = base-int
Popl14-Δbase base-bag = base-bag

ΔType : Type → Type
ΔType = lift-Δtype₀ Popl14-Δbase

module Syntax.Type.Popl14 where

-- Types of Calculus Popl14

infixr 5 _⇒_

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

ΔType : Type → Type
ΔType int = int
ΔType bag = bag
ΔType (σ ⇒ τ) = σ ⇒ ΔType σ ⇒ ΔType τ


Lamport: +extract-signkey +extract-signkey-correct

{-# OPTIONS --without-K #-}
open import Function using (_∘_)
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP renaming (map to ×-map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP
import Crypto.Sig.LamportOneBit

module Crypto.Sig.Lamport
          (#digest  : ℕ)
          (#seed    : ℕ)
          (#secret  : ℕ)
          (#message : ℕ)
          (hash-secret    : Bits #secret → Bits #digest)
          (seed-expansion : Bits #seed   → Bits (#message * 2* #secret))
          where

open ≡-Reasoning

module OTS1 = Crypto.Sig.LamportOneBit #secret #digest hash-secret

H  = hash-secret
H² = map2* #secret #digest H

#signkey1   = OTS1.#signkey
#verifkey1  = OTS1.#verifkey
#signature1 = OTS1.#signature
#signkey    = #message * #signkey1
#verifkey   = #message * #verifkey1
#signature  = #message * #signature1

Digest     = Bits #digest
Seed       = Bits #seed
Secret     = Bits #secret
SignKey    = Bits #signkey
Message    = Bits #message
Signature  = Bits #signature
VerifKey   = Bits #verifkey

verif-key : SignKey → VerifKey
verif-key = map* #message OTS1.verif-key

module verifkey (vk : VerifKey) where
  vk1s = group #message #verifkey1 vk

  concat-vk1s : concat vk1s ≡ vk
  concat-vk1s = concat-group #message #verifkey1 vk

module signkey (sk : SignKey) where
  sk1s = group #message #signkey1 sk
  sc1s = map OTS1.signkey.skP sk1s
  vk   = verif-key sk
  open verifkey vk public
  sc1s-sk1s : map (uncurry _++_) sc1s ≡ sk1s
  sc1s-sk1s = ! map-∘ (uncurry _++_) OTS1.signkey.skP sk1s
            ∙ map-id= (take-drop-lem #secret) sk1s
  H-sc1s-sk1s : map (uncurry _++_ ∘ ×-map H H) sc1s ≡ map H² sk1s
  H-sc1s-sk1s = ! map-∘= (map2*-++ H) sc1s ∙ ap (map H²) sc1s-sk1s

module signature (sig : Signature) where
  sig1s = group #message #signature1 sig

  concat-sig1s : concat sig1s ≡ sig
  concat-sig1s = concat-group #message #secret sig

key-gen : Seed → VerifKey × SignKey
key-gen s = vk , sk
  module key-gen where
    sk = seed-expansion s
    vk = verif-key sk

sign : SignKey → Message → Signature
sign sk m = sig
  module sign where
    open signkey sk public
    sig1s = map OTS1.sign sk1s ⊛ m
    sig   = concat sig1s

    group-sig : group #message #signature1 sig ≡ sig1s
    group-sig = group-concat sig1s

verify : VerifKey → Message → Signature → Bit
verify vk m sig = and checks
  module verify where
    open verifkey  vk  public
    open signature sig public
    checks = map OTS1.verify vk1s ⊛ m ⊛ sig1s

private
  module lemma {#m} (sk : Bits (suc #m * #signkey1))
                    (b : Bit) (m : Bits #m) where
    skL  = take #signkey1 sk
    skH  = drop #signkey1 sk
    vkL  = OTS1.verif-key skL
    vkH  = map* #m OTS1.verif-key skH
    sigL = OTS1.sign skL b
    sigH = concat (map OTS1.sign (group #m #signkey1 skH) ⊛ m)

verifkey-is-hash-sig : ∀ sk m (open signkey sk)
                       → map (take2* _) m ⊛ vk1s
                       ≡ map H (map OTS1.sign sk1s ⊛ m)
verifkey-is-hash-sig sk m = lemma sk m
  module verifkey-is-hash-sig where
    lemma : ∀ {#m} sk m → map (take2* _) m ⊛ group #m #verifkey1 (map* #m OTS1.verif-key sk)
                        ≡ map hash-secret (map OTS1.sign (group #m #signkey1 sk) ⊛ m)
    lemma sk [] = refl
    lemma {suc #m} sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signkey1 skL skH)
            | (let open lemma sk b m in drop-++ #signkey1 skL skH)
            | (let open lemma sk b m in lemma skH m)
            | (let open lemma sk b m in OTS1.verifkey-is-hash-sig skL b)
      = refl

verify-correct-sig : ∀ sk m → verify (verif-key sk) m (sign sk m) ≡ 1b
verify-correct-sig sk m = lemma sk m
  module verify-correct-sig where
    lemma : ∀ {#m} sk m → and (map OTS1.verify (group #m #verifkey1 (map* #m OTS1.verif-key sk)) ⊛ m ⊛ group #m #signature1
                              (concat (map OTS1.sign (group #m #signkey1 sk) ⊛ m))) ≡ 1b
    lemma sk [] = refl
    lemma sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signature1 sigL sigH)
            | (let open lemma sk b m in drop-++ #signature1 sigL sigH)
            | (let open lemma sk b m in OTS1.verify-correct-sig skL b)
            | (let open lemma sk b m in lemma skH m)
            = refl

extract-signkey : (sig₀ sig₁ : Signature) → SignKey
extract-signkey sig₀ sig₁ = sk
  module extract-signkey where
    module sig₀ = signature sig₀
    module sig₁ = signature sig₁
    sk1s = map _++_ sig₀.sig1s ⊛ sig₁.sig1s
    sk   = concat sk1s

extract-signkey-correct :
  ∀ sk → extract-signkey (sign sk 0ⁿ) (sign sk 1ⁿ) ≡ sk
extract-signkey-correct sk = sk-lemma
  where
    module sk   = signkey sk
    module sig₀ = sign sk 0ⁿ
    module sig₁ = sign sk 1ⁿ
    module sk'  = extract-signkey sig₀.sig sig₁.sig

    sk1s-lemma : sk'.sk1s ≡ sk.sk1s
    sk1s-lemma = ap₂ (λ x y → map _++_ x ⊛ y)
                     (sig₀.group-sig ∙ ⊛-replicate _ 0b ∙ map-∘= (λ _ → refl) _)
                     (sig₁.group-sig ∙ ⊛-replicate _ 1b ∙ map-∘= (λ _ → refl) _)
               ∙ ⊛-take-drop-lem #secret sk.sk1s

    sk-lemma : sk'.sk ≡ sk
    sk-lemma = ap concat sk1s-lemma
             ∙ concat-group #message _ sk

-- -}
-- -}
-- -}
-- -}

{-# OPTIONS --without-K #-}
open import Function using (_∘_)
open import Data.Nat.NP hiding (_==_)
open import Data.Product.NP renaming (map to ×-map)
open import Data.Bit hiding (_==_)
open import Data.Bits
open import Data.Bits.Properties
open import Data.Vec.NP
open import Relation.Binary.PropositionalEquality.NP
import Crypto.Sig.LamportOneBit

module Crypto.Sig.Lamport
          (#digest  : ℕ)
          (#seed    : ℕ)
          (#secret  : ℕ)
          (#message : ℕ)
          (hash-secret    : Bits #secret → Bits #digest)
          (seed-expansion : Bits #seed   → Bits (#message * 2* #secret))
          where

module OTS1 = Crypto.Sig.LamportOneBit #secret #digest hash-secret

H  = hash-secret
H² = map2* #secret #digest H

#signkey1   = OTS1.#signkey
#verifkey1  = OTS1.#verifkey
#signature1 = OTS1.#signature
#signkey    = #message * #signkey1
#verifkey   = #message * #verifkey1
#signature  = #message * #signature1

Digest     = Bits #digest
Seed       = Bits #seed
Secret     = Bits #secret
SignKey    = Bits #signkey
Message    = Bits #message
Signature  = Bits #signature
VerifKey   = Bits #verifkey

verif-key : SignKey → VerifKey
verif-key = map* #message OTS1.verif-key

module verifkey (vk : VerifKey) where
  vk1s = group #message #verifkey1 vk

  concat-vk1s : concat vk1s ≡ vk
  concat-vk1s = concat-group #message #verifkey1 vk

module signkey (sk : SignKey) where
  sk1s = group #message #signkey1 sk
  sc1s = map OTS1.signkey.skP sk1s
  vk   = verif-key sk
  open verifkey vk public
  sc1s-sk1s : map (uncurry _++_) sc1s ≡ sk1s
  sc1s-sk1s = ! map-∘ (uncurry _++_) OTS1.signkey.skP sk1s
            ∙ map-id= (take-drop-lem #secret) sk1s
  H-sc1s-sk1s : map (uncurry _++_ ∘ ×-map H H) sc1s ≡ map H² sk1s
  H-sc1s-sk1s = ! map-∘= (map2*-++ H) sc1s ∙ ap (map H²) sc1s-sk1s

module signature (sig : Signature) where
  sig1s = group #message #signature1 sig

  concat-sig1s : concat sig1s ≡ sig
  concat-sig1s = concat-group #message #secret sig

key-gen : Seed → VerifKey × SignKey
key-gen s = vk , sk
  module key-gen where
    sk = seed-expansion s
    vk = verif-key sk

sign : SignKey → Message → Signature
sign sk m = sig
  module sign where
    open signkey sk public
    sig1s = map OTS1.sign sk1s ⊛ m
    sig   = concat sig1s

    group-sig : group #message #signature1 sig ≡ sig1s
    group-sig = group-concat sig1s

verify : VerifKey → Message → Signature → Bit
verify vk m sig = and checks
  module verify where
    open verifkey  vk  public
    open signature sig public
    checks = map OTS1.verify vk1s ⊛ m ⊛ sig1s

private
  module lemma {#m} (sk : Bits (suc #m * #signkey1))
                    (b : Bit) (m : Bits #m) where
    skL  = take #signkey1 sk
    skH  = drop #signkey1 sk
    vkL  = OTS1.verif-key skL
    vkH  = map* #m OTS1.verif-key skH
    sigL = OTS1.sign skL b
    sigH = concat (map OTS1.sign (group #m #signkey1 skH) ⊛ m)

verifkey-is-hash-sig : ∀ sk m (open signkey sk)
                       → map (take2* _) m ⊛ vk1s
                       ≡ map H (map OTS1.sign sk1s ⊛ m)
verifkey-is-hash-sig sk m = lemma sk m
  module verifkey-is-hash-sig where
    lemma : ∀ {#m} sk m → map (take2* _) m ⊛ group #m #verifkey1 (map* #m OTS1.verif-key sk)
                        ≡ map hash-secret (map OTS1.sign (group #m #signkey1 sk) ⊛ m)
    lemma sk [] = refl
    lemma {suc #m} sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signkey1 skL skH)
            | (let open lemma sk b m in drop-++ #signkey1 skL skH)
            | (let open lemma sk b m in lemma skH m)
            | (let open lemma sk b m in OTS1.verifkey-is-hash-sig skL b)
      = refl

verify-correct-sig : ∀ sk m → verify (verif-key sk) m (sign sk m) ≡ 1b
verify-correct-sig sk m = lemma sk m
  module verify-correct-sig where
    lemma : ∀ {#m} sk m → and (map OTS1.verify (group #m #verifkey1 (map* #m OTS1.verif-key sk)) ⊛ m ⊛ group #m #signature1
                              (concat (map OTS1.sign (group #m #signkey1 sk) ⊛ m))) ≡ 1b
    lemma sk [] = refl
    lemma sk (b ∷ m)
      rewrite (let open lemma sk b m in take-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in drop-++ #verifkey1 vkL vkH)
            | (let open lemma sk b m in take-++ #signature1 sigL sigH)
            | (let open lemma sk b m in drop-++ #signature1 sigL sigH)
            | (let open lemma sk b m in OTS1.verify-correct-sig skL b)
            | (let open lemma sk b m in lemma skH m)
            = refl
-- -}
-- -}
-- -}
-- -}


Updated a note.

Updated a note.

Ignore-this: ff92cf63d71d2a20c973e95b701a3ff3

darcs-hash:20111103145522-3bd4e-b34a41ced2551fcad2ad1814dcd1d73f59a63884.gz

-- Tested with Agda 2.2.11 on 11 October 2011.

module LeastFixedPoints where

open import FOTC.Base
open import FOTC.Base.PropertiesI

infixl 9 _+_

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d               -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e  -- d is the least prefixed-point of f

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d               -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e  -- d is the least prefixed-point of f

-- Thm: If d is the least pre-fixed point of f, then d is a fixed
-- point of f (TODO: source).

------------------------------------------------------------------------------
-- Auxiliary definitions

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

------------------------------------------------------------------------------
-- N is a least pre-fixed point of a functor

-- Instead defining the least pre-fixed via a (higher-order)
-- operator, we will define it using an instance of that operator.

-- The functor
-- NatF : (D → Set) → D → Set
-- NatF X n = n ≡ zero ∨ (∃ λ m → n ≡ succ m ∧ X m)

-- The natural numbers are the least pre-fixed point of NatF.
postulate
  N : D → Set

  -- N is pre-fixed point of NatF.
  -- Peter: It corresponds to the introduction rules.
  N-lfp₁ : ∀ n → n ≡ zero ∨ (∃ λ m → n ≡ succ₁ m ∧ N m) → N n

  -- N is the least prefixed-point of NatF.
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-lfp₂ : ∀ (P : D → Set) {n} →
           (n ≡ zero ∨ (∃ λ m → n ≡ succ₁ m ∧ P m) → P n) →
           N n → P n

------------------------------------------------------------------------------
-- The data constructors of N.
zN : N zero
zN = N-lfp₁ zero (inj₁ refl)

sN : ∀ {n} → N n → N (succ₁ n)
sN {n} Nn = N-lfp₁ (succ₁ n) (inj₂ (n , (refl , Nn)))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-lfp₁ and
-- N-lfp₂), we can proof that N is also post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-lfp₃ : ∀ {n} → N n → n ≡ zero ∨ (∃ λ m → n ≡ succ₁ m ∧ N m)
N-lfp₃ {n} Nn = N-lfp₂ P prf Nn
  where
  P : D → Set
  P x = x ≡ zero ∨ ∃ λ m → x ≡ succ₁ m ∧ N m

  prf : n ≡ zero ∨ ∃ (λ m → n ≡ succ₁ m ∧ P m) → P n
  prf h = [ inj₁ , (λ h₁ → inj₂ (prf₁ h₁)) ] h
    where
    prf₁ : ∃ (λ m → n ≡ succ₁ m ∧ (m ≡ zero ∨ ∃ (λ m' → m ≡ succ₁ m' ∧ N m'))) →
           ∃ λ m → n ≡ succ₁ m ∧ N m
    prf₁ (m , n=Sm , h₂) = m , n=Sm , prf₂ h₂
      where
      prf₂ : m ≡ zero ∨ ∃ (λ m' → m ≡ succ₁ m' ∧ N m') → N m
      prf₂ h₂ = [ (λ h₃ → subst N (sym h₃) zN) , prf₃ ] h₂
        where
        prf₃ : ∃ (λ m' → m ≡ succ₁ m' ∧ N m') → N m
        prf₃ (m' , m≡Sm' , Nm') = subst N (sym m≡Sm') (sN Nm')

------------------------------------------------------------------------------
-- The induction principle for N.
indN : (P : D → Set) →
       P zero →
       (∀ {n} → P n → P (succ₁ n)) →
       ∀ {n} → N n → P n
indN P P0 is {n} Nn = N-lfp₂ P [ prf₁ , prf₂ ] Nn
  where
  prf₁ : n ≡ zero → P n
  prf₁ n≡0 = subst P (sym n≡0) P0

  prf₂ : ∃ (λ m → n ≡ succ₁ m ∧ P m) → P n
  prf₂ (m , n≡Sm , Pm) = subst P (sym n≡Sm) (is Pm)

------------------------------------------------------------------------------
-- Example: We will use N-lfp₂ as the induction principle on N.
postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero    + d ≡ d
  +-Sx : ∀ d e → succ₁ d + e ≡ succ₁ (d + e)

+-leftIdentity : ∀ n → zero + n ≡ n
+-leftIdentity n = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-lfp₂ P prf Nm

  where
  P : D → Set
  P i = N (i + n)

  prf : m ≡ zero ∨ ∃ (λ m' → m ≡ succ₁ m' ∧ P m') → P m
  prf h = [ prf₁ , prf₂ ] h
    where
    P0 : P zero
    P0 = subst N (sym (+-leftIdentity n)) Nn

    prf₁ : m ≡ zero → P m
    prf₁ h₁ = subst N (cong (flip _+_ n) (sym h₁)) P0

    is : ∀ {i} → P i → P (succ₁ i)
    is {i} Pi = subst N (sym (+-Sx i n)) (sN Pi)

    prf₂ : ∃ (λ m' → m ≡ succ₁ m' ∧ P m') → P m
    prf₂ (m' , m≡Sm' , Pm') = subst N (cong (flip _+_ n) (sym m≡Sm')) (is Pm')

-- Tested with Agda 2.2.11 on 11 October 2011.

module LeastFixedPoints where

open import FOTC.Base
open import FOTC.Base.PropertiesI

infixl 9 _+_

------------------------------------------------------------------------------
-- Basic definitions

-- Pre-fixed point  : d is a pre-fixed point of f if f d ≤ d

-- Post-fixed point : d is a post-fixed point of f if d ≤ f d

-- Fixed-point      : d is a fixed-point of f if f d = d

-- Least pre-fixed point : d is the least pre-fixed point of f if
-- 1. f d ≤ d               -- d is a pre-fixed point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e  -- d is the least prefixed-point of f

-- Least fixed-point : d is the least fixed-point of f if
-- 1. f d = d               -- d is a fixed-point of f
-- 2. ∀ e. f e ≤ e ⇒ d ≤ e  -- d is the least prefixed-point of f

-- Thm: If d is the least pre-fixed point of f, then d is a fixed
-- point of f (TODO: source).

------------------------------------------------------------------------------
-- Auxiliary definitions

flip : {A B C : Set} → (A → B → C) → B → A → C
flip f b a = f a b

------------------------------------------------------------------------------
-- N is a least pre-fixed point of a functor

-- Instead defining the least pre-fixed via a (higher-order)
-- operator, we will define it using an instance of that operator.

-- The functor
-- NatF : (D → Set) → D → Set
-- NatF X n = n ≡ zero ∨ (∃ λ m → n ≡ succ m ∧ X m)

-- The natural numbers are the least pre-fixed point of NatF.
postulate
  N : D → Set

  -- N is pre-fixed point of NatF.
  -- Peter: It corresponds to the introduction rules.
  N-lfp₁ : ∀ n → n ≡ zero ∨ (∃ λ m → n ≡ succ m ∧ N m) → N n

  -- N is the least prefixed-point of NatF.
  -- Peter: It corresponds to the elimination rule of an inductively
  -- defined predicate.
  N-lfp₂ : ∀ (P : D → Set) {n} →
           (n ≡ zero ∨ (∃ λ m → n ≡ succ m ∧ P m) → P n) →
           N n → P n

------------------------------------------------------------------------------
-- The data constructors of N.
zN : N zero
zN = N-lfp₁ zero (inj₁ refl)

sN : ∀ {n} → N n → N (succ n)
sN {n} Nn = N-lfp₁ (succ n) (inj₂ (n , (refl , Nn)))

------------------------------------------------------------------------------
-- Because N is the least pre-fixed point of NatF (i.e. N-lfp₁ and
-- N-lfp₂), we can proof that N is also post-fixed point of NatF.

-- N is a post-fixed point of NatF.
N-lfp₃ : ∀ {n} → N n → n ≡ zero ∨ (∃ λ m → n ≡ succ m ∧ N m)
N-lfp₃ {n} Nn = N-lfp₂ P prf Nn
  where
  P : D → Set
  P x = x ≡ zero ∨ ∃ λ m → x ≡ succ m ∧ N m

  prf : n ≡ zero ∨ ∃ (λ m → n ≡ succ m ∧ P m) → P n
  prf h = [ inj₁ , (λ h₁ → inj₂ (prf₁ h₁)) ] h
    where
    prf₁ : ∃ (λ m → n ≡ succ m ∧ (m ≡ zero ∨ ∃ (λ m' → m ≡ succ m' ∧ N m'))) →
           ∃ λ m → n ≡ succ m ∧ N m
    prf₁ (m , n=Sm , h₂) = m , n=Sm , prf₂ h₂
      where
      prf₂ : m ≡ zero ∨ ∃ (λ m' → m ≡ succ m' ∧ N m') → N m
      prf₂ h₂ = [ (λ h₃ → subst N (sym h₃) zN) , prf₃ ] h₂
        where
        prf₃ : ∃ (λ m' → m ≡ succ m' ∧ N m') → N m
        prf₃ (m' , m≡Sm' , Nm') = subst N (sym m≡Sm') (sN Nm')

------------------------------------------------------------------------------
-- The induction principle for N.
indN : (P : D → Set) →
       P zero →
       (∀ {n} → N n → P n → P (succ n)) →
       ∀ {n} → N n → P n
indN P P0 is {n} Nn = N-lfp₂ P [ prf₁ , prf₂ ] Nn
  where
  prf₁ : n ≡ zero → P n
  prf₁ n≡0 = subst P (sym n≡0) P0

  prf₂ : ∃ (λ m → n ≡ succ m ∧ P m) → P n
  prf₂ (m , n≡Sm , Pm) = subst P (sym n≡Sm) (is helper Pm)
    where
    helper : N m
    helper = [ prf₃ , prf₄ ] (N-lfp₃ Nn)
      where
      prf₃ : n ≡ zero → N m
      prf₃ n≡0 = ⊥-elim (0≠S (trans (sym n≡0) n≡Sm))

      prf₄ : ∃ (λ m' → n ≡ succ m' ∧ N m') → N m
      prf₄ (m' , n≡Sm' , Nm') =
        subst N (succInjective (trans (sym n≡Sm') n≡Sm)) Nm'

------------------------------------------------------------------------------
-- Example: We will use N-lfp₂ as the induction principle on N.
postulate
  _+_  : D → D → D
  +-0x : ∀ d →   zero   + d ≡ d
  +-Sx : ∀ d e → succ d + e ≡ succ (d + e)

+-leftIdentity : ∀ {n} → N n → zero + n ≡ n
+-leftIdentity {n} _ = +-0x n

+-N : ∀ {m n} → N m → N n → N (m + n)
+-N {m} {n} Nm Nn = N-lfp₂ P prf Nm

  where
  P : D → Set
  P i = N (i + n)

  prf : m ≡ zero ∨ ∃ (λ m' → m ≡ succ m' ∧ P m') → P m
  prf h = [ prf₁ , prf₂ ] h
    where
    P0 : P zero
    P0 = subst N (sym (+-leftIdentity Nn)) Nn

    prf₁ : m ≡ zero → P m
    prf₁ h₁ = subst N (cong (flip _+_ n) (sym h₁)) P0

    is : ∀ {i} → P i → P (succ i)
    is {i} Pi = subst N (sym (+-Sx i n)) (sN Pi)

    prf₂ : ∃ (λ m' → m ≡ succ m' ∧ P m') → P m
    prf₂ (m' , m≡Sm' , Pm') = subst N (cong (flip _+_ n) (sym m≡Sm')) (is Pm')


Fixed module.

Fixed module.

------------------------------------------------------------------------------
-- Proving properties without using pattern matching on refl
------------------------------------------------------------------------------

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

module FOT.FOTC.NoPatternMatchingOnRefl where

open import FOTC.Base
open import FOTC.Base.List

open import FOTC.Data.Bool
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Stream

open import FOTC.Program.McCarthy91.McCarthy91

open import FOTC.Relation.Binary.Bisimilarity
open import FOTC.Relation.Binary.Bisimilarity.PropertiesI

------------------------------------------------------------------------------
-- From FOTC.Base.PropertiesI

-- Congruence properties

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong {a} {c = c} h = subst (λ t → a · c ≡ t · c) h refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong {a} {b} h = subst (λ t → a · b ≡ a · t) h refl

·-cong : ∀ {a b c d} → a ≡ b → c ≡ d → a · c ≡ b · d
·-cong {a} {c = c} h₁ h₂ = subst₂ (λ t₁ t₂ → a · c ≡ t₁ · t₂) h₁ h₂ refl

succCong : ∀ {m n} → m ≡ n → succ₁ m ≡ succ₁ n
succCong {m} h = subst (λ t → succ₁ m ≡ succ₁ t) h refl

predCong : ∀ {m n} → m ≡ n → pred₁ m ≡ pred₁ n
predCong {m} h = subst (λ t → pred₁ m ≡ pred₁ t) h refl

ifCong₁ : ∀ {b b' t t'} → b ≡ b' → if b then t else t' ≡ if b' then t else t'
ifCong₁ {b} {t = t} {t'} h =
  subst (λ x → if b then t else t' ≡ if x then t else t') h refl

ifCong₂ : ∀ {b t₁ t₂ t} → t₁ ≡ t₂ → if b then t₁ else t ≡ if b then t₂ else t
ifCong₂ {b} {t₁} {t = t} h =
  subst (λ x → if b then t₁ else t ≡ if b then x else t) h refl

ifCong₃ : ∀ {b t t₁ t₂} → t₁ ≡ t₂ → if b then t else t₁ ≡ if b then t else t₂
ifCong₃ {b} {t} {t₁} h =
  subst (λ x → if b then t else t₁ ≡ if b then t else x) h refl

------------------------------------------------------------------------------
-- From FOTC.Base.List.PropertiesI

-- Congruence properties

∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
∷-leftCong {x} {xs = xs} h = subst (λ t → x ∷ xs ≡ t ∷ xs) h refl

∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
∷-rightCong {x}{xs} h = subst (λ t → x ∷ xs ≡ x ∷ t) h refl

∷-Cong : ∀ {x y xs ys} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
∷-Cong {x} {xs = xs} h₁ h₂ = subst₂ (λ t₁ t₂ → x ∷ xs ≡ t₁ ∷ t₂) h₁ h₂ refl

headCong : ∀ {xs ys} → xs ≡ ys → head₁ xs ≡ head₁ ys
headCong {xs} h = subst (λ t → head₁ xs ≡ head₁ t) h refl

tailCong : ∀ {xs ys} → xs ≡ ys → tail₁ xs ≡ tail₁ ys
tailCong {xs} h = subst (λ t → tail₁ xs ≡ tail₁ t) h refl

------------------------------------------------------------------------------
-- From FOTC.Data.Bool.PropertiesI

-- Congruence properties

&&-leftCong : ∀ {a b c} → a ≡ b → a && c ≡ b && c
&&-leftCong {a} {c = c} h = subst (λ t → a && c ≡ t && c) h refl

&&-rightCong : ∀ {a b c} → b ≡ c → a && b ≡ a && c
&&-rightCong {a} {b} h = subst (λ t → a && b ≡ a && t) h refl

&&-cong : ∀ {a b c d } → a ≡ c → b ≡ d → a && b ≡ c && d
&&-cong {a} {b} h₁ h₂ = subst₂ (λ t₁ t₂ → a && b ≡ t₁ && t₂) h₁ h₂ refl

notCong : ∀ {a b} → a ≡ b → not a ≡ not b
notCong {a} h = subst (λ t → not a ≡ not t) h refl

------------------------------------------------------------------------------
-- FOTC.Data.Conat.Equality.PropertiesI

≈N-refl : ∀ {n} → Conat n → n ≈N n
≈N-refl {n} Cn = ≈N-coind R h₁ h₂
  where
  R : D → D → Set
  R a b = Conat a ∧ Conat b ∧ a ≡ b

  h₁ : ∀ {a b} → R a b →
       a ≡ zero ∧ b ≡ zero
         ∨ (∃[ a' ] ∃[ b' ] a ≡ succ₁ a' ∧ b ≡ succ₁ b' ∧ R a' b')
  h₁ (Ca , Cb , h) with Conat-unf Ca
  ... | inj₁ prf              = inj₁ (prf , trans (sym h) prf)
  ... | inj₂ (a' , prf , Ca') =
    inj₂ (a' , a' , prf , trans (sym h) prf , (Ca' , Ca' , refl))

  h₂ : R n n
  h₂ = Cn , Cn , refl

≡→≈N : ∀ {m n} → Conat m → Conat n → m ≡ n → m ≈N n
≡→≈N {m} Cm _ h = subst (_≈N_ m) h (≈N-refl Cm)

------------------------------------------------------------------------------
-- FOTC.Data.List.PropertiesI

-- Congruence properties

++-leftCong : ∀ {xs ys zs} → xs ≡ ys → xs ++ zs ≡ ys ++ zs
++-leftCong {xs} {zs = zs} h = subst (λ t → xs ++ zs ≡ t ++ zs) h refl

++-rightCong : ∀ {xs ys zs} → ys ≡ zs → xs ++ ys ≡ xs ++ zs
++-rightCong {xs} {ys} h = subst (λ t → xs ++ ys ≡ xs ++ t) h refl

mapCong₂ : ∀ {f xs ys} → xs ≡ ys → map f xs ≡ map f ys
mapCong₂ {f} {xs} h = subst (λ t → map f xs ≡ map f t) h refl

revCong₁ : ∀ {xs ys zs} → xs ≡ ys → rev xs zs ≡ rev ys zs
revCong₁ {xs} {zs = zs} h = subst (λ t → rev xs zs ≡ rev t zs) h refl

revCong₂ : ∀ {xs ys zs} → ys ≡ zs → rev xs ys ≡ rev xs zs
revCong₂ {xs} {ys} h = subst (λ t → rev xs ys ≡ rev xs t) h refl

reverseCong : ∀ {xs ys} → xs ≡ ys → reverse xs ≡ reverse ys
reverseCong {xs} h = subst (λ t → reverse xs ≡ reverse t) h refl

lengthCong : ∀ {xs ys} → xs ≡ ys → length xs ≡ length ys
lengthCong {xs} h = subst (λ t → length xs ≡ length t) h refl

------------------------------------------------------------------------------
-- From FOTC.Data.Nat.Inequalities.PropertiesI

-- Congruence properties

leLeftCong : ∀ {m n o} → m ≡ n → le m o ≡ le n o
leLeftCong {m} {o = o} h = subst (λ t → le m o ≡ le t o) h refl

ltLeftCong : ∀ {m n o} → m ≡ n → lt m o ≡ lt n o
ltLeftCong {m} {o = o} h = subst (λ t → lt m o ≡ lt t o) h refl

ltRightCong : ∀ {m n o} → n ≡ o → lt m n ≡ lt m o
ltRightCong {m} {n} h = subst (λ t → lt m n ≡ lt m t) h refl

ltCong : ∀ {m₁ n₁ m₂ n₂} → m₁ ≡ m₂ → n₁ ≡ n₂ → lt m₁ n₁ ≡ lt m₂ n₂
ltCong {m₁} {n₁} h₁ h₂ = subst₂ (λ t₁ t₂ → lt m₁ n₁ ≡ lt t₁ t₂) h₁ h₂ refl

------------------------------------------------------------------------------
-- From FOTC.Data.Nat.PropertiesI

-- Congruence properties

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong {m} {o = o} h = subst (λ t → m + o ≡ t + o) h refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong {m} {n} h = subst (λ t → m + n ≡ m + t) h refl

∸-leftCong : ∀ {m n o} → m ≡ n → m ∸ o ≡ n ∸ o
∸-leftCong {m} {o = o} h = subst (λ t → m ∸ o ≡ t ∸ o) h refl

∸-rightCong : ∀ {m n o} → n ≡ o → m ∸ n ≡ m ∸ o
∸-rightCong {m} {n} h = subst (λ t → m ∸ n ≡ m ∸ t) h refl

*-leftCong : ∀ {m n o} → m ≡ n → m * o ≡ n * o
*-leftCong {m} {o = o} h = subst (λ t → m * o ≡ t * o) h refl

*-rightCong : ∀ {m n o} → n ≡ o → m * n ≡ m * o
*-rightCong {m} {n} h = subst (λ t → m * n ≡ m * t) h refl

------------------------------------------------------------------------------
-- From FOT.FOTC.Data.Stream.Equality.PropertiesI where

stream-≡→≈ : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
stream-≡→≈ {xs} Sxs _ h = subst (_≈_ xs) h (≈-refl Sxs)

------------------------------------------------------------------------------
-- From FOTC.Program.McCarthy91.AuxiliaryPropertiesATP

f₉₁-x≡y : ∀ {m n o} → f₉₁ m ≡ n → o ≡ m → f₉₁ o ≡ n
f₉₁-x≡y {n = n} h₁ h₂ = subst (λ t → f₉₁ t ≡ n) (sym h₂) h₁

------------------------------------------------------------------------------
-- Proving properties without using pattern matching on refl
------------------------------------------------------------------------------

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

module FOT.FOTC.NoPatternMatchingOnRefl where

open import FOTC.Base
open import FOTC.Base.List

open import FOTC.Data.Bool
open import FOTC.Data.Conat
open import FOTC.Data.Conat.Equality
open import FOTC.Data.List
open import FOTC.Data.Nat
open import FOTC.Data.Nat.Inequalities
open import FOTC.Data.Stream

open import FOTC.Program.McCarthy91.McCarthy91

open import FOTC.Relation.Binary.Bisimilarity

------------------------------------------------------------------------------
-- From FOTC.Base.PropertiesI

-- Congruence properties

·-leftCong : ∀ {a b c} → a ≡ b → a · c ≡ b · c
·-leftCong {a} {c = c} h = subst (λ t → a · c ≡ t · c) h refl

·-rightCong : ∀ {a b c} → b ≡ c → a · b ≡ a · c
·-rightCong {a} {b} h = subst (λ t → a · b ≡ a · t) h refl

·-cong : ∀ {a b c d} → a ≡ b → c ≡ d → a · c ≡ b · d
·-cong {a} {c = c} h₁ h₂ = subst₂ (λ t₁ t₂ → a · c ≡ t₁ · t₂) h₁ h₂ refl

succCong : ∀ {m n} → m ≡ n → succ₁ m ≡ succ₁ n
succCong {m} h = subst (λ t → succ₁ m ≡ succ₁ t) h refl

predCong : ∀ {m n} → m ≡ n → pred₁ m ≡ pred₁ n
predCong {m} h = subst (λ t → pred₁ m ≡ pred₁ t) h refl

ifCong₁ : ∀ {b b' t t'} → b ≡ b' → if b then t else t' ≡ if b' then t else t'
ifCong₁ {b} {t = t} {t'} h =
  subst (λ x → if b then t else t' ≡ if x then t else t') h refl

ifCong₂ : ∀ {b t₁ t₂ t} → t₁ ≡ t₂ → if b then t₁ else t ≡ if b then t₂ else t
ifCong₂ {b} {t₁} {t = t} h =
  subst (λ x → if b then t₁ else t ≡ if b then x else t) h refl

ifCong₃ : ∀ {b t t₁ t₂} → t₁ ≡ t₂ → if b then t else t₁ ≡ if b then t else t₂
ifCong₃ {b} {t} {t₁} h =
  subst (λ x → if b then t else t₁ ≡ if b then t else x) h refl

------------------------------------------------------------------------------
-- From FOTC.Base.List.PropertiesI

-- Congruence properties

∷-leftCong : ∀ {x y xs} → x ≡ y → x ∷ xs ≡ y ∷ xs
∷-leftCong {x} {xs = xs} h = subst (λ t → x ∷ xs ≡ t ∷ xs) h refl

∷-rightCong : ∀ {x xs ys} → xs ≡ ys → x ∷ xs ≡ x ∷ ys
∷-rightCong {x}{xs} h = subst (λ t → x ∷ xs ≡ x ∷ t) h refl

∷-Cong : ∀ {x y xs ys} → x ≡ y → xs ≡ ys → x ∷ xs ≡ y ∷ ys
∷-Cong {x} {xs = xs} h₁ h₂ = subst₂ (λ t₁ t₂ → x ∷ xs ≡ t₁ ∷ t₂) h₁ h₂ refl

headCong : ∀ {xs ys} → xs ≡ ys → head₁ xs ≡ head₁ ys
headCong {xs} h = subst (λ t → head₁ xs ≡ head₁ t) h refl

tailCong : ∀ {xs ys} → xs ≡ ys → tail₁ xs ≡ tail₁ ys
tailCong {xs} h = subst (λ t → tail₁ xs ≡ tail₁ t) h refl

------------------------------------------------------------------------------
-- From FOTC.Data.Bool.PropertiesI

-- Congruence properties

&&-leftCong : ∀ {a b c} → a ≡ b → a && c ≡ b && c
&&-leftCong {a} {c = c} h = subst (λ t → a && c ≡ t && c) h refl

&&-rightCong : ∀ {a b c} → b ≡ c → a && b ≡ a && c
&&-rightCong {a} {b} h = subst (λ t → a && b ≡ a && t) h refl

&&-cong : ∀ {a b c d } → a ≡ c → b ≡ d → a && b ≡ c && d
&&-cong {a} {b} h₁ h₂ = subst₂ (λ t₁ t₂ → a && b ≡ t₁ && t₂) h₁ h₂ refl

notCong : ∀ {a b} → a ≡ b → not a ≡ not b
notCong {a} h = subst (λ t → not a ≡ not t) h refl

------------------------------------------------------------------------------
-- FOTC.Data.Conat.Equality.PropertiesI

≈N-refl : ∀ {n} → Conat n → n ≈N n
≈N-refl {n} Cn = ≈N-coind R h₁ h₂
  where
  R : D → D → Set
  R a b = Conat a ∧ Conat b ∧ a ≡ b

  h₁ : ∀ {a b} → R a b →
       a ≡ zero ∧ b ≡ zero
         ∨ (∃[ a' ] ∃[ b' ] a ≡ succ₁ a' ∧ b ≡ succ₁ b' ∧ R a' b')
  h₁ (Ca , Cb , h) with Conat-unf Ca
  ... | inj₁ prf              = inj₁ (prf , trans (sym h) prf)
  ... | inj₂ (a' , prf , Ca') =
    inj₂ (a' , a' , prf , trans (sym h) prf , (Ca' , Ca' , refl))

  h₂ : R n n
  h₂ = Cn , Cn , refl

≡→≈N : ∀ {m n} → Conat m → Conat n → m ≡ n → m ≈N n
≡→≈N {m} Cm _ h = subst (_≈N_ m) h (≈N-refl Cm)

------------------------------------------------------------------------------
-- FOTC.Data.List.PropertiesI

-- Congruence properties

++-leftCong : ∀ {xs ys zs} → xs ≡ ys → xs ++ zs ≡ ys ++ zs
++-leftCong {xs} {zs = zs} h = subst (λ t → xs ++ zs ≡ t ++ zs) h refl

++-rightCong : ∀ {xs ys zs} → ys ≡ zs → xs ++ ys ≡ xs ++ zs
++-rightCong {xs} {ys} h = subst (λ t → xs ++ ys ≡ xs ++ t) h refl

mapCong₂ : ∀ {f xs ys} → xs ≡ ys → map f xs ≡ map f ys
mapCong₂ {f} {xs} h = subst (λ t → map f xs ≡ map f t) h refl

revCong₁ : ∀ {xs ys zs} → xs ≡ ys → rev xs zs ≡ rev ys zs
revCong₁ {xs} {zs = zs} h = subst (λ t → rev xs zs ≡ rev t zs) h refl

revCong₂ : ∀ {xs ys zs} → ys ≡ zs → rev xs ys ≡ rev xs zs
revCong₂ {xs} {ys} h = subst (λ t → rev xs ys ≡ rev xs t) h refl

reverseCong : ∀ {xs ys} → xs ≡ ys → reverse xs ≡ reverse ys
reverseCong {xs} h = subst (λ t → reverse xs ≡ reverse t) h refl

lengthCong : ∀ {xs ys} → xs ≡ ys → length xs ≡ length ys
lengthCong {xs} h = subst (λ t → length xs ≡ length t) h refl

------------------------------------------------------------------------------
-- From FOTC.Data.Nat.Inequalities.PropertiesI

-- Congruence properties

leLeftCong : ∀ {m n o} → m ≡ n → le m o ≡ le n o
leLeftCong {m} {o = o} h = subst (λ t → le m o ≡ le t o) h refl

ltLeftCong : ∀ {m n o} → m ≡ n → lt m o ≡ lt n o
ltLeftCong {m} {o = o} h = subst (λ t → lt m o ≡ lt t o) h refl

ltRightCong : ∀ {m n o} → n ≡ o → lt m n ≡ lt m o
ltRightCong {m} {n} h = subst (λ t → lt m n ≡ lt m t) h refl

ltCong : ∀ {m₁ n₁ m₂ n₂} → m₁ ≡ m₂ → n₁ ≡ n₂ → lt m₁ n₁ ≡ lt m₂ n₂
ltCong {m₁} {n₁} h₁ h₂ = subst₂ (λ t₁ t₂ → lt m₁ n₁ ≡ lt t₁ t₂) h₁ h₂ refl

------------------------------------------------------------------------------
-- From FOTC.Data.Nat.PropertiesI

-- Congruence properties

+-leftCong : ∀ {m n o} → m ≡ n → m + o ≡ n + o
+-leftCong {m} {o = o} h = subst (λ t → m + o ≡ t + o) h refl

+-rightCong : ∀ {m n o} → n ≡ o → m + n ≡ m + o
+-rightCong {m} {n} h = subst (λ t → m + n ≡ m + t) h refl

∸-leftCong : ∀ {m n o} → m ≡ n → m ∸ o ≡ n ∸ o
∸-leftCong {m} {o = o} h = subst (λ t → m ∸ o ≡ t ∸ o) h refl

∸-rightCong : ∀ {m n o} → n ≡ o → m ∸ n ≡ m ∸ o
∸-rightCong {m} {n} h = subst (λ t → m ∸ n ≡ m ∸ t) h refl

*-leftCong : ∀ {m n o} → m ≡ n → m * o ≡ n * o
*-leftCong {m} {o = o} h = subst (λ t → m * o ≡ t * o) h refl

*-rightCong : ∀ {m n o} → n ≡ o → m * n ≡ m * o
*-rightCong {m} {n} h = subst (λ t → m * n ≡ m * t) h refl

------------------------------------------------------------------------------
-- From FOT.FOTC.Data.Stream.Equality.PropertiesI where

stream-≡→≈ : ∀ {xs ys} → Stream xs → Stream ys → xs ≡ ys → xs ≈ ys
stream-≡→≈ {xs} Sxs _ h = subst (_≈_ xs) h (≈-refl Sxs)

------------------------------------------------------------------------------
-- From FOTC.Program.McCarthy91.AuxiliaryPropertiesATP

f₉₁-x≡y : ∀ {m n o} → f₉₁ m ≡ n → o ≡ m → f₉₁ o ≡ n
f₉₁-x≡y {n = n} h₁ h₂ = subst (λ t → f₉₁ t ≡ n) (sym h₂) h₁