(** The language of Cobham *)
(** * Syntax and induction principle  - [Cobham_ind2] is a handmade induction principle because the one generated automatically by Coq ignores the type [list BC] in the constructor [Comp]. *)
Inductive Cobham : Type :=
| Zero : Cobham
| Proj : nat -> nat -> Cobham
| Succ : bool -> Cobham
| Smash : Cobham
| Rec  : Cobham -> Cobham -> Cobham -> Cobham -> Cobham
| Comp : nat -> Cobham -> list Cobham -> Cobham.
Definition Rec2 g h j := Rec g h h j.
(** * Arity  - [arity e] returns the arity (i.e., the number variables) of the expression [e] if it is well formed, or an error including the arity of the subterms. *)
Inductive Arity : Set :=
| error_Rec : Arity -> Arity -> Arity -> Arity -> Arity
| error_Comp : Arity -> list Arity -> Arity
| error_Proj : nat -> nat -> Arity
| ok_arity : nat -> Arity.
Definition arity_eq (a1 a2 : Arity) :=
match a1, a2 with
| ok_arity n1, ok_arity n2 => beq_nat n1 n2
| _, _ => false
end.
Fixpoint arity (e : Cobham) : Arity :=
match e with
| Zero => ok_arity 0
| Proj n j => if leb (S j) n
then ok_arity n else error_Proj n j
| Succ _ => ok_arity 1
| Smash => ok_arity 2
| Rec g h0 h1 j =>
match arity g, arity h0, arity h1, arity j with
| ok_arity gn, ok_arity h0n, ok_arity h1n, ok_arity jn =>
if beq_nat (S (S gn)) h0n &&
beq_nat h1n h0n &&
beq_nat (S jn) h1n
then ok_arity jn
else error_Rec (ok_arity gn) (ok_arity h0n)
(ok_arity h1n) (ok_arity jn)
| ag, ah0, ah1, aj => error_Rec ag ah0 ah1 aj
end
| Comp n h l =>
match arity h, map arity l with
| ok_arity nh, al =>
if beq_nat nh (length l) &&
forallb (fun e => arity_eq e (ok_arity n)) al then
ok_arity n else error_Comp (ok_arity nh) al
| e , le => error_Comp e le
end
end.
(** * Semantics  - [Sem e vl] is the evaluation of the expression [e] where the [i]th variable is instantiated with the [i]th value of [vl]. If a variable is not assigned a value, then it is assumed to be the empty bitstring [nil]. Values in [vl] that do not correspond to a variable are ignored.  - [Cobham_ind_inf] is an induction principle that makes easier dealing with arity in inductive proofs. *)
Fixpoint sem_Rec (sem_g sem_h0 sem_h1 : list bs -> bs) (v : bs) (vl : list bs) : bs :=
match v with
| nil => sem_g vl
| b::v' => if b then
sem_h1 (v' :: (sem_Rec sem_g sem_h0 sem_h1 v' vl) :: vl)
else sem_h0 (v' :: (sem_Rec sem_g sem_h0 sem_h1 v' vl) :: vl)
end.
Fixpoint smash' (x y : bs) :=
match x with
| nil => y
| _ :: x' => false :: smash' x' y
end.
Fixpoint smash_bs (x y : bs) : bs :=
match x with
| nil => true :: nil
| _ :: x' => smash' y (smash_bs x' y)
end.
Fixpoint Sem (e: Cobham) (vl:list bs) : bs :=
match e with
| Zero => nil
| Proj n j => nth j vl nil
| Succ b => b :: hd nil vl
| Smash => smash_bs (hd nil vl) (hd nil (tl vl))
| Rec g h0 h1 j =>
sem_Rec (Sem g) (Sem h0) (Sem h1) (hd nil vl) (tail vl)
| Comp _ h l => Sem h (List.map (fun e => Sem e vl) l)
end.
(** * Length-bounding condition that must hold for a Cobham expression to be valid *)
Fixpoint rec_bounded' (e : Cobham) : Prop :=
match e with
| Rec g h0 h1 j =>
rec_bounded' j  /\
rec_bounded' g /\
rec_bounded' h0 /\
rec_bounded' h1 /\
(match (arity e) with
| ok_arity n => forall l, length l = n ->
length (Sem e l) <= length (Sem j l)
| _ => True (* never happen *)
end)
| Comp n h l => rec_bounded' h /\
andl rec_bounded' l
| _ => True
end.
Fixpoint rec_bounded (e : Cobham) : Prop :=
match e with
| Rec g h0 h1 j =>
rec_bounded j  /\
rec_bounded g /\
rec_bounded h0 /\
rec_bounded h1 /\
(forall l,
length (Sem e l) <= length (Sem j l))
| Comp n h l => rec_bounded h /\
andl rec_bounded l
| _ => True
end.
(** * Length-bounding polynomial for Cobham expressions  - The lemma [poly_Cobham_correct] states that the output of an expression [e] is bounded by the polynomial [poly_Cobham e]. *)
Fixpoint poly_Cobham (e : Cobham) :=
match e with
| Zero => pcst 0 0
| Proj n i => pproj n i
| Succ b => pplus (pcst 0 1) (pproj 1 0)
| Smash => pplus (pcst 0 1) (pmult (pproj 2 0) (pproj 2 1))
| Rec g h0 h1 j => poly_Cobham j
| Comp n h l =>
pplus (pcst n 0)
(pcomp (poly_Cobham h) (map poly_Cobham l))
end.

Lemma pWF_poly_Cobham : forall (e : Cobham) n,
arity e = ok_arity n ->
pWF (poly_Cobham e).