Section CBV.
Variables variable function constructor : Type.
Variable variable_eq_dec : forall (x1 x2 : variable), {x1=x2}+{x1<>x2}.
Variable function_eq_dec : forall (x1 x2 : function), {x1=x2}+{x1<>x2}.
Variable constructor_eq_dec : forall (x1 x2 : constructor), {x1=x2}+{x1<>x2}.
Notation value := (Syntax.value constructor).
Notation term := (Syntax.term variable function constructor).
Notation pattern := (Syntax.pattern variable constructor).
Notation rule := (Syntax.rule variable function constructor).
Notation term_beq := (term_beq variable_eq_dec function_eq_dec constructor_eq_dec).
Definition cache : Type := list (term * value).
Notation assoc_cache := (assoc term_beq).
Definition cache_beq (C C' : cache) : bool :=
list_beq _ (prod_beq _ _ term_beq (value_beq constructor_eq_dec)) C C'.
Inductive cbv : Type :=
| cbv_constr : list cbv -> cache -> term -> cache -> value -> cbv
| cbv_split : list cbv -> cbv -> cache -> term -> cache -> value -> cbv
| cbv_update : nat -> (variable -> value) -> cbv -> cache -> term -> cache -> value -> cbv
| cbv_read : cache -> term -> value -> cbv.
(* Smarter induction principle than the one automatically generated *)
(* Being a subtree of *)
Fixpoint InCBV p proof_tree : Prop :=
p = proof_tree \/
match proof_tree with
| cbv_constr lp _ _ _ _ => orl (map (InCBV p) lp)
| cbv_split lp p' _ _ _ _ => InCBV p p' \/ orl (map (InCBV p) lp)
| cbv_update _ _ p' _ _ _ _ => InCBV p p'
| cbv_read _ _ _ => False
end.
(* Reverse induction on proof trees *)
Definition rule_subst_of_cbv_update ( subst_default : variable -> value) (proof_tree : cbv) : nat * (variable -> value) :=
match proof_tree with
| cbv_update i s _ _ _ _ _ => (i, s)
| _ => (0, subst_default) (* impossible case *)
end.
Definition proj_left (proof_tree : cbv) : term :=
match proof_tree with
| cbv_constr _ _ t _ _ => t
| cbv_split _ _ _ t _ _ => t
| cbv_update _ _ _ _ t _ _ => t
| cbv_read _ t _ => t
end.
Definition proj_right (proof_tree : cbv) : value :=
match proof_tree with
| cbv_constr _ _ _ _ v => v
| cbv_split _ _ _ _ _ v => v
| cbv_update _ _ _ _ _ _ v => v
| cbv_read _ _ v => v
end.
Definition cache_left (proof_tree : cbv) : cache :=
match proof_tree with
| cbv_constr _ c _ _ _ => c
| cbv_split _ _ c _ _ _ => c
| cbv_update _ _ _ c _ _ _ => c
| cbv_read c _ _ => c
end.
Definition cache_right (proof_tree : cbv) : cache :=
match proof_tree with
| cbv_constr _ _ _ c _ => c
| cbv_split _ _ _ _ c _ => c
| cbv_update _ _ _ _ _ c _ => c
| cbv_read c _ _ => c
end.
Fixpoint cache_path (C C' : cache)(l : list cbv) : bool :=
match l with
| nil => cache_beq C C'
| p :: l' => cache_beq C (cache_left p) && cache_path (cache_right p) C' l'
end.
Fixpoint cache_lookup (C: cache) (t: term) : term :=
match t with
| var _       => t
| capply c lt => capply c (map (cache_lookup C) lt)
| fapply f lt => match assoc_cache (fapply f (map (cache_lookup C) lt)) C with
| Some v => @term_from_value _ _ _ v
| None   => t
end
end.
Variable rule_default : rule.
Variable prog : list rule.
Variable max_arity : nat.
Fixpoint wf (proof_tree : cbv) : Prop :=
match proof_tree with
| cbv_constr l C (capply c lt) C' (c_capply c' lv) =>
cache_path C C' l = true /\
c = c' /\
lt = map proj_left l /\ lv = map proj_right l /\
andl (map wf  l) /\ List.length l <= max_arity
| cbv_split l ((cbv_update _ _ _ C' (fapply f lv) C'' v) as p) C (fapply f' lt) C''' v' =>
C''' = C'' /\
cache_path C C' l = true /\
lt = map proj_left l /\ lv = map (@term_from_value _ _ _) (map proj_right l) /\
andl (map wf  l) /\
f = f' /\ v = v' /\
wf  p /\ length l <= max_arity
| cbv_split l ((cbv_read C' (fapply f lv) v) as p) C (fapply f' lt) C'' v' =>
C'' = C' /\
cache_path C C' l = true /\
lt = map proj_left l /\ lv = map (@term_from_value _ _ _) (map proj_right l) /\
andl (map wf  l) /\
f = f' /\ v = v' /\
wf  p /\ length l <= max_arity
| cbv_update i s p C (fapply f lv as t0) C' v =>
assoc term_beq t0 C = None /\
exists lp t,
i < length prog /\
nth i prog rule_default = rule_intro f lp t /\
lv = map (@term_from_value _ _ _) (map (psubst s) lp) /\
proj_left p = subst s t /\ proj_right p = v /\
cache_left p = C /\  True /\
C' = (t0, v) :: cache_right p /\
wf  p /\ length lv <= max_arity
| cbv_read C (fapply _ lv as t) v =>
assoc term_beq t C = Some v /\
exists lv', lv = map (@term_from_value _ _ _) lv'
| _ => False
end.
(* Sizes *)
Definition cache_size (c : cache) : nat :=
suml (map (fun tv => term_size (fst tv) + value_size (snd tv)) c).
Fixpoint size_rec (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr l c1 t c2 v => term_size t + value_size v + suml (map size_rec l)
| cbv_split l p c1 t c2 v => term_size t + value_size v + size_rec p + suml (map size_rec l)
| cbv_update _ _ p c1 t c2 v => size_rec p + term_size t + value_size v
| cbv_read c t v => term_size t + value_size v
end.
Definition size (proof_tree : cbv) : nat :=
size_rec proof_tree + cache_size (cache_left proof_tree).
Fixpoint max_active_size (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp _ _ _ _ => maxl (map max_active_size lp)
| cbv_split lp p _ _ _ _ => max (max_active_size p) (maxl (map max_active_size lp))
| cbv_update _ _ p _ t _ v => max (term_size t + value_size v) (max_active_size p)
| cbv_read c t v => 0
end.
Fixpoint max_judgement_size (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp c1 t c2 v => max (term_size t + value_size v) (maxl (map max_judgement_size lp))
| cbv_split lp p c1 t c2 v => max (term_size t + value_size v) (max (max_judgement_size p) (maxl (map max_judgement_size lp)))
| cbv_update _ _ p c1 t c2 v => max (term_size t + value_size v) (max_judgement_size p)
| cbv_read c t v => term_size t + value_size v
end.
(* Sub-trees *)
Fixpoint sub_trees (proof_tree : cbv) : list cbv :=
proof_tree :: (
match proof_tree with
| cbv_constr lp _ _ _ _ => flat_map sub_trees lp
| cbv_split lp p _ _ _ _ => flat_map sub_trees (p :: lp)
| cbv_update _ _ p _ _ _ _ => sub_trees p
| cbv_read _ _ _ => []
end ).
(* Return the proof tree of the list with the largest proj_left *)
Fixpoint proj_left_max_size_list (default : cbv) (proof_trees : list cbv) : cbv :=
match proof_trees with
| [] => default
| [p] => p
| p :: ps =>
let p' := proj_left_max_size_list default ps in
if leb (term_size (proj_left p)) (term_size (proj_left p')) then p' else p
end.
Definition proj_left_max_size (proof_tree : cbv) : cbv :=
proj_left_max_size_list (proof_tree) (sub_trees proof_tree).
Fixpoint max_proj_right_size (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp _ t _ v => max (value_size v) (maxl (map max_proj_right_size lp))
| cbv_split lp p _ t _ v => max (value_size v) (max (max_proj_right_size p) (maxl (map max_proj_right_size lp)))
| cbv_update _ _ p _ t _ v => max (value_size v) (max_proj_right_size p)
| cbv_read _ t v => value_size v
end.
Fixpoint activations (proof_tree : cbv) : list cbv :=
match proof_tree with
| cbv_constr lp _ _ _ _ => flat_map activations lp
| cbv_split lp p _ _ _ _ => activations p ++ flat_map activations lp
| cbv_update _ _ p _ _ _ _ as p' => p' :: activations p
| cbv_read _ _ _ => []
end.
Fixpoint activations_cache_order (proof_tree : cbv) : list cbv :=
match proof_tree with
| cbv_constr lp _ _ _ _ => revflatten (map activations_cache_order lp)
| cbv_split lp p _ _ _ _ => activations_cache_order p ++ revflatten (map activations_cache_order lp)
| cbv_update _ _ p _ _ _ _ as p' => p' :: activations_cache_order p
| cbv_read _ _ _ => []
end.
Definition functions_of_prog : list function :=
map (fun x => match x with | rule_intro f _ _ => f end) prog.
Hypothesis prog_is_wf : wf_prog max_arity prog.
Fixpoint nb_judgements (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp _ _ _ _ => 1 + suml (map nb_judgements lp)
| cbv_split lp p _ _ _ _ => 1 + nb_judgements p + suml (map nb_judgements lp)
| cbv_update _ _ p _ _ _ _ => 1 + nb_judgements p
| cbv_read _ _ _=> 1
end.
Fixpoint nb_judgements_sub_rec (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp _ _ _ _ => 1 + suml (map nb_judgements_sub_rec lp)
| cbv_split lp p _ _ _ _ => 1 + nb_judgements_sub_rec p + suml (map nb_judgements_sub_rec lp)
| cbv_update _ _ _ _ _ _ _ => 0
| cbv_read _ _ _ => 0
end.
Definition nb_judgements_sub (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr _ _ _ _ _ => 0
| cbv_split _ _ _ _ _ _ => 0
| cbv_update _ _ p _ _ _ _ => nb_judgements_sub_rec p
| cbv_read _ _ _ => 0
end.
Fixpoint nb_nodes (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr [] _ _ _ _ => 0
| cbv_constr lp _ _ _ _ => 1 + suml (map nb_nodes lp)
| cbv_split lp p _ _ _ _ => 1 + nb_nodes p + suml (map nb_nodes lp)
| cbv_update _ _ p _ _ _ _ => 1 + nb_nodes p
| cbv_read _ _ _ => 0
end.
Fixpoint nb_read (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp _ _ _ _ => suml (map nb_read lp)
| cbv_split lp p _ _ _ _ => nb_read p + suml (map nb_read lp)
| cbv_update _ _ p _ _ _ _ => nb_read p
| cbv_read _ _ _ => 1
end.
Definition arity_cbv (proof_tree : cbv) : nat :=
match proof_tree with
| cbv_constr lp _ _ _ _  => length lp
| cbv_split lp p _ _ _ _ => 1 + length lp
| cbv_update _ _ p _ _ _ _ => 1
| cbv_read _ _ _ => 0
end.
Fixpoint first_activations_rec (proof_tree : cbv) : list cbv :=
match proof_tree with
| cbv_constr lp _ _ _ _ => flat_map first_activations_rec lp
| cbv_split lp p _ _ _ _ => first_activations_rec p ++ flat_map first_activations_rec lp
| cbv_update _ _ _ _ _ _ _ as p' => [p']
| cbv_read _ _ _ => []
end.
Definition first_activations (proof_tree : cbv) : list cbv :=
match proof_tree with
| cbv_constr lp _ _ _ _ => []
| cbv_split lp p _ _ _ _ => []
| cbv_update _ _ p _ _ _ _ => first_activations_rec p
| cbv_read _ _ _ => []
end.
Definition strict_activations (proof_tree: cbv) :=
flat_map activations (first_activations proof_tree).

Lemma first_activation_is_update proof_tree p :
In p (first_activations proof_tree) -> exists i s p' c1 t c2 v, p = cbv_update i s p' c1 t c2 v.