progress_tactics

examples/BasicDemos/Demo.ml

@@ -8,47 +8,6 @@ open Pervasives
  *)
 
 
-(********************************************************************)
-(* ** Top-level values *)
-
-let top_val_int = 5
-
-let top_val_int_list : int list = []
-
-let top_val_poly_list = []
-
-let top_val_poly_list_pair = ([],[])
-
-
-(********************************************************************)
-(* ** Polymorphic functions *)
-
-let top_fun_poly_id x =
-  x
-
-let top_fun_poly_proj1 (x,y) =
-  x
-
-let top_fun_poly_pair_homogeneous (x:'a) (y:'a) =
-  (x,y)
-
-
-(********************************************************************)
-(* ** Infix functions *)
-
-let (+++) x y = x + y  
-
-let infix_aux x y = x + y
-
-let (---) = infix_aux
-
-
-(********************************************************************)
-(* ** Inlined total functions *)
-
-let f () =
-   1 - 1/(-1) + (2 / 2) mod 3
-
 
 (********************************************************************)
 (* ** Return *)
@@ -169,7 +128,6 @@ let app_partial_builtin () =
   f 2
 
 
-
 (********************************************************************)
 (* ** Over applications *)
 
@@ -178,6 +136,48 @@ let app_over_id () =
    f f 3
 
 
+(********************************************************************)
+(* ** Infix functions *)
+
+let (+++) x y = x + y  
+
+let infix_aux x y = x + y
+
+let (---) = infix_aux
+
+
+(********************************************************************)
+(* ** Inlined total functions *)
+
+let f () =
+   1 - 1/(-1) + (2 / 2) mod 3
+
+
+(********************************************************************)
+(* ** Polymorphic functions *)
+
+let top_fun_poly_id x =
+  x
+
+let top_fun_poly_proj1 (x,y) =
+  x
+
+let top_fun_poly_pair_homogeneous (x:'a) (y:'a) =
+  (x,y)
+
+
+(********************************************************************)
+(* ** Top-level values *)
+
+let top_val_int = 5
+
+let top_val_int_list : int list = []
+
+let top_val_poly_list = []
+
+let top_val_poly_list_pair = ([],[])
+
+
 (********************************************************************)
 (* ** Polymorphic let bindings *)
 
@@ -330,6 +330,9 @@ let for_incr () =
    done;
    !n
 
+(* "for .. down to" not yet supported *)
+
+
 (********************************************************************)
 (* ** Recursive function *)
 

examples/Makefile.example

@@ -95,7 +95,8 @@ cf: $(ML)
 # Make sure TLC and CFML itself are up-to-date.
 # Needed only when developing TLC and CFML. Ideally, should be removed.
 	@$(MAKE) -C $(CFML)/lib/tlc --no-print-directory quick
-	@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick_cf 
+#	@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick_cf 
+	@$(MAKE) -C $(CFML) --no-print-directory tools coqlib_quick 
 	@$(MAKE) -C $(CFML)/lib/stdlib --no-print-directory quick
 	@$(MAKE) CFML=$(CFML) OCAML_FLAGS=$(OCAML_FLAGS) COQINCLUDE="$(COQINCLUDE)" ML="$(ML)" --no-print-directory -f $(CFML)/lib/make/Makefile.cf all
 

generator/formula_to_coq.ml

@@ -5,7 +5,7 @@ open Renaming
 
 
 (*#########################################################################*)
-(* ** Conversion of IMPERATIVE characteristic formulae to Coq *)
+(* ** Conversion of characteristic formulae to Coq *)
 
 (* TODO: extract hard coded constants*)
 

lib/coq/CFPrint.v

@@ -61,9 +61,8 @@ Ltac cfml_get_tag tt :=
 
 (** [cfml_check_not_tagged tt] fails if the head of the goal contains a tag *)
 
-Ltac cfml_check_not_tagged tt :=
-  match goal with |- @tag ?t _ _ => fail 1 end.  
-
+Ltac cfml_check_not_tagged tt ::=
+  match goal with |- @tag ?t _ _ => fail 1 | _ => idtac end.  
 
 (** [xuntag T] removes the tag [T] at the head of the goal,
     and fails if it is not there. *)

lib/coq/CFTactics.v

@@ -2082,18 +2082,54 @@ Tactic Notation "xspec" :=
     - [xapps_spec] is not supported, use [xapp_spec], then [subst]. *)
 
 
+(** Debugging for [xapp]:
+  
+    - [xapp1] sets the goal in the right form for [xapp], 
+      by calling [xseq] or [xlet], or [xgc] if applicable
+      
+    - [xapp2] looks up the specification for the function and pushes 
+      it into the goal. 
+      [xapp2_spec H] can be used to provide a custom specification.
+    
+    - [xapp3] exploits the last hypothesis in the goal as a specification
+      and instantiates it using the tactic [forward].
+      [xapp3 args] can be used to provide arguments.
+      At this point, sides conditions should be discarded.
+      //TODO: [xapp3_skip] can be used to skip all side conditions.
+    
+    - [xapp4] applies the frame rule, exploiting lemma [local_wframe].
+
+    - [xapp5] applies the last hypothesis in the goal to the goal.
+      From there, [xsimpl] should be called on the other two goals
+      produced by [xapp4].
+   
+    - [xapp12] is short for [xapp1; xapp2].
+
+    - [xapp45] is short for [xapp4; xapp5]. 
+    
+*)
+
 (* TODO: xapp_spec_no_simpl *)
 
