Require Vector.
Require Export Bool.
Require Export EqNat.
Inductive PrimRec : nat -> Set :=
| succFunc : PrimRec 1
| zeroFunc : PrimRec 0
| projFunc : forall n m : nat, m < n -> PrimRec n
| composeFunc :
forall (n m : nat) (g : PrimRecs n m) (h : PrimRec m), PrimRec n
| primRecFunc :
forall (n : nat) (g : PrimRec n) (h : PrimRec (S (S n))), PrimRec (S n)
with PrimRecs : nat -> nat -> Set :=
| PRnil : forall n : nat, PrimRecs n 0
| PRcons : forall n m : nat, PrimRec n -> PrimRecs n m -> PrimRecs n (S m).
Scheme PrimRec_PrimRecs_rec := Induction for PrimRec
Sort Set
with PrimRecs_PrimRec_rec := Induction for PrimRecs
Sort Set.
Scheme PrimRec_PrimRecs_ind := Induction for PrimRec
Sort Prop
with PrimRecs_PrimRec_ind := Induction for PrimRecs
Sort Prop.
Fixpoint evalConstFunc (n m : nat) {struct n} : naryFunc n :=
match n return (naryFunc n) with
| O => m
| S n' => fun _ => evalConstFunc n' m
end.
(* The parameters are number in opposite order. So proj(2,0)(a,b) = b. *)
Fixpoint evalProjFunc (n : nat) : forall m : nat, m < n -> naryFunc n :=
match n return (forall m : nat, m < n -> naryFunc n) with
| O => fun (m : nat) (l : m < 0) => False_rec _ (lt_n_O _ l)
| S n' =>
fun (m : nat) (l : m < S n') =>
match eq_nat_dec m n' with
| left _ => fun a : nat => evalConstFunc _ a
| right l1 =>
fun _ =>
evalProjFunc n' m
match le_lt_or_eq _ _ (lt_n_Sm_le _ _ l) with
| or_introl l2 => l2
| or_intror l2 => False_ind _ (l1 l2)
end
end
end.
Fixpoint evalList (m : nat) (l : Vector.t nat m) {struct l} :
naryFunc m -> nat :=
match l in (Vector.t _ m) return (naryFunc m -> nat) with
| Vector.nil => fun x : naryFunc 0 => x
| Vector.cons a n l' => fun x : naryFunc (S n) => evalList n l' (x a)
end.
Fixpoint evalOneParamList (n m a : nat) (l : Vector.t (naryFunc (S n)) m)
{struct l} : Vector.t (naryFunc n) m :=
match l in (Vector.t _ m) return (Vector.t (naryFunc n) m) with
| Vector.nil  => Vector.nil  (naryFunc n)
| Vector.cons f m' l' => Vector.cons _ (f a) m' (evalOneParamList n m' a l')
end.
Fixpoint evalComposeFunc (n : nat) :
forall m : nat, Vector.t (naryFunc n) m -> naryFunc m -> naryFunc n :=
match
n
return
(forall m : nat, Vector.t (naryFunc n) m -> naryFunc m -> naryFunc n)
with
| O => evalList
| S n' =>
fun (m : nat) (l : Vector.t (naryFunc (S n')) m)
(f : naryFunc m) (a : nat) =>
evalComposeFunc n' m (evalOneParamList _ _ a l) f
end.
Fixpoint compose2 (n : nat) : naryFunc n -> naryFunc (S n) -> naryFunc n :=
match n return (naryFunc n -> naryFunc (S n) -> naryFunc n) with
| O => fun (a : nat) (g : nat -> nat) => g a
| S n' =>
fun (f : naryFunc (S n')) (g : naryFunc (S (S n'))) (a : nat) =>
compose2 n' (f a) (fun x : nat => g x a)
end.
Fixpoint evalPrimRecFunc (n : nat) (g : naryFunc n)
(h : naryFunc (S (S n))) (a : nat) {struct a} : naryFunc n :=
match a with
| O => g
| S a' => compose2 _ (evalPrimRecFunc n g h a') (h a')
end.
Fixpoint evalPrimRec (n : nat) (f : PrimRec n) {struct f} :
naryFunc n :=
match f in (PrimRec n) return (naryFunc n) with
| succFunc => S
| zeroFunc => 0
| projFunc n m pf => evalProjFunc n m pf
| composeFunc n m l f =>
evalComposeFunc n m (evalPrimRecs _ _ l) (evalPrimRec _ f)
| primRecFunc n g h =>
evalPrimRecFunc n (evalPrimRec _ g) (evalPrimRec _ h)
end
with evalPrimRecs (n m : nat) (fs : PrimRecs n m) {struct fs} :
Vector.t (naryFunc n) m :=
match fs in (PrimRecs n m) return (Vector.t (naryFunc n) m) with
| PRnil a => Vector.nil  (naryFunc a)
| PRcons a b g gs => Vector.cons _ (evalPrimRec _ g) _ (evalPrimRecs _ _ gs)
end.
Definition extEqualVectorGeneral (n m : nat) (l : Vector.t (naryFunc n) m) :
forall (m' : nat) (l' : Vector.t (naryFunc n) m'), Prop.
induction l as [| a n0 l Hrecl].
intros.
destruct l' as [| a n0 v].
exact True.
exact False.
intros.
destruct l' as [| a0 n1 v].
exact False.
exact (extEqual n a a0 /\ Hrecl _ v).
Defined.
Definition extEqualVector n: forall m (l l' : Vector.t (naryFunc n) m), Prop.
refine (@Vector.rect2 _ _ _ _ _); intros.
apply True.
apply (extEqual n a b /\ X).
Defined.

Lemma extEqualCompose :
forall (n m : nat) (l1 l2 : Vector.t (naryFunc n) m) (f1 f2 : naryFunc m),
extEqualVector n m l1 l2 ->
extEqual m f1 f2 ->
extEqual n (evalComposeFunc n m l1 f1) (evalComposeFunc n m l2 f2).