(** The language of Bellantoni and Cook *)
(** * Syntax and induction principle  - [BC_ind2] is a handmade induction principle because the one generated automatically by Coq ignores the types [list BC] in the constructor [comp]. *)
Inductive BC : Set :=
| zero : BC
| proj : nat -> nat -> nat -> BC
| succ : bool -> BC
| pred : BC
| cond : BC
| rec : BC -> BC -> BC -> BC
| comp : nat -> nat -> BC -> list BC -> list BC -> BC.
(** * Arities  - [arities e] returns the arities (i.e., the number of normal and safe variables) of the expression [e] if it is well formed, or an error including the arities of the subterms. *)
Inductive Arities : Set :=
| error_rec : Arities -> Arities -> Arities -> Arities
| error_comp : Arities -> list Arities -> list Arities -> Arities
| error_proj : nat -> nat -> nat -> Arities
| ok_arities : nat -> nat -> Arities.
Definition aeq (x y:Arities) : bool :=
match x, y with
| ok_arities xn xs, ok_arities yn ys => beq_nat xn yn && beq_nat xs ys
| _, _ => false
end.
Fixpoint arities (e:BC) : Arities :=
match e with
| zero => ok_arities 0 0
| proj n s i =>
if leb (S i) (n + s) then ok_arities n s
else error_proj n s i
| succ _ => ok_arities 0 1
| pred => ok_arities 0 1
| cond => ok_arities 0 4
| rec g h0 h1 =>
match arities g, arities h0, arities h1
with | ok_arities gn gs, ok_arities h0n h0s, ok_arities h1n h1s =>
if beq_nat (S gn) h0n && beq_nat h0n h1n &&
beq_nat (S gs) h0s && beq_nat h0s h1s
then ok_arities h0n gs
else error_rec (ok_arities gn gs) (ok_arities h0n h0s) (ok_arities h1n h1s)
| e1, e2, e3 => error_rec e1 e2 e3
end
| comp n s h nl sl =>
match arities h, map arities nl, map arities sl with
| ok_arities hn hs, anl, asl =>
if beq_nat hn (length nl) && beq_nat hs (length sl) &&
forallb (fun ne => aeq (arities ne) (ok_arities n 0)) nl &&
forallb (fun se => aeq (arities se) (ok_arities n s)) sl
then ok_arities n s
else error_comp (ok_arities hn hs) anl asl
| e , anl, asl => error_comp e anl asl
end
end.
Definition arities2 e :=
match arities e with
| ok_arities n s => (n, s)
| _ => (0, 0)
end.
(** * Semantics  - [sem e vnl vsl] is the evaluation of the expression [e] where the [i]th normal variable is instantiated with the [i]th value of [vnl], and the [i]th safe variable is instantiated with the [i]th value of [vsl]. If a variable is not assigned a value, then it is assumed to be the empty bitstring [nil]. Values in [vnl] and [vsl] that do not correspond to a variable are ignored.  - [BC_ind_inf] is an induction principle that makes easier dealing with arities in inductive proofs. *)
Fixpoint sem_rec (sem_g sem_h0 sem_h1:list bs->list bs->bs)(v:bs)(vnl vsl:list bs) :=
match v with
| nil => sem_g vnl vsl
| b::v' =>
if b then sem_h1 (v'::vnl) (sem_rec sem_g sem_h0 sem_h1 v' vnl vsl :: vsl)
else sem_h0 (v'::vnl) (sem_rec sem_g sem_h0 sem_h1 v' vnl vsl :: vsl)
end.
Fixpoint sem (e:BC)(vnl vsl:list bs) : bs :=
match e with
| zero => nil
| proj n s j =>
if leb (S j) n then
nth j vnl nil
else nth (j-n) vsl nil
| succ b => b :: hd nil vsl
| pred => tail (hd nil vsl)
| cond =>
match vsl with
| a :: b :: c :: d :: _ =>
match a with
| nil => b
| true :: _ => c
| false :: _ => d
end
| a :: b :: c :: _ =>
match a with
| nil => b
| true :: _ => c
| false :: _ => nil
end
| a :: b :: _ =>
match a with
| nil => b
| _ => nil
end
| _ => nil
end
| rec g h0 h1 => sem_rec (sem g) (sem h0) (sem h1) (hd nil vnl) (tail vnl) vsl
| comp _ _ h nl sl =>
sem h (List.map (fun ne => sem ne vnl nil) nl)
(List.map (fun se => sem se vnl vsl) sl)
end.
(** * Some properties of [cond] *)

Lemma cond_simpl_notnil n s fn fc ft ff l1 l2 :
sem fc l1 l2 <> nil ->
sem (comp n s cond nil [fc; fn; ft; ff]) l1 l2 =
match sem fc l1 l2 with
| nil => nil
| true :: _ => sem ft l1 l2
| false :: _ => sem ff l1 l2
end.