src/HOL/ex/Sketch_and_Explore.thy
changeset 78820 b356019e8d49
parent 74525 c960bfcb91db
child 79799 2746dfc9ceae
equal deleted inserted replaced
78819:b8775a63cb35 78820:b356019e8d49
     4 
     4 
     5 chapter \<open>Experimental commands \<^text>\<open>sketch\<close> and \<^text>\<open>explore\<close>\<close>
     5 chapter \<open>Experimental commands \<^text>\<open>sketch\<close> and \<^text>\<open>explore\<close>\<close>
     6 
     6 
     7 theory Sketch_and_Explore
     7 theory Sketch_and_Explore
     8   imports Main \<comment> \<open>TODO: generalize existing sledgehammer functions to Pure\<close>
     8   imports Main \<comment> \<open>TODO: generalize existing sledgehammer functions to Pure\<close>
     9   keywords "sketch" "explore" :: diag
     9   keywords "sketch" "nxsketch" "explore" :: diag
    10 begin
    10 begin
    11 
    11 
    12 ML \<open>
    12 ML \<open>
    13 fun split_clause t =
    13 fun split_clause t =
    14   let
    14   let
    61       [prefix ^ "  " ^ (if is_none if_s then "" else "using that ") ^ "sorry"]);
    61       [prefix ^ "  " ^ (if is_none if_s then "" else "using that ") ^ "sorry"]);
    62   in
    62   in
    63     s
    63     s
    64   end;
    64   end;
    65 
    65 
    66 fun print_sketch ctxt method_text clauses =
    66 fun print_nonext_sketch ctxt method_text clauses =
    67   "proof" ^ method_text :: map (print_isar_skeleton ctxt 2 "show") clauses @ ["qed"];
    67   "proof" ^ method_text :: map (print_isar_skeleton ctxt 2 "show") clauses @ ["qed"];
       
    68 
       
    69 fun print_next_skeleton ctxt indent keyword stmt =
       
    70   let
       
    71     val ((fixes, assms, concl), ctxt') = eigen_context_for_statement stmt ctxt;
       
    72     val prefix = replicate_string indent " ";
       
    73     val prefix_sep = "\n" ^ prefix ^ "    and ";
       
    74     val show_s = prefix ^ keyword ^ " " ^ print_term ctxt' concl;
       
    75     val assumes_s = if null assms then NONE
       
    76       else SOME (prefix ^ "  assume " ^ space_implode prefix_sep
       
    77         (map (print_term ctxt') assms));
       
    78     val fixes_s = if null fixes then NONE
       
    79       else SOME (prefix ^ "fix " ^ space_implode prefix_sep
       
    80         (map (fn (v, T) => v ^ " :: " ^ print_typ ctxt T) fixes));
       
    81     val s = cat_lines (map_filter I [fixes_s, assumes_s] @ [show_s] @ [prefix ^ " sorry"]);
       
    82   in
       
    83     s
       
    84   end;
       
    85 
       
    86 fun print_next_sketch ctxt method_text clauses =
       
    87   "proof" ^ method_text :: separate "next" (map (print_next_skeleton ctxt 2 "show") clauses) @ ["qed"];
       
    88 
       
    89 fun print_sketch ctxt method_text [cl] = print_next_sketch ctxt method_text [cl]
       
    90   | print_sketch ctxt method_text clauses = print_nonext_sketch ctxt method_text clauses;
    68 
    91 
    69 fun print_exploration ctxt method_text [clause] =
    92 fun print_exploration ctxt method_text [clause] =
    70     ["proof -", print_isar_skeleton ctxt 2 "have" clause,
    93     ["proof -", print_isar_skeleton ctxt 2 "have" clause,
    71       "  then show ?thesis", "    by" ^ method_text, "qed"]
    94       "  then show ?thesis", "    by" ^ method_text, "qed"]
    72   | print_exploration ctxt method_text (clause :: clauses) =
    95   | print_exploration ctxt method_text (clause :: clauses) =
   108     (state |> tap (fn _ => Output.information message))
   131     (state |> tap (fn _ => Output.information message))
   109   end
   132   end
   110 
   133 
   111 val sketch = print_proof_text_from_state print_sketch;
   134 val sketch = print_proof_text_from_state print_sketch;
   112 
   135 
       
   136 val next_sketch = print_proof_text_from_state print_next_sketch;
       
   137 
   113 fun explore method_ref = print_proof_text_from_state print_exploration (SOME method_ref);
   138 fun explore method_ref = print_proof_text_from_state print_exploration (SOME method_ref);
   114 
   139 
   115 fun sketch_cmd some_method_text =
   140 fun sketch_cmd some_method_text =
   116   Toplevel.keep_proof (K () o sketch some_method_text o Toplevel.proof_of)
   141   Toplevel.keep_proof (K () o sketch some_method_text o Toplevel.proof_of)
       
   142 
       
   143 fun next_sketch_cmd some_method_text =
       
   144   Toplevel.keep_proof (K () o next_sketch some_method_text o Toplevel.proof_of)
   117 
   145 
   118 fun explore_cmd method_text =
   146 fun explore_cmd method_text =
   119   Toplevel.keep_proof (K () o explore method_text o Toplevel.proof_of)
   147   Toplevel.keep_proof (K () o explore method_text o Toplevel.proof_of)
   120 
   148 
   121 val _ =
   149 val _ =
   122   Outer_Syntax.command \<^command_keyword>\<open>sketch\<close>
   150   Outer_Syntax.command \<^command_keyword>\<open>sketch\<close>
   123     "print sketch of Isar proof text after method application"
   151     "print sketch of Isar proof text after method application"
   124     (Scan.option (Scan.trace Method.parse) >> sketch_cmd);
   152     (Scan.option (Scan.trace Method.parse) >> sketch_cmd);
   125 
   153 
   126 val _ =
   154 val _ =
       
   155   Outer_Syntax.command \<^command_keyword>\<open>nxsketch\<close>
       
   156     "print sketch of Isar proof text after method application"
       
   157     (Scan.option (Scan.trace Method.parse) >> next_sketch_cmd);
       
   158 
       
   159 val _ =
   127   Outer_Syntax.command \<^command_keyword>\<open>explore\<close>
   160   Outer_Syntax.command \<^command_keyword>\<open>explore\<close>
   128     "explore proof obligations after method application as Isar proof text"
   161     "explore proof obligations after method application as Isar proof text"
   129     (Scan.trace Method.parse >> explore_cmd);
   162     (Scan.trace Method.parse >> explore_cmd);
   130 \<close>
   163 \<close>
   131 
   164