-(* Retreives only the "app" part of the spec *)
+(* Retreives only the "app" part of the spec, from the head of the goal,
+   into an hypothesis named [Sf]. *)
 
-Ltac xapp_extract_app_from_spec H :=
+Ltac xapp_extract_app_from_spec_as Sf :=
   match goal with
-  | |- (spec _ _ _) -> _ => intros [_ H] (* drops the curried part *)
-  | |- (_) -> _ => intros H
+  | |- (spec _ _ _) -> _ => intros [_ Sf] (* drops the curried part *)
+  | |- (_) -> _ => intros Sf
   end.
-     
-Ltac xspec_for_xapp H :=
-  xspec; xapp_extract_app_from_spec H.
+
+(* [xapp_use_of_find H Sf] creates an hypothesis [Sf] 
+   that is equal to [H] if [H] is not [___], else
+   finds a spec for the current function, and names it [Sf]. *)
+
+Ltac xapp_use_of_find H Sf :=
+  match H with
+  | ___ => xspec 
+  | _ => generalize H
+  end;
+  xapp_extract_app_from_spec_as Sf.
 
 (* [xapp_prepare_goal] tactic for settings things up *)
 
@@ -2109,9 +2145,21 @@ Ltac xapp_prepare_goal cont :=
   | tag_seq => xseq; [ xuntag tag_apply; cont tt | instantiate; xextract ]
   end.
 
-Ltac xapp_instantiate H args :=
+Ltac xapp_instantiate Sf args :=
   let args := list_boxer_of args in
-  constr:((boxer H)::args).
+  constr:((boxer Sf)::args).
+
+(* [xapp_instantiate_and_apply Sf args xapp_core cont] 
+   instantiate the spec [Sf] on the arguments [args],
+   then calls [xapp_core] on the resulting lemma,
+   then calls the continuation on subgoals
+   then clears [Sf]. *)
+
+Ltac xapp_instantiate_and_apply Sf args xapp_core cont :=
+  let K := xapp_instantiate Sf args in 
+  xapp_core K; 
+  cont tt;
+  clear Sf.
 
 (* [xapp_common] executes [xapp] given
    [H] as specification (or [___]),
@@ -2122,8 +2170,9 @@ Ltac xapp_instantiate H args :=
 
 Ltac xapp_common H E xapp_core cont :=
   xapp_prepare_goal ltac:(fun _ => 
-    let K := xapp_instantiate H E in 
-    xapp_core K; cont tt).
+    let Sf := fresh "Spec" in
+    xapp_use_of_find H Sf; 
+    xapp_instantiate_and_apply Sf E xapp_core cont).
 
 (* helper for [xapp] internal implementation *)
 
@@ -2170,6 +2219,73 @@ Ltac xapp_as_core E X :=
   [ xapp_core ___ (>>) ltac:(fun _ => idtac)   (* = xapp *)
   | instantiate; try xextract ].
 
+
+(* Implementation for [xapp] debugging versions *)
+
+Ltac xapp1_core tt :=
+  xapp_prepare_goal ltac:(fun _ => idtac). 
+
+Ltac xapp2_core tt :=
+  let Sf := fresh "Spec" in
+  xapp_use_of_find ___ Sf.
+
+Ltac xapp2_spec_core H :=
+  let Sf := fresh "Spec" in
+  xapp_use_of_find H Sf.  
+
+Ltac xapp3_core args :=
+  let Sf := get_last_hyp tt in
+  let Sfi := fresh "SpecI" in
+  let K := xapp_instantiate Sf args in 
+  generalize K; intros Sfi. (* ; clear Sf. *)
+
+Ltac xapp4_core tt :=
+  eapply local_wframe; [ xlocal |  |  | ].
+
+Ltac xapp5_core tt :=
+  let K := get_last_hyp tt in
+  sapply K.
+
+Ltac xapp45_core tt :=
+  let K := get_last_hyp tt in
+  xapp_xapply_generic K ltac:(fun _ => idtac) ltac:(fun _ => idtac).
+
+
+(* Notation for [xapp] debugging versions *)
+
+Tactic Notation "xapp1" := xapp1_core tt.
+Tactic Notation "xapp2" := xapp2_core tt.
+Tactic Notation "xapp2_spec" constr(H) := xapp2_spec_core H.
+Tactic Notation "xapp12" := xapp1; xapp2_core tt.
+Tactic Notation "xapp12_spec" constr(H) := xapp1; xapp2_spec_core H.
+Tactic Notation "xapp3" := xapp3_core (>>).
+Tactic Notation "xapp3" constr(args) := xapp3_core args.
+Tactic Notation "xapp4" := xapp4_core tt.
+Tactic Notation "xapp5" := xapp5_core tt.
+Tactic Notation "xapp45" := xapp45_core tt.
+
+(* FUTURE
+
+    - [xapp_1] is like [xapp1]
+    - [xapp_2] is like [xapp1; xapp2]
+    - [xapp_3] is like [xapp1; xapp2; xapp3]
+    - [xapp_4] is like [xapp1; xapp2; xapp3; xapp4]
+    - [xapp_5] is like [xapp1; xapp2; xapp3; xapp4; xapp5]
+
+Tactic Notation "xapp_1" := xapp1.
+Tactic Notation "xapp_2" := xapp1; xapp2.
+Tactic Notation "xapp_2_spec" constr(H) := xapp_1; xapp2_spec H.
+Tactic Notation "xapp_3" := xapp_2; xapp3.
+Tactic Notation "xapp_3" constr(args) := xapp_2; xapp3 args.
+Tactic Notation "xapp_3_spec" constr(H) := xapp_2_spec H; xapp3.
+Tactic Notation "xapp_3_spec" constr(H) constr(args) := xapp_2_spec H; xapp3 args.
+Tactic Notation "xapp_4" := xapp_3; xapp4.
+Tactic Notation "xapp_4" constr(args) := xapp_3 args; xapp4.
+Tactic Notation "xapp_4_spec" constr(H) := xapp_spec H; xapp4.
+Tactic Notation "xapp_4_spec" constr(H) constr(args) := xapp_3_spec H args; xapp4.
+*)
+
+
 (* Notation for [xapp] with automation and with hints *)
 
 Tactic Notation "xapp" := 
@@ -2485,8 +2601,12 @@ Tactic Notation "xapp" "*" constr(E) "as" simple_intropattern(X) :=
 
     Variants:
     
+    - [xcf f] brings to the front of the goal the specification for [f].
+
     - [xcf_show]  will only display the CF lemma found in the database,
       putting it in a fresh hypothesis.
+
+    - [xcf_show f] is similar, only [f] is provided explicitly.
 *)
 
  (* TODO: extend to support partial application *)
@@ -2526,20 +2646,56 @@ Ltac xcf_core_app f :=
   intros [_ H]; (* curried part not needed *)
   xcf_core_app_exploit H. (* todo: might need sapply here *)
 
+Ltac xcf_top_value f := 
+  xcf_find f; 
+  let Sf := fresh "Spec" in 
+  intros Sf;
+  try (rewrite Sf; clear Sf).
+
 Ltac xcf_core tt :=
+  intros;
   match goal with 
   | |- spec ?f ?n ?P => xcf_core_spec f 
   | |- app ?f ?xs ?H ?Q => xcf_core_app f
   | |- tag tag_apply (app ?f ?xs ?H ?Q) => xuntag tag_apply; xcf_core_app f
-  end .
+  | |- ?f = _ => xcf_top_value f
+  | _ => fail 1 "need to call [xcf f; => H], where [f] is the name of the definition"
+  end.
 
 Tactic Notation "xcf" := 
   xcf_core tt.
 
+Tactic Notation "xcf" constr(f) := 
+  xcf_find f;
+  try match goal with |- tag tag_top_val _ -> _ => 
+    let H := fresh in intros H; hnf in H; revert H end.
+
+Ltac xcf_show_name f :=
+  let H := fresh "S" (*f*) in intros H;
+  try match type of H with tag tag_top_val _ => hnf in H end.
+  (* TODO: can't we make a name based on f? *)
+
+Ltac xcf_show_core tt :=
+  intros; 
+  let f := 
+    match goal with 
+    | |- spec ?f ?n ?P => constr:(f)
+    | |- app ?f ?xs ?H ?Q => constr:(f)
+    | |- tag tag_apply (app ?f ?xs ?H ?Q) => constr:(f)
+    | |- ?f = _ => constr:(f)
+    | _ => fail 1 "need to call [xcf_show f], where [f] is the name of the definition"
+    end in
+  xcf_find f; xcf_show_name f.
+
 Tactic Notation "xcf_show" := 
-  let f := cfml_get_goal_fun tt in xcf_find f;
-  let H := fresh "S" f in intros H.
+  xcf_show_core tt.
+
+Tactic Notation "xcf_show" constr(f) := 
+  xcf_find f; xcf_show_name f.
+
 
+Tactic Notation "xcf" "~" := xcf; xauto_tilde.
+Tactic Notation "xcf" "*" := xcf; xauto_star.
 
 
 (********************************************************************)

lib/coq/Makefile

@@ -19,11 +19,11 @@ SRC :=\
 	CFPrint \
 	CFHeader \
 	CFTactics \
-	CFRep \
 	CFLib 
 
 # CFLibCredits \
 # CFLibCreditsNat
+#	CFRep \
 
 V := $(SRC:=.v)