1.1 --- a/src/Tools/isac/Build_Isac.thy Thu Aug 22 16:48:04 2019 +0200
1.2 +++ b/src/Tools/isac/Build_Isac.thy Fri Aug 23 16:36:47 2019 +0200
1.3 @@ -1,30 +1,36 @@
1.4 -(* Title: build the Isac Mathengine
1.5 +(* Title: build the Isac Mathengine & Knowledge
1.6 Author: Walther Neuper, TU Graz, 100808
1.7 (c) due to copyright terms
1.8
1.9 For creating a heap image of isac see ~~/ROOT.
1.10 -For debugging see text at begin (theory dependencies!)
1.11 +For debugging see text at begin below (theory dependencies!)
1.12
1.13 -ATTENTION: no errors in this theory do not mean that there are no errors in Isac;
1.14 -errors are rigorously detected when creating a heap.
1.15 +ATTENTION: no errors in this theory do not mean that there are no errors in Isac ..
1.16 +.. open theories collecting files from folders: CalcElements.thy, ProgLang.thy etc.
1.17 +Errors are rigorously detected when creating a heap.
1.18 *)
1.19
1.20 theory Build_Isac
1.21 imports
1.22 -(* structure inherited from migration which began with Isabelle2009. improve?
1.23 - theory KEStore
1.24 - ML_file "~~/src/Tools/isac/library.sml"
1.25 - ML_file "~~/src/Tools/isac/ThydataC/rule.sml"
1.26 - ML_file "~~/src/Tools/isac/calcelems.sml"
1.27 - theory ListC
1.28 - imports "~~/src/Tools/isac/KEStore"
1.29 - ML_file "~~/src/Tools/isac/ProgLang/termC.sml"
1.30 - ML_file "~~/src/Tools/isac/ProgLang/contextC.sml"
1.31 - ML_file "~~/src/Tools/isac/ProgLang/calculate.sml"
1.32 - ML_file "~~/src/Tools/isac/ProgLang/rewrite.sml"
1.33 - theory Tools imports ListC begin
1.34 +(* see dependency graph
1.35 + ~$ evince file:///home/wneuper/.isabelle/isabisac/browser_info/Unsorted/Isac/session_graph.pdf &
1.36 +*)
1.37 +(* theory KEStore imports Complex_Main
1.38 + ML_file "~~/src/Tools/isac/CalcElements/libraryC.sml"
1.39 + ML_file "~~/src/Tools/isac/CalcElements/rule.sml"
1.40 + ML_file "~~/src/Tools/isac/CalcElements/calcelems.sml"
1.41 + theory ListC imports KEStore
1.42 + ML_file "~~/src/Tools/isac/CalcElements/termC.sml"
1.43 + ML_file "~~/src/Tools/isac/CalcElements/contextC.sml"
1.44 + theory CalcElements imports ListC
1.45 +*) "CalcElements/CalcElements"
1.46 +
1.47 +(* theory Tools imports ListC begin
1.48 + ML_file "~~/src/Tools/isac/ProgLang/calculate.sml"
1.49 + ML_file "~~/src/Tools/isac/ProgLang/rewrite.sml"
1.50 theory Program imports Tools begin
1.51 - theory Atools imports Descript Program
1.52 + ML_file "~~/src/Tools/isac/ProgLang/program.sml" ? really separate?
1.53 + theory Atools imports Delete Descript Program
1.54 ML_file "~~/src/Tools/isac/ProgLang/scrtools.sml"
1.55 theory ProgLang imports Atools
1.56 *) "ProgLang/ProgLang"
2.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
2.2 +++ b/src/Tools/isac/CalcElements/CalcElements.thy Fri Aug 23 16:36:47 2019 +0200
2.3 @@ -0,0 +1,11 @@
2.4 +(* Title: collect all defitions for both, ProgLang/ & Interpret/
2.5 + Author: Walther Neuper 190823
2.6 + (c) due to copyright terms
2.7 +*)
2.8 +theory CalcElements imports ListC
2.9 +begin
2.10 +ML \<open>
2.11 +\<close> ML \<open>
2.12 +\<close> ML \<open>
2.13 +\<close>
2.14 +end
2.15 \ No newline at end of file
3.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
3.2 +++ b/src/Tools/isac/CalcElements/KEStore.thy Fri Aug 23 16:36:47 2019 +0200
3.3 @@ -0,0 +1,240 @@
3.4 +(* Title: src/Tools/isac/KEStore.thy
3.5 + Author: Mathias Lehnfeld
3.6 +*)
3.7 +
3.8 +theory KEStore imports Complex_Main
3.9 +
3.10 +begin
3.11 +ML_file libraryC.sml
3.12 +ML_file rule.sml
3.13 +ML_file calcelems.sml
3.14 +
3.15 +ML \<open>
3.16 +\<close> ML \<open>
3.17 +\<close> text \<open>
3.18 +/usr/local/isabisac/src/Tools/isac/CalcElements/library.sml
3.19 +\<close>
3.20 +section \<open>Knowledge elements for problems and methods\<close>
3.21 +ML \<open>
3.22 +(* Knowledge (and Exercises) are held by "KEStore" in Isac's Java front-end.
3.23 + In the front-end Knowledge comprises theories, problems and methods.
3.24 + Elements of problems and methods are defined in theories alongside
3.25 + the development of respective language elements.
3.26 + However, the structure of methods and problems is independent from theories'
3.27 + deductive structure. Thus respective structures are built in Build_Thydata.thy.
3.28 +
3.29 + Most elements of problems and methods are implemented in "Knowledge/", but some
3.30 + of them are implemented in "ProgLang/" already; thus "KEStore.thy" got this
3.31 + location in the directory structure.
3.32 +
3.33 + get_* retrieves all * of the respective theory PLUS of all ancestor theories.
3.34 +*)
3.35 +signature KESTORE_ELEMS =
3.36 +sig
3.37 + val get_rlss: theory -> (Rule.rls' * (Rule.theory' * Rule.rls)) list
3.38 + val add_rlss: (Rule.rls' * (Rule.theory' * Rule.rls)) list -> theory -> theory
3.39 + val get_calcs: theory -> (Rule.prog_calcID * (Rule.calID * Rule.eval_fn)) list
3.40 + val add_calcs: (Rule.prog_calcID * (Rule.calID * Rule.eval_fn)) list -> theory -> theory
3.41 + val get_cas: theory -> Celem.cas_elem list
3.42 + val add_cas: Celem.cas_elem list -> theory -> theory
3.43 + val get_ptyps: theory -> Celem.ptyps
3.44 + val add_pbts: (Celem.pbt * Celem.pblID) list -> theory -> theory
3.45 + val get_mets: theory -> Celem.mets
3.46 + val add_mets: (Celem.met * Celem.metID) list -> theory -> theory
3.47 + val get_thes: theory -> (Celem.thydata Celem.ptyp) list
3.48 + val add_thes: (Celem.thydata * Celem.theID) list -> theory -> theory (* thydata dropped at existing elems *)
3.49 + val insert_fillpats: (Celem.theID * Celem.fillpat list) list -> theory -> theory
3.50 + val get_ref_thy: unit -> theory
3.51 + val set_ref_thy: theory -> unit
3.52 +end;
3.53 +
3.54 +structure KEStore_Elems: KESTORE_ELEMS =
3.55 +struct
3.56 + fun union_overwrite eq l1 l2 = fold (insert eq) l2 (*..swapped..*) l1;
3.57 +
3.58 + structure Data = Theory_Data (
3.59 + type T = (Rule.rls' * (Rule.theory' * Rule.rls)) list;
3.60 + val empty = [];
3.61 + val extend = I;
3.62 + val merge = Celem.merge_rlss;
3.63 + );
3.64 + fun get_rlss thy = Data.get thy
3.65 + fun add_rlss rlss = Data.map (union_overwrite Celem.rls_eq rlss)
3.66 +
3.67 + structure Data = Theory_Data (
3.68 + type T = (Rule.prog_calcID * (Rule.calID * Rule.eval_fn)) list;
3.69 + val empty = [];
3.70 + val extend = I;
3.71 + val merge = merge Rule.calc_eq;
3.72 + );
3.73 + fun get_calcs thy = Data.get thy
3.74 + fun add_calcs calcs = Data.map (union_overwrite Rule.calc_eq calcs)
3.75 +
3.76 + structure Data = Theory_Data (
3.77 + type T = (term * (Celem.spec * (term list -> (term * term list) list))) list;
3.78 + val empty = [];
3.79 + val extend = I;
3.80 + val merge = merge Celem.cas_eq;
3.81 + );
3.82 + fun get_cas thy = Data.get thy
3.83 + fun add_cas cas = Data.map (union_overwrite Celem.cas_eq cas)
3.84 +
3.85 + structure Data = Theory_Data (
3.86 + type T = Celem.ptyps;
3.87 + val empty = [Celem.e_Ptyp];
3.88 + val extend = I;
3.89 + val merge = Celem.merge_ptyps;
3.90 + );
3.91 + fun get_ptyps thy = Data.get thy;
3.92 + fun add_pbts pbts thy = let
3.93 + fun add_pbt (pbt as {guh,...}, pblID) =
3.94 + (* the pblID has the leaf-element as first; better readability achieved *)
3.95 + (if (!Celem.check_guhs_unique) then Celem.check_pblguh_unique guh (Data.get thy) else ();
3.96 + rev pblID |> Celem.insrt pblID pbt);
3.97 + in Data.map (fold add_pbt pbts) thy end;
3.98 +
3.99 + structure Data = Theory_Data (
3.100 + type T = Celem.mets;
3.101 + val empty = [Celem.e_Mets];
3.102 + val extend = I;
3.103 + val merge = Celem.merge_ptyps;
3.104 + );
3.105 + val get_mets = Data.get;
3.106 + fun add_mets mets thy = let
3.107 + fun add_met (met as {guh,...}, metID) =
3.108 + (if (!Celem.check_guhs_unique) then Celem.check_metguh_unique guh (Data.get thy) else ();
3.109 + Celem.insrt metID met metID);
3.110 + in Data.map (fold add_met mets) thy end;
3.111 +
3.112 + structure Data = Theory_Data (
3.113 + type T = (Celem.thydata Celem.ptyp) list;
3.114 + val empty = [];
3.115 + val extend = I;
3.116 + val merge = Celem.merge_ptyps; (* relevant for store_thm, store_rls *)
3.117 + );
3.118 + fun get_thes thy = Data.get thy
3.119 + fun add_thes thes thy = let
3.120 + fun add_the (thydata, theID) = Celem.add_thydata ([], theID) thydata
3.121 + in Data.map (fold add_the thes) thy end;
3.122 + fun insert_fillpats fis thy =
3.123 + let
3.124 + fun update_elem (theID, fillpats) =
3.125 + let
3.126 + val hthm = Celem.get_py (Data.get thy) theID theID
3.127 + val hthm' = Celem.update_hthm hthm fillpats
3.128 + handle ERROR _ =>
3.129 + error ("insert_fillpats: " ^ strs2str theID ^ "must address a theorem")
3.130 + in Celem.update_ptyps theID theID hthm' end
3.131 + in Data.map (fold update_elem fis) thy end
3.132 +
3.133 + val cur_thy = Synchronized.var "finally_knowledge_complete" @{theory};
3.134 + fun set_ref_thy thy = Synchronized.change cur_thy (fn _ => thy); (* never RE-set ! *)
3.135 + fun get_ref_thy () = Synchronized.value cur_thy;
3.136 +end;
3.137 +\<close>
3.138 +
3.139 +section \<open>Re-use existing access functions for knowledge elements\<close>
3.140 +text \<open>
3.141 + The independence of problems' and methods' structure enforces the accesse
3.142 + functions to use "Isac", the final theory which comprises all knowledge defined.
3.143 +\<close>
3.144 +ML \<open>
3.145 +val get_ref_thy = KEStore_Elems.get_ref_thy;
3.146 +
3.147 +fun assoc_rls (rls' : Rule.rls') =
3.148 + case AList.lookup (op =) (KEStore_Elems.get_rlss (Rule.Thy_Info_get_theory "Isac")) rls' of
3.149 + SOME (_, rls) => rls
3.150 + | NONE => raise ERROR ("rls \""^ rls' ^ "\" missing in KEStore.\n" ^
3.151 + "TODO exception hierarchy needs to be established.")
3.152 +
3.153 +fun assoc_rls' thy (rls' : Rule.rls') =
3.154 + case AList.lookup (op =) (KEStore_Elems.get_rlss thy) rls' of
3.155 + SOME (_, rls) => rls
3.156 + | NONE => raise ERROR ("rls \""^ rls' ^ "\" missing in KEStore.\n" ^
3.157 + "TODO exception hierarchy needs to be established.")
3.158 +
3.159 +fun assoc_calc thy calID = let
3.160 + fun ass ([], key) =
3.161 + error ("assoc_calc: '" ^ key ^ "' not found in theory " ^ (Context.theory_name thy))
3.162 + | ass ((calc, (keyi, _)) :: pairs, key) =
3.163 + if key = keyi then calc else ass (pairs, key);
3.164 + in ass (thy |> KEStore_Elems.get_calcs, calID) end;
3.165 +
3.166 +fun assoc_calc' thy key = let
3.167 + fun ass ([], key') =
3.168 + error ("assoc_calc': '" ^ key' ^ "' not found in theory " ^ (Context.theory_name thy))
3.169 + | ass ((all as (keyi, _)) :: pairs, key') =
3.170 + if key' = keyi then all else ass (pairs, key');
3.171 + in ass (KEStore_Elems.get_calcs thy, key) end;
3.172 +
3.173 +fun assoc_cas thy key = assoc (KEStore_Elems.get_cas thy, key);
3.174 +
3.175 +fun get_ptyps () = get_ref_thy () |> KEStore_Elems.get_ptyps;
3.176 +fun get_mets () = get_ref_thy () |> KEStore_Elems.get_mets;
3.177 +fun get_thes () = get_ref_thy () |> KEStore_Elems.get_thes;
3.178 +\<close>
3.179 +setup \<open>KEStore_Elems.add_rlss
3.180 + [("e_rls", (Context.theory_name @{theory}, Rule.e_rls)),
3.181 + ("e_rrls", (Context.theory_name @{theory}, Rule.e_rrls))]\<close>
3.182 +
3.183 +section \<open>determine sequence of main parts in thehier\<close>
3.184 +setup \<open>
3.185 +KEStore_Elems.add_thes
3.186 + [(Celem.Html {guh = Celem.part2guh ["IsacKnowledge"], html = "",
3.187 + mathauthors = ["Isac team"], coursedesign = []}, ["IsacKnowledge"]),
3.188 + (Celem.Html {guh = Celem.part2guh ["Isabelle"], html = "",
3.189 + mathauthors = ["Isabelle team, TU Munich"], coursedesign = []}, ["Isabelle"]),
3.190 + (Celem.Html {guh = Celem.part2guh ["IsacScripts"], html = "",
3.191 + mathauthors = ["Isac team"], coursedesign = []}, ["IsacScripts"])]
3.192 +\<close>
3.193 +
3.194 +section \<open>Functions for checking KEStore_Elems\<close>
3.195 +ML \<open>
3.196 +fun short_string_of_rls Rule.Erls = "Erls"
3.197 + | short_string_of_rls (Rule.Rls {calc, rules, ...}) =
3.198 + "Rls {#calc = " ^ string_of_int (length calc) ^
3.199 + ", #rules = " ^ string_of_int (length rules) ^ ", ..."
3.200 + | short_string_of_rls (Rule.Seq {calc, rules, ...}) =
3.201 + "Seq {#calc = " ^ string_of_int (length calc) ^
3.202 + ", #rules = " ^ string_of_int (length rules) ^ ", ..."
3.203 + | short_string_of_rls (Rule.Rrls _) = "Rrls {...}";
3.204 +fun check_kestore_rls (rls', (thyID, rls)) =
3.205 + "(" ^ rls' ^ ", (" ^ thyID ^ ", " ^ short_string_of_rls rls ^ "))";
3.206 +
3.207 +fun check_kestore_calc ((id, (c, _)) : Rule.calc) = "(" ^ id ^ ", (" ^ c ^ ", fn))";
3.208 +
3.209 +fun check_kestore_cas ((t, (s, _)) : Celem.cas_elem) =
3.210 + "(" ^ (Rule.term_to_string''' @{theory} t) ^ ", " ^ (Celem.spec2str s) ^ ")";
3.211 +
3.212 +fun count_kestore_ptyps [] = 0
3.213 + | count_kestore_ptyps ((Celem.Ptyp (_, _, ps)) :: ps') =
3.214 + 1 + count_kestore_ptyps ps + count_kestore_ptyps ps';
3.215 +fun check_kestore_ptyp' strfun (Celem.Ptyp (key, pbts, pts)) = "Ptyp (" ^ (quote key) ^ ", " ^
3.216 + (strfun pbts) ^ ", " ^ (map (check_kestore_ptyp' strfun) pts |> list2str) ^ ")" |> Celem.linefeed;
3.217 +val check_kestore_ptyp = check_kestore_ptyp' Celem.pbts2str;
3.218 +fun ptyp_ord ((Celem.Ptyp (s1, _, _)), (Celem.Ptyp (s2, _, _))) = string_ord (s1, s2);
3.219 +fun pbt_ord ({guh = guh'1, ...} : Celem.pbt, {guh = guh'2, ...} : Celem.pbt) = string_ord (guh'1, guh'2);
3.220 +fun sort_kestore_ptyp' _ [] = []
3.221 + | sort_kestore_ptyp' ordfun ((Celem.Ptyp (key, pbts, ps)) :: ps') =
3.222 + ((Celem.Ptyp (key, sort ordfun pbts, sort_kestore_ptyp' ordfun ps |> sort ptyp_ord))
3.223 + :: sort_kestore_ptyp' ordfun ps');
3.224 +val sort_kestore_ptyp = sort_kestore_ptyp' pbt_ord;
3.225 +
3.226 +fun metguh2str ({guh,...} : Celem.met) = guh : string;
3.227 +fun check_kestore_met (mp: Celem.met Celem.ptyp) =
3.228 + check_kestore_ptyp' (fn xs => map metguh2str xs |> strs2str) mp;
3.229 +fun met_ord ({guh = guh'1, ...} : Celem.met, {guh = guh'2, ...} : Celem.met) = string_ord (guh'1, guh'2);
3.230 +val sort_kestore_met = sort_kestore_ptyp' met_ord;
3.231 +
3.232 +fun check_kestore_thes thes = ((map writeln) o (map (check_kestore_ptyp' Celem.thes2str))) thes
3.233 +fun write_thes thydata_list =
3.234 + thydata_list
3.235 + |> map (fn (id, the) => (Celem.theID2str id, Celem.the2str the))
3.236 + |> map pair2str
3.237 + |> map writeln
3.238 +\<close>
3.239 +ML \<open>
3.240 +\<close> ML \<open>
3.241 +\<close> ML \<open>
3.242 +\<close>
3.243 +end
4.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
4.2 +++ b/src/Tools/isac/CalcElements/ListC.thy Fri Aug 23 16:36:47 2019 +0200
4.3 @@ -0,0 +1,185 @@
4.4 +(* Title: functions on lists for Programs
4.5 + Author: Walther Neuper 0108
4.6 + (c) due to copyright terms
4.7 +*)
4.8 +
4.9 +theory ListC imports KEStore
4.10 +
4.11 +begin
4.12 +ML_file termC.sml
4.13 +ML_file contextC.sml
4.14 +
4.15 +ML \<open>
4.16 +\<close> ML \<open>
4.17 +\<close> ML \<open>
4.18 +\<close>
4.19 +
4.20 +subsection \<open>Notes on Isac's programming language\<close>
4.21 +text \<open>
4.22 + Isac's programming language combines tacticals (TRY, etc) and
4.23 + tactics (Rewrite, etc) with list processing.
4.24 +
4.25 + In order to distinguish list expressions of the meta (programming)
4.26 + language from the object language in Lucas-Interpretation, a
4.27 + new 'type xlist' is introduced.
4.28 + TODO: Switch the role of 'xlist' and 'list' (the former only used
4.29 + by InsSort.thy)
4.30 +
4.31 + Isac's programming language preceeded the function package
4.32 + in 2002. For naming "axiomatization" is used for reasons of uniformity
4.33 + with the other replacements for "axioms".
4.34 + Another reminiscence from Isabelle2002 are Isac-specific numerals,
4.35 + introduced in order to have floating point numerals at a time,
4.36 + when Isabelle did not consider that requirement. For the sake of uniformity
4.37 + 'nat' from List.thy is replaced by 'real' by 'fun parse',
4.38 + however, 'fun parseNEW' has started to replace this fix (after finishing
4.39 + this fix, there will be a 'rename all parseNEW --> parse).
4.40 +
4.41 + Note: *one* "axiomatization" over all equations caused strange "'a list list"
4.42 + types.
4.43 +\<close>
4.44 +
4.45 +subsection \<open>Type 'xlist' for Lucas-Interpretation\<close>
4.46 +(* cp fom ~~/src/HOL/List.thy
4.47 + TODO: ask for shorter deliminters in xlist *)
4.48 +datatype 'a xlist =
4.49 + XNil ("{|| ||}")
4.50 + | XCons (xhd: 'a) (xtl: "'a xlist") (infixr "@#" 65)
4.51 +
4.52 +syntax
4.53 + \<comment> \<open>list Enumeration\<close>
4.54 + "_xlist" :: "args => 'a xlist" ("{|| (_) ||}")
4.55 +
4.56 +translations
4.57 + "{||x, xs||}" == "x@#{||xs||}"
4.58 + "{||x||}" == "x@#{|| ||}"
4.59 +
4.60 +term "{|| ||}"
4.61 +term "{||1,2,3||}"
4.62 +
4.63 +subsection \<open>Functions for 'xlist'\<close>
4.64 +(* TODO:
4.65 +(1) revise, if definition of identifiers like LENGTH_NIL are still required.
4.66 +(2) switch the role of 'xlist' and 'list' in the functions below, in particular for
4.67 + 'foldr', 'foldr_Nil', 'foldr_Cons' and 'xfoldr', 'xfoldr_Nil', 'xfoldr_Cons'.
4.68 + For transition phase just outcomment InsSort.thy and inssort.sml.
4.69 +*)
4.70 +
4.71 +primrec xfoldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a xlist \<Rightarrow> 'b \<Rightarrow> 'b" where
4.72 +xfoldr_Nil: "xfoldr f {|| ||} = id" |
4.73 +xfoldr_Cons: "xfoldr f (x @# xs) = f x \<circ> xfoldr f xs"
4.74 +
4.75 +primrec LENGTH :: "'a list => real"
4.76 +where
4.77 +LENGTH_NIL: "LENGTH [] = 0" |
4.78 +LENGTH_CONS: "LENGTH (x#xs) = 1 + LENGTH xs"
4.79 +
4.80 +consts NTH :: "[real, 'a list] => 'a"
4.81 +axiomatization where
4.82 +NTH_NIL: "NTH 1 (x # xs) = x" and
4.83 +NTH_CONS: (*NO primrec, fun ..*)"1 < n ==> NTH n (x # xs) = NTH (n + -1) xs"
4.84 +
4.85 +(* redefine together with identifiers (still) required for KEStore ..*)
4.86 +axiomatization where
4.87 +hd_thm: "hd (x # xs) = x"
4.88 +
4.89 +axiomatization where
4.90 +tl_Nil: "tl [] = []" and
4.91 +tl_Cons: "tl (x # xs) = xs"
4.92 +
4.93 +axiomatization where
4.94 +LAST: "last (x # xs) = (if xs = [] then x else last xs)"
4.95 +
4.96 +axiomatization where
4.97 +butlast_Nil: "butlast [] = []" and
4.98 +butlast_Cons: "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
4.99 +
4.100 +axiomatization where
4.101 +map_Nil:"map f [] = []" and
4.102 +map_Cons: "map f (x # xs) = f x # map f xs"
4.103 +
4.104 +axiomatization where
4.105 +rev_Nil: "rev [] = []" and
4.106 +rev_Cons: "rev (x # xs) = rev xs @ [x]"
4.107 +
4.108 +axiomatization where
4.109 +filter_Nil: "filter P [] = []" and
4.110 +filter_Cons: "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"
4.111 +
4.112 +axiomatization where
4.113 +concat_Nil: "concat [] = []" and
4.114 +concat_Cons: "concat (x # xs) = x @ concat xs"
4.115 +
4.116 +axiomatization where
4.117 +takeWhile_Nil: "takeWhile P [] = []" and
4.118 +takeWhile_Cons: "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"
4.119 +
4.120 +axiomatization where
4.121 +dropWhile_Nil: "dropWhile P [] = []" and
4.122 +dropWhile_Cons: "dropWhile P (x # xs) = (if P x then dropWhile P xs else x#xs)"
4.123 +
4.124 +axiomatization where
4.125 +zip_Nil: "zip xs [] = []" and
4.126 +zip_Cons: "zip xs (y # ys) = (case xs of [] => [] | z # zs => (z,y) # zip zs ys)"
4.127 +
4.128 +axiomatization where
4.129 +distinct_Nil: "distinct [] = True" and
4.130 +distinct_Cons: "distinct (x # xs) = (x ~: set xs & distinct xs)"
4.131 +
4.132 +axiomatization where
4.133 +remdups_Nil: "remdups [] = []" and
4.134 +remdups_Cons: "remdups (x#xs) = (if x : set xs then remdups xs else x # remdups xs)"
4.135 +
4.136 +ML\<open>
4.137 +(** rule set for evaluating listexpr in scripts, will be extended in several thys **)
4.138 +val list_rls =
4.139 + Rule.Rls {id = "list_rls", preconds = [], rew_ord = ("dummy_ord", Rule.dummy_ord),
4.140 + erls = Rule.Erls, srls = Rule.Erls, calc = [], errpatts = [],
4.141 + rules = [Rule.Thm ("refl", TermC.num_str @{thm refl}), (*'a<>b -> FALSE' by fun eval_equal*)
4.142 + Rule.Thm ("o_apply", TermC.num_str @{thm o_apply}),
4.143 +
4.144 + Rule.Thm ("NTH_CONS",TermC.num_str @{thm NTH_CONS}),(*erls for cond. in Atools.ML*)
4.145 + Rule.Thm ("NTH_NIL",TermC.num_str @{thm NTH_NIL}),
4.146 + Rule.Thm ("append_Cons",TermC.num_str @{thm append_Cons}),
4.147 + Rule.Thm ("append_Nil",TermC.num_str @{thm append_Nil}),
4.148 +(* Thm ("butlast_Cons",num_str @{thm butlast_Cons}),
4.149 + Thm ("butlast_Nil",num_str @{thm butlast_Nil}),*)
4.150 + Rule.Thm ("concat_Cons",TermC.num_str @{thm concat_Cons}),
4.151 + Rule.Thm ("concat_Nil",TermC.num_str @{thm concat_Nil}),
4.152 +(* Rule.Thm ("del_base",num_str @{thm del_base}),
4.153 + Rule.Thm ("del_rec",num_str @{thm del_rec}), *)
4.154 +
4.155 + Rule.Thm ("distinct_Cons",TermC.num_str @{thm distinct_Cons}),
4.156 + Rule.Thm ("distinct_Nil",TermC.num_str @{thm distinct_Nil}),
4.157 + Rule.Thm ("dropWhile_Cons",TermC.num_str @{thm dropWhile_Cons}),
4.158 + Rule.Thm ("dropWhile_Nil",TermC.num_str @{thm dropWhile_Nil}),
4.159 + Rule.Thm ("filter_Cons",TermC.num_str @{thm filter_Cons}),
4.160 + Rule.Thm ("filter_Nil",TermC.num_str @{thm filter_Nil}),
4.161 + Rule.Thm ("foldr_Cons",TermC.num_str @{thm foldr_Cons}),
4.162 + Rule.Thm ("foldr_Nil",TermC.num_str @{thm foldr_Nil}),
4.163 + Rule.Thm ("hd_thm",TermC.num_str @{thm hd_thm}),
4.164 + Rule.Thm ("LAST",TermC.num_str @{thm LAST}),
4.165 + Rule.Thm ("LENGTH_CONS",TermC.num_str @{thm LENGTH_CONS}),
4.166 + Rule.Thm ("LENGTH_NIL",TermC.num_str @{thm LENGTH_NIL}),
4.167 +(* Rule.Thm ("list_diff_def",num_str @{thm list_diff_def}),*)
4.168 + Rule.Thm ("map_Cons",TermC.num_str @{thm map_Cons}),
4.169 + Rule.Thm ("map_Nil",TermC.num_str @{thm map_Cons}),
4.170 +(* Rule.Thm ("mem_Cons",TermC.num_str @{thm mem_Cons}),
4.171 + Rule.Thm ("mem_Nil",TermC.num_str @{thm mem_Nil}), *)
4.172 +(* Rule.Thm ("null_Cons",TermC.num_str @{thm null_Cons}),
4.173 + Rule.Thm ("null_Nil",TermC.num_str @{thm null_Nil}),*)
4.174 + Rule.Thm ("remdups_Cons",TermC.num_str @{thm remdups_Cons}),
4.175 + Rule.Thm ("remdups_Nil",TermC.num_str @{thm remdups_Nil}),
4.176 + Rule.Thm ("rev_Cons",TermC.num_str @{thm rev_Cons}),
4.177 + Rule.Thm ("rev_Nil",TermC.num_str @{thm rev_Nil}),
4.178 + Rule.Thm ("take_Nil",TermC.num_str @{thm take_Nil}),
4.179 + Rule.Thm ("take_Cons",TermC.num_str @{thm take_Cons}),
4.180 + Rule.Thm ("tl_Cons",TermC.num_str @{thm tl_Cons}),
4.181 + Rule.Thm ("tl_Nil",TermC.num_str @{thm tl_Nil}),
4.182 + Rule.Thm ("zip_Cons",TermC.num_str @{thm zip_Cons}),
4.183 + Rule.Thm ("zip_Nil",TermC.num_str @{thm zip_Nil})],
4.184 + scr = Rule.EmptyScr}: Rule.rls;
4.185 +\<close>
4.186 +setup \<open>KEStore_Elems.add_rlss [("list_rls", (Context.theory_name @{theory}, list_rls))]\<close>
4.187 +
4.188 +end
5.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
5.2 +++ b/src/Tools/isac/CalcElements/calcelems.sml Fri Aug 23 16:36:47 2019 +0200
5.3 @@ -0,0 +1,757 @@
5.4 +(* ~~/src/Tools/isac/calcelems.sml
5.5 + elements of calculations.
5.6 + they are partially held in association lists as ref's for
5.7 + switching language levels (meta-string, object-values).
5.8 + in order to keep these ref's during re-evaluation of code,
5.9 + they are defined here at the beginning of the code.
5.10 + Author: Walther Neuper 2003
5.11 + (c) copyright due to lincense terms
5.12 +*)
5.13 +
5.14 +signature CALC_ELEMENT =
5.15 + sig
5.16 + type cas_elem
5.17 + type pbt
5.18 + type ptyps
5.19 + type metID
5.20 + type pblID
5.21 + type mets
5.22 + type met
5.23 + datatype 'a ptyp = Ptyp of string * 'a list * 'a ptyp list
5.24 +
5.25 + type authors
5.26 + type guh
5.27 + val env2str: Rule.subst -> string
5.28 + val subst2str: Rule.subst -> string
5.29 + val subst2str': Rule.subst -> string
5.30 +
5.31 + type fillpat
5.32 + datatype thydata
5.33 + = Hcal of {calc: Rule.calc, coursedesign: authors, guh: guh, mathauthors: authors}
5.34 + | Hord of {coursedesign: authors, guh: guh, mathauthors: authors, ord: Rule.subst -> term * term -> bool}
5.35 + | Hrls of {coursedesign: authors, guh: guh, mathauthors: authors, thy_rls: Rule.thyID * Rule.rls}
5.36 + | Hthm of {coursedesign: authors, fillpats: fillpat list, guh: guh, mathauthors: authors, thm: thm}
5.37 + | Html of {coursedesign: authors, guh: guh, html: string, mathauthors: authors}
5.38 + type theID
5.39 + type rlss_elem
5.40 + val merge_rlss: rlss_elem list * rlss_elem list -> rlss_elem list
5.41 + val rls_eq: (''a * ('b * 'c)) * (''a * ('d * 'e)) -> bool
5.42 + type spec
5.43 + val cas_eq: cas_elem * cas_elem -> bool
5.44 + val e_Ptyp: pbt ptyp
5.45 + val merge_ptyps: 'a ptyp list * 'a ptyp list -> 'a ptyp list
5.46 + val check_guhs_unique: bool Unsynchronized.ref
5.47 + val check_pblguh_unique: guh -> pbt ptyp list -> unit
5.48 + val insrt: pblID -> 'a -> string list -> 'a ptyp list -> 'a ptyp list
5.49 + val e_Mets: met ptyp
5.50 + val check_metguh_unique: guh -> met ptyp list -> unit
5.51 + val add_thydata: string list * string list -> thydata -> thydata ptyp list -> thydata ptyp list
5.52 + val get_py: 'a ptyp list -> pblID -> string list -> 'a
5.53 + val update_hthm: thydata -> fillpat list -> thydata
5.54 + val update_ptyps: string list -> string list -> 'a -> 'a ptyp list -> 'a ptyp list
5.55 + val part2guh: theID -> guh
5.56 + val spec2str: string * string list * string list -> string
5.57 + val linefeed: string -> string
5.58 + val pbts2str: pbt list -> string
5.59 + val thes2str: thydata list -> string
5.60 + val theID2str: string list -> string
5.61 + val the2str: thydata -> string
5.62 + val trace_calc: bool Unsynchronized.ref
5.63 + eqtype thmID
5.64 + type thm'
5.65 + datatype lrd = D | L | R
5.66 + val trace_rewrite: bool Unsynchronized.ref
5.67 + val depth: int Unsynchronized.ref
5.68 + val assoc_thy: Rule.theory' -> theory
5.69 + type loc_
5.70 + val loc_2str: loc_ -> string
5.71 + type thm''
5.72 + val metID2str: string list -> string
5.73 + val e_pblID: pblID
5.74 + val e_metID: metID
5.75 + val empty_spec: spec
5.76 + val e_spec: spec
5.77 + datatype ketype = Exp_ | Met_ | Pbl_ | Thy_
5.78 + type kestoreID
5.79 + val app_py: 'a ptyp list -> ('a ptyp -> 'b) -> pblID -> string list -> 'b
5.80 + val ketype2str: ketype -> string
5.81 + val coll_pblguhs: pbt ptyp list -> guh list
5.82 + val coll_metguhs: met ptyp list -> guh list
5.83 + type pat
5.84 + val pats2str: pat list -> string
5.85 + val maxthy: theory -> theory -> theory
5.86 + eqtype filename
5.87 + val lim_deriv: int Unsynchronized.ref
5.88 + val id_of_thm: Rule.rule -> string
5.89 + val isabthys: unit -> theory list
5.90 + val thyID_of_derivation_name: string -> string
5.91 + val partID': Rule.theory' -> string
5.92 + val thm2guh: string * Rule.thyID -> thmID -> guh
5.93 + val thmID_of_derivation_name: string -> string
5.94 + val rls2guh: string * Rule.thyID -> Rule.rls' -> guh
5.95 + val theID2guh: theID -> guh
5.96 + eqtype fillpatID
5.97 + type pbt_ = string * (term * term)
5.98 + eqtype xml
5.99 + val cal2guh: string * Rule.thyID -> string -> guh
5.100 + val ketype2str': ketype -> string
5.101 + val str2ketype': string -> ketype
5.102 + val thmID_of_derivation_name': thm -> string
5.103 + eqtype path
5.104 + val theID2thyID: theID -> Rule.thyID
5.105 + val thy2guh: theID -> guh
5.106 + val thypart2guh: theID -> guh
5.107 + val ord2guh: string * Rule.theory' -> string -> string
5.108 + val update_hrls: thydata -> Rule.errpatID list -> thydata
5.109 + eqtype iterID
5.110 + eqtype calcID
5.111 + val thm''_of_thm: thm -> thm''
5.112 + val thm_of_thm: Rule.rule -> thm
5.113 +(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
5.114 + val pats2str' : pat list -> string
5.115 + val insert_fillpats: thydata ptyp list -> (pblID * fillpat list) list -> thydata ptyp list ->
5.116 + thydata ptyp list
5.117 +(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
5.118 + val knowthys: unit -> theory list
5.119 + val e_pbt: pbt
5.120 + val e_met: met
5.121 +( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
5.122 +
5.123 +(*----- unused code, kept as hints to design ideas ---------------------------------------------*)
5.124 +val overwritelthy: theory -> (Rule.rls' * (string * Rule.rls)) list * (Rule.rls' * Rule.rls) list ->
5.125 + (Rule.rls' * (string * Rule.rls)) list end
5.126 +
5.127 +
5.128 +structure Celem(**): CALC_ELEMENT(**) =
5.129 +struct
5.130 +
5.131 +val linefeed = (curry op^) "\n"; (* ?\<longrightarrow> libraryC ?*)
5.132 +type authors = string list;
5.133 +
5.134 +type iterID = int;
5.135 +type calcID = int;
5.136 +
5.137 +(* TODO CLEANUP Thm:
5.138 +Thm (string, thm): (a) needs string to identify sym_thmID for handling in front-end;
5.139 + (b) investigate if ""RS sym" attaches a [.]" still occurs: string_of_thmI
5.140 +thmID : type for data from user input + program
5.141 +thmDeriv : type for thy_hierarchy ONLY
5.142 +obsolete types : thm' (SEE "ad thm'"), thm''.
5.143 +revise funs : id_of_thm, thm_of_thm, rep_thm_G', eq_thmI, eq_thmI', thm''_of_thm thm.
5.144 +activate : thmID_of_derivation_name'
5.145 +*)
5.146 +type thmID = string; (* identifier for a thm (the shortest possible identifier) *)
5.147 +type thmDeriv = string; (* WN120524 deprecated
5.148 + thyID ^"."^ xxx ^"."^ thmID, see fun thmID_of_derivation_name
5.149 + WN120524: dont use Thm.derivation_name, this is destroyed by num_str;
5.150 + Thm.get_name_hint survives num_str and seems perfectly reliable *)
5.151 +
5.152 +type thm' = thmID * Rule.cterm';(*WN060610 deprecated in favour of thm''; WN180324: used in TODO review:
5.153 +val thm'2xml : int -> Celem.thm' -> Celem.xml
5.154 +val assoc_thm': theory -> Celem.thm' -> thm
5.155 +| Calculate' of Rule.theory' * string * term * (term * Celem.thm')
5.156 +*)
5.157 +(* tricky combination of (string, term) for theorems in Isac:
5.158 + * case 1 general: frontend + lucin, e.g. applicable_in..Rewrite: (thmID, _) --> (thmID, thm)
5.159 + by Global_Theory.get_thm, special cases ("add_commute",..) see convert_metaview_to_thmid.
5.160 + * case 2 "sym_..": Global_Theory.get_thm..RS sym
5.161 + * case 3 ad-hoc thm "#..." mk_thm from ad-hoc term (numerals only) in calculate_:
5.162 + from applicable_in..Calculate: opstr --calculate_/adhoc_thm--> (thmID, thm)
5.163 +*)
5.164 +type thm'' = thmID * thm; (* only for transport via libisabelle isac-java <--- ME *)
5.165 +
5.166 +(*.a 'guh'='globally unique handle' is a string unique for each element
5.167 + of isac's KEStore and persistent over time
5.168 + (in particular under shifts within the respective hierarchy);
5.169 + specialty for thys:
5.170 + # guh NOT resistant agains shifts from one thy to another
5.171 + (which is the price for Isabelle's design: thy's overwrite ids of subthy's)
5.172 + # requirement for matchTheory: induce guh from tac + current thy
5.173 + (see 'fun thy_containing_thm', 'fun thy_containing_rls' etc.)
5.174 + TODO: introduce to pbl, met.*)
5.175 +type guh = string;
5.176 +
5.177 +type xml = string; (* rm together with old code replaced by XML.tree *)
5.178 +
5.179 +
5.180 +(* for (at least) 2 kinds of access:
5.181 + (1) given an errpatID, find the respective fillpats (e.g. in fun find_fill_pats)
5.182 + (2) given a thm, find respective fillpats *)
5.183 +type fillpatID = string
5.184 +type fillpat =
5.185 + fillpatID (* DESIGN ?TODO: give an order w.r.t difficulty ? *)
5.186 + * term (* the pattern with fill-in gaps *)
5.187 + * Rule.errpatID; (* which the fillpat would be a help for
5.188 + DESIGN ?TODO: list for several patterns ? *)
5.189 +
5.190 +
5.191 +(* WN0509 discussion:
5.192 +#############################################################################
5.193 +# How to manage theorys in subproblems wrt. the requirement, #
5.194 +# that scripts should be re-usable ? #
5.195 +#############################################################################
5.196 +
5.197 + eg. 'Program Solve_rat_equation' calls 'SubProblem (RatEq',..'
5.198 + which would not allow to 'solve (y'' = -M_b / EI, M_b)' by this script
5.199 + because Biegelinie.thy is subthy of RatEq.thy and thus Biegelinie.M_b
5.200 + is unknown in RatEq.thy and M_b cannot be parsed into the scripts guard
5.201 + (see match_ags).
5.202 +
5.203 + Preliminary solution:
5.204 + # the thy in 'SubProblem (thy', pbl, arglist)' is not taken automatically,
5.205 + # instead the 'maxthy (rootthy pt) thy' is taken for each subpbl
5.206 + # however, a thy specified by the user in the rootpbl may lead to
5.207 + errors in far-off subpbls (which are not yet reported properly !!!)
5.208 + and interactively specifiying thys in subpbl is not very relevant.
5.209 +
5.210 + Other solutions possible:
5.211 + # always parse and type-check with Thy_Info_get_theory "Isac"
5.212 + (rejected due to the vague idea eg. to re-use equations for R in C etc.)
5.213 + # regard the subthy-relation in specifying thys of subpbls
5.214 + # specifically handle 'SubProblem (undefined, pbl, arglist)'
5.215 + # ???
5.216 +*)
5.217 +
5.218 +fun id_of_thm (Rule.Thm (id, _)) = id (* TODO re-arrange code for rule2str *)
5.219 + | id_of_thm _ = raise ERROR ("id_of_thm: uncovered case " (* ^ rule2str r *))
5.220 +fun thm_of_thm (Rule.Thm (_, thm)) = thm (* TODO re-arrange code for rule2str *)
5.221 + | thm_of_thm _ = raise ERROR ("thm_of_thm: uncovered case " (* ^ rule2str r *))
5.222 +
5.223 +fun thmID_of_derivation_name dn = last_elem (space_explode "." dn);
5.224 +fun thmID_of_derivation_name' thm = (thmID_of_derivation_name o Thm.get_name_hint) thm
5.225 +fun thyID_of_derivation_name dn = hd (space_explode "." dn);
5.226 +fun thm''_of_thm thm = (thmID_of_derivation_name' thm, thm) : thm''
5.227 +
5.228 +
5.229 +
5.230 +(*the key into the hierarchy ob theory elements*)
5.231 +type theID = string list;
5.232 +val theID2str = strs2str; (*theID eg. is ["IsacKnowledge", "Test", "Rulesets", "ac_plus_times"]*)
5.233 +fun theID2thyID theID =
5.234 + if length theID >= 3 then (last_elem o (drop_last_n 2)) theID
5.235 + else error ("theID2thyID called with " ^ theID2str theID);
5.236 +
5.237 +(*the key into the hierarchy ob problems*)
5.238 +type pblID = string list; (* domID :: ...*)
5.239 +val e_pblID = ["e_pblID"];
5.240 +
5.241 +(*the key into the hierarchy ob methods*)
5.242 +type metID = string list;
5.243 +type spec = Rule.domID * pblID * metID;
5.244 +fun spec2str (dom, pbl, met) =
5.245 + "(" ^ quote dom ^ ", " ^ strs2str pbl ^ ", " ^ strs2str met ^ ")";
5.246 +val e_metID = ["e_metID"];
5.247 +val metID2str = strs2str;
5.248 +val empty_spec = (Rule.e_domID, e_pblID, e_metID);
5.249 +val e_spec = empty_spec;
5.250 +
5.251 +(* association list with cas-commands, for generating a complete calc-head *)
5.252 +type generate_fn =
5.253 + (term list -> (* the arguments of the cas-command, eg. (x+1=2, x) *)
5.254 + (term * (* description of an element *)
5.255 + term list) (* value of the element (always put into a list) *)
5.256 + list) (* of elements in the formalization *)
5.257 +type cas_elem =
5.258 + (term * (* cas-command, eg. 'solve' *)
5.259 + (spec * (* theory, problem, method *)
5.260 + generate_fn))
5.261 +fun cas_eq ((t1, (_, _)) : cas_elem, (t2, (_, _)) : cas_elem) = t1 = t2
5.262 +
5.263 +(*either theID or pblID or metID*)
5.264 +type kestoreID = string list;
5.265 +
5.266 +(* for distinction of contexts WN130621: disambiguate with Isabelle's Context *)
5.267 +datatype ketype = Exp_ | Thy_ | Pbl_ | Met_;
5.268 +fun ketype2str Exp_ = "Exp_"
5.269 + | ketype2str Thy_ = "Thy_"
5.270 + | ketype2str Pbl_ = "Pbl_"
5.271 + | ketype2str Met_ = "Met_";
5.272 +fun ketype2str' Exp_ = "Example"
5.273 + | ketype2str' Thy_ = "Theory"
5.274 + | ketype2str' Pbl_ = "Problem"
5.275 + | ketype2str' Met_ = "Method";
5.276 +(* for conversion from XML *)
5.277 +fun str2ketype' "exp" = Exp_
5.278 + | str2ketype' "thy" = Thy_
5.279 + | str2ketype' "pbl" = Pbl_
5.280 + | str2ketype' "met" = Met_
5.281 + | str2ketype' str = raise ERROR ("str2ketype': WRONG arg = " ^ str)
5.282 +
5.283 +(* A tree for storing data defined in different theories
5.284 + for access from the Interpreter and from dialogue authoring
5.285 + using a string list as key.
5.286 + 'a is for pbt | met | thydata; after WN030424 naming "pbt" became inappropriate *)
5.287 +datatype 'a ptyp =
5.288 + Ptyp of string * (* element of the key *)
5.289 + 'a list * (* several pbts with different domIDs/thy TODO: select by subthy (isaref.p.69)
5.290 + presently only _ONE_ elem FOR ALL KINDS OF CONTENT pbt | met | thydata *)
5.291 + ('a ptyp) list; (* the children nodes *)
5.292 +
5.293 +(* datatype for collecting thydata for hierarchy *)
5.294 +(*WN060720 more consistent naming would be 'type thyelem' or 'thelem'*)
5.295 +datatype thydata =
5.296 + Html of {guh: guh, coursedesign: authors, mathauthors: authors, html: string}
5.297 +| Hthm of {guh: guh, coursedesign: authors, mathauthors: authors, fillpats: fillpat list,
5.298 + thm: thm} (* here no sym_thm, thus no thmID required *)
5.299 +| Hrls of {guh: guh, coursedesign: authors, mathauthors: authors, thy_rls: (Rule.thyID * Rule.rls)}
5.300 +| Hcal of {guh: guh, coursedesign: authors, mathauthors: authors, calc: Rule.calc}
5.301 +| Hord of {guh: guh, coursedesign: authors, mathauthors: authors,
5.302 + ord: (Rule.subst -> (term * term) -> bool)};
5.303 +fun the2str (Html {guh, ...}) = guh
5.304 + | the2str (Hthm {guh, ...}) = guh
5.305 + | the2str (Hrls {guh, ...}) = guh
5.306 + | the2str (Hcal {guh, ...}) = guh
5.307 + | the2str (Hord {guh, ...}) = guh
5.308 +fun thes2str thes = map the2str thes |> list2str;
5.309 +
5.310 +(* notes on thehier concerning sym_thmID theorems (created in derivations, reverse rewriting)
5.311 + (a): thehier does not contain sym_thmID theorems
5.312 + (b): lookup for sym_thmID directly from Isabelle using sym_thm
5.313 + (within math-engine NO lookup in thehier -- within java in *.xml only!)
5.314 +TODO (c): export from thehier to xml
5.315 +TODO (c1) creates one entry for "thmID" (and NONE for "sym_thmID") in the hierarchy
5.316 +TODO (c2) creates 2 files "thy_*-thm-thmID.xml" and "thy_*-thm-sym_thmID.xml"
5.317 +TODO (d): 1 entry in the MiniBrowser's hierarchy (generated from xml)
5.318 + stands for both, "thmID" and "sym_thmID"
5.319 +TODO (d1) lookup from calctxt
5.320 +TODO (d1) lookup from from rule set in MiniBrowser *)
5.321 +type thehier = (thydata ptyp) list;
5.322 +(* required to determine sequence of main nodes of thehier in KEStore.thy *)
5.323 +fun part2guh [str] = (case str of
5.324 + "Isabelle" => "thy_isab_" ^ str ^ "-part" : guh
5.325 + | "IsacScripts" => "thy_scri_" ^ str ^ "-part"
5.326 + | "IsacKnowledge" => "thy_isac_" ^ str ^ "-part"
5.327 + | str => raise ERROR ("thy2guh: called with \""^ str ^"\""))
5.328 + | part2guh theID = raise ERROR ("part2guh called with theID = \"" ^ theID2str theID ^ "'");
5.329 +
5.330 +fun thy2guh [part, thyID] = (case part of
5.331 + "Isabelle" => "thy_isab_" ^ thyID
5.332 + | "IsacScripts" => "thy_scri_" ^ thyID
5.333 + | "IsacKnowledge" => "thy_isac_" ^ thyID
5.334 + | str => raise ERROR ("thy2guh: called with \"" ^ str ^ "\""))
5.335 + | thy2guh theID = raise ERROR ("thy2guh called with \"" ^ strs2str' theID ^ "\"");
5.336 +
5.337 +fun thypart2guh ([part, thyID, thypart] : theID) = (case part of
5.338 + "Isabelle" => "thy_isab_" ^ thyID ^ "-" ^ thypart : guh
5.339 + | "IsacScripts" => "thy_scri_" ^ thyID ^ "-" ^ thypart
5.340 + | "IsacKnowledge" => "thy_isac_" ^ thyID ^ "-" ^ thypart
5.341 + | str => raise ERROR ("thypart2guh: called with '" ^ str ^ "'"))
5.342 + | thypart2guh strs = raise ERROR ("thypart2guh called with \"" ^ strs2str' strs ^ "\"");
5.343 +
5.344 +
5.345 +(* convert the data got via contextToThy to a globally unique handle.
5.346 + there is another way to get the guh: get out of the 'theID' in the hierarchy *)
5.347 +fun thm2guh (isa, thyID) thmID = case isa of
5.348 + "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID : guh
5.349 + | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
5.350 + | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
5.351 + | _ => raise ERROR
5.352 + ("thm2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for thm = \"" ^ thmID ^ "\"");
5.353 +
5.354 +fun rls2guh (isa, thyID) rls' = case isa of
5.355 + "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-rls-" ^ rls' : guh
5.356 + | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-rls-" ^ rls'
5.357 + | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-rls-" ^ rls'
5.358 + | _ => raise ERROR
5.359 + ("rls2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for rls = \"" ^ rls' ^ "\"");
5.360 +
5.361 +fun cal2guh (isa, thyID) calID = case isa of
5.362 + "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-cal-" ^ calID : guh
5.363 + | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-cal-" ^ calID
5.364 + | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-cal-" ^ calID
5.365 + | _ => raise ERROR
5.366 + ("cal2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for cal = \"" ^ calID ^ "\"");
5.367 +
5.368 +fun ord2guh (isa, thyID) rew_ord' = case isa of
5.369 + "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-ord-" ^ rew_ord' : guh
5.370 + | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-ord-" ^ rew_ord'
5.371 + | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-ord-" ^ rew_ord'
5.372 + | _ => raise ERROR
5.373 + ("ord2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for ord = \"" ^ rew_ord' ^ "\"");
5.374 +
5.375 +(* not only for thydata, but also for thy's etc *)
5.376 +(* TODO
5.377 +fun theID2guh theID = case length theID of
5.378 + 0 => error ("theID2guh: called with theID = " ^ strs2str' theID)
5.379 + | 1 => part2guh theID
5.380 + | 2 => thy2guh theID
5.381 + | 3 => thypart2guh theID
5.382 + | 4 =>
5.383 + let val [isa, thyID, typ, elemID] = theID
5.384 + in case typ of
5.385 + "Theorems" => thm2guh (isa, thyID) elemID
5.386 + | "Rulesets" => rls2guh (isa, thyID) elemID
5.387 + | "Calculations" => cal2guh (isa, thyID) elemID
5.388 + | "Orders" => ord2guh (isa, thyID) elemID
5.389 + | "Theorems" => thy2guh [isa, thyID]
5.390 + | str => raise ERROR ("theID2guh: called with theID = " ^ strs2str' theID)
5.391 + end
5.392 + | n => raise ERROR ("theID2guh called with theID = " ^ strs2str' theID);
5.393 +*)
5.394 +(* not only for thydata, but also for thy's etc *)
5.395 +fun theID2guh [] = raise ERROR ("theID2guh: called with []")
5.396 + | theID2guh [str] = part2guh [str]
5.397 + | theID2guh [s1, s2] = thy2guh [s1, s2]
5.398 + | theID2guh [s1, s2, s3] = thypart2guh [s1, s2, s3]
5.399 + | theID2guh (strs as [isa, thyID, typ, elemID]) = (case typ of
5.400 + "Theorems" => thm2guh (isa, thyID) elemID
5.401 + | "Rulesets" => rls2guh (isa, thyID) elemID
5.402 + | "Calculations" => cal2guh (isa, thyID) elemID
5.403 + | "Orders" => ord2guh (isa, thyID) elemID
5.404 + | _ => raise ERROR ("theID2guh: called with theID = " ^ strs2str' strs))
5.405 + | theID2guh strs = raise ERROR ("theID2guh called with theID = " ^ strs2str' strs);
5.406 +
5.407 +type path = string;
5.408 +type filename = string;
5.409 +
5.410 +
5.411 +
5.412 +(* datastructure for KEStore_Elems, intermediate for thehier *)
5.413 +type rlss_elem =
5.414 + (Rule.rls' * (* identifier unique within Isac *)
5.415 + (Rule.theory' * (* just for assignment in thehier, not appropriate for parsing etc *)
5.416 + Rule.rls)) (* ((#id o rep_rls) rls) = rls' by coding discipline *)
5.417 +fun rls_eq ((id1, (_, _)), (id2, (_, _))) = id1 = id2
5.418 +
5.419 +fun insert_merge_rls (re as (id, (thyID, r1)) : rlss_elem) ys =
5.420 + case get_index (fn y => if curry rls_eq re y then SOME y else NONE) ys of
5.421 + NONE => re :: ys
5.422 + | SOME (i, (_, (_, r2))) =>
5.423 + let
5.424 + val r12 = Rule.merge_rls id r1 r2
5.425 + in list_update ys i (id, (thyID, r12)) end
5.426 +fun merge_rlss (s1, s2) = fold insert_merge_rls s1 s2;
5.427 +
5.428 +
5.429 +fun assoc_thy thy =
5.430 + if thy = "e_domID"
5.431 + then (Rule.Thy_Info_get_theory "Program") (*lower bound of Knowledge*)
5.432 + else (Rule.Thy_Info_get_theory thy) handle _ => error ("ME_Isa: thy \"" ^ thy ^ "\" not in system");
5.433 +
5.434 +(* overwrite an element in an association list and pair it with a thyID
5.435 + in order to create the thy_hierarchy;
5.436 + overwrites existing rls' even if they are defined in a different thy;
5.437 + this is related to assoc_rls, TODO.WN060120: assoc_rew_ord, assoc_calc *)
5.438 +(* WN060120 ...these are NOT compatible to "fun assoc_thm'" in that
5.439 + they do NOT handle overlays by re-using an identifier in different thys;
5.440 + "thyID.rlsID" would be a good solution, if the "." would be possible
5.441 + in scripts...
5.442 + actually a hack to get alltogether run again with minimal effort *)
5.443 +fun insthy thy' (rls', rls) = (rls', (thy', rls));
5.444 +fun overwritelthy thy (al, bl: (Rule.rls' * Rule.rls) list) =
5.445 + let val bl' = map (insthy ((get_thy o Rule.theory2theory') thy)) bl
5.446 + in overwritel (al, bl') end;
5.447 +
5.448 +fun subst2str s =
5.449 + (strs2str o
5.450 + (map (
5.451 + linefeed o pair2str o (apsnd Rule.term2str) o (apfst Rule.term2str)))) s;
5.452 +fun subst2str' s =
5.453 + (strs2str' o
5.454 + (map (
5.455 + pair2str o (apsnd Rule.term2str) o (apfst Rule.term2str)))) s;
5.456 +val env2str = subst2str;
5.457 +
5.458 +fun maxthy thy1 thy2 = if Context.subthy (thy1, thy2) then thy2 else thy1;
5.459 +
5.460 +
5.461 +(* trace internal steps of isac's numeral calculations *)
5.462 +val trace_calc = Unsynchronized.ref false;
5.463 +(* trace internal steps of isac's rewriter *)
5.464 +val trace_rewrite = Unsynchronized.ref false;
5.465 +(* depth of recursion in traces of the rewriter, if trace_rewrite:=true *)
5.466 +val depth = Unsynchronized.ref 99999;
5.467 +(* no of rewrites exceeding this int -> NO rewrite *)
5.468 +val lim_deriv = Unsynchronized.ref 100;
5.469 +(* switch for checking guhs unique before storing a pbl or met;
5.470 + set true at startup (done at begin of ROOT.ML)
5.471 + set false for editing IsacKnowledge (done at end of ROOT.ML) *)
5.472 +val check_guhs_unique = Unsynchronized.ref true;
5.473 +
5.474 +
5.475 +datatype lrd = (*elements of "type loc_" into an Isabelle term*)
5.476 + L (*go left at $*)
5.477 +| R (*go right at $*)
5.478 +| D; (*go down at Abs*)
5.479 +type loc_ = lrd list;
5.480 +fun ldr2str L = "L"
5.481 + | ldr2str R = "R"
5.482 + | ldr2str D = "D";
5.483 +fun loc_2str k = (strs2str' o (map ldr2str)) k;
5.484 +
5.485 +
5.486 +(* the pattern for an item of a problems model or a methods guard *)
5.487 +type pat =
5.488 + (string * (* field *)
5.489 + (term * (* description *)
5.490 + term)) (* id | arbitrary term *);
5.491 +fun pat2str ((field, (dsc, id)) : pat) =
5.492 + pair2str (field, pair2str (Rule.term2str dsc, Rule.term2str id))
5.493 +fun pats2str pats = (strs2str o (map pat2str)) pats
5.494 +fun pat2str' ((field, (dsc, id)) : pat) =
5.495 + pair2str (field, pair2str (Rule.term2str dsc, Rule.term2str id)) ^ "\n"
5.496 +fun pats2str' pats = (strs2str o (map pat2str')) pats
5.497 +
5.498 +(* types for problems models (TODO rename to specification models) *)
5.499 +type pbt_ =
5.500 + (string * (* field "#Given",..*)(*deprecated due to 'type pat'*)
5.501 + (term * (* description *)
5.502 + term)); (* id | struct-var *)
5.503 +type pbt =
5.504 + {guh : guh, (* unique within this isac-knowledge *)
5.505 + mathauthors : string list, (* copyright *)
5.506 + init : pblID, (* to start refinement with *)
5.507 + thy : theory, (* which allows to compile that pbt
5.508 + TODO: search generalized for subthy (ref.p.69*)
5.509 + (*^^^ WN050912 NOT used during application of the problem,
5.510 + because applied terms may be from 'subthy' as well as from super;
5.511 + thus we take 'maxthy'; see match_ags ! *)
5.512 + cas : term option, (* 'CAS-command' *)
5.513 + prls : Rule.rls, (* for preds in where_ *)
5.514 + where_ : term list, (* where - predicates *)
5.515 + ppc : pat list, (* this is the model-pattern;
5.516 + it contains "#Given","#Where","#Find","#Relate"-patterns
5.517 + for constraints on identifiers see "fun cpy_nam" *)
5.518 + met : metID list} (* methods solving the pbt *)
5.519 +
5.520 +val e_pbt = {guh = "pbl_empty", mathauthors = [], init = e_pblID, thy = Thy_Info.get_theory "Pure",
5.521 + cas = NONE, prls = Rule.Erls, where_ = [], ppc = [], met = []} : pbt
5.522 +fun pbt2str ({cas = cas', guh = guh', init = init', mathauthors = ma', met = met', ppc = ppc',
5.523 + prls = prls', thy = thy', where_ = w'} : pbt)
5.524 + = "{cas = " ^ (Rule.termopt2str cas') ^ ", guh = \"" ^ guh' ^ "\", init = "
5.525 + ^ (strs2str init') ^ ", mathauthors = " ^ (strs2str ma' |> quote) ^ ", met = "
5.526 + ^ (strslist2strs met') ^ ", ppc = " ^ pats2str ppc' ^ ", prls = "
5.527 + ^ (Rule.rls2str prls' |> quote) ^ ", thy = {" ^ (Rule.theory2str thy') ^ "}, where_ = "
5.528 + ^ (Rule.terms2str w') ^ "}" |> linefeed;
5.529 +fun pbts2str pbts = map pbt2str pbts |> list2str;
5.530 +
5.531 +val e_Ptyp = Ptyp ("e_pblID", [e_pbt], [])
5.532 +type ptyps = (pbt ptyp) list
5.533 +
5.534 +fun coll_pblguhs pbls =
5.535 + let
5.536 + fun node coll (Ptyp (_, [n], ns)) = [(#guh : pbt -> guh) n] @ (nodes coll ns)
5.537 + | node _ _ = raise ERROR "coll_pblguhs - node"
5.538 + and nodes coll [] = coll
5.539 + | nodes coll (n :: ns) = (node coll n) @ (nodes coll ns);
5.540 + in nodes [] pbls end;
5.541 +fun check_pblguh_unique guh pbls =
5.542 + if member op = (coll_pblguhs pbls) guh
5.543 + then error ("check_guh_unique failed with \""^ guh ^"\";\n"^
5.544 + "use \"sort_pblguhs()\" for a list of guhs;\n"^
5.545 + "consider setting \"check_guhs_unique := false\"")
5.546 + else ();
5.547 +
5.548 +fun insrt _ pbt [k] [] = [Ptyp (k, [pbt], [])]
5.549 + | insrt d pbt [k] ((Ptyp (k', [p], ps)) :: pys) =
5.550 + ((*writeln ("### insert 1: ks = " ^ strs2str [k] ^ " k'= " ^ k');*)
5.551 + if k = k'
5.552 + then ((Ptyp (k', [pbt], ps)) :: pys)
5.553 + else ((Ptyp (k', [p], ps)) :: (insrt d pbt [k] pys))
5.554 + )
5.555 + | insrt d pbt (k::ks) ((Ptyp (k', [p], ps)) :: pys) =
5.556 + ((*writeln ("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*)
5.557 + if k = k'
5.558 + then ((Ptyp (k', [p], insrt d pbt ks ps)) :: pys)
5.559 + else
5.560 + if length pys = 0
5.561 + then error ("insert: not found " ^ (strs2str (d : pblID)))
5.562 + else ((Ptyp (k', [p], ps)) :: (insrt d pbt (k :: ks) pys))
5.563 + )
5.564 + | insrt _ _ _ _ = raise ERROR "";
5.565 +
5.566 +fun update_ptyps ID _ _ [] =
5.567 + error ("update_ptyps: " ^ strs2str' ID ^ " does not exist")
5.568 + | update_ptyps ID [i] data ((py as Ptyp (key, _, pys)) :: pyss) =
5.569 + if i = key
5.570 + then
5.571 + if length pys = 0
5.572 + then ((Ptyp (key, [data], [])) :: pyss)
5.573 + else error ("update_ptyps: " ^ strs2str' ID ^ " has descendants")
5.574 + else py :: update_ptyps ID [i] data pyss
5.575 + | update_ptyps ID (i :: is) data ((py as Ptyp (key, d, pys)) :: pyss) =
5.576 + if i = key
5.577 + then ((Ptyp (key, d, update_ptyps ID is data pys)) :: pyss)
5.578 + else (py :: (update_ptyps ID (i :: is) data pyss))
5.579 + | update_ptyps _ _ _ _ = raise ERROR "update_ptyps called with undef pattern.";
5.580 +
5.581 +(* this function only works wrt. the way Isabelle evaluates Theories and is not a general merge
5.582 + function for trees / ptyps *)
5.583 +fun merge_ptyps ([], pt) = pt
5.584 + | merge_ptyps (pt, []) = pt
5.585 + | merge_ptyps ((x' as Ptyp (k, _, ps)) :: xs, (xs' as Ptyp (k', y, ps') :: ys)) =
5.586 + if k = k'
5.587 + then Ptyp (k, y, merge_ptyps (ps, ps')) :: merge_ptyps (xs, ys)
5.588 + else x' :: merge_ptyps (xs, xs');
5.589 +
5.590 +(* data for methods stored in 'methods'-database*)
5.591 +type met =
5.592 + {guh : guh, (* unique within this isac-knowledge *)
5.593 + mathauthors: string list, (* copyright *)
5.594 + init : pblID, (* WN060721 introduced mistakenly--TODO.REMOVE! *)
5.595 + rew_ord' : Rule.rew_ord', (* for rules in Detail
5.596 + TODO.WN0509 store fun itself, see 'type pbt' *)
5.597 + erls : Rule.rls, (* the eval_rls for cond. in rules FIXME "rls'
5.598 + instead erls in "fun prep_met" *)
5.599 + srls : Rule.rls, (* for evaluating list expressions in scr *)
5.600 + prls : Rule.rls, (* for evaluating predicates in modelpattern *)
5.601 + crls : Rule.rls, (* for check_elementwise, ie. formulae in calc. *)
5.602 + nrls : Rule.rls, (* canonical simplifier specific for this met *)
5.603 + errpats : Rule.errpat list,(* error patterns expected in this method *)
5.604 + calc : Rule.calc list, (* Theory_Data in fun prep_met *)
5.605 + (*branch : TransitiveB set in append_problem at generation ob pblobj *)
5.606 + ppc : pat list, (* items in given, find, relate;
5.607 + items (in "#Find") which need not occur in the arg-list of a SubProblem
5.608 + are 'copy-named' with an identifier "*'.'".
5.609 + copy-named items are 'generating' if they are NOT "*'''" ?WN120516??
5.610 + see ME/calchead.sml 'fun is_copy_named'. *)
5.611 + pre : term list, (* preconditions in where *)
5.612 + scr : Rule.program (* progam, empty as @{thm refl} or Rfuns *)
5.613 + };
5.614 +val e_met = {guh = "met_empty", mathauthors = [], init = e_metID, rew_ord' = "e_rew_ord'",
5.615 + erls = Rule.e_rls, srls = Rule.e_rls, prls = Rule.e_rls, calc = [], crls = Rule.e_rls,
5.616 + errpats = [], nrls = Rule.e_rls, ppc = [], pre = [], scr = Rule.EmptyScr};
5.617 +val e_Mets = Ptyp ("e_metID", [e_met],[]);
5.618 +
5.619 +type mets = (met ptyp) list;
5.620 +fun coll_metguhs mets =
5.621 + let
5.622 + fun node coll (Ptyp (_, [n], ns)) = [(#guh : met -> guh) n] @ (nodes coll ns)
5.623 + | node _ _ = raise ERROR "coll_pblguhs - node"
5.624 + and nodes coll [] = coll
5.625 + | nodes coll (n :: ns) = (node coll n) @ (nodes coll ns);
5.626 + in nodes [] mets end;
5.627 +fun check_metguh_unique (guh:guh) (mets: (met ptyp) list) =
5.628 + if member op = (coll_metguhs mets) guh
5.629 + then raise ERROR ("check_guh_unique failed with \"" ^ guh ^"\";\n"^
5.630 + (*"use \"sort_metguhs()\" for a list of guhs;\n" ^ ...evaluates to [] ?!?*)
5.631 + "consider setting \"check_guhs_unique := false\"")
5.632 + else ();
5.633 +
5.634 +fun Html_default exist = (Html {guh = theID2guh exist,
5.635 + coursedesign = ["isac team 2006"], mathauthors = [], html = ""})
5.636 +
5.637 +fun fill_parents (_, [i]) thydata = Ptyp (i, [thydata], [])
5.638 + | fill_parents (exist, i :: is) thydata =
5.639 + Ptyp (i, [Html_default (exist @ [i])], [fill_parents (exist @ [i], is) thydata])
5.640 + | fill_parents _ _ = raise ERROR "Html_default: avoid ML warning: Matches are not exhaustive"
5.641 +
5.642 +fun add_thydata (exist, is) thydata [] = [fill_parents (exist, is) thydata]
5.643 + | add_thydata (exist, [i]) data (pys as (py as Ptyp (key, _, _)) :: pyss) =
5.644 + if i = key
5.645 + then pys (* preserve existing thydata *)
5.646 + else py :: add_thydata (exist, [i]) data pyss
5.647 + | add_thydata (exist, iss as (i :: is)) data ((py as Ptyp (key, d, pys)) :: pyss) =
5.648 + if i = key
5.649 + then
5.650 + if length pys = 0
5.651 + then Ptyp (key, d, [fill_parents (exist @ [i], is) data]) :: pyss
5.652 + else Ptyp (key, d, add_thydata (exist @ [i], is) data pys) :: pyss
5.653 + else py :: add_thydata (exist, iss) data pyss
5.654 + | add_thydata _ _ _ = raise ERROR "add_thydata: avoid ML warning: Matches are not exhaustive"
5.655 +
5.656 +fun update_hthm (Hthm {guh, coursedesign, mathauthors, thm, ...}) fillpats' =
5.657 + Hthm {guh = guh, coursedesign = coursedesign, mathauthors = mathauthors,
5.658 + fillpats = fillpats', thm = thm}
5.659 + | update_hthm _ _ = raise ERROR "update_hthm: wrong arguments";
5.660 +
5.661 +(* for dialog-authoring *)
5.662 +fun update_hrls (Hrls {guh, coursedesign, mathauthors, thy_rls = (thyID, rls)}) errpatIDs =
5.663 + let
5.664 + val rls' =
5.665 + case rls of
5.666 + Rule.Rls {id, preconds, rew_ord, erls, srls, calc, rules, scr, ...}
5.667 + => Rule.Rls {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls,
5.668 + calc = calc, rules = rules, scr = scr, errpatts = errpatIDs}
5.669 + | Rule.Seq {id, preconds, rew_ord, erls, srls, calc, rules, scr, ...}
5.670 + => Rule.Seq {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls,
5.671 + calc = calc, rules = rules, scr = scr, errpatts = errpatIDs}
5.672 + | Rule.Rrls {id, prepat, rew_ord, erls, calc, scr, ...}
5.673 + => Rule.Rrls {id = id, prepat = prepat, rew_ord = rew_ord, erls = erls, calc = calc,
5.674 + scr = scr, errpatts = errpatIDs}
5.675 + | Erls => Erls
5.676 + in
5.677 + Hrls {guh = guh, coursedesign = coursedesign, mathauthors = mathauthors,
5.678 + thy_rls = (thyID, rls')}
5.679 + end
5.680 + | update_hrls _ _ = raise ERROR "update_hrls: wrong arguments";
5.681 +
5.682 +fun app_py p f (d:pblID) (k(*:pblRD*)) =
5.683 + let
5.684 + fun py_err _ = raise ERROR ("app_py: not found: " ^ strs2str d);
5.685 + fun app_py' _ [] = py_err ()
5.686 + | app_py' [] _ = py_err ()
5.687 + | app_py' [k0] ((p' as Ptyp (k', _, _ )) :: ps) =
5.688 + if k0 = k' then f p' else app_py' [k0] ps
5.689 + | app_py' (k' as (k0 :: ks)) (Ptyp (k'', _, ps) :: ps') =
5.690 + if k0 = k'' then app_py' ks ps else app_py' k' ps';
5.691 + in app_py' k p end;
5.692 +fun get_py p =
5.693 + let
5.694 + fun extract_py (Ptyp (_, [py], _)) = py
5.695 + | extract_py _ = raise ERROR ("extract_py: Ptyp has wrong format.");
5.696 + in app_py p extract_py end;
5.697 +
5.698 +fun (*KEStore_Elems.*)insert_fillpats th fis = (* for tests bypassing setup KEStore_Elems *)
5.699 + let
5.700 + fun update_elem th (theID, fillpats) =
5.701 + let
5.702 + val hthm = get_py th theID theID
5.703 + val hthm' = update_hthm hthm fillpats
5.704 + handle ERROR _ => error ("insert_fillpats: " ^ strs2str theID ^ "must address a theorem")
5.705 + in update_ptyps theID theID hthm' end
5.706 + in fold (update_elem th) fis end
5.707 +
5.708 +(* group the theories defined in Isac, compare Build_Thydata:
5.709 + section "Get and group the theories defined in Isac" *)
5.710 +fun isabthys () = (*["Complex_Main", "Taylor", .., "Pure"]*)
5.711 + let
5.712 + val allthys = Theory.ancestors_of (Rule.Thy_Info_get_theory "Build_Thydata")
5.713 + in
5.714 + drop ((find_index (curry Context.eq_thy (Thy_Info.get_theory "Complex_Main")) allthys), allthys)
5.715 + end
5.716 +fun knowthys () = (*["Isac", .., "Descript", "Delete"]*)
5.717 + let
5.718 + fun isacthys () = (* ["Isac", .., "KEStore"] without Build_Isac thys: "Interpret" etc *)
5.719 + let
5.720 + val allthys = filter_out (member Context.eq_thy
5.721 + [(*Thy_Info_get_theory "ProgLang",*) Rule.Thy_Info_get_theory "Interpret",
5.722 + Rule.Thy_Info_get_theory "xmlsrc", Rule.Thy_Info_get_theory "Frontend"])
5.723 + (Theory.ancestors_of (Rule.Thy_Info_get_theory "Build_Thydata"))
5.724 + in
5.725 + take ((find_index (curry Context.eq_thy (Thy_Info.get_theory "Complex_Main")) allthys),
5.726 + allthys)
5.727 + end
5.728 + val isacthys' = isacthys ()
5.729 + val proglang_parent = Rule.Thy_Info_get_theory "ProgLang"
5.730 + in
5.731 + take ((find_index (curry Context.eq_thy proglang_parent) isacthys'), isacthys')
5.732 + end
5.733 +
5.734 +fun progthys () = (*["Isac", .., "Descript", "Delete"]*)
5.735 + let
5.736 + fun isacthys () = (* ["Isac", .., "KEStore"] without Build_Isac thys: "Interpret" etc *)
5.737 + let
5.738 + val allthys = filter_out (member Context.eq_thy
5.739 + [(*Thy_Info_get_theory "ProgLang",*) Rule.Thy_Info_get_theory "Interpret",
5.740 + Rule.Thy_Info_get_theory "xmlsrc", Rule.Thy_Info_get_theory "Frontend"])
5.741 + (Theory.ancestors_of (Rule.Thy_Info_get_theory "Build_Thydata"))
5.742 + in
5.743 + take ((find_index (curry Context.eq_thy (Thy_Info.get_theory "Complex_Main")) allthys),
5.744 + allthys)
5.745 + end
5.746 + val isacthys' = isacthys ()
5.747 + val proglang_parent = Rule.Thy_Info_get_theory "ProgLang"
5.748 + in
5.749 + drop ((find_index (curry Context.eq_thy proglang_parent) isacthys') + 1(*ProgLang*), isacthys')
5.750 + end
5.751 +
5.752 +fun partID thy =
5.753 + if member Context.eq_thy (knowthys ()) thy then "IsacKnowledge"
5.754 + else if member Context.eq_thy (progthys ()) thy then "IsacScripts"
5.755 + else if member Context.eq_thy (isabthys ()) thy then "Isabelle"
5.756 + else error ("closure of thys in Isac is broken by " ^ Rule.string_of_thy thy)
5.757 +fun partID' thy' = partID (Rule.Thy_Info_get_theory thy')
5.758 +
5.759 +end (*struct*)
5.760 +
6.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
6.2 +++ b/src/Tools/isac/CalcElements/contextC.sml Fri Aug 23 16:36:47 2019 +0200
6.3 @@ -0,0 +1,229 @@
6.4 +(* Title: ../contextC.sml
6.5 + Author: Walther Neuper, Mathias Lehnfeld
6.6 + (c) due to copyright terms
6.7 +*)
6.8 +(* Extension to Isabelle's naming conventions: "C" indicates Isac add-ons to an Isabelle module *)
6.9 +signature CONTEXT_C =
6.10 +sig
6.11 + val e_ctxt : Proof.context
6.12 + val initialise : string -> term list -> Proof.context
6.13 + val initialise' : theory -> string list -> Proof.context
6.14 + val get_assumptions : Proof.context -> term list
6.15 + val insert_assumptions : term list -> Proof.context -> Proof.context
6.16 + val from_subpbl_to_caller : Proof.context -> term -> Proof.context -> Proof.context
6.17 +(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
6.18 + (*NONE*)
6.19 +(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
6.20 + val transfer_asms_from_to : Proof.context -> Proof.context -> Proof.context
6.21 +( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
6.22 +end
6.23 +
6.24 +(* survey on handling contexts:
6.25 +-------------------------------
6.26 + theory is required for Pattern.match (and thus for Tactic.Rewrite* ), while
6.27 + ctxt is required for parsing and for managing pre-conditions and assumptions.
6.28 + * model-specify-phase:
6.29 + * Tactic.Model_Problem does declare_constraints for parsing (in Tactic.Add_Given, etc)
6.30 + ("insert_assumptions pres" has to wait for completing Tactic.Add_Given, etc)
6.31 + (Tactic.Refine_Problem uses theory NOT ctxt due to Pattern.match)
6.32 + *
6.33 + *
6.34 + * solve-phase by Lucas-Interpretation:
6.35 + * locate_input_tactic:
6.36 + * Tactic.Apply_Method
6.37 + * initialises ctxt (declare_constraints' + insert_assumptions pres) by init_pstate
6.38 + * in solve for root problem
6.39 + * in begin_end_prog for subproblem
6.40 + * Tactic.Rewrite* create assumptions; respective insert_assumptions is done by associate
6.41 + * associate..Subproblem' returns ctxt ONLY with declare_constraints',
6.42 + with insert_assumptions wait for Tactic.Apply_Method
6.43 + * storing ctxt is done after return form locate_input_tactic
6.44 + * determine_next_tactic:
6.45 + * TODO initialises ctxt by TODO
6.46 + * Tactic.Rewrite* create assumptions; respective insert_assumptions TODO
6.47 + *
6.48 + *
6.49 + *
6.50 + * locate_input_formula: follows sig. of determine_next_tactic
6.51 + * changing from one method to another (in determine_next_tactic only):
6.52 + * from method to sub-program: just add new preconditions of the guard
6.53 + * locate_input_tactic: init_pstate by begin_end_prog
6.54 + * determine_next_tactic:
6.55 + * from_subpbl_to_caller
6.56 + * finishing a method:
6.57 + * Tactic.Check_Postcond' uses ctxt for proving the post-condition (not yet implemented)
6.58 + *
6.59 + *
6.60 + *
6.61 + *
6.62 +================================================================================================
6.63 +call hierarchy
6.64 +================================================================================================
6.65 +
6.66 + locatetac
6.67 + applicable_in (p, p_) pt (Tactic.Apply_Method pres
6.68 + insert_assumptions
6.69 +
6.70 + context_thy
6.71 + applicable_in (p, p_) pt (Tactic.Apply_Method pres
6.72 + insert_assumptions
6.73 +
6.74 +
6.75 +
6.76 +
6.77 +
6.78 +
6.79 + generate1 _ (Tactic.Rewrite***
6.80 + insert_assumptions
6.81 +
6.82 +
6.83 +
6.84 +
6.85 +
6.86 +------------------------------------------------------------------------------------------------
6.87 +solve phase before LI
6.88 +------------------------------------------------------------------------------------------------
6.89 +autocalc
6.90 + all_modspec
6.91 + declare_constraints'
6.92 + complete_solve
6.93 + all_modspec
6.94 + declare_constraints'
6.95 +
6.96 +all_solve
6.97 + begin_end_prog (Tactic.Apply_Method'
6.98 + init_pstate
6.99 + declare_constraints'
6.100 + insert_assumptions
6.101 +
6.102 +nxt_specify_
6.103 + begin_end_prog (Tactic.Apply_Method'
6.104 + init_pstate
6.105 + declare_constraints'
6.106 + insert_assumptions
6.107 +------------------------------------------------------------------------------------------------
6.108 +LI
6.109 +------------------------------------------------------------------------------------------------
6.110 +solve ("Apply_Method" root-program
6.111 + init_pstate
6.112 + declare_constraints'
6.113 + insert_assumptions
6.114 + locate_input_tactic
6.115 + execute_progr_2
6.116 + assy ..leaf sub-program
6.117 + associate
6.118 + declare_constraints'
6.119 + applicable_in .. Tactic.Apply_Method pres
6.120 + insert_assumptions
6.121 + ? generate1 (look in test with "from ... to..))
6.122 +
6.123 +determine_next_tactic
6.124 + execute_progr_1
6.125 + appy ..leaf
6.126 + stac2tac_
6.127 + declare_constraints'
6.128 + applicable_in (p, p_) pt (Tactic.Apply_Method pres
6.129 + insert_assumptions
6.130 + ? generate1 (look in test with "from ... to..))
6.131 +
6.132 +locate_input_formula uses determine_next_tactic
6.133 + compare_step
6.134 + all_modspec
6.135 + declare_constraints'
6.136 + begin_end_prog (Tactic.Apply_Method'
6.137 + init_pstate
6.138 + declare_constraints'
6.139 + insert_assumptions
6.140 +------------------------------------------------------------------------------------------------
6.141 +specification phase
6.142 +------------------------------------------------------------------------------------------------
6.143 + loc_specify_
6.144 + specify (Tactic.Init_Proof'
6.145 + prep_ori
6.146 + declare_constraints
6.147 +
6.148 + CalcTree
6.149 + nxt_specify_init_calc
6.150 + prep_ori
6.151 + declare_constraints
6.152 +
6.153 + modifyCalcHead
6.154 + input_icalhd
6.155 + prep_ori
6.156 + declare_constraints
6.157 +
6.158 + refine
6.159 + refin'
6.160 + prep_ori
6.161 + declare_constraints
6.162 +------------------------------------------------------------------------------------------------
6.163 +unused ?!
6.164 +------------------------------------------------------------------------------------------------
6.165 + ??
6.166 + match_pbl
6.167 + prep_ori
6.168 + declare_constraints
6.169 + ??
6.170 + from_pblobj'
6.171 + init_pstate
6.172 + declare_constraints'
6.173 + insert_assumptions
6.174 + ??
6.175 + tac2tac_
6.176 + applicable_in (p, p_) pt (Tactic.Apply_Method pres
6.177 + insert_assumptions
6.178 +
6.179 +*)
6.180 +
6.181 +structure ContextC(**) : CONTEXT_C(**) =
6.182 +struct
6.183 +
6.184 +val e_ctxt = Proof_Context.init_global @{theory "Pure"};
6.185 +
6.186 +(* in root-problem take respective formalisation *)
6.187 +fun initialise' thy fmz =
6.188 + let
6.189 + val ctxt = thy |> Proof_Context.init_global
6.190 + val frees = map (TermC.parseNEW' ctxt) fmz |> map TermC.vars |> flat |> distinct
6.191 + val _ = TermC.raise_type_conflicts frees
6.192 + in
6.193 + fold Variable.declare_constraints frees ctxt
6.194 + end
6.195 +(* in Subproblem take respective actual arguments from program *)
6.196 +fun initialise thy' ts =
6.197 + let
6.198 + val ctxt = Rule.Thy_Info_get_theory thy' |> Proof_Context.init_global
6.199 + val frees = map TermC.vars ts |> flat |> distinct
6.200 + val _ = TermC.raise_type_conflicts frees
6.201 + in
6.202 + fold Variable.declare_constraints frees ctxt
6.203 + end
6.204 +
6.205 +structure Context_Data = Proof_Data (type T = term list fun init _ = []);
6.206 +fun get_assumptions ctxt = Context_Data.get ctxt
6.207 +fun insert_assumptions asms = Context_Data.map (fn xs => distinct (asms @ xs))
6.208 +
6.209 +(* transfer assumptions from one to another ctxt.
6.210 + does NOT respect scope: in a calculation identifiers are unique.
6.211 + but environments are scoped as usual in Luacs-interpretation.
6.212 + WN110520 redo (1) take declare_constraints (2) with combinators*)
6.213 +fun transfer_asms_from_to from_ctxt to_ctxt =
6.214 + let
6.215 + val to_vars = get_assumptions to_ctxt |> map TermC.vars |> flat
6.216 + fun transfer [] to_ctxt = to_ctxt
6.217 + | transfer (from_asm :: fas) to_ctxt =
6.218 + if inter op = (TermC.vars from_asm) to_vars = []
6.219 + then transfer fas to_ctxt
6.220 + else transfer fas (insert_assumptions [from_asm] to_ctxt)
6.221 + in transfer (get_assumptions from_ctxt) to_ctxt end
6.222 +
6.223 +(* exported from a subproblem to the context of the calling method:
6.224 + # 'scrval': the result of script interpretation and
6.225 + # those assumptions in the subproblem wich contain a variable known
6.226 + in the calling method. *)
6.227 +fun from_subpbl_to_caller sub_ctxt scrval caller_ctxt =
6.228 + let
6.229 + val caller_ctxt = (scrval |> TermC.dest_list' |> insert_assumptions) caller_ctxt
6.230 + in transfer_asms_from_to sub_ctxt caller_ctxt end;
6.231 +
6.232 +end
7.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
7.2 +++ b/src/Tools/isac/CalcElements/libraryC.sml Fri Aug 23 16:36:47 2019 +0200
7.3 @@ -0,0 +1,297 @@
7.4 +(* library extending Isabelle's library.
7.5 + Author: Walther Neuper 1999
7.6 + (c) copyright due to lincense terms
7.7 +
7.8 +Note: Here many functions reflect changes since Isabelle 98. Changes frequently were resolved
7.9 + quick and dirty by additing Isabelle's old version to the library below.
7.10 +TODO:
7.11 + * remove unused functions
7.12 + * review duplicates with other signatures and re-locate respectively
7.13 + * move unparsing ("*_t0_str", "*2str", etc) somewhere else in ThydataC/
7.14 + * apply Isabelle's coding standards and remove warnings
7.15 + * rename "library.sml" to "libraryC.sml" like many other files, where struct <> filename.
7.16 +*)
7.17 +
7.18 +infix 1 ~~~
7.19 +
7.20 +signature LIBRARYC =
7.21 + sig
7.22 + val and_: bool * bool -> bool
7.23 + val assoc: (''a * 'b) list * ''a -> 'b option
7.24 + val assoc_string: (string * 'a) list * string -> 'a option
7.25 + val bool2str: bool -> string
7.26 + val commas: string list -> string
7.27 + val compare_strs: string -> string -> unit list
7.28 + val dashs: int -> string
7.29 + val de_quote: string -> string
7.30 + val distinct: ''a list -> ''a list
7.31 + val dots: int -> string
7.32 + val drop: int * 'a list -> 'a list
7.33 + val drop_last: 'a list -> 'a list
7.34 + val drop_last_n: int -> 'a list -> 'a list
7.35 + val drop_nth: 'a list -> int * 'a list -> 'a list
7.36 + val dropuntil: ('a -> bool) -> 'a list -> 'a list
7.37 + val dropwhile: ('a -> bool) -> 'a list -> 'a list
7.38 + val foldl: ('a * 'b -> 'a) -> 'a * 'b list -> 'a
7.39 + val foldr: ('a * 'b -> 'b) -> 'a list * 'b -> 'b
7.40 + val fst3: 'a * 'b * 'c -> 'a
7.41 + val gen_distinct: ('a * 'a -> bool) -> 'a list -> 'a list
7.42 + val gen_mem: ('a * 'b -> bool) -> 'a * 'b list -> bool
7.43 + val gen_rems: ('a * 'b -> bool) -> 'a list * 'b list -> 'a list
7.44 + val if_none: 'a option -> 'a -> 'a
7.45 + val indent: int -> string
7.46 + val indt: int -> string
7.47 + val idt: string -> int -> string
7.48 + val int2str: int -> string
7.49 + val ints2str': int list -> string
7.50 + val intsto: int -> int list
7.51 + val last_elem: 'a list -> 'a
7.52 + val list2str: string list -> string
7.53 + val list_update: 'a list -> int -> 'a -> 'a list
7.54 + val maxl: int list -> int
7.55 + val member_swap: ('a * 'b -> bool) -> 'a -> 'b list -> bool
7.56 + val nos: string list -> string
7.57 + val nth: int -> 'a list -> 'a
7.58 + val or_: bool * bool -> bool
7.59 + val overwrite: (''a * 'b) list * (''a * 'b) -> (''a * 'b) list
7.60 + val overwritel: (''a * 'b) list * (''a * 'b) list -> (''a * 'b) list
7.61 + val pair2str: string * string -> string
7.62 + val pair2str_: string * string -> string
7.63 + val pair2tri: ('a * 'b) * 'c -> 'a * 'b * 'c
7.64 + val snd3: 'a * 'b * 'c -> 'b
7.65 + val spair2str: string * string -> string
7.66 + val split_nlast: int * 'a list -> 'a list * 'a list
7.67 + val string_to_bool: string -> bool
7.68 + val strs2str: string list -> string
7.69 + val strs2str': string list -> string
7.70 + val strs2str_: string list -> string (* duplicates in Rule *)
7.71 + val strslist2strs: string list list -> string
7.72 + val take: int * 'a list -> 'a list
7.73 + val take_fromto: int -> int -> 'a list -> 'a list
7.74 + val takelast: int * 'a list -> 'a list
7.75 + val takerest: int * 'a list -> 'a list
7.76 + val takewhile: 'a list -> ('a -> bool) -> 'a list -> 'a list
7.77 + val termless: term * term -> bool
7.78 + val thd3: 'a * 'b * 'c -> 'c
7.79 + val triple2pair: 'a * 'b * 'c -> 'a * 'b
7.80 + val ~~~ : 'a list * 'b list -> ('a * 'b) list
7.81 +(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
7.82 + (* NONE *)
7.83 +(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
7.84 + val enumerate_strings: string list -> string list
7.85 + val quad2pair: 'a * 'b * 'c * 'd -> 'a * 'b
7.86 +( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
7.87 +
7.88 +
7.89 +(*///------------------------------>>> thy ------------------------------------------------\\\*)
7.90 + val get_thy: string -> string
7.91 + val strip_thy: string -> string
7.92 +(*\\\------------------------------>>> thy ------------------------------------------------///*)
7.93 +(*///------------------------------>>> term -----------------------------------------------\\\*)
7.94 + val subs2str: string list -> string
7.95 + val id_of: term -> string
7.96 + val ids_of: term -> string list
7.97 +(*\\\------------------------------>>> term -----------------------------------------------///*)
7.98 + end;
7.99 +
7.100 +(**)
7.101 +structure LibraryC(*: RULE*) =
7.102 +struct
7.103 +(**)
7.104 +
7.105 +val foldl = Library.foldl
7.106 +val foldr = Library.foldr
7.107 +fun take (n, xs) = Library.take n xs;;
7.108 +fun drop (n, xs) = Library.drop n xs;
7.109 +
7.110 +fun last_elem [] = raise ERROR "last_elem"
7.111 + | last_elem [x] = x
7.112 + | last_elem (_ :: xs) = last_elem xs;
7.113 +fun member_swap eq x xs = member eq xs x
7.114 +
7.115 +fun gen_mem _ (_, []) = false
7.116 + | gen_mem eq (x, y :: ys) = eq (x, y) orelse gen_mem eq (x, ys);
7.117 +fun gen_rems eq (xs, ys) = filter_out (fn x => gen_mem eq (x, ys)) xs;
7.118 +
7.119 +(* got : string list -> string list with Library.distinct (op =) ?!? *)
7.120 +fun gen_distinct eq lst =
7.121 + let
7.122 + val memb = gen_mem eq;
7.123 +
7.124 + fun dist (rev_seen, []) = rev rev_seen
7.125 + | dist (rev_seen, x :: xs) =
7.126 + if memb (x, rev_seen) then dist (rev_seen, xs)
7.127 + else dist (x :: rev_seen, xs);
7.128 + in dist ([], lst) end;
7.129 +fun distinct l = gen_distinct (op =) l;
7.130 +
7.131 +(*fun nth n xs = Library.nth xs n; exn behaviour different*)
7.132 +fun nth _ [] = raise ERROR "nth _ []" (*Isabelle2002, still saved the hours of update*)
7.133 + | nth 1 (x :: _) = x
7.134 + | nth n (_ :: xs) = nth (n - 1) xs;
7.135 +
7.136 +fun list_update [] _ _ = []
7.137 + | list_update (x :: xs) i v =
7.138 + case i of
7.139 + 0 => v :: xs
7.140 + | j => x :: list_update xs (j - 1) v
7.141 +
7.142 +fun drop_nth ls (_, []) = ls
7.143 + | drop_nth ls (n, x :: xs) =
7.144 + if n = 1
7.145 + then ls @ xs
7.146 + else drop_nth (ls @ [x]) (n - 1, xs);
7.147 +
7.148 +fun and_ (b1, b2) = b1 andalso b2;
7.149 +fun or_ (b1, b2) = b1 orelse b2;
7.150 +
7.151 +fun takerest (i, ls) = (rev o take) (length ls - i, rev ls);
7.152 +fun takelast (i, ls) = (rev o take) (i, rev ls);
7.153 +fun split_nlast (i, ls) = (take (length ls - i, ls), rev (take (i, rev ls)));
7.154 +fun dropwhile _ [] = []
7.155 + | dropwhile P (ys as x :: xs) = if P x then dropwhile P xs else ys;
7.156 +fun takewhile col _ [] = col
7.157 + | takewhile col P (x::xs) =
7.158 + if P x then takewhile (col @ [x]) P xs else col;
7.159 +fun dropuntil _ [] = []
7.160 + | dropuntil P (ys as x :: xs) = if P x then ys else dropuntil P xs;
7.161 +fun drop_last l = ((rev o tl o rev) l);
7.162 +fun drop_last_n n l = rev (takerest (n, rev l));
7.163 +
7.164 +fun pair2tri ((a,b),c) = (a,b,c);
7.165 +fun fst3 (a,_,_) = a;
7.166 +fun snd3 (_,b,_) = b;
7.167 +fun thd3 (_,_,c) = c;
7.168 +
7.169 +fun de_quote str =
7.170 + let fun scan ss' [] = ss'
7.171 + | scan ss' ("\"" :: ss) = scan ss' ss
7.172 + | scan ss' (s :: ss) = scan (ss' @ [s]) ss;
7.173 + in (implode o (scan []) o Symbol.explode) str end;
7.174 +val commas = Library.space_implode ",";
7.175 +
7.176 +fun strs2str strl = "[" ^ (commas (map quote strl)) ^ "]";
7.177 +fun strs2str' strl = "[" ^ commas strl ^ "]";
7.178 +fun list2str strl = "[" ^ commas strl ^ "]";
7.179 +val nos = space_implode "#";
7.180 +fun strs2str_ strl = "#" ^ (nos strl) ^ "#";
7.181 +fun strslist2strs strslist = map strs2str strslist |> strs2str';
7.182 +fun spair2str (s1, s2) = "(" ^ quote s1 ^ ", " ^ quote s2 ^ ")";
7.183 +fun pair2str_ (s1, s2) = s1 ^ "#" ^ s2;
7.184 +fun pair2str (s1, s2) = "(" ^ s1 ^ ", " ^ s2 ^ ")";
7.185 +
7.186 +val int2str = Library.string_of_int;
7.187 +fun ints2str' ints = (strs2str' o (map string_of_int)) ints;
7.188 +
7.189 +fun overwrite (al, p as (key, _)) =
7.190 + let fun over ((q as (keyi, _)) :: pairs) =
7.191 + if keyi = key then p :: pairs else q :: (over pairs)
7.192 + | over [] = [p]
7.193 + in over al end;
7.194 +fun overwritel (al, []) = al
7.195 + | overwritel (al, b::bl) = overwritel (overwrite (al, b), bl);
7.196 +
7.197 +local
7.198 +fun intsto1 0 = []
7.199 + | intsto1 n = (intsto1 (n - 1)) @ [n]
7.200 +in
7.201 +fun intsto n = if n < 0 then (error "intsto < 0") else intsto1 n
7.202 +end;
7.203 +
7.204 +fun bool2str true = "true"
7.205 + | bool2str false = "false";
7.206 +fun string_to_bool "true" = true
7.207 + | string_to_bool "false" = false
7.208 + | string_to_bool str = raise ERROR ("string_to_bool: arg = " ^ str)
7.209 +
7.210 +(* take elements from b to e including both *)
7.211 +fun take_fromto from to l =
7.212 + if from > to
7.213 + then raise ERROR ("take_fromto from=" ^ string_of_int from ^ " > to=" ^ string_of_int to)
7.214 + else drop (from - 1, take (to, l));
7.215 +
7.216 +fun idt _ 0 = " "
7.217 + | idt str n = str ^ idt str (n - 1);
7.218 +fun indt n = if n <= 0 then "" else " " ^ indt (n-1);
7.219 +fun indent i = fold (curry op ^) (replicate i ". ") ""
7.220 +
7.221 +fun dashs i = if 0 < i then "-" ^ dashs (i - 1) else "";
7.222 +fun dots i = if 0 < i then "." ^ dots (i - 1) else "";
7.223 +
7.224 +(*val assoc = AList.lookup (op =) SAME PROBLEM AS WITH Library.distinct *)
7.225 +fun assoc ([], _) = NONE(*cp 2002 Pure/library.ML FIXXXME take AList.lookup*)
7.226 + | assoc ((keyi, xi) :: pairs, key) =
7.227 + if key = keyi then SOME xi else assoc (pairs, key);
7.228 +(* optimized version for strings *)
7.229 +fun assoc_string ([], (_ : string)) = NONE
7.230 + | assoc_string ((keyi, xi) :: pairs, key) =
7.231 + if key = keyi then SOME xi else assoc_string (pairs, key);
7.232 +fun if_none NONE y = y (*cp from 2002 Pure/library.ML FIXXXME replace*)
7.233 + | if_none (SOME x) _ = x;
7.234 +
7.235 +fun compare_strs str1 str2 =
7.236 + let
7.237 + fun comp_char (c1, c2) = tracing ("comp_strs: " ^ c1 ^ " = " ^ c2 ^ " ..." ^ bool2str (c1 = c2))
7.238 + in map comp_char ((Symbol.explode str1) ~~ (Symbol.explode str2)) end;
7.239 +
7.240 +fun triple2pair (a, b, _) = (a, b);
7.241 +fun quad2pair (a, b, _, _) = (a, b);
7.242 +
7.243 +(* append a counter to a string list *)
7.244 +fun enumerate_strings strs =
7.245 + let fun enum _ [] = []
7.246 + | enum i (s :: ss) = (s ^ "--" ^ string_of_int i) :: (enum (i + 1) ss)
7.247 + in enum 1 strs end
7.248 +
7.249 +fun maxl [] = error "maxl of []"
7.250 + | maxl (y :: ys) =
7.251 + let
7.252 + fun mx x [] = x
7.253 + | mx x (y :: ys) = if x < (y: int) then mx y ys else mx x ys
7.254 + in mx y ys end
7.255 +
7.256 +fun xs ~~~ ys =
7.257 + let fun aaa xys [] [] = xys
7.258 + | aaa xys [] (_ :: _) = xys
7.259 + | aaa xys (_ :: _) [] = xys
7.260 + | aaa xys (x :: xs) (y :: ys) = aaa (xys @ [(x, y)]) xs ys
7.261 + in aaa [] xs ys end;
7.262 +
7.263 +(*///------------------------------>>> thy ------------------------------------------------\\\*)
7.264 +fun get_thy str =
7.265 + let
7.266 + fun get strl [] = strl
7.267 + | get strl ("." :: _) = strl
7.268 + | get strl ( s :: ss) = get (strl @ [s]) ss
7.269 + in implode (get [] (Symbol.explode str)) end;
7.270 +
7.271 +fun strip_thy str =
7.272 + let fun strip bdVar [] = implode (rev bdVar)
7.273 + | strip bdVar ("." :: _) = implode (rev bdVar)
7.274 + | strip bdVar (c :: cs) = strip (bdVar @ [c]) cs
7.275 + in strip [] (rev (Symbol.explode str)) end;
7.276 +(*\\\------------------------------>>> thy ------------------------------------------------///*)
7.277 +
7.278 +(*///------------------------------>>> term ----------------------------------------------\\\*)
7.279 +fun id_of (Var ((id,ix),_)) = if ix=0 then id else id^(string_of_int ix)
7.280 + | id_of (Free (id ,_)) = id
7.281 + | id_of (Const(id ,_)) = id
7.282 + | id_of _ = ""; (* never such an identifier *)
7.283 +
7.284 +fun ids_of t =
7.285 + let fun con ss (Const (s,_)) = s::ss
7.286 + | con ss (Free (s,_)) = s::ss
7.287 + | con ss (Abs (s,_,b)) = s::(con ss b)
7.288 + | con ss (t1 $ t2) = (con ss t1) @ (con ss t2)
7.289 + | con ss _ = ss
7.290 + in map strip_thy ((distinct o (con [])) t) end;
7.291 +
7.292 +fun subs2str (subs: string list) = list2str subs;
7.293 +(*> val sss = ["(''bdv'',x)","(err,#0)"];
7.294 +> subs2str sss;
7.295 +val it = "[(bdv,x),(err,#0)]" : string*)
7.296 +(*\\\------------------------------>>> term ----------------------------------------------///*)
7.297 +
7.298 +fun termless tu = (Term_Ord.term_ord tu = LESS);
7.299 +
7.300 +end; (*struct*) open LibraryC
8.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
8.2 +++ b/src/Tools/isac/CalcElements/rule.sml Fri Aug 23 16:36:47 2019 +0200
8.3 @@ -0,0 +1,512 @@
8.4 +(* rules guiding stepwise execution of methods in the LUCAS_INTERPRETER.
8.5 + Author: Walther Neuper 2018 (code gathered from other Isac source)
8.6 + (c) copyright due to lincense terms
8.7 +*)
8.8 +
8.9 +signature RULE =
8.10 + sig
8.11 + eqtype calID
8.12 + type eval_fn = string -> term -> theory -> (string * term) option
8.13 + val e_evalfn: 'a -> term -> theory -> (string * term) option
8.14 + type cal = calID * eval_fn
8.15 + eqtype prog_calcID
8.16 + type calc = prog_calcID * cal
8.17 + type calc_elem
8.18 + val calc_eq: calc_elem * calc_elem -> bool
8.19 +
8.20 + eqtype cterm' (* shift up in sequence of defs *)
8.21 + type subst = (term * term) list (* shift up in sequence of defs *)
8.22 +
8.23 + eqtype rew_ord'
8.24 + val e_rew_ord': rew_ord'
8.25 + type rew_ord_
8.26 + val dummy_ord: rew_ord_
8.27 + val e_rew_ord_: rew_ord_
8.28 + type rew_ord = rew_ord' * rew_ord_
8.29 + val e_rew_ord: rew_ord_
8.30 + val e_rew_ordX: rew_ord
8.31 + val rew_ord': (rew_ord' * (subst -> term * term -> bool)) list Unsynchronized.ref
8.32 + val assoc_rew_ord: string -> subst -> term * term -> bool
8.33 +
8.34 + eqtype errpatID
8.35 + type errpat = errpatID * term list * thm list
8.36 + eqtype rls'
8.37 + datatype rls
8.38 + = Erls
8.39 + | Rls of {calc: calc list, erls: rls, errpatts: errpatID list, id: string,
8.40 + preconds: term list, rew_ord: rew_ord, rules: rule list, scr: program, srls: rls}
8.41 + | Seq of {calc: calc list, erls: rls, errpatts: errpatID list, id: string,
8.42 + preconds: term list, rew_ord: rew_ord, rules: rule list, scr: program, srls: rls}
8.43 + | Rrls of {calc: calc list, erls: rls, errpatts: errpatID list, id: string,
8.44 + prepat: (term list * term) list, rew_ord: rew_ord, scr: program}
8.45 + and rule = Cal1 of string * eval_fn | Calc of string * eval_fn | Erule
8.46 + | Rls_ of rls | Thm of string * thm
8.47 + and program
8.48 + = EmptyScr
8.49 + | Prog of term
8.50 + | Rfuns of
8.51 + {attach_form: rule list list -> term -> term -> (rule * (term * term list)) list,
8.52 + init_state: term -> term * term * rule list list * (rule * (term * term list)) list,
8.53 + locate_rule: rule list list -> term -> rule -> (rule * (term * term list)) list,
8.54 + next_rule: rule list list -> term -> rule option, normal_form: term ->
8.55 + (term * term list) option}
8.56 + val rule2str: rule -> string
8.57 + val rule2str': rule -> string
8.58 + val e_rule: rule
8.59 + val get_rules: rls -> rule list
8.60 + val id_rule: rule -> string
8.61 + val eq_rule: rule * rule -> bool
8.62 +
8.63 + val scr2str: program -> string
8.64 + val e_rrls: rls
8.65 +
8.66 + val e_rls: rls
8.67 + val rls2str: rls -> string
8.68 + val id_rls: rls -> string
8.69 + val rep_rls: rls -> {calc: calc list, erls: rls, errpats: errpatID list, id: string,
8.70 + preconds: term list, rew_ord: rew_ord, rules: rule list, scr: program, srls: rls}
8.71 + val append_rls: string -> rls -> rule list -> rls
8.72 + val merge_rls: string -> rls -> rls -> rls
8.73 + val remove_rls: string -> rls -> rule list -> rls
8.74 +
8.75 + type rrlsstate = term * term * rule list list * (rule * (term * term list)) list
8.76 + val e_rrlsstate: rrlsstate
8.77 +
8.78 + val thy2ctxt: theory -> Proof.context (* shift up in sequence of defs *)
8.79 + val thy2ctxt': string -> Proof.context (* shift up in sequence of defs *)
8.80 + val Thy_Info_get_theory: string -> theory (* shift up in sequence of defs *)
8.81 +
8.82 + eqtype thyID (* shift up in sequence of defs *)
8.83 + eqtype domID (* shift up in sequence of defs *)
8.84 + val e_domID: domID (* shift up in sequence of defs *)
8.85 + eqtype theory' (* shift up in sequence of defs *)
8.86 + val theory'2thyID: theory' -> theory' (* shift up in sequence of defs *)
8.87 + val theory2theory': theory -> theory' (* shift up in sequence of defs *)
8.88 + val theory2thyID: theory -> thyID (* shift up in sequence of defs *)
8.89 + val thyID2theory': thyID -> thyID (* shift up in sequence of defs *)
8.90 + val string_of_thy: theory -> theory' (* shift up in sequence of defs *)
8.91 + val theory2domID: theory -> theory' (* shift up in sequence of defs *)
8.92 +
8.93 + val Isac: 'a -> theory (* shift up in sequence of defs *)
8.94 +
8.95 + val string_of_thmI: thm -> string (* shift up to Unparse *)
8.96 + val e_term: term (* shift up to Unparse *)
8.97 + val e_type: typ (* shift up to Unparse *)
8.98 + val type2str: typ -> string
8.99 + val term_to_string': Proof.context -> term -> string (* shift up to Unparse *)
8.100 + val term2str: term -> string (* shift up to Unparse *)
8.101 + val termopt2str: term option -> string (* shift up to Unparse *)
8.102 + val theory2str: theory -> theory' (* shift up to Unparse *)
8.103 + val terms2str: term list -> string (* shift up to Unparse *)
8.104 + val terms2strs: term list -> string list
8.105 + val term_to_string'': thyID -> term -> string (* shift up to Unparse *)
8.106 + val term_to_string''': theory -> term -> string (* shift up to Unparse *)
8.107 + val t2str: theory -> term -> string
8.108 + val ts2str: theory -> term list -> string (* shift up to Unparse *)
8.109 + val string_of_typ: typ -> string (* shift up to Unparse *)
8.110 + val string_of_typ_thy: thyID -> typ -> string (* shift up to Unparse *)
8.111 +
8.112 +(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
8.113 + val terms2str': term list -> string (* shift up to Unparse *)
8.114 + val thm2str: thm -> string
8.115 + val thms2str : thm list -> string
8.116 +(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
8.117 + val string_of_thm': theory -> thm -> string (* shift up to Unparse *)
8.118 + val string_of_thm: thm -> string (* shift up to Unparse *)
8.119 + val errpats2str : errpat list -> string
8.120 +( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
8.121 +
8.122 +(*----- unused code, kept as hints to design ideas ---------------------------------------------*)
8.123 +
8.124 + end
8.125 +
8.126 +(**)
8.127 +structure Rule(**): RULE(**) =
8.128 +struct
8.129 +(**)
8.130 +
8.131 +type calID = string;
8.132 +(* eval function calling sml code during rewriting.
8.133 +Unifying "type cal" and "type calc" would make Lucas-Interpretation more efficient,
8.134 + see "fun rule2stac": instead of
8.135 + Calc: calID * eval_fn -> rule
8.136 + would be better
8.137 + Calc: prog_calcID * (calID * eval_fn)) -> rule*)
8.138 +type eval_fn = (string -> term -> theory -> (string * term) option);
8.139 +fun e_evalfn (_ : 'a) (_ : term) (_ : theory) = NONE : (string * term) option;
8.140 +
8.141 +(* op in isa-term "Const(op,_)" *)
8.142 +type cal = calID * eval_fn;
8.143 +type prog_calcID = string;
8.144 +type calc = (prog_calcID * cal);
8.145 +
8.146 +type calc_elem = (* fun calculate_ fetches the evaluation-function via this list *)
8.147 + prog_calcID * (* a simple identifier used in programs *)
8.148 + (calID * (* a long identifier used in Const *)
8.149 + eval_fn) (* an ML function *)
8.150 +fun calc_eq ((pi1, (ci1, _)), (pi2, (ci2, _))) =
8.151 + if pi1 = pi2
8.152 + then if ci1 = ci2 then true else error ("calc_eq: " ^ ci1 ^ " <> " ^ ci2)
8.153 + else false
8.154 +
8.155 +type cterm' = string;
8.156 +type subst = (term * term) list;
8.157 +
8.158 +(*TODO.WN060610 make use of "type rew_ord" total*)
8.159 +type rew_ord' = string;
8.160 +val e_rew_ord' = "e_rew_ord" : rew_ord';
8.161 +
8.162 +type rew_ord_ = subst -> Term.term * Term.term -> bool;
8.163 +fun dummy_ord (_: subst) (_: term, _: term) = true;
8.164 +val e_rew_ord_ = dummy_ord;
8.165 +type rew_ord = rew_ord' * rew_ord_;
8.166 +val e_rew_ord = dummy_ord; (* TODO.WN071231 clarify identifiers..e_rew_ordX*)
8.167 +val e_rew_ordX = (e_rew_ord', e_rew_ord_);
8.168 +
8.169 +(* rewrite orders, also stored in 'type met' and type 'and rls'
8.170 + The association list is required for 'rewrite.."rew_ord"..' *)
8.171 +val rew_ord' = Unsynchronized.ref
8.172 + ([("e_rew_ord", e_rew_ord), ("dummy_ord", dummy_ord)]
8.173 + : (rew_ord' * (* the key for the association list *)
8.174 + (subst (* the bound variables - they get high order*)
8.175 + -> (term * term) (* (t1, t2) to be compared *)
8.176 + -> bool)) (* if t1 <= t2 then true else false *)
8.177 + list); (* association list *)
8.178 +fun assoc' ([], key) = raise ERROR ("ME_Isa: \"" ^ key ^ "\" not known")
8.179 + | assoc' ((keyi, xi) :: pairs, key) =
8.180 + if key = keyi then SOME xi else assoc' (pairs, key);
8.181 +fun assoc_rew_ord ro = ((the o assoc') (! rew_ord',ro))
8.182 + handle _ => error ("ME_Isa: rew_ord '" ^ ro ^ "' not in system");
8.183 +
8.184 +(* Since Isabelle2017 sessions in theory identifiers are enforced.
8.185 + However, we leave theory identifiers short, in particular in use as keys into KEStore. *)
8.186 +fun Thy_Info_get_theory thyID = Thy_Info.get_theory ("Isac." ^ thyID)
8.187 +fun thy2ctxt' thy' = Proof_Context.init_global (Thy_Info_get_theory thy');(*FIXXXME thy-ctxt*)
8.188 +fun thy2ctxt thy = Proof_Context.init_global thy;(*FIXXXME thy-ctxt*)
8.189 +fun Isac _ = Proof_Context.theory_of (thy2ctxt' "Isac"); (*@{theory "Isac"}*)
8.190 +
8.191 +fun term_to_string' ctxt t =
8.192 + let
8.193 + val ctxt' = Config.put show_markup false ctxt
8.194 + in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
8.195 +fun term_to_string'' thyID t =
8.196 + let
8.197 + val ctxt' = Config.put show_markup false (Proof_Context.init_global (Thy_Info_get_theory thyID))
8.198 + in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
8.199 +fun term_to_string''' thy t =
8.200 + let
8.201 + val ctxt' = Config.put show_markup false (Proof_Context.init_global thy)
8.202 + in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
8.203 +
8.204 +fun term2str t = term_to_string' (thy2ctxt' "Isac") t;
8.205 +fun t2str thy t = term_to_string' (thy2ctxt thy) t;
8.206 +fun ts2str thy ts = ts |> map (t2str thy) |> strs2str';
8.207 +fun terms2strs ts = map term2str ts; (* terms2strs [t1,t2] = ["1 + 2", "abc"]; *)
8.208 +val terms2str = strs2str o terms2strs; (* terms2str [t1,t2] = "[\"1 + 2\",\"abc\"]"; *)
8.209 +val terms2str' = strs2str' o terms2strs; (* terms2str' [t1,t2] = "[1 + 2,abc]"; *)
8.210 +fun termopt2str (SOME t) = "(SOME " ^ term2str t ^ ")"
8.211 + | termopt2str NONE = "NONE";
8.212 +
8.213 +fun thm2str thm =
8.214 + let
8.215 + val t = Thm.prop_of thm
8.216 + val ctxt = Proof_Context.init_global (Thy_Info.get_theory ("Isac.Isac"))
8.217 + val ctxt' = Config.put show_markup false ctxt
8.218 + in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
8.219 +fun thms2str thms = (strs2str o (map thm2str)) thms
8.220 +
8.221 +(* error patterns and fill patterns *)
8.222 +type errpatID = string
8.223 +type errpat =
8.224 + errpatID (* one identifier for a list of patterns
8.225 + DESIGN ?TODO: errpatID list for hierarchy of errpats ? *)
8.226 + * term list (* error patterns *)
8.227 + * thm list (* thms related to error patterns; note that respective lhs
8.228 + do not match (which reflects student's error).
8.229 + fillpatterns are stored with these thms. *)
8.230 +fun errpat2str (id, tms, thms) =
8.231 + "(\"" ^ id ^ "\",\n" ^ terms2str tms ^ ",\n" ^ thms2str thms
8.232 +fun errpats2str errpats = (strs2str' o (map errpat2str)) errpats
8.233 +
8.234 +datatype rule =
8.235 + Erule (*.the empty rule .*)
8.236 +| Thm of (string * Basic_Thm.thm) (* see TODO CLEANUP Thm *)
8.237 +| Calc of string * (*.sml-code manipulating a (sub)term .*)
8.238 + eval_fn
8.239 +| Cal1 of string * (*.sml-code applied only to whole term
8.240 + or left/right-hand-side of eqality .*)
8.241 + eval_fn
8.242 +| Rls_ of rls (*.ie. rule sets may be nested.*)
8.243 +and program =
8.244 + EmptyScr
8.245 + | Prog of term (* a leaf is either a tactic or an 'exp' in 'let v = expr'
8.246 + where 'exp' does not contain a tactic. *)
8.247 + | Rfuns of (* for Rrls, usage see rational.sml ----- reverse rewrite ----- *)
8.248 + {init_state : (* initialise for reverse rewriting by the Interpreter *)
8.249 + term -> (* for this the rrlsstate is initialised: *)
8.250 + term * (* the current formula: goes locate_input_tactic -> determine_next_tactic via istate *)
8.251 + term * (* the final formula *)
8.252 + rule list (* of reverse rewrite set (#1#) *)
8.253 + list * (* may be serveral, eg. in norm_rational *)
8.254 + ( rule * (* Thm (+ Thm generated from Calc) resulting in ... *)
8.255 + (term * (* ... rewrite with ... *)
8.256 + term list)) (* ... assumptions *)
8.257 + list, (* derivation from given term to normalform
8.258 + in reverse order with sym_thm;
8.259 + (#1#) could be extracted from here #1 *)
8.260 + normal_form: (* the function which drives the Rrls ##############################*)
8.261 + term -> (term * term list) option,
8.262 + locate_rule: (* checks a rule R for being a cancel-rule, and if it is,
8.263 + then return the list of rules (+ the terms they are rewriting to)
8.264 + which need to be applied before R should be applied.
8.265 + precondition: the rule is applicable to the argument-term. *)
8.266 + rule list list -> (* the reverse rule list *)
8.267 + term -> (* ... to which the rule shall be applied *)
8.268 + rule -> (* ... to be applied to term *)
8.269 + ( rule * (* value: a rule rewriting to ... *)
8.270 + (term * (* ... the resulting term ... *)
8.271 + term list)) (* ... with the assumptions ( //#0) *)
8.272 + list, (* there may be several such rules; the list is empty,
8.273 + if the rule has nothing to do with e.g. cancelation *)
8.274 + next_rule: (* for a given term return the next rules to be done for cancelling *)
8.275 + rule list list->(* the reverse rule list *)
8.276 + term -> (* the term for which ... *)
8.277 + rule option, (* ... this rule is appropriate for cancellation;
8.278 + there may be no such rule (if the term is eg.canceled already*)
8.279 + attach_form: (* checks an input term TI, if it may belong to e.g. a current
8.280 + cancellation, by trying to derive it from the given term TG.
8.281 + NOT IMPLEMENTED *)
8.282 + rule list list->(**)
8.283 + term -> (* TG, the last one agreed upon by user + math-eng *)
8.284 + term -> (* TI, the next one input by the user *)
8.285 + ( rule * (* the rule to be applied in order to reach TI *)
8.286 + (term * (* ... obtained by applying the rule ... *)
8.287 + term list)) (* ... and the respective assumptions *)
8.288 + list} (* there may be several such rules; the list is empty, if the
8.289 + users term does not belong to e.g. a cancellation of the term
8.290 + last agreed upon. *)
8.291 +and rls =
8.292 + Erls (*for init e_rls*)
8.293 +
8.294 + | Rls of (*a confluent and terminating ruleset, in general *)
8.295 + {id : string, (*for trace_rewrite:=true *)
8.296 + preconds : term list, (*unused WN020820 *)
8.297 + (*WN060616 for efficiency...
8.298 + bdvs : false, (*set in prep_rls' for get_bdvs *)*)
8.299 + rew_ord : rew_ord, (*for rules*)
8.300 + erls : rls, (*for the conditions in rules *)
8.301 + srls : rls, (*for evaluation of list_fns in script *)
8.302 + calc : calc list, (*for Calculate in scr, set by prep_rls' *)
8.303 + rules : rule list,
8.304 + errpatts : errpatID list,(*dialog-authoring in Build_Thydata.thy *)
8.305 + scr : program} (*Prog term: generating intermed.steps *)
8.306 + | Seq of (*a sequence of rules to be tried only once *)
8.307 + {id : string, (*for trace_rewrite:=true *)
8.308 + preconds : term list, (*unused 20.8.02 *)
8.309 + (*WN060616 for efficiency...
8.310 + bdvs : false, (*set in prep_rls' for get_bdvs *)*)
8.311 + rew_ord : rew_ord, (*for rules *)
8.312 + erls : rls, (*for the conditions in rules *)
8.313 + srls : rls, (*for evaluation of list_fns in script *)
8.314 + calc : calc list, (*for Calculate in scr, set by prep_rls' *)
8.315 + rules : rule list,
8.316 + errpatts : errpatID list,(*dialog-authoring in Build_Thydata.thy*)
8.317 + scr : program} (*Prog term (how to restrict type ???)*)
8.318 +
8.319 + (*Rrls call SML-code and simulate an rls
8.320 + difference: there is always _ONE_ redex rewritten in 1 call,
8.321 + thus wrap Rrls by: Rls (Rls_ ...)*)
8.322 + | Rrls of (* SML-functions within rewriting; step-wise execution provided;
8.323 + Rrls simulate an rls
8.324 + difference: there is always _ONE_ redex rewritten in 1 call,
8.325 + thus wrap Rrls by: Rls (Rls_ ...) *)
8.326 + {id : string, (* for trace_rewrite := true *)
8.327 + prepat : (term list *(* preconds, eval with subst from pattern;
8.328 + if [@{term True}], match decides alone *)
8.329 + term ) (* pattern matched with current (sub)term *)
8.330 + list, (* meta-conjunction is or *)
8.331 + rew_ord : rew_ord, (* for rules *)
8.332 + erls : rls, (* for the conditions in rules and preconds *)
8.333 + calc : calc list, (* for Calculate in scr, set automatic.in prep_rls' *)
8.334 + errpatts : errpatID list,(*dialog-authoring in Build_Thydata.thy*)
8.335 + scr : program}; (* Rfuns {...} (how to restrict type ???) *)
8.336 +
8.337 +fun id_rls Erls = "e_rls" (*WN060714 quick and dirty: recursive defs! TODO "Erls"*)
8.338 + | id_rls (Rls {id, ...}) = id
8.339 + | id_rls (Seq {id, ...}) = id
8.340 + | id_rls (Rrls {id, ...}) = id;
8.341 +val rls2str = id_rls;
8.342 +fun id_rule (Thm (id, _)) = id
8.343 + | id_rule (Calc (id, _)) = id
8.344 + | id_rule (Cal1 (id, _)) = id
8.345 + | id_rule (Rls_ rls) = id_rls rls
8.346 + | id_rule Erule = "Erule";
8.347 +fun eq_rule (Thm (thm1, _), Thm (thm2, _)) = thm1 = thm2
8.348 + | eq_rule (Calc (id1, _), Calc (id2, _)) = id1 = id2
8.349 + | eq_rule (Rls_ rls1, Rls_ rls2) = id_rls rls1 = id_rls rls2
8.350 + | eq_rule _ = false;
8.351 +
8.352 +(*ad thm':
8.353 + there are two kinds of theorems ...
8.354 + (1) known by isabelle
8.355 + (2) not known, eg. calc_thm, instantiated rls
8.356 + the latter have a thmid "#..."
8.357 + and thus outside isa we ALWAYS transport both (thmID, string_of_thmI)
8.358 + and have a special assoc_thm / assoc_rls in this interface *)
8.359 +type theory' = string; (* = domID ^".thy" WN.101011 ABOLISH !*)
8.360 +type domID = string; (* domID ^".thy" = theory' WN.101011 replace by thyID*)
8.361 +type thyID = string; (* WN.3.11.03 TODO: replace domID with thyID*)
8.362 +val e_domID = "e_domID" : domID;
8.363 +
8.364 +fun string_of_thy thy = Context.theory_name thy: theory';
8.365 +val theory2domID = string_of_thy;
8.366 +val theory2thyID = (get_thy o string_of_thy) : theory -> thyID;
8.367 +val theory2theory' = string_of_thy;
8.368 +val theory2str = string_of_thy; (*WN050903 ..most consistent naming*)
8.369 +
8.370 +fun thyID2theory' (thyID:thyID) = thyID;
8.371 +fun theory'2thyID (theory':theory') = theory';
8.372 +
8.373 +fun type_to_string'' (thyID : thyID) t =
8.374 + let
8.375 + val ctxt' = Config.put show_markup false (Proof_Context.init_global (Thy_Info_get_theory thyID))
8.376 + in Print_Mode.setmp [] (Syntax.string_of_typ ctxt') t end;
8.377 +fun type2str typ = type_to_string'' "Isac" typ; (*TODO legacy*)
8.378 +val string_of_typ = type2str; (*legacy*)
8.379 +fun string_of_typ_thy thy typ = type_to_string'' thy typ; (*legacy*)
8.380 +
8.381 +(*check for [.] as caused by "fun assoc_thm'"*)
8.382 +fun string_of_thm thm = term_to_string' (thy2ctxt' "Isac") (Thm.prop_of thm)
8.383 +fun string_of_thm' thy thm = term_to_string' (thy2ctxt thy) (Thm.prop_of thm)
8.384 +fun string_of_thmI thm =
8.385 + let
8.386 + val str = (de_quote o string_of_thm) thm
8.387 + val (a, b) = split_nlast (5, Symbol.explode str)
8.388 + in
8.389 + case b of
8.390 + [" ", " ","[", ".", "]"] => implode a
8.391 + | _ => str
8.392 + end
8.393 +
8.394 +fun get_rules Erls = []
8.395 + | get_rules (Rls {rules, ...}) = rules
8.396 + | get_rules (Seq {rules, ...}) = rules
8.397 + | get_rules (Rrls _) = [];
8.398 +fun rule2str Erule = "Erule"
8.399 + | rule2str (Thm (str, thm)) = "Thm (\""^str^"\","^(string_of_thmI thm)^")"
8.400 + | rule2str (Calc (str, _)) = "Calc (\""^str^"\",fn)"
8.401 + | rule2str (Cal1 (str, _)) = "Cal1 (\""^str^"\",fn)"
8.402 + | rule2str (Rls_ rls) = "Rls_ (\""^id_rls rls^"\")";
8.403 +fun rule2str' Erule = "Erule"
8.404 + | rule2str' (Thm (str, _)) = "Thm (\""^str^"\",\"\")"
8.405 + | rule2str' (Calc (str, _)) = "Calc (\""^str^"\",fn)"
8.406 + | rule2str' (Cal1 (str, _)) = "Cal1 (\""^str^"\",fn)"
8.407 + | rule2str' (Rls_ rls) = "Rls_ (\""^id_rls rls^"\")";
8.408 +fun scr2str EmptyScr = "EmptyScr"
8.409 + | scr2str (Prog s) = "Prog " ^ term2str s
8.410 + | scr2str (Rfuns _) = "Rfuns";
8.411 +
8.412 +val e_type = Type ("empty",[]);
8.413 +val e_term = Const ("empty", e_type);
8.414 +val e_rule = Thm ("refl", @{thm refl});
8.415 +val e_term = Const ("empty", Type("'a", []));
8.416 +type rrlsstate = (* state for reverse rewriting, comments see type rule and scr | Rfuns *)
8.417 + (term * term * rule list list * (rule * (term * term list)) list);
8.418 +val e_rrlsstate = (e_term,e_term, [[e_rule]], [(e_rule, (e_term, []))]) : rrlsstate;
8.419 +
8.420 +type rls' = string;
8.421 +local
8.422 + fun ii (_: term) = e_rrlsstate;
8.423 + fun no (_: term) = SOME (e_term, [e_term]);
8.424 + fun lo (_: rule list list) (_: term) (_: rule) = [(e_rule, (e_term, [e_term]))];
8.425 + fun ne (_: rule list list) (_: term) = SOME e_rule;
8.426 + fun fo (_: rule list list) (_: term) (_: term) = [(e_rule, (e_term, [e_term]))];
8.427 +in
8.428 +val e_rfuns = Rfuns {init_state = ii, normal_form = no, locate_rule = lo,
8.429 + next_rule = ne, attach_form = fo};
8.430 +end;
8.431 +val e_rls =
8.432 + Rls {id = "e_rls", preconds = [], rew_ord = ("dummy_ord", dummy_ord), erls = Erls,
8.433 + srls = Erls, calc = [], rules = [], errpatts = [], scr = EmptyScr}: rls;
8.434 +val e_rrls =
8.435 + Rrls {id = "e_rrls", prepat = [], rew_ord = ("dummy_ord", dummy_ord), erls = Erls,
8.436 + calc = [], errpatts = [], scr = e_rfuns}:rls;
8.437 +
8.438 +fun rep_rls Erls = rep_rls e_rls
8.439 + | rep_rls (Rls {id, preconds, rew_ord, erls, srls, calc, errpatts, rules, scr}) =
8.440 + {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls, errpats = errpatts,
8.441 + calc = calc, rules = rules, scr = scr}
8.442 + | rep_rls (Seq {id, preconds, rew_ord, erls, srls, calc, errpatts, rules, scr}) =
8.443 + {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls, errpats = errpatts,
8.444 + calc = calc, rules = rules, scr = scr}
8.445 + | rep_rls (Rrls _) = rep_rls e_rls
8.446 +
8.447 +fun append_rls id Erls _ = raise ERROR ("append_rls: with \"" ^ id ^ "\" not for Erls")
8.448 + | append_rls id (Rls {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.449 + rules = rs, errpatts = errpatts, scr = sc}) r =
8.450 + Rls {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.451 + rules = rs @ r, errpatts = errpatts, scr = sc}
8.452 + | append_rls id (Seq {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.453 + rules = rs, errpatts = errpatts, scr = sc}) r =
8.454 + Seq {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.455 + rules = rs @ r, errpatts = errpatts, scr = sc}
8.456 + | append_rls id (Rrls _) _ = raise ERROR ("append_rls: not for reverse-rewrite-rule-set " ^ id);
8.457 +
8.458 +fun merge_ids rls1 rls2 =
8.459 + let
8.460 + val id1 = (#id o rep_rls) rls1
8.461 + val id2 = (#id o rep_rls) rls2
8.462 + in
8.463 + if id1 = id2 then id1 else "merged_" ^ id1 ^ "_" ^ id2
8.464 + end
8.465 +fun merge_rls _ Erls rls = rls
8.466 + | merge_rls _ rls Erls = rls
8.467 + | merge_rls _ (Rrls x) _ = Rrls x (* required for merging Theory_Data *)
8.468 + | merge_rls _ _ (Rrls x) = Rrls x
8.469 + | merge_rls id
8.470 + (Rls {preconds = pc1, rew_ord = ro1, erls = er1, srls = sr1, calc = ca1,
8.471 + rules = rs1, errpatts = eps1, scr = sc1, ...})
8.472 + (Rls {preconds = pc2, erls = er2, srls = sr2, calc = ca2,
8.473 + rules = rs2, errpatts = eps2, ...})
8.474 + =
8.475 + Rls {id = id, rew_ord = ro1, scr = sc1,
8.476 + preconds = union (op =) pc1 pc2,
8.477 + erls = merge_rls (merge_ids er1 er2) er1 er2,
8.478 + srls = merge_rls (merge_ids sr1 sr2) sr1 sr2,
8.479 + calc = union calc_eq ca1 ca2,
8.480 + rules = union eq_rule rs1 rs2,
8.481 + errpatts = union (op =) eps1 eps2}
8.482 + | merge_rls id
8.483 + (Seq {preconds = pc1, rew_ord = ro1, erls = er1, srls = sr1, calc = ca1,
8.484 + rules = rs1, errpatts = eps1, scr = sc1, ...})
8.485 + (Seq {preconds = pc2, erls = er2, srls = sr2, calc = ca2,
8.486 + rules = rs2, errpatts = eps2, ...})
8.487 + =
8.488 + Seq {id = id, rew_ord = ro1, scr = sc1,
8.489 + preconds = union (op =) pc1 pc2,
8.490 + erls = merge_rls (merge_ids er1 er2) er1 er2,
8.491 + srls = merge_rls (merge_ids sr1 sr2) sr1 sr2,
8.492 + calc = union calc_eq ca1 ca2,
8.493 + rules = union eq_rule rs1 rs2,
8.494 + errpatts = union (op =) eps1 eps2}
8.495 + | merge_rls id _ _ = error ("merge_rls: \"" ^ id ^
8.496 + "\"; not for reverse-rewrite-rule-sets and not for mixed Rls -- Seq");
8.497 +
8.498 +(* used only for one hack TODO remove *)
8.499 +fun remove_rls id (Rls {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.500 + rules = rs, errpatts = eps, scr = sc}) r =
8.501 + Rls {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.502 + rules = gen_rems eq_rule (rs, r),
8.503 + errpatts = eps,
8.504 + scr = sc}
8.505 + | remove_rls id (Seq {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.506 + rules = rs, errpatts = eps, scr = sc}) r =
8.507 + Seq {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
8.508 + rules = gen_rems eq_rule (rs, r),
8.509 + errpatts = eps,
8.510 + scr = sc}
8.511 + | remove_rls id (Rrls _) _ = raise ERROR ("remove_rls: not for reverse-rewrite-rule-set "^id)
8.512 + | remove_rls _ rls _ = raise ERROR ("remove_rls called with " ^ rls2str rls);
8.513 +
8.514 +
8.515 +end (*struct*)
9.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
9.2 +++ b/src/Tools/isac/CalcElements/termC.sml Fri Aug 23 16:36:47 2019 +0200
9.3 @@ -0,0 +1,572 @@
9.4 +(* Title: extends Isabelle/src/Pure/term.ML
9.5 + Author: Walther Neuper 1999, Mathias Lehnfeld
9.6 + (c) due to copyright terms
9.7 +*)
9.8 +infix contains_one_of
9.9 +
9.10 +(* TERM_C extends Isabelle's naming conventions: "C" indicates Isac add-ons to an Isabelle module *)
9.11 +signature TERM_C =
9.12 + sig
9.13 + val contains_Var: term -> bool
9.14 + val dest_binop_typ: typ -> typ * typ * typ
9.15 + val dest_equals: term -> term * term
9.16 + val free2str: term -> string
9.17 + val ids2str: term -> string list
9.18 + val ins_concl: term -> term -> term
9.19 + val inst_abs: term -> term
9.20 + val inst_bdv: (term * term) list -> term -> term
9.21 +
9.22 + val term_of_num: typ -> int -> term
9.23 + val num_of_term: term -> int
9.24 + val int_of_str_opt: string -> int option
9.25 + val int_of_str: string -> int
9.26 + val isastr_of_int: int -> string
9.27 +
9.28 + val isalist2list: term -> term list
9.29 + val list2isalist: typ -> term list -> term
9.30 + val isapair2pair: term -> term * term (* rename to dest_pair, compare HOLogic.dest_string *)
9.31 +
9.32 + val is_atom: term -> bool
9.33 + val is_bdv: string -> bool
9.34 + val is_bdv_subst: term -> bool
9.35 + val is_equality: term -> bool
9.36 + val is_expliceq: term -> bool
9.37 + val is_f_x: term -> bool
9.38 + val is_list: term -> bool
9.39 + val is_num: term -> bool
9.40 + val is_num': string -> bool
9.41 +
9.42 + val mk_add: term -> term -> term
9.43 + val mk_free: typ -> string -> term
9.44 + val mk_equality: term * term -> term
9.45 + val mk_factroot: string -> typ -> int -> int -> term
9.46 + val mk_Free: string * typ -> term
9.47 + val mk_thmid: string -> string -> string -> string
9.48 + val mk_num_op_num: typ -> typ -> string * typ -> int -> int -> term
9.49 + val mk_num_op_var: term -> string -> typ -> typ -> int -> term
9.50 + val mk_var_op_num: term -> string -> typ -> typ -> int -> term
9.51 +
9.52 + val matches: theory -> term -> term -> bool
9.53 + val parse: theory -> string -> cterm option
9.54 + val parseN: theory -> string -> cterm option
9.55 + val parseNEW: Proof.context -> string -> term option
9.56 + val parseNEW': Proof.context -> string -> term
9.57 + val parseold: theory -> string -> cterm option
9.58 + val parse_patt: theory -> string -> term
9.59 + val perm: term -> term -> bool
9.60 +
9.61 + val str_of_free_opt: term -> string option
9.62 + val str_of_int: int -> string
9.63 + val str2term: string -> term
9.64 + val strip_imp_prems': term -> term option
9.65 + val subst_atomic_all: (term * term) list -> term -> bool * term
9.66 + val term_detail2str: term -> string
9.67 +
9.68 + val pairt: term -> term -> term
9.69 + val pairT: typ -> typ -> typ
9.70 + val raise_type_conflicts: term list -> unit
9.71 + val strip_trueprop: term -> term
9.72 +
9.73 + val num_str: thm -> thm
9.74 + val numbers_to_string: term -> term
9.75 + val uminus_to_string: term -> term
9.76 + val var2free: term -> term
9.77 + val vars: term -> term list (* recognises numverals, should replace "fun vars_of" *)
9.78 + val vars_of: term -> term list
9.79 + val dest_list': term -> term list
9.80 +
9.81 +(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
9.82 + val scala_of_term: term -> string
9.83 + val atomtyp(*<-- atom_typ TODO*): typ -> unit
9.84 + val atomty: term -> unit
9.85 + val atomw: term -> unit
9.86 + val atomwy: term -> unit
9.87 + val atomty_thy: Rule.thyID -> term -> unit
9.88 + val free2var: term -> term
9.89 + val contains_one_of: thm * (string * typ) list -> bool
9.90 +(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
9.91 + val atomt: term -> unit
9.92 + val typ_a2real: term -> term
9.93 +( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
9.94 + end
9.95 +
9.96 +(**)
9.97 +structure TermC(**): TERM_C(**) =
9.98 +struct
9.99 +(**)
9.100 +
9.101 +fun isastr_of_int i = if i >= 0 then string_of_int i else "-" ^ string_of_int (abs i)
9.102 +
9.103 +fun matches thy tm pa =
9.104 + (Pattern.match thy (pa, tm) (Vartab.empty, Vartab.empty); true)
9.105 + handle Pattern.MATCH => false
9.106 +
9.107 +(** transform typ / term to a String to be parsed by Scala after transport via libisabelle **)
9.108 +
9.109 +fun scala_of_typ (Type (s, typs)) =
9.110 + enclose "Type(" ")" (quote s ^ ", " ^
9.111 + (typs |> map scala_of_typ |> commas |> enclose "List(" ")"))
9.112 + | scala_of_typ (TFree (s, sort)) =
9.113 + enclose "TFree(" ")" (quote s ^ ", " ^ (sort |> map quote |> commas |> enclose "List(" ")"))
9.114 + | scala_of_typ (TVar ((s, i), sort)) =
9.115 + enclose "TVar(" ")" (
9.116 + enclose "(" ")," (quote s ^ "," ^ quote (string_of_int i)) ^
9.117 + (sort |> map quote |> commas |> enclose "List(" ")"))
9.118 +fun scala_of_term (Const (s, T)) =
9.119 + enclose "Const(" ")" (quote s ^ ", " ^ scala_of_typ T)
9.120 + | scala_of_term (Free (s, T)) =
9.121 + enclose "Free(" ")" (quote s ^ ", " ^ scala_of_typ T)
9.122 + | scala_of_term (Var ((s, i), T)) =
9.123 + enclose "TVar(" ")" (
9.124 + enclose "(" ")," (quote s ^ "," ^ quote (string_of_int i)) ^
9.125 + scala_of_typ T)
9.126 + | scala_of_term (Bound i) = enclose "Bound(" ")" (string_of_int i)
9.127 + | scala_of_term (Abs (s, T, t)) =
9.128 + enclose "Abs(" ")" (
9.129 + quote s ^ ", " ^
9.130 + scala_of_typ T ^ ", " ^
9.131 + scala_of_term t)
9.132 + | scala_of_term (t1 $ t2) =
9.133 + enclose "App(" ")" (scala_of_term t1 ^ ", " ^ scala_of_term t2)
9.134 +
9.135 +(* see structure's bare bones.
9.136 + for Isabelle standard output compare 2017 "structure ML_PP" *)
9.137 +fun atomtyp t =
9.138 + let
9.139 + fun ato n (Type (s, [])) = "\n*** " ^ indent n ^ "Type (" ^ s ^",[])"
9.140 + | ato n (Type (s, Ts)) = "\n*** " ^ indent n ^ "Type (" ^ s ^ ",[" ^ atol (n + 1) Ts
9.141 + | ato n (TFree (s, sort)) = "\n*** " ^ indent n ^ "TFree (" ^ s ^ "," ^ strs2str' sort
9.142 + | ato n (TVar ((s, i), sort)) =
9.143 + "\n*** " ^ indent n ^ "TVar ((" ^ s ^ "," ^ string_of_int i ^ strs2str' sort
9.144 + and atol n [] = "\n*** " ^ indent n ^ "]"
9.145 + | atol n (T :: Ts) = (ato n T ^ atol n Ts)
9.146 +in tracing (ato 0 t ^ "\n") end;
9.147 +
9.148 +local
9.149 + fun ato (Const (a, _)) n = "\n*** " ^ indent n ^ "Const (" ^ a ^ ", _)"
9.150 + | ato (Free (a, _)) n = "\n*** " ^ indent n ^ "Free (" ^ a ^ ", _)"
9.151 + | ato (Var ((a, i), _)) n =
9.152 + "\n*** " ^ indent n ^ "Var (" ^ a ^ ", " ^ string_of_int i ^ "), _)"
9.153 + | ato (Bound i) n = "\n*** " ^ indent n ^ "Bound " ^ string_of_int i
9.154 + | ato (Abs (a, _, body)) n = "\n*** " ^ indent n ^ "Abs(" ^ a ^ ", _" ^ ato body (n+1)
9.155 + | ato (f $ t) n = (ato f n ^ ato t (n + 1))
9.156 +in
9.157 + fun atomw t = writeln ("\n*** -------------" ^ ato t 0 ^ "\n***");
9.158 + fun atomt t = tracing ("\n*** -------------" ^ ato t 0 ^ "\n***");
9.159 +end;
9.160 +
9.161 +fun term_detail2str t =
9.162 + let
9.163 + fun ato (Const (a, T)) n = "\n*** " ^ indent n ^ "Const (" ^ a ^ ", " ^ Rule.string_of_typ T ^ ")"
9.164 + | ato (Free (a, T)) n = "\n*** " ^ indent n ^ "Free (" ^ a ^ ", " ^ Rule.string_of_typ T ^ ")"
9.165 + | ato (Var ((a, i), T)) n =
9.166 + "\n*** " ^ indent n ^ "Var ((" ^ a ^ ", " ^ string_of_int i ^ "), " ^ Rule.string_of_typ T ^ ")"
9.167 + | ato (Bound i) n = "\n*** " ^ indent n ^ "Bound " ^ string_of_int i
9.168 + | ato (Abs(a, T, body)) n =
9.169 + "\n*** " ^ indent n ^ "Abs (" ^ a ^ ", " ^ Rule.string_of_typ T ^ ",.." ^ ato body (n + 1)
9.170 + | ato (f $ t) n = ato f n ^ ato t (n + 1)
9.171 + in "\n*** " ^ ato t 0 ^ "\n***" end;
9.172 +fun term_detail2str_thy thy t =
9.173 + let
9.174 + fun ato (Const (a, T)) n =
9.175 + "\n*** " ^ indent n ^ "Const (" ^ a ^ ", " ^ Rule.string_of_typ_thy thy T ^ ")"
9.176 + | ato (Free (a, T)) n =
9.177 + "\n*** " ^ indent n ^ "Free (" ^ a ^ ", " ^ Rule.string_of_typ_thy thy T ^ ")"
9.178 + | ato (Var ((a, i), T)) n =
9.179 + "\n*** " ^ indent n ^ "Var ((" ^ a ^ ", " ^ string_of_int i ^ "), " ^
9.180 + Rule.string_of_typ_thy thy T ^ ")"
9.181 + | ato (Bound i) n =
9.182 + "\n*** " ^ indent n ^ "Bound " ^ string_of_int i
9.183 + | ato (Abs(a, T, body)) n =
9.184 + "\n*** " ^ indent n ^ "Abs (" ^ a ^ ", " ^ Rule.string_of_typ_thy thy T ^ ",.." ^
9.185 + ato body (n + 1)
9.186 + | ato (f $ t) n = ato f n ^ ato t (n + 1)
9.187 + in "\n*** " ^ ato t 0 ^ "\n***" end;
9.188 +fun atomwy t = (writeln o term_detail2str) t;
9.189 +fun atomty t = (tracing o term_detail2str) t;
9.190 +fun atomty_thy thy t = (tracing o (term_detail2str_thy thy)) t;
9.191 +
9.192 +(* contains the term a VAR(("*",_),_) ? *)
9.193 +fun contains_Var (Abs(_,_,body)) = contains_Var body
9.194 + | contains_Var (f $ f') = contains_Var f orelse contains_Var f'
9.195 + | contains_Var (Var _) = true
9.196 + | contains_Var _ = false;
9.197 +
9.198 +fun str_of_int n =
9.199 + if n < 0 then "-" ^ ((string_of_int o abs) n)
9.200 + else string_of_int n;
9.201 +val int_of_str = Value.parse_int;
9.202 +fun int_of_str_opt str =
9.203 + let
9.204 + val ss = Symbol.explode str
9.205 + val ss' = case ss of "(" :: s => drop_last s | _ => ss
9.206 + val (sign, istr) = case ss' of "-" :: istr => (~1, istr) | _ => (1, ss')
9.207 + in
9.208 + case Library.read_int istr of (i, []) => SOME (sign * i) | _ => NONE
9.209 + end;
9.210 +fun is_num' str = case int_of_str_opt str of SOME _ => true | NONE => false;
9.211 +fun is_num (Free (s, _)) = if is_num' s then true else false | is_num _ = false;
9.212 +fun term_of_num ntyp n = Free (str_of_int n, ntyp);
9.213 +fun num_of_term (t as (Free (istr, _))) =
9.214 + (case int_of_str_opt istr of SOME i => i | NONE => raise TERM ("num_of_term: NOT int ", [t]))
9.215 + | num_of_term t = raise TERM ("num_of_term: NOT Free ", [t])
9.216 +
9.217 +fun is_Free (Free _) = true | is_Free _ = false;
9.218 +fun is_fun_id (Const _) = true
9.219 + | is_fun_id (Free _) = true
9.220 + | is_fun_id _ = false;
9.221 +fun is_f_x (f $ x) = is_fun_id f andalso is_Free x
9.222 + | is_f_x _ = false;
9.223 +
9.224 +fun vars t =
9.225 + let
9.226 + fun scan vs (Const _) = vs
9.227 + | scan vs (t as Free (s, _)) = if is_num' s then vs else t :: vs
9.228 + | scan vs (t as Var _) = t :: vs
9.229 + | scan vs (Bound _) = vs
9.230 + | scan vs (Abs (_, _, t)) = scan vs t
9.231 + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
9.232 + in (distinct o (scan [])) t end;
9.233 +(* bypass Isabelle's Pretty, which requires ctxt *)
9.234 +fun ids2str t =
9.235 + let
9.236 + fun scan vs (Const (s, _)) = if is_num' s then vs else s :: vs
9.237 + | scan vs (Free (s, _)) = if is_num' s then vs else s :: vs
9.238 + | scan vs (Var ((s, i), _)) = (s ^ "_" ^ string_of_int i) :: vs
9.239 + | scan vs (Bound _) = vs
9.240 + | scan vs (Abs (s, _, t)) = scan (s :: vs) t
9.241 + | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
9.242 + in (distinct o (scan [])) t end;
9.243 +fun is_bdv str = case Symbol.explode str of "b"::"d"::"v"::_ => true | _ => false;
9.244 +(* instantiate #prop thm with bound variables (as Free) *)
9.245 +fun inst_bdv [] t = t
9.246 + | inst_bdv (instl: (term*term) list) t =
9.247 + let
9.248 + fun subst (v as Var((s, _), T)) =
9.249 + (case Symbol.explode s of
9.250 + "b"::"d"::"v"::_ => if_none (assoc(instl,Free(s,T))) (Free(s,T))
9.251 + | _ => v)
9.252 + | subst (Abs(a, T, body)) = Abs(a, T, subst body)
9.253 + | subst (f $ t') = subst f $ subst t'
9.254 + | subst t = if_none (assoc (instl, t)) t
9.255 + in subst t end;
9.256 +
9.257 +(* is a term a substitution for a bdv as found in programs and tactics *)
9.258 +fun is_bdv_subst (Const ("List.list.Cons", _) $
9.259 + (Const ("Product_Type.Pair", _) $ str $ _) $ _) = is_bdv (HOLogic.dest_string str)
9.260 + | is_bdv_subst _ = false;
9.261 +
9.262 +fun free2str (Free (s, _)) = s
9.263 + | free2str t = error ("free2str not for " ^ Rule.term2str t);
9.264 +fun str_of_free_opt (Free (s, _)) = SOME s
9.265 + | str_of_free_opt _ = NONE
9.266 +
9.267 +(* compare Logic.unvarify_global, which rejects Free *)
9.268 +fun var2free (t as Const _) = t
9.269 + | var2free (t as Free _) = t
9.270 + | var2free (Var((s, _), T)) = Free (s,T)
9.271 + | var2free (t as Bound _) = t
9.272 + | var2free (Abs(s, T, t)) = Abs(s, T, var2free t)
9.273 + | var2free (t1 $ t2) = (var2free t1) $ (var2free t2);
9.274 +
9.275 +(* Logic.varify does NOT take care of 'Free ("1", _)'*)
9.276 +fun free2var (t as Const _) = t
9.277 + | free2var (t as Free (s, T)) = if is_num' s then t else Var ((s, 0), T)
9.278 + | free2var (t as Var _) = t
9.279 + | free2var (t as Bound _) = t
9.280 + | free2var (Abs (s, T, t)) = Abs (s, T, free2var t)
9.281 + | free2var (t1 $ t2) = (free2var t1) $ (free2var t2);
9.282 +
9.283 +fun mk_listT T = Type ("List.list", [T]);
9.284 +fun list_const T = Const ("List.list.Cons", [T, mk_listT T] ---> mk_listT T);
9.285 +fun list2isalist T [] = Const ("List.list.Nil", mk_listT T)
9.286 + | list2isalist T (t :: ts) = (list_const T) $ t $ (list2isalist T ts);
9.287 +
9.288 +fun isapair2pair (Const ("Product_Type.Pair",_) $ a $ b) = (a, b)
9.289 + | isapair2pair t =
9.290 + error ("isapair2pair called with " ^ Rule.term2str t);
9.291 +fun isalist2list ls =
9.292 + let
9.293 + fun get es (Const("List.list.Cons", _) $ t $ ls) = get (t :: es) ls
9.294 + | get es (Const("List.list.Nil", _)) = es
9.295 + | get _ t = raise TERM ("isalist2list applied to NON-list: ", [t])
9.296 + in (rev o (get [])) ls end;
9.297 +
9.298 +fun is_list ((Const ("List.list.Cons", _)) $ _ $ _) = true
9.299 + | is_list _ = false;
9.300 +fun dest_binop_typ (Type ("fun", [range, Type ("fun", [arg2, arg1])])) = (arg1, arg2, range)
9.301 + | dest_binop_typ _ = raise ERROR "dest_binop_typ: not binary";
9.302 +fun dest_equals (Const("HOL.eq", _) $ t $ u) = (t, u) (* Pure/logic.ML: Const ("==", ..*)
9.303 + | dest_equals t = raise TERM ("dest_equals'", [t]);
9.304 +fun is_equality (Const("HOL.eq",_) $ _ $ _) = true (* logic.ML: Const("=="*)
9.305 + | is_equality _ = false;
9.306 +fun mk_equality (t, u) = (Const("HOL.eq", [type_of t, type_of u] ---> HOLogic.boolT) $ t $ u);
9.307 +fun is_expliceq (Const("HOL.eq",_) $ (Free _) $ _) = true
9.308 + | is_expliceq _ = false;
9.309 +fun strip_trueprop (Const ("HOL.Trueprop", _) $ t) = t
9.310 + | strip_trueprop t = t;
9.311 +
9.312 +(* (A1==>...An==>B) goes to (A1==>...An==>) Pure/logic.ML: term -> term list*)
9.313 +fun strip_imp_prems' (Const ("Pure.imp", _) $ A $ t) =
9.314 + let
9.315 + fun coll_prems As (Const("Pure.imp", _) $ A $ t) =
9.316 + coll_prems (As $ (Logic.implies $ A)) t
9.317 + | coll_prems As _ = SOME As
9.318 + in coll_prems (Logic.implies $ A) t end
9.319 + | strip_imp_prems' _ = NONE; (* *)
9.320 +
9.321 +(* (A1==>...An==>) (B) goes to (A1==>...An==>B), where B is lowest branch, 2002 Pure/thm.ML *)
9.322 +fun ins_concl (Const ("Pure.imp", _) $ A $ t) B = Logic.implies $ A $ (ins_concl t B)
9.323 + | ins_concl (Const ("Pure.imp", _) $ A ) B = Logic.implies $ A $ B
9.324 + | ins_concl t B = raise TERM ("ins_concl", [t, B]);
9.325 +
9.326 +fun vperm (Var _, Var _) = true (* 2002 Pure/thm.ML *)
9.327 + | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t)
9.328 + | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2)
9.329 + | vperm (t, u) = (t = u);
9.330 +
9.331 +(*2002 cp from Pure/term.ML --- since 2009 in Pure/old_term.ML*)
9.332 +fun mem_term (_, []) = false
9.333 + | mem_term (t, t' :: ts) = t aconv t' orelse mem_term (t, ts);
9.334 +fun subset_term ([], _) = true
9.335 + | subset_term (x :: xs, ys) = mem_term (x, ys) andalso subset_term (xs, ys);
9.336 +fun eq_set_term (xs, ys) =
9.337 + xs = ys orelse (subset_term (xs, ys) andalso subset_term (ys, xs));
9.338 +(*a total, irreflexive ordering on index names*)
9.339 +fun xless ((a, i), (b, j): indexname) = i<j orelse (i = j andalso a < b);
9.340 +(*a partial ordering (not reflexive) for atomic terms*)
9.341 +fun atless (Const (a, _), Const (b, _)) = a < b
9.342 + | atless (Free (a, _), Free (b, _)) = a < b
9.343 + | atless (Var (v, _), Var (w, _)) = xless (v, w)
9.344 + | atless (Bound i, Bound j) = i < j
9.345 + | atless _ = false;
9.346 +(*insert atomic term into partially sorted list, suppressing duplicates (?)*)
9.347 +fun insert_aterm (t,us) =
9.348 + let fun inserta [] = [t]
9.349 + | inserta (us as u::us') =
9.350 + if atless(t,u) then t::us
9.351 + else if t=u then us (*duplicate*)
9.352 + else u :: inserta us'
9.353 + in inserta us end;
9.354 +
9.355 +(* Accumulates the Vars in the term, suppressing duplicates *)
9.356 +fun add_term_vars (t, vars: term list) = case t of
9.357 + Var _ => insert_aterm (t, vars)
9.358 + | Abs (_, _, body) => add_term_vars (body, vars)
9.359 + | f$t => add_term_vars (f, add_term_vars (t, vars))
9.360 + | _ => vars;
9.361 +fun term_vars t = add_term_vars (t, []);
9.362 +
9.363 +(*2002 Pure/thm.ML *)
9.364 +fun var_perm (t, u) = vperm (t, u) andalso eq_set_term (term_vars t, term_vars u);
9.365 +(*2002 fun decomp_simp, Pure/thm.ML *)
9.366 +fun perm lhs rhs = var_perm (lhs, rhs) andalso not (lhs aconv rhs) andalso not (is_Var lhs);
9.367 +
9.368 +
9.369 +fun pairT T1 T2 = Type ("*", [T1, T2]);
9.370 +fun PairT T1 T2 = ([T1, T2] ---> Type ("*", [T1, T2]));
9.371 +fun pairt t1 t2 = Const ("Product_Type.Pair", PairT (type_of t1) (type_of t2)) $ t1 $ t2;
9.372 +
9.373 +fun mk_factroot op_(*=thy.sqrt*) T fact root =
9.374 + Const ("Groups.times_class.times", [T, T] ---> T) $ (term_of_num T fact) $
9.375 + (Const (op_, T --> T) $ term_of_num T root);
9.376 +fun mk_var_op_num v op_ optype ntyp n = Const (op_, optype) $ v $ Free (str_of_int n, ntyp);
9.377 +fun mk_num_op_var v op_ optype ntyp n = Const (op_, optype) $ Free (str_of_int n, ntyp) $ v;
9.378 +fun mk_num_op_num T1 T2 (op_, Top) n1 n2 =
9.379 + Const (op_, Top) $ Free (str_of_int n1, T1) $ Free (str_of_int n2, T2);
9.380 +fun mk_thmid thmid n1 n2 =
9.381 + thmid ^ (strip_thy n1) ^ "_" ^ (strip_thy n2);
9.382 +fun mk_add t1 t2 =
9.383 + let
9.384 + val (T1, T2) = (type_of t1, type_of t2)
9.385 + in
9.386 + if T1 <> T2 then raise TYPE ("mk_add gets ", [T1, T2], [t1,t2])
9.387 + else (Const ("Groups.plus_class.plus", [T1, T2] ---> T1) $ t1 $ t2)
9.388 + end;
9.389 +
9.390 +(** transform binary numeralsstrings **)
9.391 +(*Makarius 100308, hacked by WN*)
9.392 +val numbers_to_string =
9.393 + let
9.394 + fun dest_num t =
9.395 + (case try HOLogic.dest_number t of
9.396 + SOME (T, i) =>
9.397 + (*if T = @{typ int} orelse T = @{typ real} then WN*)
9.398 + SOME (Free (signed_string_of_int i, T))
9.399 + (*else NONE WN*)
9.400 + | NONE => NONE);
9.401 + fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
9.402 + | to_str (t as (u1 $ u2)) =
9.403 + (case dest_num t of
9.404 + SOME t' => t'
9.405 + | NONE => to_str u1 $ to_str u2)
9.406 + | to_str t = perhaps dest_num t;
9.407 + in to_str end
9.408 +val uminus_to_string =
9.409 + let
9.410 + fun dest_num t =
9.411 + case t of
9.412 + (Const ("Groups.uminus_class.uminus", _) $ Free (s, T)) =>
9.413 + (case int_of_str_opt s of
9.414 + SOME i => SOME (Free (signed_string_of_int (~1 * i), T))
9.415 + | NONE => NONE)
9.416 + | _ => NONE;
9.417 + fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
9.418 + | to_str (t as (u1 $ u2)) =
9.419 + (case dest_num t of SOME t' => t' | NONE => to_str u1 $ to_str u2)
9.420 + | to_str t = perhaps dest_num t;
9.421 + in to_str end;
9.422 +fun num_str thm =
9.423 + let
9.424 + val (deriv,
9.425 + {cert = cert, tags = tags, maxidx = maxidx, shyps = shyps,
9.426 + hyps = hyps, tpairs = tpairs, prop = prop}) = Thm.rep_thm_G thm
9.427 + val prop' = numbers_to_string prop;
9.428 + in Thm.assbl_thm deriv cert tags maxidx shyps hyps tpairs prop' end;
9.429 +
9.430 +fun mk_Free (s,T) = Free (s, T);
9.431 +fun mk_free T s = Free (s, T);
9.432 +
9.433 +(*Special case: one argument cp from Isabelle2002/src/Pure/term.ML*)
9.434 +fun subst_bound (arg, t) =
9.435 + let
9.436 + fun subst (t as Bound i, lev) =
9.437 + if i < lev then t (*var is locally bound*)
9.438 + else if i = lev then incr_boundvars lev arg
9.439 + else Bound (i - 1) (*loose: change it*)
9.440 + | subst (Abs(a, T, body), lev) = Abs (a, T, subst (body, lev + 1))
9.441 + | subst (f$t, lev) = subst(f, lev) $ subst(t, lev)
9.442 + | subst (t, _) = t
9.443 + in subst (t, 0) end;
9.444 +
9.445 +(* instantiate let; necessary for ass_up *)
9.446 +fun inst_abs (Const sT) = Const sT
9.447 + | inst_abs (Free sT) = Free sT
9.448 + | inst_abs (Bound n) = Bound n
9.449 + | inst_abs (Var iT) = Var iT
9.450 + | inst_abs (Const ("HOL.Let",T1) $ e $ (Abs (v, T2, b))) =
9.451 + let val b' = subst_bound (Free (v, T2), b); (*fun variant_abs: term.ML*)
9.452 + in Const ("HOL.Let", T1) $ inst_abs e $ (Abs (v, T2, inst_abs b')) end
9.453 + | inst_abs (t1 $ t2) = inst_abs t1 $ inst_abs t2
9.454 + | inst_abs t = t;
9.455 +
9.456 +(* for parse and parse_patt: fix all types to real *)
9.457 +fun T_a2real (Type (s, [])) =
9.458 + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else Type (s, [])
9.459 + | T_a2real (Type (s, Ts)) = Type (s, map T_a2real Ts)
9.460 + | T_a2real (TFree (s, srt)) =
9.461 + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TFree (s, srt)
9.462 + | T_a2real (TVar (("DUMMY", _), _)) = HOLogic.realT
9.463 + | T_a2real (TVar ((s, i), srt)) =
9.464 + if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TVar ((s, i), srt)
9.465 +fun typ_a2real (Const( s, T)) = (Const( s, T_a2real T))
9.466 + | typ_a2real (Free( s, T)) = (Free( s, T_a2real T))
9.467 + | typ_a2real (Var( n, T)) = (Var( n, T_a2real T))
9.468 + | typ_a2real (Bound i) = (Bound i)
9.469 + | typ_a2real (Abs(s,T,t)) = Abs(s, T, typ_a2real t)
9.470 + | typ_a2real (t1 $ t2) = (typ_a2real t1) $ (typ_a2real t2);
9.471 +
9.472 +(* TODO clarify parse with Test_Isac *)
9.473 +fun parseold thy str = (* before 2002 *)
9.474 + (let val t = ((*typ_a2real o*) numbers_to_string) (Syntax.read_term_global thy str)
9.475 + in SOME (Thm.global_cterm_of thy t) end)
9.476 + handle _(*EXN? ..Inner syntax error Failed to parse term*) => NONE;
9.477 +fun parseN thy str = (* introduced 2002 *)
9.478 + (let val t = (*(typ_a2real o numbers_to_string)*) (Syntax.read_term_global thy str)
9.479 + in SOME (Thm.global_cterm_of thy t) end)
9.480 + handle _(*EXN? ..Inner syntax error Failed to parse term*) => NONE;
9.481 +fun parse thy str = (* introduced 2010 *)
9.482 + (let val t = (typ_a2real o numbers_to_string) (Syntax.read_term_global thy str)
9.483 + in SOME (Thm.global_cterm_of thy t) end)
9.484 + handle _(*EXN? ..Inner syntax error Failed to parse term*) => NONE;
9.485 +
9.486 +(*WN110317 parseNEW will replace parse after introduction of ctxt completed*)
9.487 +fun parseNEW ctxt str = SOME (Syntax.read_term ctxt str |> numbers_to_string)
9.488 + handle _ => NONE;
9.489 +fun parseNEW' ctxt str =
9.490 + case parseNEW ctxt str of
9.491 + SOME t => t
9.492 + | NONE => raise TERM ("NO parseNEW' for " ^ str, [])
9.493 +
9.494 +(* parse term patterns; Var ("v",_), i.e. "?v", are required for instantiation
9.495 + WN130613 probably compare to
9.496 + http://www.mail-archive.com/isabelle-dev@mailbroy.informatik.tu-muenchen.de/msg04249.html*)
9.497 +fun parse_patt thy str =
9.498 + (thy, str) |>> Rule.thy2ctxt
9.499 + |-> Proof_Context.read_term_pattern
9.500 + |> numbers_to_string (*TODO drop*)
9.501 + |> typ_a2real; (*TODO drop*)
9.502 +fun str2term str = parse_patt (Rule.Thy_Info_get_theory "Isac") str
9.503 +
9.504 +(* TODO decide with Test_Isac *)
9.505 +fun is_atom t = length (vars t) = 1
9.506 +fun is_atom (Const ("Float.Float",_) $ _) = true
9.507 + | is_atom (Const ("ComplexI.I'_'_",_)) = true
9.508 + | is_atom (Const ("Groups.times_class.times",_) $ t $ Const ("ComplexI.I'_'_",_)) = is_atom t
9.509 + | is_atom (Const ("Groups.plus_class.plus",_) $ t1 $ Const ("ComplexI.I'_'_",_)) = is_atom t1
9.510 + | is_atom (Const ("Groups.plus_class.plus",_) $ t1 $
9.511 + (Const ("Groups.times_class.times",_) $ t2 $ Const ("ComplexI.I'_'_",_))) =
9.512 + is_atom t1 andalso is_atom t2
9.513 + | is_atom (Const _) = true
9.514 + | is_atom (Free _) = true
9.515 + | is_atom (Var _) = true
9.516 + | is_atom _ = false;
9.517 +
9.518 +(* from Pure/term.ML; reports if ALL Free's have found a substitution
9.519 + (required for evaluating the preconditions of _incomplete_ models) *)
9.520 +fun subst_atomic_all [] t = (false (*TODO may be 'true' for some terms ?*), t)
9.521 + | subst_atomic_all instl t =
9.522 + let
9.523 + fun subst (Abs (a, T, body)) =
9.524 + let
9.525 + val (all, body') = subst body
9.526 + in (all, Abs(a, T, body')) end
9.527 + | subst (f$tt) =
9.528 + let
9.529 + val (all1, f') = subst f
9.530 + val (all2, tt') = subst tt
9.531 + in (all1 andalso all2, f' $ tt') end
9.532 + | subst (t as Free _) =
9.533 + if is_num t then (true, t) (*numerals cannot be subst*)
9.534 + else (case assoc (instl, t) of
9.535 + SOME t' => (true, t')
9.536 + | NONE => (false, t))
9.537 + | subst t = (true, if_none (assoc(instl,t)) t)
9.538 + in subst t end;
9.539 +
9.540 +fun op contains_one_of (thm, ids) =
9.541 + Term.exists_Const (fn id => member op= ids id) (Thm.prop_of thm)
9.542 +
9.543 +fun var_for vs (t as Const (str, _)) id = if id = strip_thy str then t :: vs else vs
9.544 + | var_for vs (t as Free (str, _)) id = if id = str then t :: vs else vs
9.545 + | var_for vs (t as Var (idn, _)) id = if id = Term.string_of_vname idn then t :: vs else vs
9.546 + | var_for vs (Bound _) _ = vs
9.547 + | var_for vs (Abs (_, _, t)) id = var_for vs t id
9.548 + | var_for vs (t1 $ t2) id = (var_for vs t1 id) @ (var_for vs t2 id)
9.549 +
9.550 +val poly_consts = (* TODO: adopt syntax-const from Isabelle*)
9.551 + ["Groups.plus_class.plus", "Groups.minus_class.minus",
9.552 + "Rings.divide_class.divide", "Groups.times_class.times",
9.553 + "Atools.pow"];
9.554 +(* treat Free, Const, Var as variables in polynomials *)
9.555 +fun vars_of t =
9.556 + let
9.557 + val var_ids = t |> ids2str |> subtract op = poly_consts |> map strip_thy |> sort string_ord
9.558 + in (map (var_for [] t) var_ids) |> flat |> distinct end
9.559 +
9.560 +(* this may decompose an object-language isa-list;
9.561 + use only, if description is not available, eg. not input ?WN:14.5.03 ??!?*)
9.562 +fun dest_list' t = if is_list t then isalist2list t else [t];
9.563 +
9.564 +fun raise_type_conflicts ts =
9.565 + let
9.566 + val dups = duplicates (op =) (map (fst o dest_Free) ts)
9.567 + val confl = filter (fn Free (str, _) => member op = dups str) ts
9.568 + in
9.569 + if confl = []
9.570 + then ()
9.571 + else raise TYPE ("formalisation inconsistent w.r.t. type inference: ",
9.572 + map (snd o dest_Free)confl, confl)
9.573 + end
9.574 +
9.575 +end
9.576 \ No newline at end of file
10.1 --- a/src/Tools/isac/KEStore.thy Thu Aug 22 16:48:04 2019 +0200
10.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
10.3 @@ -1,245 +0,0 @@
10.4 -(* Title: src/Tools/isac/KEStore.thy
10.5 - Author: Mathias Lehnfeld
10.6 -*)
10.7 -
10.8 -theory KEStore
10.9 - imports "~~/src/HOL/Complex_Main"
10.10 -
10.11 -begin
10.12 -(* TODO:
10.13 - * separate structures from calcelems.sml in addition to Rule to ThydataC/.
10.14 - * separate structures from rule.sml as noted in the respective signature.
10.15 - * move remainings of calcelems.sml and KEStore.thy to ThydataC/.
10.16 - * rename strucuture KEStore to ThydataC.
10.17 -*)
10.18 - ML_file "~~/src/Tools/isac/library.sml"
10.19 - ML_file "~~/src/Tools/isac/ThydataC/rule.sml"
10.20 - ML_file "~~/src/Tools/isac/calcelems.sml"
10.21 -
10.22 -ML \<open>
10.23 -\<close> ML \<open>
10.24 -\<close>
10.25 -
10.26 -section \<open>Knowledge elements for problems and methods\<close>
10.27 -ML \<open>
10.28 -(* Knowledge (and Exercises) are held by "KEStore" in Isac's Java front-end.
10.29 - In the front-end Knowledge comprises theories, problems and methods.
10.30 - Elements of problems and methods are defined in theories alongside
10.31 - the development of respective language elements.
10.32 - However, the structure of methods and problems is independent from theories'
10.33 - deductive structure. Thus respective structures are built in Build_Thydata.thy.
10.34 -
10.35 - Most elements of problems and methods are implemented in "Knowledge/", but some
10.36 - of them are implemented in "ProgLang/" already; thus "KEStore.thy" got this
10.37 - location in the directory structure.
10.38 -
10.39 - get_* retrieves all * of the respective theory PLUS of all ancestor theories.
10.40 -*)
10.41 -signature KESTORE_ELEMS =
10.42 -sig
10.43 - val get_rlss: theory -> (Rule.rls' * (Rule.theory' * Rule.rls)) list
10.44 - val add_rlss: (Rule.rls' * (Rule.theory' * Rule.rls)) list -> theory -> theory
10.45 - val get_calcs: theory -> (Rule.prog_calcID * (Rule.calID * Rule.eval_fn)) list
10.46 - val add_calcs: (Rule.prog_calcID * (Rule.calID * Rule.eval_fn)) list -> theory -> theory
10.47 - val get_cas: theory -> Celem.cas_elem list
10.48 - val add_cas: Celem.cas_elem list -> theory -> theory
10.49 - val get_ptyps: theory -> Celem.ptyps
10.50 - val add_pbts: (Celem.pbt * Celem.pblID) list -> theory -> theory
10.51 - val get_mets: theory -> Celem.mets
10.52 - val add_mets: (Celem.met * Celem.metID) list -> theory -> theory
10.53 - val get_thes: theory -> (Celem.thydata Celem.ptyp) list
10.54 - val add_thes: (Celem.thydata * Celem.theID) list -> theory -> theory (* thydata dropped at existing elems *)
10.55 - val insert_fillpats: (Celem.theID * Celem.fillpat list) list -> theory -> theory
10.56 - val get_ref_thy: unit -> theory
10.57 - val set_ref_thy: theory -> unit
10.58 -end;
10.59 -
10.60 -structure KEStore_Elems: KESTORE_ELEMS =
10.61 -struct
10.62 - fun union_overwrite eq l1 l2 = fold (insert eq) l2 (*..swapped..*) l1;
10.63 -
10.64 - structure Data = Theory_Data (
10.65 - type T = (Rule.rls' * (Rule.theory' * Rule.rls)) list;
10.66 - val empty = [];
10.67 - val extend = I;
10.68 - val merge = Celem.merge_rlss;
10.69 - );
10.70 - fun get_rlss thy = Data.get thy
10.71 - fun add_rlss rlss = Data.map (union_overwrite Celem.rls_eq rlss)
10.72 -
10.73 - structure Data = Theory_Data (
10.74 - type T = (Rule.prog_calcID * (Rule.calID * Rule.eval_fn)) list;
10.75 - val empty = [];
10.76 - val extend = I;
10.77 - val merge = merge Rule.calc_eq;
10.78 - );
10.79 - fun get_calcs thy = Data.get thy
10.80 - fun add_calcs calcs = Data.map (union_overwrite Rule.calc_eq calcs)
10.81 -
10.82 - structure Data = Theory_Data (
10.83 - type T = (term * (Celem.spec * (term list -> (term * term list) list))) list;
10.84 - val empty = [];
10.85 - val extend = I;
10.86 - val merge = merge Celem.cas_eq;
10.87 - );
10.88 - fun get_cas thy = Data.get thy
10.89 - fun add_cas cas = Data.map (union_overwrite Celem.cas_eq cas)
10.90 -
10.91 - structure Data = Theory_Data (
10.92 - type T = Celem.ptyps;
10.93 - val empty = [Celem.e_Ptyp];
10.94 - val extend = I;
10.95 - val merge = Celem.merge_ptyps;
10.96 - );
10.97 - fun get_ptyps thy = Data.get thy;
10.98 - fun add_pbts pbts thy = let
10.99 - fun add_pbt (pbt as {guh,...}, pblID) =
10.100 - (* the pblID has the leaf-element as first; better readability achieved *)
10.101 - (if (!Celem.check_guhs_unique) then Celem.check_pblguh_unique guh (Data.get thy) else ();
10.102 - rev pblID |> Celem.insrt pblID pbt);
10.103 - in Data.map (fold add_pbt pbts) thy end;
10.104 -
10.105 - structure Data = Theory_Data (
10.106 - type T = Celem.mets;
10.107 - val empty = [Celem.e_Mets];
10.108 - val extend = I;
10.109 - val merge = Celem.merge_ptyps;
10.110 - );
10.111 - val get_mets = Data.get;
10.112 - fun add_mets mets thy = let
10.113 - fun add_met (met as {guh,...}, metID) =
10.114 - (if (!Celem.check_guhs_unique) then Celem.check_metguh_unique guh (Data.get thy) else ();
10.115 - Celem.insrt metID met metID);
10.116 - in Data.map (fold add_met mets) thy end;
10.117 -
10.118 - structure Data = Theory_Data (
10.119 - type T = (Celem.thydata Celem.ptyp) list;
10.120 - val empty = [];
10.121 - val extend = I;
10.122 - val merge = Celem.merge_ptyps; (* relevant for store_thm, store_rls *)
10.123 - );
10.124 - fun get_thes thy = Data.get thy
10.125 - fun add_thes thes thy = let
10.126 - fun add_the (thydata, theID) = Celem.add_thydata ([], theID) thydata
10.127 - in Data.map (fold add_the thes) thy end;
10.128 - fun insert_fillpats fis thy =
10.129 - let
10.130 - fun update_elem (theID, fillpats) =
10.131 - let
10.132 - val hthm = Celem.get_py (Data.get thy) theID theID
10.133 - val hthm' = Celem.update_hthm hthm fillpats
10.134 - handle ERROR _ =>
10.135 - error ("insert_fillpats: " ^ strs2str theID ^ "must address a theorem")
10.136 - in Celem.update_ptyps theID theID hthm' end
10.137 - in Data.map (fold update_elem fis) thy end
10.138 -
10.139 - val cur_thy = Synchronized.var "finally_knowledge_complete" @{theory};
10.140 - fun set_ref_thy thy = Synchronized.change cur_thy (fn _ => thy); (* never RE-set ! *)
10.141 - fun get_ref_thy () = Synchronized.value cur_thy;
10.142 -end;
10.143 -\<close>
10.144 -
10.145 -section \<open>Re-use existing access functions for knowledge elements\<close>
10.146 -text \<open>
10.147 - The independence of problems' and methods' structure enforces the accesse
10.148 - functions to use "Isac", the final theory which comprises all knowledge defined.
10.149 -\<close>
10.150 -ML \<open>
10.151 -val get_ref_thy = KEStore_Elems.get_ref_thy;
10.152 -
10.153 -fun assoc_rls (rls' : Rule.rls') =
10.154 - case AList.lookup (op =) (KEStore_Elems.get_rlss (Rule.Thy_Info_get_theory "Isac")) rls' of
10.155 - SOME (_, rls) => rls
10.156 - | NONE => raise ERROR ("rls \""^ rls' ^ "\" missing in KEStore.\n" ^
10.157 - "TODO exception hierarchy needs to be established.")
10.158 -
10.159 -fun assoc_rls' thy (rls' : Rule.rls') =
10.160 - case AList.lookup (op =) (KEStore_Elems.get_rlss thy) rls' of
10.161 - SOME (_, rls) => rls
10.162 - | NONE => raise ERROR ("rls \""^ rls' ^ "\" missing in KEStore.\n" ^
10.163 - "TODO exception hierarchy needs to be established.")
10.164 -
10.165 -fun assoc_calc thy calID = let
10.166 - fun ass ([], key) =
10.167 - error ("assoc_calc: '" ^ key ^ "' not found in theory " ^ (Context.theory_name thy))
10.168 - | ass ((calc, (keyi, _)) :: pairs, key) =
10.169 - if key = keyi then calc else ass (pairs, key);
10.170 - in ass (thy |> KEStore_Elems.get_calcs, calID) end;
10.171 -
10.172 -fun assoc_calc' thy key = let
10.173 - fun ass ([], key') =
10.174 - error ("assoc_calc': '" ^ key' ^ "' not found in theory " ^ (Context.theory_name thy))
10.175 - | ass ((all as (keyi, _)) :: pairs, key') =
10.176 - if key' = keyi then all else ass (pairs, key');
10.177 - in ass (KEStore_Elems.get_calcs thy, key) end;
10.178 -
10.179 -fun assoc_cas thy key = assoc (KEStore_Elems.get_cas thy, key);
10.180 -
10.181 -fun get_ptyps () = get_ref_thy () |> KEStore_Elems.get_ptyps;
10.182 -fun get_mets () = get_ref_thy () |> KEStore_Elems.get_mets;
10.183 -fun get_thes () = get_ref_thy () |> KEStore_Elems.get_thes;
10.184 -\<close>
10.185 -setup \<open>KEStore_Elems.add_rlss
10.186 - [("e_rls", (Context.theory_name @{theory}, Rule.e_rls)),
10.187 - ("e_rrls", (Context.theory_name @{theory}, Rule.e_rrls))]\<close>
10.188 -
10.189 -section \<open>determine sequence of main parts in thehier\<close>
10.190 -setup \<open>
10.191 -KEStore_Elems.add_thes
10.192 - [(Celem.Html {guh = Celem.part2guh ["IsacKnowledge"], html = "",
10.193 - mathauthors = ["Isac team"], coursedesign = []}, ["IsacKnowledge"]),
10.194 - (Celem.Html {guh = Celem.part2guh ["Isabelle"], html = "",
10.195 - mathauthors = ["Isabelle team, TU Munich"], coursedesign = []}, ["Isabelle"]),
10.196 - (Celem.Html {guh = Celem.part2guh ["IsacScripts"], html = "",
10.197 - mathauthors = ["Isac team"], coursedesign = []}, ["IsacScripts"])]
10.198 -\<close>
10.199 -
10.200 -section \<open>Functions for checking KEStore_Elems\<close>
10.201 -ML \<open>
10.202 -fun short_string_of_rls Rule.Erls = "Erls"
10.203 - | short_string_of_rls (Rule.Rls {calc, rules, ...}) =
10.204 - "Rls {#calc = " ^ string_of_int (length calc) ^
10.205 - ", #rules = " ^ string_of_int (length rules) ^ ", ..."
10.206 - | short_string_of_rls (Rule.Seq {calc, rules, ...}) =
10.207 - "Seq {#calc = " ^ string_of_int (length calc) ^
10.208 - ", #rules = " ^ string_of_int (length rules) ^ ", ..."
10.209 - | short_string_of_rls (Rule.Rrls _) = "Rrls {...}";
10.210 -fun check_kestore_rls (rls', (thyID, rls)) =
10.211 - "(" ^ rls' ^ ", (" ^ thyID ^ ", " ^ short_string_of_rls rls ^ "))";
10.212 -
10.213 -fun check_kestore_calc ((id, (c, _)) : Rule.calc) = "(" ^ id ^ ", (" ^ c ^ ", fn))";
10.214 -
10.215 -fun check_kestore_cas ((t, (s, _)) : Celem.cas_elem) =
10.216 - "(" ^ (Rule.term_to_string''' @{theory} t) ^ ", " ^ (Celem.spec2str s) ^ ")";
10.217 -
10.218 -fun count_kestore_ptyps [] = 0
10.219 - | count_kestore_ptyps ((Celem.Ptyp (_, _, ps)) :: ps') =
10.220 - 1 + count_kestore_ptyps ps + count_kestore_ptyps ps';
10.221 -fun check_kestore_ptyp' strfun (Celem.Ptyp (key, pbts, pts)) = "Ptyp (" ^ (quote key) ^ ", " ^
10.222 - (strfun pbts) ^ ", " ^ (map (check_kestore_ptyp' strfun) pts |> list2str) ^ ")" |> Celem.linefeed;
10.223 -val check_kestore_ptyp = check_kestore_ptyp' Celem.pbts2str;
10.224 -fun ptyp_ord ((Celem.Ptyp (s1, _, _)), (Celem.Ptyp (s2, _, _))) = string_ord (s1, s2);
10.225 -fun pbt_ord ({guh = guh'1, ...} : Celem.pbt, {guh = guh'2, ...} : Celem.pbt) = string_ord (guh'1, guh'2);
10.226 -fun sort_kestore_ptyp' _ [] = []
10.227 - | sort_kestore_ptyp' ordfun ((Celem.Ptyp (key, pbts, ps)) :: ps') =
10.228 - ((Celem.Ptyp (key, sort ordfun pbts, sort_kestore_ptyp' ordfun ps |> sort ptyp_ord))
10.229 - :: sort_kestore_ptyp' ordfun ps');
10.230 -val sort_kestore_ptyp = sort_kestore_ptyp' pbt_ord;
10.231 -
10.232 -fun metguh2str ({guh,...} : Celem.met) = guh : string;
10.233 -fun check_kestore_met (mp: Celem.met Celem.ptyp) =
10.234 - check_kestore_ptyp' (fn xs => map metguh2str xs |> strs2str) mp;
10.235 -fun met_ord ({guh = guh'1, ...} : Celem.met, {guh = guh'2, ...} : Celem.met) = string_ord (guh'1, guh'2);
10.236 -val sort_kestore_met = sort_kestore_ptyp' met_ord;
10.237 -
10.238 -fun check_kestore_thes thes = ((map writeln) o (map (check_kestore_ptyp' Celem.thes2str))) thes
10.239 -fun write_thes thydata_list =
10.240 - thydata_list
10.241 - |> map (fn (id, the) => (Celem.theID2str id, Celem.the2str the))
10.242 - |> map pair2str
10.243 - |> map writeln
10.244 -\<close>
10.245 -ML \<open>
10.246 -\<close> ML \<open>
10.247 -\<close>
10.248 -end
11.1 --- a/src/Tools/isac/ProgLang/Atools.thy Thu Aug 22 16:48:04 2019 +0200
11.2 +++ b/src/Tools/isac/ProgLang/Atools.thy Fri Aug 23 16:36:47 2019 +0200
11.3 @@ -3,7 +3,7 @@
11.4 (c) due to copyright terms
11.5 *)
11.6
11.7 -theory Atools imports Descript Program
11.8 +theory Atools imports Delete Descript Program
11.9 begin
11.10
11.11 subsection \<open>preparation to build up a program from rules\<close>
11.12 @@ -704,5 +704,6 @@
11.13
11.14 ML \<open>
11.15 \<close> ML \<open>
11.16 +\<close> ML \<open>
11.17 \<close>
11.18 end
12.1 --- a/src/Tools/isac/ProgLang/Descript.thy Thu Aug 22 16:48:04 2019 +0200
12.2 +++ b/src/Tools/isac/ProgLang/Descript.thy Fri Aug 23 16:36:47 2019 +0200
12.3 @@ -1,10 +1,9 @@
12.4 -(* Title: descriptions for items in model-patterns of problems and in method's
12.5 - guards
12.6 +(* Title: descriptions for items in model-patterns of problems and in method's guards
12.7 Author: Walther Neuper 000301
12.8 (c) due to copyright terms
12.9 *)
12.10
12.11 -theory Descript imports Delete begin
12.12 +theory Descript imports Tools begin
12.13
12.14 consts
12.15 (*TODO.180331: review for localisation of model-patterns and of method's guards*)
12.16 @@ -43,4 +42,8 @@
12.17 boolTestGiven :: "bool => una"
12.18 boolTestFind :: "bool => una"
12.19
12.20 +ML \<open>
12.21 +\<close> ML \<open>
12.22 +\<close> ML \<open>
12.23 +\<close>
12.24 end
12.25 \ No newline at end of file
13.1 --- a/src/Tools/isac/ProgLang/ListC.thy Thu Aug 22 16:48:04 2019 +0200
13.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
13.3 @@ -1,186 +0,0 @@
13.4 -(* Title: functions on lists for Programs
13.5 - Author: Walther Neuper 0108
13.6 - (c) due to copyright terms
13.7 -*)
13.8 -
13.9 -theory ListC
13.10 -imports "~~/src/Tools/isac/KEStore"
13.11 -begin
13.12 -
13.13 -ML_file "~~/src/Tools/isac/ProgLang/termC.sml"
13.14 -ML_file "~~/src/Tools/isac/ProgLang/contextC.sml"
13.15 -ML_file "~~/src/Tools/isac/ProgLang/calculate.sml"
13.16 -ML_file "~~/src/Tools/isac/ProgLang/rewrite.sml"
13.17 -ML \<open>
13.18 -\<close> ML \<open>
13.19 -\<close>
13.20 -
13.21 -subsection \<open>Notes on Isac's programming language\<close>
13.22 -text \<open>
13.23 - Isac's programming language combines tacticals (TRY, etc) and
13.24 - tactics (Rewrite, etc) with list processing.
13.25 -
13.26 - In order to distinguish list expressions of the meta (programming)
13.27 - language from the object language in Lucas-Interpretation, a
13.28 - new 'type xlist' is introduced.
13.29 - TODO: Switch the role of 'xlist' and 'list' (the former only used
13.30 - by InsSort.thy)
13.31 -
13.32 - Isac's programming language preceeded the function package
13.33 - in 2002. For naming "axiomatization" is used for reasons of uniformity
13.34 - with the other replacements for "axioms".
13.35 - Another reminiscence from Isabelle2002 are Isac-specific numerals,
13.36 - introduced in order to have floating point numerals at a time,
13.37 - when Isabelle did not consider that requirement. For the sake of uniformity
13.38 - 'nat' from List.thy is replaced by 'real' by 'fun parse',
13.39 - however, 'fun parseNEW' has started to replace this fix (after finishing
13.40 - this fix, there will be a 'rename all parseNEW --> parse).
13.41 -
13.42 - Note: *one* "axiomatization" over all equations caused strange "'a list list"
13.43 - types.
13.44 -\<close>
13.45 -
13.46 -subsection \<open>Type 'xlist' for Lucas-Interpretation\<close>
13.47 -(* cp fom ~~/src/HOL/List.thy
13.48 - TODO: ask for shorter deliminters in xlist *)
13.49 -datatype 'a xlist =
13.50 - XNil ("{|| ||}")
13.51 - | XCons (xhd: 'a) (xtl: "'a xlist") (infixr "@#" 65)
13.52 -
13.53 -syntax
13.54 - \<comment> \<open>list Enumeration\<close>
13.55 - "_xlist" :: "args => 'a xlist" ("{|| (_) ||}")
13.56 -
13.57 -translations
13.58 - "{||x, xs||}" == "x@#{||xs||}"
13.59 - "{||x||}" == "x@#{|| ||}"
13.60 -
13.61 -term "{|| ||}"
13.62 -term "{||1,2,3||}"
13.63 -
13.64 -subsection \<open>Functions for 'xlist'\<close>
13.65 -(* TODO:
13.66 -(1) revise, if definition of identifiers like LENGTH_NIL are still required.
13.67 -(2) switch the role of 'xlist' and 'list' in the functions below, in particular for
13.68 - 'foldr', 'foldr_Nil', 'foldr_Cons' and 'xfoldr', 'xfoldr_Nil', 'xfoldr_Cons'.
13.69 - For transition phase just outcomment InsSort.thy and inssort.sml.
13.70 -*)
13.71 -
13.72 -primrec xfoldr :: "('a \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> 'a xlist \<Rightarrow> 'b \<Rightarrow> 'b" where
13.73 -xfoldr_Nil: "xfoldr f {|| ||} = id" |
13.74 -xfoldr_Cons: "xfoldr f (x @# xs) = f x \<circ> xfoldr f xs"
13.75 -
13.76 -primrec LENGTH :: "'a list => real"
13.77 -where
13.78 -LENGTH_NIL: "LENGTH [] = 0" |
13.79 -LENGTH_CONS: "LENGTH (x#xs) = 1 + LENGTH xs"
13.80 -
13.81 -consts NTH :: "[real, 'a list] => 'a"
13.82 -axiomatization where
13.83 -NTH_NIL: "NTH 1 (x # xs) = x" and
13.84 -NTH_CONS: (*NO primrec, fun ..*)"1 < n ==> NTH n (x # xs) = NTH (n + -1) xs"
13.85 -
13.86 -(* redefine together with identifiers (still) required for KEStore ..*)
13.87 -axiomatization where
13.88 -hd_thm: "hd (x # xs) = x"
13.89 -
13.90 -axiomatization where
13.91 -tl_Nil: "tl [] = []" and
13.92 -tl_Cons: "tl (x # xs) = xs"
13.93 -
13.94 -axiomatization where
13.95 -LAST: "last (x # xs) = (if xs = [] then x else last xs)"
13.96 -
13.97 -axiomatization where
13.98 -butlast_Nil: "butlast [] = []" and
13.99 -butlast_Cons: "butlast (x # xs) = (if xs = [] then [] else x # butlast xs)"
13.100 -
13.101 -axiomatization where
13.102 -map_Nil:"map f [] = []" and
13.103 -map_Cons: "map f (x # xs) = f x # map f xs"
13.104 -
13.105 -axiomatization where
13.106 -rev_Nil: "rev [] = []" and
13.107 -rev_Cons: "rev (x # xs) = rev xs @ [x]"
13.108 -
13.109 -axiomatization where
13.110 -filter_Nil: "filter P [] = []" and
13.111 -filter_Cons: "filter P (x # xs) = (if P x then x # filter P xs else filter P xs)"
13.112 -
13.113 -axiomatization where
13.114 -concat_Nil: "concat [] = []" and
13.115 -concat_Cons: "concat (x # xs) = x @ concat xs"
13.116 -
13.117 -axiomatization where
13.118 -takeWhile_Nil: "takeWhile P [] = []" and
13.119 -takeWhile_Cons: "takeWhile P (x # xs) = (if P x then x # takeWhile P xs else [])"
13.120 -
13.121 -axiomatization where
13.122 -dropWhile_Nil: "dropWhile P [] = []" and
13.123 -dropWhile_Cons: "dropWhile P (x # xs) = (if P x then dropWhile P xs else x#xs)"
13.124 -
13.125 -axiomatization where
13.126 -zip_Nil: "zip xs [] = []" and
13.127 -zip_Cons: "zip xs (y # ys) = (case xs of [] => [] | z # zs => (z,y) # zip zs ys)"
13.128 -
13.129 -axiomatization where
13.130 -distinct_Nil: "distinct [] = True" and
13.131 -distinct_Cons: "distinct (x # xs) = (x ~: set xs & distinct xs)"
13.132 -
13.133 -axiomatization where
13.134 -remdups_Nil: "remdups [] = []" and
13.135 -remdups_Cons: "remdups (x#xs) = (if x : set xs then remdups xs else x # remdups xs)"
13.136 -
13.137 -ML\<open>
13.138 -(** rule set for evaluating listexpr in scripts, will be extended in several thys **)
13.139 -val list_rls =
13.140 - Rule.Rls {id = "list_rls", preconds = [], rew_ord = ("dummy_ord", Rule.dummy_ord),
13.141 - erls = Rule.Erls, srls = Rule.Erls, calc = [], errpatts = [],
13.142 - rules = [Rule.Thm ("refl", TermC.num_str @{thm refl}), (*'a<>b -> FALSE' by fun eval_equal*)
13.143 - Rule.Thm ("o_apply", TermC.num_str @{thm o_apply}),
13.144 -
13.145 - Rule.Thm ("NTH_CONS",TermC.num_str @{thm NTH_CONS}),(*erls for cond. in Atools.ML*)
13.146 - Rule.Thm ("NTH_NIL",TermC.num_str @{thm NTH_NIL}),
13.147 - Rule.Thm ("append_Cons",TermC.num_str @{thm append_Cons}),
13.148 - Rule.Thm ("append_Nil",TermC.num_str @{thm append_Nil}),
13.149 -(* Thm ("butlast_Cons",num_str @{thm butlast_Cons}),
13.150 - Thm ("butlast_Nil",num_str @{thm butlast_Nil}),*)
13.151 - Rule.Thm ("concat_Cons",TermC.num_str @{thm concat_Cons}),
13.152 - Rule.Thm ("concat_Nil",TermC.num_str @{thm concat_Nil}),
13.153 -(* Rule.Thm ("del_base",num_str @{thm del_base}),
13.154 - Rule.Thm ("del_rec",num_str @{thm del_rec}), *)
13.155 -
13.156 - Rule.Thm ("distinct_Cons",TermC.num_str @{thm distinct_Cons}),
13.157 - Rule.Thm ("distinct_Nil",TermC.num_str @{thm distinct_Nil}),
13.158 - Rule.Thm ("dropWhile_Cons",TermC.num_str @{thm dropWhile_Cons}),
13.159 - Rule.Thm ("dropWhile_Nil",TermC.num_str @{thm dropWhile_Nil}),
13.160 - Rule.Thm ("filter_Cons",TermC.num_str @{thm filter_Cons}),
13.161 - Rule.Thm ("filter_Nil",TermC.num_str @{thm filter_Nil}),
13.162 - Rule.Thm ("foldr_Cons",TermC.num_str @{thm foldr_Cons}),
13.163 - Rule.Thm ("foldr_Nil",TermC.num_str @{thm foldr_Nil}),
13.164 - Rule.Thm ("hd_thm",TermC.num_str @{thm hd_thm}),
13.165 - Rule.Thm ("LAST",TermC.num_str @{thm LAST}),
13.166 - Rule.Thm ("LENGTH_CONS",TermC.num_str @{thm LENGTH_CONS}),
13.167 - Rule.Thm ("LENGTH_NIL",TermC.num_str @{thm LENGTH_NIL}),
13.168 -(* Rule.Thm ("list_diff_def",num_str @{thm list_diff_def}),*)
13.169 - Rule.Thm ("map_Cons",TermC.num_str @{thm map_Cons}),
13.170 - Rule.Thm ("map_Nil",TermC.num_str @{thm map_Cons}),
13.171 -(* Rule.Thm ("mem_Cons",TermC.num_str @{thm mem_Cons}),
13.172 - Rule.Thm ("mem_Nil",TermC.num_str @{thm mem_Nil}), *)
13.173 -(* Rule.Thm ("null_Cons",TermC.num_str @{thm null_Cons}),
13.174 - Rule.Thm ("null_Nil",TermC.num_str @{thm null_Nil}),*)
13.175 - Rule.Thm ("remdups_Cons",TermC.num_str @{thm remdups_Cons}),
13.176 - Rule.Thm ("remdups_Nil",TermC.num_str @{thm remdups_Nil}),
13.177 - Rule.Thm ("rev_Cons",TermC.num_str @{thm rev_Cons}),
13.178 - Rule.Thm ("rev_Nil",TermC.num_str @{thm rev_Nil}),
13.179 - Rule.Thm ("take_Nil",TermC.num_str @{thm take_Nil}),
13.180 - Rule.Thm ("take_Cons",TermC.num_str @{thm take_Cons}),
13.181 - Rule.Thm ("tl_Cons",TermC.num_str @{thm tl_Cons}),
13.182 - Rule.Thm ("tl_Nil",TermC.num_str @{thm tl_Nil}),
13.183 - Rule.Thm ("zip_Cons",TermC.num_str @{thm zip_Cons}),
13.184 - Rule.Thm ("zip_Nil",TermC.num_str @{thm zip_Nil})],
13.185 - scr = Rule.EmptyScr}: Rule.rls;
13.186 -\<close>
13.187 -setup \<open>KEStore_Elems.add_rlss [("list_rls", (Context.theory_name @{theory}, list_rls))]\<close>
13.188 -
13.189 -end
14.1 --- a/src/Tools/isac/ProgLang/ProgLang.thy Thu Aug 22 16:48:04 2019 +0200
14.2 +++ b/src/Tools/isac/ProgLang/ProgLang.thy Fri Aug 23 16:36:47 2019 +0200
14.3 @@ -1,12 +1,11 @@
14.4 (* Title: collect all defitions for the program language
14.5 Author: Walther Neuper 100831
14.6 (c) due to copyright terms
14.7 - *)
14.8 -
14.9 +*)
14.10 theory ProgLang imports Atools
14.11 begin
14.12 -
14.13 ML \<open>
14.14 \<close> ML \<open>
14.15 +\<close> ML \<open>
14.16 \<close>
14.17 end
14.18 \ No newline at end of file
15.1 --- a/src/Tools/isac/ProgLang/Program.thy Thu Aug 22 16:48:04 2019 +0200
15.2 +++ b/src/Tools/isac/ProgLang/Program.thy Fri Aug 23 16:36:47 2019 +0200
15.3 @@ -45,7 +45,7 @@
15.4 SubProblem :: "[char list * char list list * char list list, arg list] => 'a"
15.5
15.6 Or'_to'_List :: "bool => 'a list" ("Or'_to'_List (_)" 11)
15.7 - (*=========== record these ^^^ in 'tacs' in Program.ML =========*)
15.8 + (*=========== record these ^^^ in 'tacs' in program.ML =========*)
15.9
15.10 Assumptions :: bool
15.11 Problem :: "[char list * char list list] => 'a"
15.12 @@ -86,4 +86,8 @@
15.13 *** ("_Letpar" ("_bind" x a) e) -> (Letpar a ("_abs" x e))
15.14 *** At command "translations" (line 140 of "/usr/local/isabisac/src/Pure/isac/Scripts/Program").
15.15 *)
15.16 +ML \<open>
15.17 +\<close> ML \<open>
15.18 +\<close> ML \<open>
15.19 +\<close>
15.20 end
16.1 --- a/src/Tools/isac/ProgLang/Tools.thy Thu Aug 22 16:48:04 2019 +0200
16.2 +++ b/src/Tools/isac/ProgLang/Tools.thy Fri Aug 23 16:36:47 2019 +0200
16.3 @@ -5,31 +5,33 @@
16.4 (c) copyright due to lincense terms.
16.5 *)
16.6
16.7 -theory Tools imports ListC begin
16.8 +theory Tools imports "~~/src/Tools/isac/CalcElements/CalcElements"
16.9 +begin
16.10 +ML_file calculate.sml
16.11 +ML_file rewrite.sml
16.12
16.13 (*belongs to theory ListC*)
16.14 ML \<open>
16.15 -val first_isac_thy = @{theory ListC}
16.16 +(*val first_isac_thy = @{theory ListC}*)
16.17 \<close>
16.18
16.19 (*for Descript.thy*)
16.20
16.21 - (***********************************************************************)
16.22 - (* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !!*)
16.23 - (***********************************************************************)
16.24 +(****************>***************************************************************)
16.25 +(* 'fun is_dsc' in ProgLang/scrtools.sml MUST contain ALL these types !! *)
16.26 +(****************>***************************************************************)
16.27 typedecl nam (* named variables *)
16.28 -typedecl una (* unnamed variables *)
16.29 -typedecl unl (* unnamed variables of type list, elementwise input prohibited*)
16.30 -typedecl str (* structured variables *)
16.31 -typedecl toreal (* var with undef real value: forces typing *)
16.32 -typedecl toreall (* var with undef real list value: forces typing *)
16.33 -typedecl tobooll (* var with undef bool list value: forces typing *)
16.34 -typedecl unknow (* input without dsc in fmz=[] *)
16.35 -typedecl cpy (* UNUSED: copy-named variables
16.36 - identified by .._0, .._i .._' in pbt *)
16.37 - (***********************************************************************)
16.38 - (* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !!*)
16.39 - (***********************************************************************)
16.40 +typedecl una (* unnamed variables *)
16.41 +typedecl unl (* unnamed variables of type list, elementwise input prohibited*)
16.42 +typedecl str (* structured variables *)
16.43 +typedecl toreal (* var with undef real value: forces typing *)
16.44 +typedecl toreall (* var with undef real list value: forces typing *)
16.45 +typedecl tobooll (* var with undef bool list value: forces typing *)
16.46 +typedecl unknow (* input without dsc in fmz=[] *)
16.47 +typedecl cpy (* copy-named variables identified by .._0, .._i .._' in pbt *)
16.48 +(****************>***************************************************************)
16.49 +(* 'fun is_dsc' in ProgLang/scrtools.smlMUST contain ALL these types !! *)
16.50 +(****************>***************************************************************)
16.51
16.52 consts
16.53
16.54 @@ -248,4 +250,8 @@
16.55 ("lhs", ("Tools.lhs", Tools.eval_lhs "")),
16.56 ("rhs", ("Tools.rhs", Tools.eval_rhs ""))]\<close>
16.57
16.58 +ML \<open>
16.59 +\<close> ML \<open>
16.60 +\<close> ML \<open>
16.61 +\<close>
16.62 end
17.1 --- a/src/Tools/isac/ProgLang/contextC.sml Thu Aug 22 16:48:04 2019 +0200
17.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
17.3 @@ -1,229 +0,0 @@
17.4 -(* Title: ../contextC.sml
17.5 - Author: Walther Neuper, Mathias Lehnfeld
17.6 - (c) due to copyright terms
17.7 -*)
17.8 -(* Extension to Isabelle's naming conventions: "C" indicates Isac add-ons to an Isabelle module *)
17.9 -signature CONTEXT_C =
17.10 -sig
17.11 - val e_ctxt : Proof.context
17.12 - val initialise : string -> term list -> Proof.context
17.13 - val initialise' : theory -> string list -> Proof.context
17.14 - val get_assumptions : Proof.context -> term list
17.15 - val insert_assumptions : term list -> Proof.context -> Proof.context
17.16 - val from_subpbl_to_caller : Proof.context -> term -> Proof.context -> Proof.context
17.17 -(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
17.18 - (*NONE*)
17.19 -(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
17.20 - val transfer_asms_from_to : Proof.context -> Proof.context -> Proof.context
17.21 -( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
17.22 -end
17.23 -
17.24 -(* survey on handling contexts:
17.25 --------------------------------
17.26 - theory is required for Pattern.match (and thus for Tactic.Rewrite* ), while
17.27 - ctxt is required for parsing and for managing pre-conditions and assumptions.
17.28 - * model-specify-phase:
17.29 - * Tactic.Model_Problem does declare_constraints for parsing (in Tactic.Add_Given, etc)
17.30 - ("insert_assumptions pres" has to wait for completing Tactic.Add_Given, etc)
17.31 - (Tactic.Refine_Problem uses theory NOT ctxt due to Pattern.match)
17.32 - *
17.33 - *
17.34 - * solve-phase by Lucas-Interpretation:
17.35 - * locate_input_tactic:
17.36 - * Tactic.Apply_Method
17.37 - * initialises ctxt (declare_constraints' + insert_assumptions pres) by init_pstate
17.38 - * in solve for root problem
17.39 - * in begin_end_prog for subproblem
17.40 - * Tactic.Rewrite* create assumptions; respective insert_assumptions is done by associate
17.41 - * associate..Subproblem' returns ctxt ONLY with declare_constraints',
17.42 - with insert_assumptions wait for Tactic.Apply_Method
17.43 - * storing ctxt is done after return form locate_input_tactic
17.44 - * determine_next_tactic:
17.45 - * TODO initialises ctxt by TODO
17.46 - * Tactic.Rewrite* create assumptions; respective insert_assumptions TODO
17.47 - *
17.48 - *
17.49 - *
17.50 - * locate_input_formula: follows sig. of determine_next_tactic
17.51 - * changing from one method to another (in determine_next_tactic only):
17.52 - * from method to sub-program: just add new preconditions of the guard
17.53 - * locate_input_tactic: init_pstate by begin_end_prog
17.54 - * determine_next_tactic:
17.55 - * from_subpbl_to_caller
17.56 - * finishing a method:
17.57 - * Tactic.Check_Postcond' uses ctxt for proving the post-condition (not yet implemented)
17.58 - *
17.59 - *
17.60 - *
17.61 - *
17.62 -================================================================================================
17.63 -call hierarchy
17.64 -================================================================================================
17.65 -
17.66 - locatetac
17.67 - applicable_in (p, p_) pt (Tactic.Apply_Method pres
17.68 - insert_assumptions
17.69 -
17.70 - context_thy
17.71 - applicable_in (p, p_) pt (Tactic.Apply_Method pres
17.72 - insert_assumptions
17.73 -
17.74 -
17.75 -
17.76 -
17.77 -
17.78 -
17.79 - generate1 _ (Tactic.Rewrite***
17.80 - insert_assumptions
17.81 -
17.82 -
17.83 -
17.84 -
17.85 -
17.86 -------------------------------------------------------------------------------------------------
17.87 -solve phase before LI
17.88 -------------------------------------------------------------------------------------------------
17.89 -autocalc
17.90 - all_modspec
17.91 - declare_constraints'
17.92 - complete_solve
17.93 - all_modspec
17.94 - declare_constraints'
17.95 -
17.96 -all_solve
17.97 - begin_end_prog (Tactic.Apply_Method'
17.98 - init_pstate
17.99 - declare_constraints'
17.100 - insert_assumptions
17.101 -
17.102 -nxt_specify_
17.103 - begin_end_prog (Tactic.Apply_Method'
17.104 - init_pstate
17.105 - declare_constraints'
17.106 - insert_assumptions
17.107 -------------------------------------------------------------------------------------------------
17.108 -LI
17.109 -------------------------------------------------------------------------------------------------
17.110 -solve ("Apply_Method" root-program
17.111 - init_pstate
17.112 - declare_constraints'
17.113 - insert_assumptions
17.114 - locate_input_tactic
17.115 - execute_progr_2
17.116 - assy ..leaf sub-program
17.117 - associate
17.118 - declare_constraints'
17.119 - applicable_in .. Tactic.Apply_Method pres
17.120 - insert_assumptions
17.121 - ? generate1 (look in test with "from ... to..))
17.122 -
17.123 -determine_next_tactic
17.124 - execute_progr_1
17.125 - appy ..leaf
17.126 - stac2tac_
17.127 - declare_constraints'
17.128 - applicable_in (p, p_) pt (Tactic.Apply_Method pres
17.129 - insert_assumptions
17.130 - ? generate1 (look in test with "from ... to..))
17.131 -
17.132 -locate_input_formula uses determine_next_tactic
17.133 - compare_step
17.134 - all_modspec
17.135 - declare_constraints'
17.136 - begin_end_prog (Tactic.Apply_Method'
17.137 - init_pstate
17.138 - declare_constraints'
17.139 - insert_assumptions
17.140 -------------------------------------------------------------------------------------------------
17.141 -specification phase
17.142 -------------------------------------------------------------------------------------------------
17.143 - loc_specify_
17.144 - specify (Tactic.Init_Proof'
17.145 - prep_ori
17.146 - declare_constraints
17.147 -
17.148 - CalcTree
17.149 - nxt_specify_init_calc
17.150 - prep_ori
17.151 - declare_constraints
17.152 -
17.153 - modifyCalcHead
17.154 - input_icalhd
17.155 - prep_ori
17.156 - declare_constraints
17.157 -
17.158 - refine
17.159 - refin'
17.160 - prep_ori
17.161 - declare_constraints
17.162 -------------------------------------------------------------------------------------------------
17.163 -unused ?!
17.164 -------------------------------------------------------------------------------------------------
17.165 - ??
17.166 - match_pbl
17.167 - prep_ori
17.168 - declare_constraints
17.169 - ??
17.170 - from_pblobj'
17.171 - init_pstate
17.172 - declare_constraints'
17.173 - insert_assumptions
17.174 - ??
17.175 - tac2tac_
17.176 - applicable_in (p, p_) pt (Tactic.Apply_Method pres
17.177 - insert_assumptions
17.178 -
17.179 -*)
17.180 -
17.181 -structure ContextC(**) : CONTEXT_C(**) =
17.182 -struct
17.183 -
17.184 -val e_ctxt = Proof_Context.init_global @{theory "Pure"};
17.185 -
17.186 -(* in root-problem take respective formalisation *)
17.187 -fun initialise' thy fmz =
17.188 - let
17.189 - val ctxt = thy |> Proof_Context.init_global
17.190 - val frees = map (TermC.parseNEW' ctxt) fmz |> map TermC.vars |> flat |> distinct
17.191 - val _ = TermC.raise_type_conflicts frees
17.192 - in
17.193 - fold Variable.declare_constraints frees ctxt
17.194 - end
17.195 -(* in Subproblem take respective actual arguments from program *)
17.196 -fun initialise thy' ts =
17.197 - let
17.198 - val ctxt = Rule.Thy_Info_get_theory thy' |> Proof_Context.init_global
17.199 - val frees = map TermC.vars ts |> flat |> distinct
17.200 - val _ = TermC.raise_type_conflicts frees
17.201 - in
17.202 - fold Variable.declare_constraints frees ctxt
17.203 - end
17.204 -
17.205 -structure Context_Data = Proof_Data (type T = term list fun init _ = []);
17.206 -fun get_assumptions ctxt = Context_Data.get ctxt
17.207 -fun insert_assumptions asms = Context_Data.map (fn xs => distinct (asms @ xs))
17.208 -
17.209 -(* transfer assumptions from one to another ctxt.
17.210 - does NOT respect scope: in a calculation identifiers are unique.
17.211 - but environments are scoped as usual in Luacs-interpretation.
17.212 - WN110520 redo (1) take declare_constraints (2) with combinators*)
17.213 -fun transfer_asms_from_to from_ctxt to_ctxt =
17.214 - let
17.215 - val to_vars = get_assumptions to_ctxt |> map TermC.vars |> flat
17.216 - fun transfer [] to_ctxt = to_ctxt
17.217 - | transfer (from_asm :: fas) to_ctxt =
17.218 - if inter op = (TermC.vars from_asm) to_vars = []
17.219 - then transfer fas to_ctxt
17.220 - else transfer fas (insert_assumptions [from_asm] to_ctxt)
17.221 - in transfer (get_assumptions from_ctxt) to_ctxt end
17.222 -
17.223 -(* exported from a subproblem to the context of the calling method:
17.224 - # 'scrval': the result of script interpretation and
17.225 - # those assumptions in the subproblem wich contain a variable known
17.226 - in the calling method. *)
17.227 -fun from_subpbl_to_caller sub_ctxt scrval caller_ctxt =
17.228 - let
17.229 - val caller_ctxt = (scrval |> TermC.dest_list' |> insert_assumptions) caller_ctxt
17.230 - in transfer_asms_from_to sub_ctxt caller_ctxt end;
17.231 -
17.232 -end
18.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
18.2 +++ b/src/Tools/isac/ProgLang/program.sml Fri Aug 23 16:36:47 2019 +0200
18.3 @@ -0,0 +1,21 @@
18.4 +(* Title: ../program.sml
18.5 + Author: Walther Neuper
18.6 + (c) due to copyright terms
18.7 +*)
18.8 +signature PROGRAM =
18.9 +sig
18.10 +(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
18.11 + (*NONE*)
18.12 +(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
18.13 +( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
18.14 +end
18.15 +
18.16 +structure Program(**) : PROGRAM(**) =
18.17 +struct
18.18 +
18.19 +val (str, T) = ("", 123);
18.20 +
18.21 +val thy = @{theory}
18.22 +
18.23 +
18.24 +end
19.1 --- a/src/Tools/isac/ProgLang/termC.sml Thu Aug 22 16:48:04 2019 +0200
19.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
19.3 @@ -1,572 +0,0 @@
19.4 -(* Title: extends Isabelle/src/Pure/term.ML
19.5 - Author: Walther Neuper 1999, Mathias Lehnfeld
19.6 - (c) due to copyright terms
19.7 -*)
19.8 -infix contains_one_of
19.9 -
19.10 -(* TERM_C extends Isabelle's naming conventions: "C" indicates Isac add-ons to an Isabelle module *)
19.11 -signature TERM_C =
19.12 - sig
19.13 - val contains_Var: term -> bool
19.14 - val dest_binop_typ: typ -> typ * typ * typ
19.15 - val dest_equals: term -> term * term
19.16 - val free2str: term -> string
19.17 - val ids2str: term -> string list
19.18 - val ins_concl: term -> term -> term
19.19 - val inst_abs: term -> term
19.20 - val inst_bdv: (term * term) list -> term -> term
19.21 -
19.22 - val term_of_num: typ -> int -> term
19.23 - val num_of_term: term -> int
19.24 - val int_of_str_opt: string -> int option
19.25 - val int_of_str: string -> int
19.26 - val isastr_of_int: int -> string
19.27 -
19.28 - val isalist2list: term -> term list
19.29 - val list2isalist: typ -> term list -> term
19.30 - val isapair2pair: term -> term * term (* rename to dest_pair, compare HOLogic.dest_string *)
19.31 -
19.32 - val is_atom: term -> bool
19.33 - val is_bdv: string -> bool
19.34 - val is_bdv_subst: term -> bool
19.35 - val is_equality: term -> bool
19.36 - val is_expliceq: term -> bool
19.37 - val is_f_x: term -> bool
19.38 - val is_list: term -> bool
19.39 - val is_num: term -> bool
19.40 - val is_num': string -> bool
19.41 -
19.42 - val mk_add: term -> term -> term
19.43 - val mk_free: typ -> string -> term
19.44 - val mk_equality: term * term -> term
19.45 - val mk_factroot: string -> typ -> int -> int -> term
19.46 - val mk_Free: string * typ -> term
19.47 - val mk_thmid: string -> string -> string -> string
19.48 - val mk_num_op_num: typ -> typ -> string * typ -> int -> int -> term
19.49 - val mk_num_op_var: term -> string -> typ -> typ -> int -> term
19.50 - val mk_var_op_num: term -> string -> typ -> typ -> int -> term
19.51 -
19.52 - val matches: theory -> term -> term -> bool
19.53 - val parse: theory -> string -> cterm option
19.54 - val parseN: theory -> string -> cterm option
19.55 - val parseNEW: Proof.context -> string -> term option
19.56 - val parseNEW': Proof.context -> string -> term
19.57 - val parseold: theory -> string -> cterm option
19.58 - val parse_patt: theory -> string -> term
19.59 - val perm: term -> term -> bool
19.60 -
19.61 - val str_of_free_opt: term -> string option
19.62 - val str_of_int: int -> string
19.63 - val str2term: string -> term
19.64 - val strip_imp_prems': term -> term option
19.65 - val subst_atomic_all: (term * term) list -> term -> bool * term
19.66 - val term_detail2str: term -> string
19.67 -
19.68 - val pairt: term -> term -> term
19.69 - val pairT: typ -> typ -> typ
19.70 - val raise_type_conflicts: term list -> unit
19.71 - val strip_trueprop: term -> term
19.72 -
19.73 - val num_str: thm -> thm
19.74 - val numbers_to_string: term -> term
19.75 - val uminus_to_string: term -> term
19.76 - val var2free: term -> term
19.77 - val vars: term -> term list (* recognises numverals, should replace "fun vars_of" *)
19.78 - val vars_of: term -> term list
19.79 - val dest_list': term -> term list
19.80 -
19.81 -(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
19.82 - val scala_of_term: term -> string
19.83 - val atomtyp(*<-- atom_typ TODO*): typ -> unit
19.84 - val atomty: term -> unit
19.85 - val atomw: term -> unit
19.86 - val atomwy: term -> unit
19.87 - val atomty_thy: Rule.thyID -> term -> unit
19.88 - val free2var: term -> term
19.89 - val contains_one_of: thm * (string * typ) list -> bool
19.90 -(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
19.91 - val atomt: term -> unit
19.92 - val typ_a2real: term -> term
19.93 -( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
19.94 - end
19.95 -
19.96 -(**)
19.97 -structure TermC(**): TERM_C(**) =
19.98 -struct
19.99 -(**)
19.100 -
19.101 -fun isastr_of_int i = if i >= 0 then string_of_int i else "-" ^ string_of_int (abs i)
19.102 -
19.103 -fun matches thy tm pa =
19.104 - (Pattern.match thy (pa, tm) (Vartab.empty, Vartab.empty); true)
19.105 - handle Pattern.MATCH => false
19.106 -
19.107 -(** transform typ / term to a String to be parsed by Scala after transport via libisabelle **)
19.108 -
19.109 -fun scala_of_typ (Type (s, typs)) =
19.110 - enclose "Type(" ")" (quote s ^ ", " ^
19.111 - (typs |> map scala_of_typ |> commas |> enclose "List(" ")"))
19.112 - | scala_of_typ (TFree (s, sort)) =
19.113 - enclose "TFree(" ")" (quote s ^ ", " ^ (sort |> map quote |> commas |> enclose "List(" ")"))
19.114 - | scala_of_typ (TVar ((s, i), sort)) =
19.115 - enclose "TVar(" ")" (
19.116 - enclose "(" ")," (quote s ^ "," ^ quote (string_of_int i)) ^
19.117 - (sort |> map quote |> commas |> enclose "List(" ")"))
19.118 -fun scala_of_term (Const (s, T)) =
19.119 - enclose "Const(" ")" (quote s ^ ", " ^ scala_of_typ T)
19.120 - | scala_of_term (Free (s, T)) =
19.121 - enclose "Free(" ")" (quote s ^ ", " ^ scala_of_typ T)
19.122 - | scala_of_term (Var ((s, i), T)) =
19.123 - enclose "TVar(" ")" (
19.124 - enclose "(" ")," (quote s ^ "," ^ quote (string_of_int i)) ^
19.125 - scala_of_typ T)
19.126 - | scala_of_term (Bound i) = enclose "Bound(" ")" (string_of_int i)
19.127 - | scala_of_term (Abs (s, T, t)) =
19.128 - enclose "Abs(" ")" (
19.129 - quote s ^ ", " ^
19.130 - scala_of_typ T ^ ", " ^
19.131 - scala_of_term t)
19.132 - | scala_of_term (t1 $ t2) =
19.133 - enclose "App(" ")" (scala_of_term t1 ^ ", " ^ scala_of_term t2)
19.134 -
19.135 -(* see structure's bare bones.
19.136 - for Isabelle standard output compare 2017 "structure ML_PP" *)
19.137 -fun atomtyp t =
19.138 - let
19.139 - fun ato n (Type (s, [])) = "\n*** " ^ indent n ^ "Type (" ^ s ^",[])"
19.140 - | ato n (Type (s, Ts)) = "\n*** " ^ indent n ^ "Type (" ^ s ^ ",[" ^ atol (n + 1) Ts
19.141 - | ato n (TFree (s, sort)) = "\n*** " ^ indent n ^ "TFree (" ^ s ^ "," ^ strs2str' sort
19.142 - | ato n (TVar ((s, i), sort)) =
19.143 - "\n*** " ^ indent n ^ "TVar ((" ^ s ^ "," ^ string_of_int i ^ strs2str' sort
19.144 - and atol n [] = "\n*** " ^ indent n ^ "]"
19.145 - | atol n (T :: Ts) = (ato n T ^ atol n Ts)
19.146 -in tracing (ato 0 t ^ "\n") end;
19.147 -
19.148 -local
19.149 - fun ato (Const (a, _)) n = "\n*** " ^ indent n ^ "Const (" ^ a ^ ", _)"
19.150 - | ato (Free (a, _)) n = "\n*** " ^ indent n ^ "Free (" ^ a ^ ", _)"
19.151 - | ato (Var ((a, i), _)) n =
19.152 - "\n*** " ^ indent n ^ "Var (" ^ a ^ ", " ^ string_of_int i ^ "), _)"
19.153 - | ato (Bound i) n = "\n*** " ^ indent n ^ "Bound " ^ string_of_int i
19.154 - | ato (Abs (a, _, body)) n = "\n*** " ^ indent n ^ "Abs(" ^ a ^ ", _" ^ ato body (n+1)
19.155 - | ato (f $ t) n = (ato f n ^ ato t (n + 1))
19.156 -in
19.157 - fun atomw t = writeln ("\n*** -------------" ^ ato t 0 ^ "\n***");
19.158 - fun atomt t = tracing ("\n*** -------------" ^ ato t 0 ^ "\n***");
19.159 -end;
19.160 -
19.161 -fun term_detail2str t =
19.162 - let
19.163 - fun ato (Const (a, T)) n = "\n*** " ^ indent n ^ "Const (" ^ a ^ ", " ^ Rule.string_of_typ T ^ ")"
19.164 - | ato (Free (a, T)) n = "\n*** " ^ indent n ^ "Free (" ^ a ^ ", " ^ Rule.string_of_typ T ^ ")"
19.165 - | ato (Var ((a, i), T)) n =
19.166 - "\n*** " ^ indent n ^ "Var ((" ^ a ^ ", " ^ string_of_int i ^ "), " ^ Rule.string_of_typ T ^ ")"
19.167 - | ato (Bound i) n = "\n*** " ^ indent n ^ "Bound " ^ string_of_int i
19.168 - | ato (Abs(a, T, body)) n =
19.169 - "\n*** " ^ indent n ^ "Abs (" ^ a ^ ", " ^ Rule.string_of_typ T ^ ",.." ^ ato body (n + 1)
19.170 - | ato (f $ t) n = ato f n ^ ato t (n + 1)
19.171 - in "\n*** " ^ ato t 0 ^ "\n***" end;
19.172 -fun term_detail2str_thy thy t =
19.173 - let
19.174 - fun ato (Const (a, T)) n =
19.175 - "\n*** " ^ indent n ^ "Const (" ^ a ^ ", " ^ Rule.string_of_typ_thy thy T ^ ")"
19.176 - | ato (Free (a, T)) n =
19.177 - "\n*** " ^ indent n ^ "Free (" ^ a ^ ", " ^ Rule.string_of_typ_thy thy T ^ ")"
19.178 - | ato (Var ((a, i), T)) n =
19.179 - "\n*** " ^ indent n ^ "Var ((" ^ a ^ ", " ^ string_of_int i ^ "), " ^
19.180 - Rule.string_of_typ_thy thy T ^ ")"
19.181 - | ato (Bound i) n =
19.182 - "\n*** " ^ indent n ^ "Bound " ^ string_of_int i
19.183 - | ato (Abs(a, T, body)) n =
19.184 - "\n*** " ^ indent n ^ "Abs (" ^ a ^ ", " ^ Rule.string_of_typ_thy thy T ^ ",.." ^
19.185 - ato body (n + 1)
19.186 - | ato (f $ t) n = ato f n ^ ato t (n + 1)
19.187 - in "\n*** " ^ ato t 0 ^ "\n***" end;
19.188 -fun atomwy t = (writeln o term_detail2str) t;
19.189 -fun atomty t = (tracing o term_detail2str) t;
19.190 -fun atomty_thy thy t = (tracing o (term_detail2str_thy thy)) t;
19.191 -
19.192 -(* contains the term a VAR(("*",_),_) ? *)
19.193 -fun contains_Var (Abs(_,_,body)) = contains_Var body
19.194 - | contains_Var (f $ f') = contains_Var f orelse contains_Var f'
19.195 - | contains_Var (Var _) = true
19.196 - | contains_Var _ = false;
19.197 -
19.198 -fun str_of_int n =
19.199 - if n < 0 then "-" ^ ((string_of_int o abs) n)
19.200 - else string_of_int n;
19.201 -val int_of_str = Value.parse_int;
19.202 -fun int_of_str_opt str =
19.203 - let
19.204 - val ss = Symbol.explode str
19.205 - val ss' = case ss of "(" :: s => drop_last s | _ => ss
19.206 - val (sign, istr) = case ss' of "-" :: istr => (~1, istr) | _ => (1, ss')
19.207 - in
19.208 - case Library.read_int istr of (i, []) => SOME (sign * i) | _ => NONE
19.209 - end;
19.210 -fun is_num' str = case int_of_str_opt str of SOME _ => true | NONE => false;
19.211 -fun is_num (Free (s, _)) = if is_num' s then true else false | is_num _ = false;
19.212 -fun term_of_num ntyp n = Free (str_of_int n, ntyp);
19.213 -fun num_of_term (t as (Free (istr, _))) =
19.214 - (case int_of_str_opt istr of SOME i => i | NONE => raise TERM ("num_of_term: NOT int ", [t]))
19.215 - | num_of_term t = raise TERM ("num_of_term: NOT Free ", [t])
19.216 -
19.217 -fun is_Free (Free _) = true | is_Free _ = false;
19.218 -fun is_fun_id (Const _) = true
19.219 - | is_fun_id (Free _) = true
19.220 - | is_fun_id _ = false;
19.221 -fun is_f_x (f $ x) = is_fun_id f andalso is_Free x
19.222 - | is_f_x _ = false;
19.223 -
19.224 -fun vars t =
19.225 - let
19.226 - fun scan vs (Const _) = vs
19.227 - | scan vs (t as Free (s, _)) = if is_num' s then vs else t :: vs
19.228 - | scan vs (t as Var _) = t :: vs
19.229 - | scan vs (Bound _) = vs
19.230 - | scan vs (Abs (_, _, t)) = scan vs t
19.231 - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
19.232 - in (distinct o (scan [])) t end;
19.233 -(* bypass Isabelle's Pretty, which requires ctxt *)
19.234 -fun ids2str t =
19.235 - let
19.236 - fun scan vs (Const (s, _)) = if is_num' s then vs else s :: vs
19.237 - | scan vs (Free (s, _)) = if is_num' s then vs else s :: vs
19.238 - | scan vs (Var ((s, i), _)) = (s ^ "_" ^ string_of_int i) :: vs
19.239 - | scan vs (Bound _) = vs
19.240 - | scan vs (Abs (s, _, t)) = scan (s :: vs) t
19.241 - | scan vs (t1 $ t2) = (scan vs t1) @ (scan vs t2)
19.242 - in (distinct o (scan [])) t end;
19.243 -fun is_bdv str = case Symbol.explode str of "b"::"d"::"v"::_ => true | _ => false;
19.244 -(* instantiate #prop thm with bound variables (as Free) *)
19.245 -fun inst_bdv [] t = t
19.246 - | inst_bdv (instl: (term*term) list) t =
19.247 - let
19.248 - fun subst (v as Var((s, _), T)) =
19.249 - (case Symbol.explode s of
19.250 - "b"::"d"::"v"::_ => if_none (assoc(instl,Free(s,T))) (Free(s,T))
19.251 - | _ => v)
19.252 - | subst (Abs(a, T, body)) = Abs(a, T, subst body)
19.253 - | subst (f $ t') = subst f $ subst t'
19.254 - | subst t = if_none (assoc (instl, t)) t
19.255 - in subst t end;
19.256 -
19.257 -(* is a term a substitution for a bdv as found in programs and tactics *)
19.258 -fun is_bdv_subst (Const ("List.list.Cons", _) $
19.259 - (Const ("Product_Type.Pair", _) $ str $ _) $ _) = is_bdv (HOLogic.dest_string str)
19.260 - | is_bdv_subst _ = false;
19.261 -
19.262 -fun free2str (Free (s, _)) = s
19.263 - | free2str t = error ("free2str not for " ^ Rule.term2str t);
19.264 -fun str_of_free_opt (Free (s, _)) = SOME s
19.265 - | str_of_free_opt _ = NONE
19.266 -
19.267 -(* compare Logic.unvarify_global, which rejects Free *)
19.268 -fun var2free (t as Const _) = t
19.269 - | var2free (t as Free _) = t
19.270 - | var2free (Var((s, _), T)) = Free (s,T)
19.271 - | var2free (t as Bound _) = t
19.272 - | var2free (Abs(s, T, t)) = Abs(s, T, var2free t)
19.273 - | var2free (t1 $ t2) = (var2free t1) $ (var2free t2);
19.274 -
19.275 -(* Logic.varify does NOT take care of 'Free ("1", _)'*)
19.276 -fun free2var (t as Const _) = t
19.277 - | free2var (t as Free (s, T)) = if is_num' s then t else Var ((s, 0), T)
19.278 - | free2var (t as Var _) = t
19.279 - | free2var (t as Bound _) = t
19.280 - | free2var (Abs (s, T, t)) = Abs (s, T, free2var t)
19.281 - | free2var (t1 $ t2) = (free2var t1) $ (free2var t2);
19.282 -
19.283 -fun mk_listT T = Type ("List.list", [T]);
19.284 -fun list_const T = Const ("List.list.Cons", [T, mk_listT T] ---> mk_listT T);
19.285 -fun list2isalist T [] = Const ("List.list.Nil", mk_listT T)
19.286 - | list2isalist T (t :: ts) = (list_const T) $ t $ (list2isalist T ts);
19.287 -
19.288 -fun isapair2pair (Const ("Product_Type.Pair",_) $ a $ b) = (a, b)
19.289 - | isapair2pair t =
19.290 - error ("isapair2pair called with " ^ Rule.term2str t);
19.291 -fun isalist2list ls =
19.292 - let
19.293 - fun get es (Const("List.list.Cons", _) $ t $ ls) = get (t :: es) ls
19.294 - | get es (Const("List.list.Nil", _)) = es
19.295 - | get _ t = raise TERM ("isalist2list applied to NON-list: ", [t])
19.296 - in (rev o (get [])) ls end;
19.297 -
19.298 -fun is_list ((Const ("List.list.Cons", _)) $ _ $ _) = true
19.299 - | is_list _ = false;
19.300 -fun dest_binop_typ (Type ("fun", [range, Type ("fun", [arg2, arg1])])) = (arg1, arg2, range)
19.301 - | dest_binop_typ _ = raise ERROR "dest_binop_typ: not binary";
19.302 -fun dest_equals (Const("HOL.eq", _) $ t $ u) = (t, u) (* Pure/logic.ML: Const ("==", ..*)
19.303 - | dest_equals t = raise TERM ("dest_equals'", [t]);
19.304 -fun is_equality (Const("HOL.eq",_) $ _ $ _) = true (* logic.ML: Const("=="*)
19.305 - | is_equality _ = false;
19.306 -fun mk_equality (t, u) = (Const("HOL.eq", [type_of t, type_of u] ---> HOLogic.boolT) $ t $ u);
19.307 -fun is_expliceq (Const("HOL.eq",_) $ (Free _) $ _) = true
19.308 - | is_expliceq _ = false;
19.309 -fun strip_trueprop (Const ("HOL.Trueprop", _) $ t) = t
19.310 - | strip_trueprop t = t;
19.311 -
19.312 -(* (A1==>...An==>B) goes to (A1==>...An==>) Pure/logic.ML: term -> term list*)
19.313 -fun strip_imp_prems' (Const ("Pure.imp", _) $ A $ t) =
19.314 - let
19.315 - fun coll_prems As (Const("Pure.imp", _) $ A $ t) =
19.316 - coll_prems (As $ (Logic.implies $ A)) t
19.317 - | coll_prems As _ = SOME As
19.318 - in coll_prems (Logic.implies $ A) t end
19.319 - | strip_imp_prems' _ = NONE; (* *)
19.320 -
19.321 -(* (A1==>...An==>) (B) goes to (A1==>...An==>B), where B is lowest branch, 2002 Pure/thm.ML *)
19.322 -fun ins_concl (Const ("Pure.imp", _) $ A $ t) B = Logic.implies $ A $ (ins_concl t B)
19.323 - | ins_concl (Const ("Pure.imp", _) $ A ) B = Logic.implies $ A $ B
19.324 - | ins_concl t B = raise TERM ("ins_concl", [t, B]);
19.325 -
19.326 -fun vperm (Var _, Var _) = true (* 2002 Pure/thm.ML *)
19.327 - | vperm (Abs (_, _, s), Abs (_, _, t)) = vperm (s, t)
19.328 - | vperm (t1 $ t2, u1 $ u2) = vperm (t1, u1) andalso vperm (t2, u2)
19.329 - | vperm (t, u) = (t = u);
19.330 -
19.331 -(*2002 cp from Pure/term.ML --- since 2009 in Pure/old_term.ML*)
19.332 -fun mem_term (_, []) = false
19.333 - | mem_term (t, t' :: ts) = t aconv t' orelse mem_term (t, ts);
19.334 -fun subset_term ([], _) = true
19.335 - | subset_term (x :: xs, ys) = mem_term (x, ys) andalso subset_term (xs, ys);
19.336 -fun eq_set_term (xs, ys) =
19.337 - xs = ys orelse (subset_term (xs, ys) andalso subset_term (ys, xs));
19.338 -(*a total, irreflexive ordering on index names*)
19.339 -fun xless ((a, i), (b, j): indexname) = i<j orelse (i = j andalso a < b);
19.340 -(*a partial ordering (not reflexive) for atomic terms*)
19.341 -fun atless (Const (a, _), Const (b, _)) = a < b
19.342 - | atless (Free (a, _), Free (b, _)) = a < b
19.343 - | atless (Var (v, _), Var (w, _)) = xless (v, w)
19.344 - | atless (Bound i, Bound j) = i < j
19.345 - | atless _ = false;
19.346 -(*insert atomic term into partially sorted list, suppressing duplicates (?)*)
19.347 -fun insert_aterm (t,us) =
19.348 - let fun inserta [] = [t]
19.349 - | inserta (us as u::us') =
19.350 - if atless(t,u) then t::us
19.351 - else if t=u then us (*duplicate*)
19.352 - else u :: inserta us'
19.353 - in inserta us end;
19.354 -
19.355 -(* Accumulates the Vars in the term, suppressing duplicates *)
19.356 -fun add_term_vars (t, vars: term list) = case t of
19.357 - Var _ => insert_aterm (t, vars)
19.358 - | Abs (_, _, body) => add_term_vars (body, vars)
19.359 - | f$t => add_term_vars (f, add_term_vars (t, vars))
19.360 - | _ => vars;
19.361 -fun term_vars t = add_term_vars (t, []);
19.362 -
19.363 -(*2002 Pure/thm.ML *)
19.364 -fun var_perm (t, u) = vperm (t, u) andalso eq_set_term (term_vars t, term_vars u);
19.365 -(*2002 fun decomp_simp, Pure/thm.ML *)
19.366 -fun perm lhs rhs = var_perm (lhs, rhs) andalso not (lhs aconv rhs) andalso not (is_Var lhs);
19.367 -
19.368 -
19.369 -fun pairT T1 T2 = Type ("*", [T1, T2]);
19.370 -fun PairT T1 T2 = ([T1, T2] ---> Type ("*", [T1, T2]));
19.371 -fun pairt t1 t2 = Const ("Product_Type.Pair", PairT (type_of t1) (type_of t2)) $ t1 $ t2;
19.372 -
19.373 -fun mk_factroot op_(*=thy.sqrt*) T fact root =
19.374 - Const ("Groups.times_class.times", [T, T] ---> T) $ (term_of_num T fact) $
19.375 - (Const (op_, T --> T) $ term_of_num T root);
19.376 -fun mk_var_op_num v op_ optype ntyp n = Const (op_, optype) $ v $ Free (str_of_int n, ntyp);
19.377 -fun mk_num_op_var v op_ optype ntyp n = Const (op_, optype) $ Free (str_of_int n, ntyp) $ v;
19.378 -fun mk_num_op_num T1 T2 (op_, Top) n1 n2 =
19.379 - Const (op_, Top) $ Free (str_of_int n1, T1) $ Free (str_of_int n2, T2);
19.380 -fun mk_thmid thmid n1 n2 =
19.381 - thmid ^ (strip_thy n1) ^ "_" ^ (strip_thy n2);
19.382 -fun mk_add t1 t2 =
19.383 - let
19.384 - val (T1, T2) = (type_of t1, type_of t2)
19.385 - in
19.386 - if T1 <> T2 then raise TYPE ("mk_add gets ", [T1, T2], [t1,t2])
19.387 - else (Const ("Groups.plus_class.plus", [T1, T2] ---> T1) $ t1 $ t2)
19.388 - end;
19.389 -
19.390 -(** transform binary numeralsstrings **)
19.391 -(*Makarius 100308, hacked by WN*)
19.392 -val numbers_to_string =
19.393 - let
19.394 - fun dest_num t =
19.395 - (case try HOLogic.dest_number t of
19.396 - SOME (T, i) =>
19.397 - (*if T = @{typ int} orelse T = @{typ real} then WN*)
19.398 - SOME (Free (signed_string_of_int i, T))
19.399 - (*else NONE WN*)
19.400 - | NONE => NONE);
19.401 - fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
19.402 - | to_str (t as (u1 $ u2)) =
19.403 - (case dest_num t of
19.404 - SOME t' => t'
19.405 - | NONE => to_str u1 $ to_str u2)
19.406 - | to_str t = perhaps dest_num t;
19.407 - in to_str end
19.408 -val uminus_to_string =
19.409 - let
19.410 - fun dest_num t =
19.411 - case t of
19.412 - (Const ("Groups.uminus_class.uminus", _) $ Free (s, T)) =>
19.413 - (case int_of_str_opt s of
19.414 - SOME i => SOME (Free (signed_string_of_int (~1 * i), T))
19.415 - | NONE => NONE)
19.416 - | _ => NONE;
19.417 - fun to_str (Abs (x, T, b)) = Abs (x, T, to_str b)
19.418 - | to_str (t as (u1 $ u2)) =
19.419 - (case dest_num t of SOME t' => t' | NONE => to_str u1 $ to_str u2)
19.420 - | to_str t = perhaps dest_num t;
19.421 - in to_str end;
19.422 -fun num_str thm =
19.423 - let
19.424 - val (deriv,
19.425 - {cert = cert, tags = tags, maxidx = maxidx, shyps = shyps,
19.426 - hyps = hyps, tpairs = tpairs, prop = prop}) = Thm.rep_thm_G thm
19.427 - val prop' = numbers_to_string prop;
19.428 - in Thm.assbl_thm deriv cert tags maxidx shyps hyps tpairs prop' end;
19.429 -
19.430 -fun mk_Free (s,T) = Free (s, T);
19.431 -fun mk_free T s = Free (s, T);
19.432 -
19.433 -(*Special case: one argument cp from Isabelle2002/src/Pure/term.ML*)
19.434 -fun subst_bound (arg, t) =
19.435 - let
19.436 - fun subst (t as Bound i, lev) =
19.437 - if i < lev then t (*var is locally bound*)
19.438 - else if i = lev then incr_boundvars lev arg
19.439 - else Bound (i - 1) (*loose: change it*)
19.440 - | subst (Abs(a, T, body), lev) = Abs (a, T, subst (body, lev + 1))
19.441 - | subst (f$t, lev) = subst(f, lev) $ subst(t, lev)
19.442 - | subst (t, _) = t
19.443 - in subst (t, 0) end;
19.444 -
19.445 -(* instantiate let; necessary for ass_up *)
19.446 -fun inst_abs (Const sT) = Const sT
19.447 - | inst_abs (Free sT) = Free sT
19.448 - | inst_abs (Bound n) = Bound n
19.449 - | inst_abs (Var iT) = Var iT
19.450 - | inst_abs (Const ("HOL.Let",T1) $ e $ (Abs (v, T2, b))) =
19.451 - let val b' = subst_bound (Free (v, T2), b); (*fun variant_abs: term.ML*)
19.452 - in Const ("HOL.Let", T1) $ inst_abs e $ (Abs (v, T2, inst_abs b')) end
19.453 - | inst_abs (t1 $ t2) = inst_abs t1 $ inst_abs t2
19.454 - | inst_abs t = t;
19.455 -
19.456 -(* for parse and parse_patt: fix all types to real *)
19.457 -fun T_a2real (Type (s, [])) =
19.458 - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else Type (s, [])
19.459 - | T_a2real (Type (s, Ts)) = Type (s, map T_a2real Ts)
19.460 - | T_a2real (TFree (s, srt)) =
19.461 - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TFree (s, srt)
19.462 - | T_a2real (TVar (("DUMMY", _), _)) = HOLogic.realT
19.463 - | T_a2real (TVar ((s, i), srt)) =
19.464 - if s = "'a" orelse s = "'b" orelse s = "'c" then HOLogic.realT else TVar ((s, i), srt)
19.465 -fun typ_a2real (Const( s, T)) = (Const( s, T_a2real T))
19.466 - | typ_a2real (Free( s, T)) = (Free( s, T_a2real T))
19.467 - | typ_a2real (Var( n, T)) = (Var( n, T_a2real T))
19.468 - | typ_a2real (Bound i) = (Bound i)
19.469 - | typ_a2real (Abs(s,T,t)) = Abs(s, T, typ_a2real t)
19.470 - | typ_a2real (t1 $ t2) = (typ_a2real t1) $ (typ_a2real t2);
19.471 -
19.472 -(* TODO clarify parse with Test_Isac *)
19.473 -fun parseold thy str = (* before 2002 *)
19.474 - (let val t = ((*typ_a2real o*) numbers_to_string) (Syntax.read_term_global thy str)
19.475 - in SOME (Thm.global_cterm_of thy t) end)
19.476 - handle _(*EXN? ..Inner syntax error Failed to parse term*) => NONE;
19.477 -fun parseN thy str = (* introduced 2002 *)
19.478 - (let val t = (*(typ_a2real o numbers_to_string)*) (Syntax.read_term_global thy str)
19.479 - in SOME (Thm.global_cterm_of thy t) end)
19.480 - handle _(*EXN? ..Inner syntax error Failed to parse term*) => NONE;
19.481 -fun parse thy str = (* introduced 2010 *)
19.482 - (let val t = (typ_a2real o numbers_to_string) (Syntax.read_term_global thy str)
19.483 - in SOME (Thm.global_cterm_of thy t) end)
19.484 - handle _(*EXN? ..Inner syntax error Failed to parse term*) => NONE;
19.485 -
19.486 -(*WN110317 parseNEW will replace parse after introduction of ctxt completed*)
19.487 -fun parseNEW ctxt str = SOME (Syntax.read_term ctxt str |> numbers_to_string)
19.488 - handle _ => NONE;
19.489 -fun parseNEW' ctxt str =
19.490 - case parseNEW ctxt str of
19.491 - SOME t => t
19.492 - | NONE => raise TERM ("NO parseNEW' for " ^ str, [])
19.493 -
19.494 -(* parse term patterns; Var ("v",_), i.e. "?v", are required for instantiation
19.495 - WN130613 probably compare to
19.496 - http://www.mail-archive.com/isabelle-dev@mailbroy.informatik.tu-muenchen.de/msg04249.html*)
19.497 -fun parse_patt thy str =
19.498 - (thy, str) |>> Rule.thy2ctxt
19.499 - |-> Proof_Context.read_term_pattern
19.500 - |> numbers_to_string (*TODO drop*)
19.501 - |> typ_a2real; (*TODO drop*)
19.502 -fun str2term str = parse_patt (Rule.Thy_Info_get_theory "Isac") str
19.503 -
19.504 -(* TODO decide with Test_Isac *)
19.505 -fun is_atom t = length (vars t) = 1
19.506 -fun is_atom (Const ("Float.Float",_) $ _) = true
19.507 - | is_atom (Const ("ComplexI.I'_'_",_)) = true
19.508 - | is_atom (Const ("Groups.times_class.times",_) $ t $ Const ("ComplexI.I'_'_",_)) = is_atom t
19.509 - | is_atom (Const ("Groups.plus_class.plus",_) $ t1 $ Const ("ComplexI.I'_'_",_)) = is_atom t1
19.510 - | is_atom (Const ("Groups.plus_class.plus",_) $ t1 $
19.511 - (Const ("Groups.times_class.times",_) $ t2 $ Const ("ComplexI.I'_'_",_))) =
19.512 - is_atom t1 andalso is_atom t2
19.513 - | is_atom (Const _) = true
19.514 - | is_atom (Free _) = true
19.515 - | is_atom (Var _) = true
19.516 - | is_atom _ = false;
19.517 -
19.518 -(* from Pure/term.ML; reports if ALL Free's have found a substitution
19.519 - (required for evaluating the preconditions of _incomplete_ models) *)
19.520 -fun subst_atomic_all [] t = (false (*TODO may be 'true' for some terms ?*), t)
19.521 - | subst_atomic_all instl t =
19.522 - let
19.523 - fun subst (Abs (a, T, body)) =
19.524 - let
19.525 - val (all, body') = subst body
19.526 - in (all, Abs(a, T, body')) end
19.527 - | subst (f$tt) =
19.528 - let
19.529 - val (all1, f') = subst f
19.530 - val (all2, tt') = subst tt
19.531 - in (all1 andalso all2, f' $ tt') end
19.532 - | subst (t as Free _) =
19.533 - if is_num t then (true, t) (*numerals cannot be subst*)
19.534 - else (case assoc (instl, t) of
19.535 - SOME t' => (true, t')
19.536 - | NONE => (false, t))
19.537 - | subst t = (true, if_none (assoc(instl,t)) t)
19.538 - in subst t end;
19.539 -
19.540 -fun op contains_one_of (thm, ids) =
19.541 - Term.exists_Const (fn id => member op= ids id) (Thm.prop_of thm)
19.542 -
19.543 -fun var_for vs (t as Const (str, _)) id = if id = strip_thy str then t :: vs else vs
19.544 - | var_for vs (t as Free (str, _)) id = if id = str then t :: vs else vs
19.545 - | var_for vs (t as Var (idn, _)) id = if id = Term.string_of_vname idn then t :: vs else vs
19.546 - | var_for vs (Bound _) _ = vs
19.547 - | var_for vs (Abs (_, _, t)) id = var_for vs t id
19.548 - | var_for vs (t1 $ t2) id = (var_for vs t1 id) @ (var_for vs t2 id)
19.549 -
19.550 -val poly_consts = (* TODO: adopt syntax-const from Isabelle*)
19.551 - ["Groups.plus_class.plus", "Groups.minus_class.minus",
19.552 - "Rings.divide_class.divide", "Groups.times_class.times",
19.553 - "Atools.pow"];
19.554 -(* treat Free, Const, Var as variables in polynomials *)
19.555 -fun vars_of t =
19.556 - let
19.557 - val var_ids = t |> ids2str |> subtract op = poly_consts |> map strip_thy |> sort string_ord
19.558 - in (map (var_for [] t) var_ids) |> flat |> distinct end
19.559 -
19.560 -(* this may decompose an object-language isa-list;
19.561 - use only, if description is not available, eg. not input ?WN:14.5.03 ??!?*)
19.562 -fun dest_list' t = if is_list t then isalist2list t else [t];
19.563 -
19.564 -fun raise_type_conflicts ts =
19.565 - let
19.566 - val dups = duplicates (op =) (map (fst o dest_Free) ts)
19.567 - val confl = filter (fn Free (str, _) => member op = dups str) ts
19.568 - in
19.569 - if confl = []
19.570 - then ()
19.571 - else raise TYPE ("formalisation inconsistent w.r.t. type inference: ",
19.572 - map (snd o dest_Free)confl, confl)
19.573 - end
19.574 -
19.575 -end
19.576 \ No newline at end of file
20.1 --- a/src/Tools/isac/TODO.thy Thu Aug 22 16:48:04 2019 +0200
20.2 +++ b/src/Tools/isac/TODO.thy Fri Aug 23 16:36:47 2019 +0200
20.3 @@ -13,13 +13,41 @@
20.4 subsection \<open>Current changeset\<close>
20.5 text \<open>
20.6 \begin{itemize}
20.7 + \item separate code required in both, ProgLang & Interpret
20.8 + \begin{itemize}
20.9 + \item signature LIBRARY_C
20.10 + \item Program.thy (*=========== record these ^^^ in 'tacs' in program.ML =========*)
20.11 + \item sig/struc ..elems --> elem
20.12 + \item separate and re-join Tools.thy, Descript.thy, ProgLang.thy
20.13 + \begin{itemize}
20.14 + \item join Tools.thy.typedecl nam & scrtools.sml.fun is_dsc
20.15 + \item xxx
20.16 + \item separate Tools.thy --> TypeC.thy & FunC.thy
20.17 + \item join FunC.thy <-- Descript.thy
20.18 + \item xxx
20.19 + \item rename ProgLang.thy -?-> Prog_Tac
20.20 + \item xxx
20.21 + \item xxx
20.22 + \item xxx
20.23 + \end{itemize}
20.24 + \item rm Delete.thy
20.25 + \begin{itemize}
20.26 + \item Atools requires "fun calcul", "fun float_op_var", term_of_float ?!?
20.27 + \item xxx
20.28 + \item xxx
20.29 + \end{itemize}
20.30 + \item xxx
20.31 + \item Isac.thy --> All_Knowledge.thy
20.32 + \item xxx
20.33 + \item xxx
20.34 + \end{itemize}
20.35 \item xxx
20.36 \item xxx
20.37 \item xxx
20.38 - \item lucas-intrpreter.locate_input_tactic: execute_progr_2 srls tac cstate (progr, Rule.e_rls)
20.39 - ^^^^^^^^^^
20.40 \item xxx
20.41 \item xxx
20.42 + \item simplify calls of assy, appy etc
20.43 + \item open Istate in LucinNEW
20.44 \end{itemize}
20.45 \<close>
20.46 subsection \<open>Postponed from current changeset\<close>
20.47 @@ -28,6 +56,7 @@
20.48 \item clarify handling of contexts
20.49 \begin{itemize}
20.50 \item Check_Elementwise "Assumptions": prerequisite for ^^goal
20.51 + rm tactic Check_elementwise "Assumptions" in a way, which keeps it for Minisubpbl
20.52 \item xxx
20.53 \item Tactic.Apply_Method' (mI, _, _, _(*ctxt ?!?*))) .. remove ctxt
20.54 \item rm ctxt from Subproblem' (is separated in associate!))
20.55 @@ -46,38 +75,44 @@
20.56 \item xxx
20.57 \item check in states: length ?? > 1 with tracing these cases
20.58 \item xxx
20.59 - \item datatype L,R,D --> Istate
20.60 \item xxx
20.61 \item Lucin.Ass_Weak etc \<longrightarrow> NEW structutre ? LItool ?
20.62 \item xxx
20.63 \item istate
20.64 \begin{itemize}
20.65 - \item DONE rename srcstate --> pstate
20.66 - and after review of Rrls, detail ?-->? istate
20.67 + \item datatype L,R,D --> Istate
20.68 + \item xxx
20.69 + \item xxx
20.70 + \item xxx
20.71 + \item in locate_input_tactic .. ?assy?; Program.is_eval_expr .use Term.exists_Const
20.72 + \item xxx
20.73 + \item change Lucin.handle_leaf "locate" "Isac" sr E a v t
20.74 + to Lucin.handle_leaf "locate" ctxt ( pstate ) !!srls in scrstate!!^^
20.75 + and redesign handle_leaf .. subst_stacexpr .. associate
20.76 + to Tactic.from_code :
20.77 + + keep ! trace_script
20.78 + \item xxx
20.79 + \item after review of Rrls, detail ?-->? istate
20.80 \item locate_input_tactic: get_simplifier cstate (*TODO: shift to init_istate*)
20.81 \item xxx
20.82 + \item push srls into pstate
20.83 + \item lucas-intrpreter.locate_input_tactic: execute_progr_2 srls tac cstate (progr, Rule.e_rls)
20.84 + ^^^^^^^^^^
20.85 \item xxx
20.86 \item xxx
20.87 \end{itemize}
20.88 \item xxx
20.89 \item ctxt context
20.90 \begin{itemize}
20.91 - \item DONE Rewrite.eval_listexpr_ thy ..: can thy be extracted from ctxt ?
20.92 + \item xxx
20.93 \item xxx
20.94 \item xxx
20.95 \end{itemize}
20.96 - \item push srls into srcstate
20.97 - \item change Lucin.handle_leaf "locate" "Isac" sr E a v t
20.98 - to Lucin.handle_leaf "locate" ctxt ( srcstate ) !!srls in scrstate!!^^
20.99 - and redesign handle_leaf .. subst_stacexpr .. associate
20.100 - to Tactic.from_code :
20.101 - + keep ! trace_script
20.102 - \item in locate_input_tactic .. ?assy?; Program.is_eval_expr .use Term.exists_Const
20.103 \item trace_script: replace ' by " in writeln
20.104 \item xxx
20.105 \item librarys.ml --> libraryC.sml + text from termC.sml
20.106 \item xxx
20.107 - \item rm tactic Check_elementwise "Assumptions" in a way, which keeps it for Minisubpbl
20.108 + \item xxx
20.109 \item xxx
20.110 \item language definition: use (f #> g) x = x |> f |> g instead of @
20.111 see implementation.pdf p.16
20.112 @@ -91,7 +126,7 @@
20.113 \item
20.114 \item xxx
20.115 \end{itemize}
20.116 - \item concentracte "insert_assumptions" in "associate" ?for determine_next_tactic ?where?
20.117 + \item concentrate "insert_assumptions" in "associate" ?for determine_next_tactic ?where?
20.118 \begin{itemize}
20.119 \item rm from "generate1" ("Detail_Set_Inst'", Tactic.Detail_Set' ?)
20.120 \item shift from "applicable_in..Apply_Method" to ? ? ? (is ONLY use-case in appl.sml))
21.1 --- a/src/Tools/isac/ThydataC/rule.sml Thu Aug 22 16:48:04 2019 +0200
21.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
21.3 @@ -1,512 +0,0 @@
21.4 -(* rules guiding stepwise execution of methods in the LUCAS_INTERPRETER.
21.5 - Author: Walther Neuper 2018 (code gathered from other Isac source)
21.6 - (c) copyright due to lincense terms
21.7 -*)
21.8 -
21.9 -signature RULE =
21.10 - sig
21.11 - eqtype calID
21.12 - type eval_fn = string -> term -> theory -> (string * term) option
21.13 - val e_evalfn: 'a -> term -> theory -> (string * term) option
21.14 - type cal = calID * eval_fn
21.15 - eqtype prog_calcID
21.16 - type calc = prog_calcID * cal
21.17 - type calc_elem
21.18 - val calc_eq: calc_elem * calc_elem -> bool
21.19 -
21.20 - eqtype cterm' (* shift up in sequence of defs *)
21.21 - type subst = (term * term) list (* shift up in sequence of defs *)
21.22 -
21.23 - eqtype rew_ord'
21.24 - val e_rew_ord': rew_ord'
21.25 - type rew_ord_
21.26 - val dummy_ord: rew_ord_
21.27 - val e_rew_ord_: rew_ord_
21.28 - type rew_ord = rew_ord' * rew_ord_
21.29 - val e_rew_ord: rew_ord_
21.30 - val e_rew_ordX: rew_ord
21.31 - val rew_ord': (rew_ord' * (subst -> term * term -> bool)) list Unsynchronized.ref
21.32 - val assoc_rew_ord: string -> subst -> term * term -> bool
21.33 -
21.34 - eqtype errpatID
21.35 - type errpat = errpatID * term list * thm list
21.36 - eqtype rls'
21.37 - datatype rls
21.38 - = Erls
21.39 - | Rls of {calc: calc list, erls: rls, errpatts: errpatID list, id: string,
21.40 - preconds: term list, rew_ord: rew_ord, rules: rule list, scr: program, srls: rls}
21.41 - | Seq of {calc: calc list, erls: rls, errpatts: errpatID list, id: string,
21.42 - preconds: term list, rew_ord: rew_ord, rules: rule list, scr: program, srls: rls}
21.43 - | Rrls of {calc: calc list, erls: rls, errpatts: errpatID list, id: string,
21.44 - prepat: (term list * term) list, rew_ord: rew_ord, scr: program}
21.45 - and rule = Cal1 of string * eval_fn | Calc of string * eval_fn | Erule
21.46 - | Rls_ of rls | Thm of string * thm
21.47 - and program
21.48 - = EmptyScr
21.49 - | Prog of term
21.50 - | Rfuns of
21.51 - {attach_form: rule list list -> term -> term -> (rule * (term * term list)) list,
21.52 - init_state: term -> term * term * rule list list * (rule * (term * term list)) list,
21.53 - locate_rule: rule list list -> term -> rule -> (rule * (term * term list)) list,
21.54 - next_rule: rule list list -> term -> rule option, normal_form: term ->
21.55 - (term * term list) option}
21.56 - val rule2str: rule -> string
21.57 - val rule2str': rule -> string
21.58 - val e_rule: rule
21.59 - val get_rules: rls -> rule list
21.60 - val id_rule: rule -> string
21.61 - val eq_rule: rule * rule -> bool
21.62 -
21.63 - val scr2str: program -> string
21.64 - val e_rrls: rls
21.65 -
21.66 - val e_rls: rls
21.67 - val rls2str: rls -> string
21.68 - val id_rls: rls -> string
21.69 - val rep_rls: rls -> {calc: calc list, erls: rls, errpats: errpatID list, id: string,
21.70 - preconds: term list, rew_ord: rew_ord, rules: rule list, scr: program, srls: rls}
21.71 - val append_rls: string -> rls -> rule list -> rls
21.72 - val merge_rls: string -> rls -> rls -> rls
21.73 - val remove_rls: string -> rls -> rule list -> rls
21.74 -
21.75 - type rrlsstate = term * term * rule list list * (rule * (term * term list)) list
21.76 - val e_rrlsstate: rrlsstate
21.77 -
21.78 - val thy2ctxt: theory -> Proof.context (* shift up in sequence of defs *)
21.79 - val thy2ctxt': string -> Proof.context (* shift up in sequence of defs *)
21.80 - val Thy_Info_get_theory: string -> theory (* shift up in sequence of defs *)
21.81 -
21.82 - eqtype thyID (* shift up in sequence of defs *)
21.83 - eqtype domID (* shift up in sequence of defs *)
21.84 - val e_domID: domID (* shift up in sequence of defs *)
21.85 - eqtype theory' (* shift up in sequence of defs *)
21.86 - val theory'2thyID: theory' -> theory' (* shift up in sequence of defs *)
21.87 - val theory2theory': theory -> theory' (* shift up in sequence of defs *)
21.88 - val theory2thyID: theory -> thyID (* shift up in sequence of defs *)
21.89 - val thyID2theory': thyID -> thyID (* shift up in sequence of defs *)
21.90 - val string_of_thy: theory -> theory' (* shift up in sequence of defs *)
21.91 - val theory2domID: theory -> theory' (* shift up in sequence of defs *)
21.92 -
21.93 - val Isac: 'a -> theory (* shift up in sequence of defs *)
21.94 -
21.95 - val string_of_thmI: thm -> string (* shift up to Unparse *)
21.96 - val e_term: term (* shift up to Unparse *)
21.97 - val e_type: typ (* shift up to Unparse *)
21.98 - val type2str: typ -> string
21.99 - val term_to_string': Proof.context -> term -> string (* shift up to Unparse *)
21.100 - val term2str: term -> string (* shift up to Unparse *)
21.101 - val termopt2str: term option -> string (* shift up to Unparse *)
21.102 - val theory2str: theory -> theory' (* shift up to Unparse *)
21.103 - val terms2str: term list -> string (* shift up to Unparse *)
21.104 - val terms2strs: term list -> string list
21.105 - val term_to_string'': thyID -> term -> string (* shift up to Unparse *)
21.106 - val term_to_string''': theory -> term -> string (* shift up to Unparse *)
21.107 - val t2str: theory -> term -> string
21.108 - val ts2str: theory -> term list -> string (* shift up to Unparse *)
21.109 - val string_of_typ: typ -> string (* shift up to Unparse *)
21.110 - val string_of_typ_thy: thyID -> typ -> string (* shift up to Unparse *)
21.111 -
21.112 -(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
21.113 - val terms2str': term list -> string (* shift up to Unparse *)
21.114 - val thm2str: thm -> string
21.115 - val thms2str : thm list -> string
21.116 -(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
21.117 - val string_of_thm': theory -> thm -> string (* shift up to Unparse *)
21.118 - val string_of_thm: thm -> string (* shift up to Unparse *)
21.119 - val errpats2str : errpat list -> string
21.120 -( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
21.121 -
21.122 -(*----- unused code, kept as hints to design ideas ---------------------------------------------*)
21.123 -
21.124 - end
21.125 -
21.126 -(**)
21.127 -structure Rule(**): RULE(**) =
21.128 -struct
21.129 -(**)
21.130 -
21.131 -type calID = string;
21.132 -(* eval function calling sml code during rewriting.
21.133 -Unifying "type cal" and "type calc" would make Lucas-Interpretation more efficient,
21.134 - see "fun rule2stac": instead of
21.135 - Calc: calID * eval_fn -> rule
21.136 - would be better
21.137 - Calc: prog_calcID * (calID * eval_fn)) -> rule*)
21.138 -type eval_fn = (string -> term -> theory -> (string * term) option);
21.139 -fun e_evalfn (_ : 'a) (_ : term) (_ : theory) = NONE : (string * term) option;
21.140 -
21.141 -(* op in isa-term "Const(op,_)" *)
21.142 -type cal = calID * eval_fn;
21.143 -type prog_calcID = string;
21.144 -type calc = (prog_calcID * cal);
21.145 -
21.146 -type calc_elem = (* fun calculate_ fetches the evaluation-function via this list *)
21.147 - prog_calcID * (* a simple identifier used in programs *)
21.148 - (calID * (* a long identifier used in Const *)
21.149 - eval_fn) (* an ML function *)
21.150 -fun calc_eq ((pi1, (ci1, _)), (pi2, (ci2, _))) =
21.151 - if pi1 = pi2
21.152 - then if ci1 = ci2 then true else error ("calc_eq: " ^ ci1 ^ " <> " ^ ci2)
21.153 - else false
21.154 -
21.155 -type cterm' = string;
21.156 -type subst = (term * term) list;
21.157 -
21.158 -(*TODO.WN060610 make use of "type rew_ord" total*)
21.159 -type rew_ord' = string;
21.160 -val e_rew_ord' = "e_rew_ord" : rew_ord';
21.161 -
21.162 -type rew_ord_ = subst -> Term.term * Term.term -> bool;
21.163 -fun dummy_ord (_: subst) (_: term, _: term) = true;
21.164 -val e_rew_ord_ = dummy_ord;
21.165 -type rew_ord = rew_ord' * rew_ord_;
21.166 -val e_rew_ord = dummy_ord; (* TODO.WN071231 clarify identifiers..e_rew_ordX*)
21.167 -val e_rew_ordX = (e_rew_ord', e_rew_ord_);
21.168 -
21.169 -(* rewrite orders, also stored in 'type met' and type 'and rls'
21.170 - The association list is required for 'rewrite.."rew_ord"..' *)
21.171 -val rew_ord' = Unsynchronized.ref
21.172 - ([("e_rew_ord", e_rew_ord), ("dummy_ord", dummy_ord)]
21.173 - : (rew_ord' * (* the key for the association list *)
21.174 - (subst (* the bound variables - they get high order*)
21.175 - -> (term * term) (* (t1, t2) to be compared *)
21.176 - -> bool)) (* if t1 <= t2 then true else false *)
21.177 - list); (* association list *)
21.178 -fun assoc' ([], key) = raise ERROR ("ME_Isa: \"" ^ key ^ "\" not known")
21.179 - | assoc' ((keyi, xi) :: pairs, key) =
21.180 - if key = keyi then SOME xi else assoc' (pairs, key);
21.181 -fun assoc_rew_ord ro = ((the o assoc') (! rew_ord',ro))
21.182 - handle _ => error ("ME_Isa: rew_ord '" ^ ro ^ "' not in system");
21.183 -
21.184 -(* Since Isabelle2017 sessions in theory identifiers are enforced.
21.185 - However, we leave theory identifiers short, in particular in use as keys into KEStore. *)
21.186 -fun Thy_Info_get_theory thyID = Thy_Info.get_theory ("Isac." ^ thyID)
21.187 -fun thy2ctxt' thy' = Proof_Context.init_global (Thy_Info_get_theory thy');(*FIXXXME thy-ctxt*)
21.188 -fun thy2ctxt thy = Proof_Context.init_global thy;(*FIXXXME thy-ctxt*)
21.189 -fun Isac _ = Proof_Context.theory_of (thy2ctxt' "Isac"); (*@{theory "Isac"}*)
21.190 -
21.191 -fun term_to_string' ctxt t =
21.192 - let
21.193 - val ctxt' = Config.put show_markup false ctxt
21.194 - in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
21.195 -fun term_to_string'' thyID t =
21.196 - let
21.197 - val ctxt' = Config.put show_markup false (Proof_Context.init_global (Thy_Info_get_theory thyID))
21.198 - in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
21.199 -fun term_to_string''' thy t =
21.200 - let
21.201 - val ctxt' = Config.put show_markup false (Proof_Context.init_global thy)
21.202 - in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
21.203 -
21.204 -fun term2str t = term_to_string' (thy2ctxt' "Isac") t;
21.205 -fun t2str thy t = term_to_string' (thy2ctxt thy) t;
21.206 -fun ts2str thy ts = ts |> map (t2str thy) |> strs2str';
21.207 -fun terms2strs ts = map term2str ts; (* terms2strs [t1,t2] = ["1 + 2", "abc"]; *)
21.208 -val terms2str = strs2str o terms2strs; (* terms2str [t1,t2] = "[\"1 + 2\",\"abc\"]"; *)
21.209 -val terms2str' = strs2str' o terms2strs; (* terms2str' [t1,t2] = "[1 + 2,abc]"; *)
21.210 -fun termopt2str (SOME t) = "(SOME " ^ term2str t ^ ")"
21.211 - | termopt2str NONE = "NONE";
21.212 -
21.213 -fun thm2str thm =
21.214 - let
21.215 - val t = Thm.prop_of thm
21.216 - val ctxt = Proof_Context.init_global (Thy_Info.get_theory ("Isac.Isac"))
21.217 - val ctxt' = Config.put show_markup false ctxt
21.218 - in Print_Mode.setmp [] (Syntax.string_of_term ctxt') t end;
21.219 -fun thms2str thms = (strs2str o (map thm2str)) thms
21.220 -
21.221 -(* error patterns and fill patterns *)
21.222 -type errpatID = string
21.223 -type errpat =
21.224 - errpatID (* one identifier for a list of patterns
21.225 - DESIGN ?TODO: errpatID list for hierarchy of errpats ? *)
21.226 - * term list (* error patterns *)
21.227 - * thm list (* thms related to error patterns; note that respective lhs
21.228 - do not match (which reflects student's error).
21.229 - fillpatterns are stored with these thms. *)
21.230 -fun errpat2str (id, tms, thms) =
21.231 - "(\"" ^ id ^ "\",\n" ^ terms2str tms ^ ",\n" ^ thms2str thms
21.232 -fun errpats2str errpats = (strs2str' o (map errpat2str)) errpats
21.233 -
21.234 -datatype rule =
21.235 - Erule (*.the empty rule .*)
21.236 -| Thm of (string * Basic_Thm.thm) (* see TODO CLEANUP Thm *)
21.237 -| Calc of string * (*.sml-code manipulating a (sub)term .*)
21.238 - eval_fn
21.239 -| Cal1 of string * (*.sml-code applied only to whole term
21.240 - or left/right-hand-side of eqality .*)
21.241 - eval_fn
21.242 -| Rls_ of rls (*.ie. rule sets may be nested.*)
21.243 -and program =
21.244 - EmptyScr
21.245 - | Prog of term (* a leaf is either a tactic or an 'exp' in 'let v = expr'
21.246 - where 'exp' does not contain a tactic. *)
21.247 - | Rfuns of (* for Rrls, usage see rational.sml ----- reverse rewrite ----- *)
21.248 - {init_state : (* initialise for reverse rewriting by the Interpreter *)
21.249 - term -> (* for this the rrlsstate is initialised: *)
21.250 - term * (* the current formula: goes locate_input_tactic -> determine_next_tactic via istate *)
21.251 - term * (* the final formula *)
21.252 - rule list (* of reverse rewrite set (#1#) *)
21.253 - list * (* may be serveral, eg. in norm_rational *)
21.254 - ( rule * (* Thm (+ Thm generated from Calc) resulting in ... *)
21.255 - (term * (* ... rewrite with ... *)
21.256 - term list)) (* ... assumptions *)
21.257 - list, (* derivation from given term to normalform
21.258 - in reverse order with sym_thm;
21.259 - (#1#) could be extracted from here #1 *)
21.260 - normal_form: (* the function which drives the Rrls ##############################*)
21.261 - term -> (term * term list) option,
21.262 - locate_rule: (* checks a rule R for being a cancel-rule, and if it is,
21.263 - then return the list of rules (+ the terms they are rewriting to)
21.264 - which need to be applied before R should be applied.
21.265 - precondition: the rule is applicable to the argument-term. *)
21.266 - rule list list -> (* the reverse rule list *)
21.267 - term -> (* ... to which the rule shall be applied *)
21.268 - rule -> (* ... to be applied to term *)
21.269 - ( rule * (* value: a rule rewriting to ... *)
21.270 - (term * (* ... the resulting term ... *)
21.271 - term list)) (* ... with the assumptions ( //#0) *)
21.272 - list, (* there may be several such rules; the list is empty,
21.273 - if the rule has nothing to do with e.g. cancelation *)
21.274 - next_rule: (* for a given term return the next rules to be done for cancelling *)
21.275 - rule list list->(* the reverse rule list *)
21.276 - term -> (* the term for which ... *)
21.277 - rule option, (* ... this rule is appropriate for cancellation;
21.278 - there may be no such rule (if the term is eg.canceled already*)
21.279 - attach_form: (* checks an input term TI, if it may belong to e.g. a current
21.280 - cancellation, by trying to derive it from the given term TG.
21.281 - NOT IMPLEMENTED *)
21.282 - rule list list->(**)
21.283 - term -> (* TG, the last one agreed upon by user + math-eng *)
21.284 - term -> (* TI, the next one input by the user *)
21.285 - ( rule * (* the rule to be applied in order to reach TI *)
21.286 - (term * (* ... obtained by applying the rule ... *)
21.287 - term list)) (* ... and the respective assumptions *)
21.288 - list} (* there may be several such rules; the list is empty, if the
21.289 - users term does not belong to e.g. a cancellation of the term
21.290 - last agreed upon. *)
21.291 -and rls =
21.292 - Erls (*for init e_rls*)
21.293 -
21.294 - | Rls of (*a confluent and terminating ruleset, in general *)
21.295 - {id : string, (*for trace_rewrite:=true *)
21.296 - preconds : term list, (*unused WN020820 *)
21.297 - (*WN060616 for efficiency...
21.298 - bdvs : false, (*set in prep_rls' for get_bdvs *)*)
21.299 - rew_ord : rew_ord, (*for rules*)
21.300 - erls : rls, (*for the conditions in rules *)
21.301 - srls : rls, (*for evaluation of list_fns in script *)
21.302 - calc : calc list, (*for Calculate in scr, set by prep_rls' *)
21.303 - rules : rule list,
21.304 - errpatts : errpatID list,(*dialog-authoring in Build_Thydata.thy *)
21.305 - scr : program} (*Prog term: generating intermed.steps *)
21.306 - | Seq of (*a sequence of rules to be tried only once *)
21.307 - {id : string, (*for trace_rewrite:=true *)
21.308 - preconds : term list, (*unused 20.8.02 *)
21.309 - (*WN060616 for efficiency...
21.310 - bdvs : false, (*set in prep_rls' for get_bdvs *)*)
21.311 - rew_ord : rew_ord, (*for rules *)
21.312 - erls : rls, (*for the conditions in rules *)
21.313 - srls : rls, (*for evaluation of list_fns in script *)
21.314 - calc : calc list, (*for Calculate in scr, set by prep_rls' *)
21.315 - rules : rule list,
21.316 - errpatts : errpatID list,(*dialog-authoring in Build_Thydata.thy*)
21.317 - scr : program} (*Prog term (how to restrict type ???)*)
21.318 -
21.319 - (*Rrls call SML-code and simulate an rls
21.320 - difference: there is always _ONE_ redex rewritten in 1 call,
21.321 - thus wrap Rrls by: Rls (Rls_ ...)*)
21.322 - | Rrls of (* SML-functions within rewriting; step-wise execution provided;
21.323 - Rrls simulate an rls
21.324 - difference: there is always _ONE_ redex rewritten in 1 call,
21.325 - thus wrap Rrls by: Rls (Rls_ ...) *)
21.326 - {id : string, (* for trace_rewrite := true *)
21.327 - prepat : (term list *(* preconds, eval with subst from pattern;
21.328 - if [@{term True}], match decides alone *)
21.329 - term ) (* pattern matched with current (sub)term *)
21.330 - list, (* meta-conjunction is or *)
21.331 - rew_ord : rew_ord, (* for rules *)
21.332 - erls : rls, (* for the conditions in rules and preconds *)
21.333 - calc : calc list, (* for Calculate in scr, set automatic.in prep_rls' *)
21.334 - errpatts : errpatID list,(*dialog-authoring in Build_Thydata.thy*)
21.335 - scr : program}; (* Rfuns {...} (how to restrict type ???) *)
21.336 -
21.337 -fun id_rls Erls = "e_rls" (*WN060714 quick and dirty: recursive defs! TODO "Erls"*)
21.338 - | id_rls (Rls {id, ...}) = id
21.339 - | id_rls (Seq {id, ...}) = id
21.340 - | id_rls (Rrls {id, ...}) = id;
21.341 -val rls2str = id_rls;
21.342 -fun id_rule (Thm (id, _)) = id
21.343 - | id_rule (Calc (id, _)) = id
21.344 - | id_rule (Cal1 (id, _)) = id
21.345 - | id_rule (Rls_ rls) = id_rls rls
21.346 - | id_rule Erule = "Erule";
21.347 -fun eq_rule (Thm (thm1, _), Thm (thm2, _)) = thm1 = thm2
21.348 - | eq_rule (Calc (id1, _), Calc (id2, _)) = id1 = id2
21.349 - | eq_rule (Rls_ rls1, Rls_ rls2) = id_rls rls1 = id_rls rls2
21.350 - | eq_rule _ = false;
21.351 -
21.352 -(*ad thm':
21.353 - there are two kinds of theorems ...
21.354 - (1) known by isabelle
21.355 - (2) not known, eg. calc_thm, instantiated rls
21.356 - the latter have a thmid "#..."
21.357 - and thus outside isa we ALWAYS transport both (thmID, string_of_thmI)
21.358 - and have a special assoc_thm / assoc_rls in this interface *)
21.359 -type theory' = string; (* = domID ^".thy" WN.101011 ABOLISH !*)
21.360 -type domID = string; (* domID ^".thy" = theory' WN.101011 replace by thyID*)
21.361 -type thyID = string; (* WN.3.11.03 TODO: replace domID with thyID*)
21.362 -val e_domID = "e_domID" : domID;
21.363 -
21.364 -fun string_of_thy thy = Context.theory_name thy: theory';
21.365 -val theory2domID = string_of_thy;
21.366 -val theory2thyID = (get_thy o string_of_thy) : theory -> thyID;
21.367 -val theory2theory' = string_of_thy;
21.368 -val theory2str = string_of_thy; (*WN050903 ..most consistent naming*)
21.369 -
21.370 -fun thyID2theory' (thyID:thyID) = thyID;
21.371 -fun theory'2thyID (theory':theory') = theory';
21.372 -
21.373 -fun type_to_string'' (thyID : thyID) t =
21.374 - let
21.375 - val ctxt' = Config.put show_markup false (Proof_Context.init_global (Thy_Info_get_theory thyID))
21.376 - in Print_Mode.setmp [] (Syntax.string_of_typ ctxt') t end;
21.377 -fun type2str typ = type_to_string'' "Isac" typ; (*TODO legacy*)
21.378 -val string_of_typ = type2str; (*legacy*)
21.379 -fun string_of_typ_thy thy typ = type_to_string'' thy typ; (*legacy*)
21.380 -
21.381 -(*check for [.] as caused by "fun assoc_thm'"*)
21.382 -fun string_of_thm thm = term_to_string' (thy2ctxt' "Isac") (Thm.prop_of thm)
21.383 -fun string_of_thm' thy thm = term_to_string' (thy2ctxt thy) (Thm.prop_of thm)
21.384 -fun string_of_thmI thm =
21.385 - let
21.386 - val str = (de_quote o string_of_thm) thm
21.387 - val (a, b) = split_nlast (5, Symbol.explode str)
21.388 - in
21.389 - case b of
21.390 - [" ", " ","[", ".", "]"] => implode a
21.391 - | _ => str
21.392 - end
21.393 -
21.394 -fun get_rules Erls = []
21.395 - | get_rules (Rls {rules, ...}) = rules
21.396 - | get_rules (Seq {rules, ...}) = rules
21.397 - | get_rules (Rrls _) = [];
21.398 -fun rule2str Erule = "Erule"
21.399 - | rule2str (Thm (str, thm)) = "Thm (\""^str^"\","^(string_of_thmI thm)^")"
21.400 - | rule2str (Calc (str, _)) = "Calc (\""^str^"\",fn)"
21.401 - | rule2str (Cal1 (str, _)) = "Cal1 (\""^str^"\",fn)"
21.402 - | rule2str (Rls_ rls) = "Rls_ (\""^id_rls rls^"\")";
21.403 -fun rule2str' Erule = "Erule"
21.404 - | rule2str' (Thm (str, _)) = "Thm (\""^str^"\",\"\")"
21.405 - | rule2str' (Calc (str, _)) = "Calc (\""^str^"\",fn)"
21.406 - | rule2str' (Cal1 (str, _)) = "Cal1 (\""^str^"\",fn)"
21.407 - | rule2str' (Rls_ rls) = "Rls_ (\""^id_rls rls^"\")";
21.408 -fun scr2str EmptyScr = "EmptyScr"
21.409 - | scr2str (Prog s) = "Prog " ^ term2str s
21.410 - | scr2str (Rfuns _) = "Rfuns";
21.411 -
21.412 -val e_type = Type ("empty",[]);
21.413 -val e_term = Const ("empty", e_type);
21.414 -val e_rule = Thm ("refl", @{thm refl});
21.415 -val e_term = Const ("empty", Type("'a", []));
21.416 -type rrlsstate = (* state for reverse rewriting, comments see type rule and scr | Rfuns *)
21.417 - (term * term * rule list list * (rule * (term * term list)) list);
21.418 -val e_rrlsstate = (e_term,e_term, [[e_rule]], [(e_rule, (e_term, []))]) : rrlsstate;
21.419 -
21.420 -type rls' = string;
21.421 -local
21.422 - fun ii (_: term) = e_rrlsstate;
21.423 - fun no (_: term) = SOME (e_term, [e_term]);
21.424 - fun lo (_: rule list list) (_: term) (_: rule) = [(e_rule, (e_term, [e_term]))];
21.425 - fun ne (_: rule list list) (_: term) = SOME e_rule;
21.426 - fun fo (_: rule list list) (_: term) (_: term) = [(e_rule, (e_term, [e_term]))];
21.427 -in
21.428 -val e_rfuns = Rfuns {init_state = ii, normal_form = no, locate_rule = lo,
21.429 - next_rule = ne, attach_form = fo};
21.430 -end;
21.431 -val e_rls =
21.432 - Rls {id = "e_rls", preconds = [], rew_ord = ("dummy_ord", dummy_ord), erls = Erls,
21.433 - srls = Erls, calc = [], rules = [], errpatts = [], scr = EmptyScr}: rls;
21.434 -val e_rrls =
21.435 - Rrls {id = "e_rrls", prepat = [], rew_ord = ("dummy_ord", dummy_ord), erls = Erls,
21.436 - calc = [], errpatts = [], scr = e_rfuns}:rls;
21.437 -
21.438 -fun rep_rls Erls = rep_rls e_rls
21.439 - | rep_rls (Rls {id, preconds, rew_ord, erls, srls, calc, errpatts, rules, scr}) =
21.440 - {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls, errpats = errpatts,
21.441 - calc = calc, rules = rules, scr = scr}
21.442 - | rep_rls (Seq {id, preconds, rew_ord, erls, srls, calc, errpatts, rules, scr}) =
21.443 - {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls, errpats = errpatts,
21.444 - calc = calc, rules = rules, scr = scr}
21.445 - | rep_rls (Rrls _) = rep_rls e_rls
21.446 -
21.447 -fun append_rls id Erls _ = raise ERROR ("append_rls: with \"" ^ id ^ "\" not for Erls")
21.448 - | append_rls id (Rls {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.449 - rules = rs, errpatts = errpatts, scr = sc}) r =
21.450 - Rls {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.451 - rules = rs @ r, errpatts = errpatts, scr = sc}
21.452 - | append_rls id (Seq {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.453 - rules = rs, errpatts = errpatts, scr = sc}) r =
21.454 - Seq {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.455 - rules = rs @ r, errpatts = errpatts, scr = sc}
21.456 - | append_rls id (Rrls _) _ = raise ERROR ("append_rls: not for reverse-rewrite-rule-set " ^ id);
21.457 -
21.458 -fun merge_ids rls1 rls2 =
21.459 - let
21.460 - val id1 = (#id o rep_rls) rls1
21.461 - val id2 = (#id o rep_rls) rls2
21.462 - in
21.463 - if id1 = id2 then id1 else "merged_" ^ id1 ^ "_" ^ id2
21.464 - end
21.465 -fun merge_rls _ Erls rls = rls
21.466 - | merge_rls _ rls Erls = rls
21.467 - | merge_rls _ (Rrls x) _ = Rrls x (* required for merging Theory_Data *)
21.468 - | merge_rls _ _ (Rrls x) = Rrls x
21.469 - | merge_rls id
21.470 - (Rls {preconds = pc1, rew_ord = ro1, erls = er1, srls = sr1, calc = ca1,
21.471 - rules = rs1, errpatts = eps1, scr = sc1, ...})
21.472 - (Rls {preconds = pc2, erls = er2, srls = sr2, calc = ca2,
21.473 - rules = rs2, errpatts = eps2, ...})
21.474 - =
21.475 - Rls {id = id, rew_ord = ro1, scr = sc1,
21.476 - preconds = union (op =) pc1 pc2,
21.477 - erls = merge_rls (merge_ids er1 er2) er1 er2,
21.478 - srls = merge_rls (merge_ids sr1 sr2) sr1 sr2,
21.479 - calc = union calc_eq ca1 ca2,
21.480 - rules = union eq_rule rs1 rs2,
21.481 - errpatts = union (op =) eps1 eps2}
21.482 - | merge_rls id
21.483 - (Seq {preconds = pc1, rew_ord = ro1, erls = er1, srls = sr1, calc = ca1,
21.484 - rules = rs1, errpatts = eps1, scr = sc1, ...})
21.485 - (Seq {preconds = pc2, erls = er2, srls = sr2, calc = ca2,
21.486 - rules = rs2, errpatts = eps2, ...})
21.487 - =
21.488 - Seq {id = id, rew_ord = ro1, scr = sc1,
21.489 - preconds = union (op =) pc1 pc2,
21.490 - erls = merge_rls (merge_ids er1 er2) er1 er2,
21.491 - srls = merge_rls (merge_ids sr1 sr2) sr1 sr2,
21.492 - calc = union calc_eq ca1 ca2,
21.493 - rules = union eq_rule rs1 rs2,
21.494 - errpatts = union (op =) eps1 eps2}
21.495 - | merge_rls id _ _ = error ("merge_rls: \"" ^ id ^
21.496 - "\"; not for reverse-rewrite-rule-sets and not for mixed Rls -- Seq");
21.497 -
21.498 -(* used only for one hack TODO remove *)
21.499 -fun remove_rls id (Rls {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.500 - rules = rs, errpatts = eps, scr = sc}) r =
21.501 - Rls {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.502 - rules = gen_rems eq_rule (rs, r),
21.503 - errpatts = eps,
21.504 - scr = sc}
21.505 - | remove_rls id (Seq {id = _, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.506 - rules = rs, errpatts = eps, scr = sc}) r =
21.507 - Seq {id = id, preconds = pc, rew_ord = ro, erls = er, srls = sr, calc = ca,
21.508 - rules = gen_rems eq_rule (rs, r),
21.509 - errpatts = eps,
21.510 - scr = sc}
21.511 - | remove_rls id (Rrls _) _ = raise ERROR ("remove_rls: not for reverse-rewrite-rule-set "^id)
21.512 - | remove_rls _ rls _ = raise ERROR ("remove_rls called with " ^ rls2str rls);
21.513 -
21.514 -
21.515 -end (*struct*)
22.1 --- a/src/Tools/isac/calcelems.sml Thu Aug 22 16:48:04 2019 +0200
22.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
22.3 @@ -1,757 +0,0 @@
22.4 -(* ~~/src/Tools/isac/calcelems.sml
22.5 - elements of calculations.
22.6 - they are partially held in association lists as ref's for
22.7 - switching language levels (meta-string, object-values).
22.8 - in order to keep these ref's during re-evaluation of code,
22.9 - they are defined here at the beginning of the code.
22.10 - Author: Walther Neuper 2003
22.11 - (c) copyright due to lincense terms
22.12 -*)
22.13 -
22.14 -signature CALC_ELEMENT =
22.15 - sig
22.16 - type cas_elem
22.17 - type pbt
22.18 - type ptyps
22.19 - type metID
22.20 - type pblID
22.21 - type mets
22.22 - type met
22.23 - datatype 'a ptyp = Ptyp of string * 'a list * 'a ptyp list
22.24 -
22.25 - type authors
22.26 - type guh
22.27 - val env2str: Rule.subst -> string
22.28 - val subst2str: Rule.subst -> string
22.29 - val subst2str': Rule.subst -> string
22.30 -
22.31 - type fillpat
22.32 - datatype thydata
22.33 - = Hcal of {calc: Rule.calc, coursedesign: authors, guh: guh, mathauthors: authors}
22.34 - | Hord of {coursedesign: authors, guh: guh, mathauthors: authors, ord: Rule.subst -> term * term -> bool}
22.35 - | Hrls of {coursedesign: authors, guh: guh, mathauthors: authors, thy_rls: Rule.thyID * Rule.rls}
22.36 - | Hthm of {coursedesign: authors, fillpats: fillpat list, guh: guh, mathauthors: authors, thm: thm}
22.37 - | Html of {coursedesign: authors, guh: guh, html: string, mathauthors: authors}
22.38 - type theID
22.39 - type rlss_elem
22.40 - val merge_rlss: rlss_elem list * rlss_elem list -> rlss_elem list
22.41 - val rls_eq: (''a * ('b * 'c)) * (''a * ('d * 'e)) -> bool
22.42 - type spec
22.43 - val cas_eq: cas_elem * cas_elem -> bool
22.44 - val e_Ptyp: pbt ptyp
22.45 - val merge_ptyps: 'a ptyp list * 'a ptyp list -> 'a ptyp list
22.46 - val check_guhs_unique: bool Unsynchronized.ref
22.47 - val check_pblguh_unique: guh -> pbt ptyp list -> unit
22.48 - val insrt: pblID -> 'a -> string list -> 'a ptyp list -> 'a ptyp list
22.49 - val e_Mets: met ptyp
22.50 - val check_metguh_unique: guh -> met ptyp list -> unit
22.51 - val add_thydata: string list * string list -> thydata -> thydata ptyp list -> thydata ptyp list
22.52 - val get_py: 'a ptyp list -> pblID -> string list -> 'a
22.53 - val update_hthm: thydata -> fillpat list -> thydata
22.54 - val update_ptyps: string list -> string list -> 'a -> 'a ptyp list -> 'a ptyp list
22.55 - val part2guh: theID -> guh
22.56 - val spec2str: string * string list * string list -> string
22.57 - val linefeed: string -> string
22.58 - val pbts2str: pbt list -> string
22.59 - val thes2str: thydata list -> string
22.60 - val theID2str: string list -> string
22.61 - val the2str: thydata -> string
22.62 - val trace_calc: bool Unsynchronized.ref
22.63 - eqtype thmID
22.64 - type thm'
22.65 - datatype lrd = D | L | R
22.66 - val trace_rewrite: bool Unsynchronized.ref
22.67 - val depth: int Unsynchronized.ref
22.68 - val assoc_thy: Rule.theory' -> theory
22.69 - type loc_
22.70 - val loc_2str: loc_ -> string
22.71 - type thm''
22.72 - val metID2str: string list -> string
22.73 - val e_pblID: pblID
22.74 - val e_metID: metID
22.75 - val empty_spec: spec
22.76 - val e_spec: spec
22.77 - datatype ketype = Exp_ | Met_ | Pbl_ | Thy_
22.78 - type kestoreID
22.79 - val app_py: 'a ptyp list -> ('a ptyp -> 'b) -> pblID -> string list -> 'b
22.80 - val ketype2str: ketype -> string
22.81 - val coll_pblguhs: pbt ptyp list -> guh list
22.82 - val coll_metguhs: met ptyp list -> guh list
22.83 - type pat
22.84 - val pats2str: pat list -> string
22.85 - val maxthy: theory -> theory -> theory
22.86 - eqtype filename
22.87 - val lim_deriv: int Unsynchronized.ref
22.88 - val id_of_thm: Rule.rule -> string
22.89 - val isabthys: unit -> theory list
22.90 - val thyID_of_derivation_name: string -> string
22.91 - val partID': Rule.theory' -> string
22.92 - val thm2guh: string * Rule.thyID -> thmID -> guh
22.93 - val thmID_of_derivation_name: string -> string
22.94 - val rls2guh: string * Rule.thyID -> Rule.rls' -> guh
22.95 - val theID2guh: theID -> guh
22.96 - eqtype fillpatID
22.97 - type pbt_ = string * (term * term)
22.98 - eqtype xml
22.99 - val cal2guh: string * Rule.thyID -> string -> guh
22.100 - val ketype2str': ketype -> string
22.101 - val str2ketype': string -> ketype
22.102 - val thmID_of_derivation_name': thm -> string
22.103 - eqtype path
22.104 - val theID2thyID: theID -> Rule.thyID
22.105 - val thy2guh: theID -> guh
22.106 - val thypart2guh: theID -> guh
22.107 - val ord2guh: string * Rule.theory' -> string -> string
22.108 - val update_hrls: thydata -> Rule.errpatID list -> thydata
22.109 - eqtype iterID
22.110 - eqtype calcID
22.111 - val thm''_of_thm: thm -> thm''
22.112 - val thm_of_thm: Rule.rule -> thm
22.113 -(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
22.114 - val pats2str' : pat list -> string
22.115 - val insert_fillpats: thydata ptyp list -> (pblID * fillpat list) list -> thydata ptyp list ->
22.116 - thydata ptyp list
22.117 -(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
22.118 - val knowthys: unit -> theory list
22.119 - val e_pbt: pbt
22.120 - val e_met: met
22.121 -( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
22.122 -
22.123 -(*----- unused code, kept as hints to design ideas ---------------------------------------------*)
22.124 -val overwritelthy: theory -> (Rule.rls' * (string * Rule.rls)) list * (Rule.rls' * Rule.rls) list ->
22.125 - (Rule.rls' * (string * Rule.rls)) list end
22.126 -
22.127 -
22.128 -structure Celem(**): CALC_ELEMENT(**) =
22.129 -struct
22.130 -
22.131 -val linefeed = (curry op^) "\n"; (* ?\<longrightarrow> libraryC ?*)
22.132 -type authors = string list;
22.133 -
22.134 -type iterID = int;
22.135 -type calcID = int;
22.136 -
22.137 -(* TODO CLEANUP Thm:
22.138 -Thm (string, thm): (a) needs string to identify sym_thmID for handling in front-end;
22.139 - (b) investigate if ""RS sym" attaches a [.]" still occurs: string_of_thmI
22.140 -thmID : type for data from user input + program
22.141 -thmDeriv : type for thy_hierarchy ONLY
22.142 -obsolete types : thm' (SEE "ad thm'"), thm''.
22.143 -revise funs : id_of_thm, thm_of_thm, rep_thm_G', eq_thmI, eq_thmI', thm''_of_thm thm.
22.144 -activate : thmID_of_derivation_name'
22.145 -*)
22.146 -type thmID = string; (* identifier for a thm (the shortest possible identifier) *)
22.147 -type thmDeriv = string; (* WN120524 deprecated
22.148 - thyID ^"."^ xxx ^"."^ thmID, see fun thmID_of_derivation_name
22.149 - WN120524: dont use Thm.derivation_name, this is destroyed by num_str;
22.150 - Thm.get_name_hint survives num_str and seems perfectly reliable *)
22.151 -
22.152 -type thm' = thmID * Rule.cterm';(*WN060610 deprecated in favour of thm''; WN180324: used in TODO review:
22.153 -val thm'2xml : int -> Celem.thm' -> Celem.xml
22.154 -val assoc_thm': theory -> Celem.thm' -> thm
22.155 -| Calculate' of Rule.theory' * string * term * (term * Celem.thm')
22.156 -*)
22.157 -(* tricky combination of (string, term) for theorems in Isac:
22.158 - * case 1 general: frontend + lucin, e.g. applicable_in..Rewrite: (thmID, _) --> (thmID, thm)
22.159 - by Global_Theory.get_thm, special cases ("add_commute",..) see convert_metaview_to_thmid.
22.160 - * case 2 "sym_..": Global_Theory.get_thm..RS sym
22.161 - * case 3 ad-hoc thm "#..." mk_thm from ad-hoc term (numerals only) in calculate_:
22.162 - from applicable_in..Calculate: opstr --calculate_/adhoc_thm--> (thmID, thm)
22.163 -*)
22.164 -type thm'' = thmID * thm; (* only for transport via libisabelle isac-java <--- ME *)
22.165 -
22.166 -(*.a 'guh'='globally unique handle' is a string unique for each element
22.167 - of isac's KEStore and persistent over time
22.168 - (in particular under shifts within the respective hierarchy);
22.169 - specialty for thys:
22.170 - # guh NOT resistant agains shifts from one thy to another
22.171 - (which is the price for Isabelle's design: thy's overwrite ids of subthy's)
22.172 - # requirement for matchTheory: induce guh from tac + current thy
22.173 - (see 'fun thy_containing_thm', 'fun thy_containing_rls' etc.)
22.174 - TODO: introduce to pbl, met.*)
22.175 -type guh = string;
22.176 -
22.177 -type xml = string; (* rm together with old code replaced by XML.tree *)
22.178 -
22.179 -
22.180 -(* for (at least) 2 kinds of access:
22.181 - (1) given an errpatID, find the respective fillpats (e.g. in fun find_fill_pats)
22.182 - (2) given a thm, find respective fillpats *)
22.183 -type fillpatID = string
22.184 -type fillpat =
22.185 - fillpatID (* DESIGN ?TODO: give an order w.r.t difficulty ? *)
22.186 - * term (* the pattern with fill-in gaps *)
22.187 - * Rule.errpatID; (* which the fillpat would be a help for
22.188 - DESIGN ?TODO: list for several patterns ? *)
22.189 -
22.190 -
22.191 -(* WN0509 discussion:
22.192 -#############################################################################
22.193 -# How to manage theorys in subproblems wrt. the requirement, #
22.194 -# that scripts should be re-usable ? #
22.195 -#############################################################################
22.196 -
22.197 - eg. 'Program Solve_rat_equation' calls 'SubProblem (RatEq',..'
22.198 - which would not allow to 'solve (y'' = -M_b / EI, M_b)' by this script
22.199 - because Biegelinie.thy is subthy of RatEq.thy and thus Biegelinie.M_b
22.200 - is unknown in RatEq.thy and M_b cannot be parsed into the scripts guard
22.201 - (see match_ags).
22.202 -
22.203 - Preliminary solution:
22.204 - # the thy in 'SubProblem (thy', pbl, arglist)' is not taken automatically,
22.205 - # instead the 'maxthy (rootthy pt) thy' is taken for each subpbl
22.206 - # however, a thy specified by the user in the rootpbl may lead to
22.207 - errors in far-off subpbls (which are not yet reported properly !!!)
22.208 - and interactively specifiying thys in subpbl is not very relevant.
22.209 -
22.210 - Other solutions possible:
22.211 - # always parse and type-check with Thy_Info_get_theory "Isac"
22.212 - (rejected due to the vague idea eg. to re-use equations for R in C etc.)
22.213 - # regard the subthy-relation in specifying thys of subpbls
22.214 - # specifically handle 'SubProblem (undefined, pbl, arglist)'
22.215 - # ???
22.216 -*)
22.217 -
22.218 -fun id_of_thm (Rule.Thm (id, _)) = id (* TODO re-arrange code for rule2str *)
22.219 - | id_of_thm _ = raise ERROR ("id_of_thm: uncovered case " (* ^ rule2str r *))
22.220 -fun thm_of_thm (Rule.Thm (_, thm)) = thm (* TODO re-arrange code for rule2str *)
22.221 - | thm_of_thm _ = raise ERROR ("thm_of_thm: uncovered case " (* ^ rule2str r *))
22.222 -
22.223 -fun thmID_of_derivation_name dn = last_elem (space_explode "." dn);
22.224 -fun thmID_of_derivation_name' thm = (thmID_of_derivation_name o Thm.get_name_hint) thm
22.225 -fun thyID_of_derivation_name dn = hd (space_explode "." dn);
22.226 -fun thm''_of_thm thm = (thmID_of_derivation_name' thm, thm) : thm''
22.227 -
22.228 -
22.229 -
22.230 -(*the key into the hierarchy ob theory elements*)
22.231 -type theID = string list;
22.232 -val theID2str = strs2str; (*theID eg. is ["IsacKnowledge", "Test", "Rulesets", "ac_plus_times"]*)
22.233 -fun theID2thyID theID =
22.234 - if length theID >= 3 then (last_elem o (drop_last_n 2)) theID
22.235 - else error ("theID2thyID called with " ^ theID2str theID);
22.236 -
22.237 -(*the key into the hierarchy ob problems*)
22.238 -type pblID = string list; (* domID :: ...*)
22.239 -val e_pblID = ["e_pblID"];
22.240 -
22.241 -(*the key into the hierarchy ob methods*)
22.242 -type metID = string list;
22.243 -type spec = Rule.domID * pblID * metID;
22.244 -fun spec2str (dom, pbl, met) =
22.245 - "(" ^ quote dom ^ ", " ^ strs2str pbl ^ ", " ^ strs2str met ^ ")";
22.246 -val e_metID = ["e_metID"];
22.247 -val metID2str = strs2str;
22.248 -val empty_spec = (Rule.e_domID, e_pblID, e_metID);
22.249 -val e_spec = empty_spec;
22.250 -
22.251 -(* association list with cas-commands, for generating a complete calc-head *)
22.252 -type generate_fn =
22.253 - (term list -> (* the arguments of the cas-command, eg. (x+1=2, x) *)
22.254 - (term * (* description of an element *)
22.255 - term list) (* value of the element (always put into a list) *)
22.256 - list) (* of elements in the formalization *)
22.257 -type cas_elem =
22.258 - (term * (* cas-command, eg. 'solve' *)
22.259 - (spec * (* theory, problem, method *)
22.260 - generate_fn))
22.261 -fun cas_eq ((t1, (_, _)) : cas_elem, (t2, (_, _)) : cas_elem) = t1 = t2
22.262 -
22.263 -(*either theID or pblID or metID*)
22.264 -type kestoreID = string list;
22.265 -
22.266 -(* for distinction of contexts WN130621: disambiguate with Isabelle's Context *)
22.267 -datatype ketype = Exp_ | Thy_ | Pbl_ | Met_;
22.268 -fun ketype2str Exp_ = "Exp_"
22.269 - | ketype2str Thy_ = "Thy_"
22.270 - | ketype2str Pbl_ = "Pbl_"
22.271 - | ketype2str Met_ = "Met_";
22.272 -fun ketype2str' Exp_ = "Example"
22.273 - | ketype2str' Thy_ = "Theory"
22.274 - | ketype2str' Pbl_ = "Problem"
22.275 - | ketype2str' Met_ = "Method";
22.276 -(* for conversion from XML *)
22.277 -fun str2ketype' "exp" = Exp_
22.278 - | str2ketype' "thy" = Thy_
22.279 - | str2ketype' "pbl" = Pbl_
22.280 - | str2ketype' "met" = Met_
22.281 - | str2ketype' str = raise ERROR ("str2ketype': WRONG arg = " ^ str)
22.282 -
22.283 -(* A tree for storing data defined in different theories
22.284 - for access from the Interpreter and from dialogue authoring
22.285 - using a string list as key.
22.286 - 'a is for pbt | met | thydata; after WN030424 naming "pbt" became inappropriate *)
22.287 -datatype 'a ptyp =
22.288 - Ptyp of string * (* element of the key *)
22.289 - 'a list * (* several pbts with different domIDs/thy TODO: select by subthy (isaref.p.69)
22.290 - presently only _ONE_ elem FOR ALL KINDS OF CONTENT pbt | met | thydata *)
22.291 - ('a ptyp) list; (* the children nodes *)
22.292 -
22.293 -(* datatype for collecting thydata for hierarchy *)
22.294 -(*WN060720 more consistent naming would be 'type thyelem' or 'thelem'*)
22.295 -datatype thydata =
22.296 - Html of {guh: guh, coursedesign: authors, mathauthors: authors, html: string}
22.297 -| Hthm of {guh: guh, coursedesign: authors, mathauthors: authors, fillpats: fillpat list,
22.298 - thm: thm} (* here no sym_thm, thus no thmID required *)
22.299 -| Hrls of {guh: guh, coursedesign: authors, mathauthors: authors, thy_rls: (Rule.thyID * Rule.rls)}
22.300 -| Hcal of {guh: guh, coursedesign: authors, mathauthors: authors, calc: Rule.calc}
22.301 -| Hord of {guh: guh, coursedesign: authors, mathauthors: authors,
22.302 - ord: (Rule.subst -> (term * term) -> bool)};
22.303 -fun the2str (Html {guh, ...}) = guh
22.304 - | the2str (Hthm {guh, ...}) = guh
22.305 - | the2str (Hrls {guh, ...}) = guh
22.306 - | the2str (Hcal {guh, ...}) = guh
22.307 - | the2str (Hord {guh, ...}) = guh
22.308 -fun thes2str thes = map the2str thes |> list2str;
22.309 -
22.310 -(* notes on thehier concerning sym_thmID theorems (created in derivations, reverse rewriting)
22.311 - (a): thehier does not contain sym_thmID theorems
22.312 - (b): lookup for sym_thmID directly from Isabelle using sym_thm
22.313 - (within math-engine NO lookup in thehier -- within java in *.xml only!)
22.314 -TODO (c): export from thehier to xml
22.315 -TODO (c1) creates one entry for "thmID" (and NONE for "sym_thmID") in the hierarchy
22.316 -TODO (c2) creates 2 files "thy_*-thm-thmID.xml" and "thy_*-thm-sym_thmID.xml"
22.317 -TODO (d): 1 entry in the MiniBrowser's hierarchy (generated from xml)
22.318 - stands for both, "thmID" and "sym_thmID"
22.319 -TODO (d1) lookup from calctxt
22.320 -TODO (d1) lookup from from rule set in MiniBrowser *)
22.321 -type thehier = (thydata ptyp) list;
22.322 -(* required to determine sequence of main nodes of thehier in KEStore.thy *)
22.323 -fun part2guh [str] = (case str of
22.324 - "Isabelle" => "thy_isab_" ^ str ^ "-part" : guh
22.325 - | "IsacScripts" => "thy_scri_" ^ str ^ "-part"
22.326 - | "IsacKnowledge" => "thy_isac_" ^ str ^ "-part"
22.327 - | str => raise ERROR ("thy2guh: called with \""^ str ^"\""))
22.328 - | part2guh theID = raise ERROR ("part2guh called with theID = \"" ^ theID2str theID ^ "'");
22.329 -
22.330 -fun thy2guh [part, thyID] = (case part of
22.331 - "Isabelle" => "thy_isab_" ^ thyID
22.332 - | "IsacScripts" => "thy_scri_" ^ thyID
22.333 - | "IsacKnowledge" => "thy_isac_" ^ thyID
22.334 - | str => raise ERROR ("thy2guh: called with \"" ^ str ^ "\""))
22.335 - | thy2guh theID = raise ERROR ("thy2guh called with \"" ^ strs2str' theID ^ "\"");
22.336 -
22.337 -fun thypart2guh ([part, thyID, thypart] : theID) = (case part of
22.338 - "Isabelle" => "thy_isab_" ^ thyID ^ "-" ^ thypart : guh
22.339 - | "IsacScripts" => "thy_scri_" ^ thyID ^ "-" ^ thypart
22.340 - | "IsacKnowledge" => "thy_isac_" ^ thyID ^ "-" ^ thypart
22.341 - | str => raise ERROR ("thypart2guh: called with '" ^ str ^ "'"))
22.342 - | thypart2guh strs = raise ERROR ("thypart2guh called with \"" ^ strs2str' strs ^ "\"");
22.343 -
22.344 -
22.345 -(* convert the data got via contextToThy to a globally unique handle.
22.346 - there is another way to get the guh: get out of the 'theID' in the hierarchy *)
22.347 -fun thm2guh (isa, thyID) thmID = case isa of
22.348 - "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID : guh
22.349 - | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
22.350 - | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-thm-" ^ strip_thy thmID
22.351 - | _ => raise ERROR
22.352 - ("thm2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for thm = \"" ^ thmID ^ "\"");
22.353 -
22.354 -fun rls2guh (isa, thyID) rls' = case isa of
22.355 - "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-rls-" ^ rls' : guh
22.356 - | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-rls-" ^ rls'
22.357 - | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-rls-" ^ rls'
22.358 - | _ => raise ERROR
22.359 - ("rls2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for rls = \"" ^ rls' ^ "\"");
22.360 -
22.361 -fun cal2guh (isa, thyID) calID = case isa of
22.362 - "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-cal-" ^ calID : guh
22.363 - | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-cal-" ^ calID
22.364 - | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-cal-" ^ calID
22.365 - | _ => raise ERROR
22.366 - ("cal2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for cal = \"" ^ calID ^ "\"");
22.367 -
22.368 -fun ord2guh (isa, thyID) rew_ord' = case isa of
22.369 - "Isabelle" => "thy_isab_" ^ Rule.theory'2thyID thyID ^ "-ord-" ^ rew_ord' : guh
22.370 - | "IsacKnowledge" => "thy_isac_" ^ Rule.theory'2thyID thyID ^ "-ord-" ^ rew_ord'
22.371 - | "IsacScripts" => "thy_scri_" ^ Rule.theory'2thyID thyID ^ "-ord-" ^ rew_ord'
22.372 - | _ => raise ERROR
22.373 - ("ord2guh called with (isa, thyID) = (" ^ isa ^ ", " ^ thyID ^ ") for ord = \"" ^ rew_ord' ^ "\"");
22.374 -
22.375 -(* not only for thydata, but also for thy's etc *)
22.376 -(* TODO
22.377 -fun theID2guh theID = case length theID of
22.378 - 0 => error ("theID2guh: called with theID = " ^ strs2str' theID)
22.379 - | 1 => part2guh theID
22.380 - | 2 => thy2guh theID
22.381 - | 3 => thypart2guh theID
22.382 - | 4 =>
22.383 - let val [isa, thyID, typ, elemID] = theID
22.384 - in case typ of
22.385 - "Theorems" => thm2guh (isa, thyID) elemID
22.386 - | "Rulesets" => rls2guh (isa, thyID) elemID
22.387 - | "Calculations" => cal2guh (isa, thyID) elemID
22.388 - | "Orders" => ord2guh (isa, thyID) elemID
22.389 - | "Theorems" => thy2guh [isa, thyID]
22.390 - | str => raise ERROR ("theID2guh: called with theID = " ^ strs2str' theID)
22.391 - end
22.392 - | n => raise ERROR ("theID2guh called with theID = " ^ strs2str' theID);
22.393 -*)
22.394 -(* not only for thydata, but also for thy's etc *)
22.395 -fun theID2guh [] = raise ERROR ("theID2guh: called with []")
22.396 - | theID2guh [str] = part2guh [str]
22.397 - | theID2guh [s1, s2] = thy2guh [s1, s2]
22.398 - | theID2guh [s1, s2, s3] = thypart2guh [s1, s2, s3]
22.399 - | theID2guh (strs as [isa, thyID, typ, elemID]) = (case typ of
22.400 - "Theorems" => thm2guh (isa, thyID) elemID
22.401 - | "Rulesets" => rls2guh (isa, thyID) elemID
22.402 - | "Calculations" => cal2guh (isa, thyID) elemID
22.403 - | "Orders" => ord2guh (isa, thyID) elemID
22.404 - | _ => raise ERROR ("theID2guh: called with theID = " ^ strs2str' strs))
22.405 - | theID2guh strs = raise ERROR ("theID2guh called with theID = " ^ strs2str' strs);
22.406 -
22.407 -type path = string;
22.408 -type filename = string;
22.409 -
22.410 -
22.411 -
22.412 -(* datastructure for KEStore_Elems, intermediate for thehier *)
22.413 -type rlss_elem =
22.414 - (Rule.rls' * (* identifier unique within Isac *)
22.415 - (Rule.theory' * (* just for assignment in thehier, not appropriate for parsing etc *)
22.416 - Rule.rls)) (* ((#id o rep_rls) rls) = rls' by coding discipline *)
22.417 -fun rls_eq ((id1, (_, _)), (id2, (_, _))) = id1 = id2
22.418 -
22.419 -fun insert_merge_rls (re as (id, (thyID, r1)) : rlss_elem) ys =
22.420 - case get_index (fn y => if curry rls_eq re y then SOME y else NONE) ys of
22.421 - NONE => re :: ys
22.422 - | SOME (i, (_, (_, r2))) =>
22.423 - let
22.424 - val r12 = Rule.merge_rls id r1 r2
22.425 - in list_update ys i (id, (thyID, r12)) end
22.426 -fun merge_rlss (s1, s2) = fold insert_merge_rls s1 s2;
22.427 -
22.428 -
22.429 -fun assoc_thy thy =
22.430 - if thy = "e_domID"
22.431 - then (Rule.Thy_Info_get_theory "Program") (*lower bound of Knowledge*)
22.432 - else (Rule.Thy_Info_get_theory thy) handle _ => error ("ME_Isa: thy \"" ^ thy ^ "\" not in system");
22.433 -
22.434 -(* overwrite an element in an association list and pair it with a thyID
22.435 - in order to create the thy_hierarchy;
22.436 - overwrites existing rls' even if they are defined in a different thy;
22.437 - this is related to assoc_rls, TODO.WN060120: assoc_rew_ord, assoc_calc *)
22.438 -(* WN060120 ...these are NOT compatible to "fun assoc_thm'" in that
22.439 - they do NOT handle overlays by re-using an identifier in different thys;
22.440 - "thyID.rlsID" would be a good solution, if the "." would be possible
22.441 - in scripts...
22.442 - actually a hack to get alltogether run again with minimal effort *)
22.443 -fun insthy thy' (rls', rls) = (rls', (thy', rls));
22.444 -fun overwritelthy thy (al, bl: (Rule.rls' * Rule.rls) list) =
22.445 - let val bl' = map (insthy ((get_thy o Rule.theory2theory') thy)) bl
22.446 - in overwritel (al, bl') end;
22.447 -
22.448 -fun subst2str s =
22.449 - (strs2str o
22.450 - (map (
22.451 - linefeed o pair2str o (apsnd Rule.term2str) o (apfst Rule.term2str)))) s;
22.452 -fun subst2str' s =
22.453 - (strs2str' o
22.454 - (map (
22.455 - pair2str o (apsnd Rule.term2str) o (apfst Rule.term2str)))) s;
22.456 -val env2str = subst2str;
22.457 -
22.458 -fun maxthy thy1 thy2 = if Context.subthy (thy1, thy2) then thy2 else thy1;
22.459 -
22.460 -
22.461 -(* trace internal steps of isac's numeral calculations *)
22.462 -val trace_calc = Unsynchronized.ref false;
22.463 -(* trace internal steps of isac's rewriter *)
22.464 -val trace_rewrite = Unsynchronized.ref false;
22.465 -(* depth of recursion in traces of the rewriter, if trace_rewrite:=true *)
22.466 -val depth = Unsynchronized.ref 99999;
22.467 -(* no of rewrites exceeding this int -> NO rewrite *)
22.468 -val lim_deriv = Unsynchronized.ref 100;
22.469 -(* switch for checking guhs unique before storing a pbl or met;
22.470 - set true at startup (done at begin of ROOT.ML)
22.471 - set false for editing IsacKnowledge (done at end of ROOT.ML) *)
22.472 -val check_guhs_unique = Unsynchronized.ref true;
22.473 -
22.474 -
22.475 -datatype lrd = (*elements of "type loc_" into an Isabelle term*)
22.476 - L (*go left at $*)
22.477 -| R (*go right at $*)
22.478 -| D; (*go down at Abs*)
22.479 -type loc_ = lrd list;
22.480 -fun ldr2str L = "L"
22.481 - | ldr2str R = "R"
22.482 - | ldr2str D = "D";
22.483 -fun loc_2str k = (strs2str' o (map ldr2str)) k;
22.484 -
22.485 -
22.486 -(* the pattern for an item of a problems model or a methods guard *)
22.487 -type pat =
22.488 - (string * (* field *)
22.489 - (term * (* description *)
22.490 - term)) (* id | arbitrary term *);
22.491 -fun pat2str ((field, (dsc, id)) : pat) =
22.492 - pair2str (field, pair2str (Rule.term2str dsc, Rule.term2str id))
22.493 -fun pats2str pats = (strs2str o (map pat2str)) pats
22.494 -fun pat2str' ((field, (dsc, id)) : pat) =
22.495 - pair2str (field, pair2str (Rule.term2str dsc, Rule.term2str id)) ^ "\n"
22.496 -fun pats2str' pats = (strs2str o (map pat2str')) pats
22.497 -
22.498 -(* types for problems models (TODO rename to specification models) *)
22.499 -type pbt_ =
22.500 - (string * (* field "#Given",..*)(*deprecated due to 'type pat'*)
22.501 - (term * (* description *)
22.502 - term)); (* id | struct-var *)
22.503 -type pbt =
22.504 - {guh : guh, (* unique within this isac-knowledge *)
22.505 - mathauthors : string list, (* copyright *)
22.506 - init : pblID, (* to start refinement with *)
22.507 - thy : theory, (* which allows to compile that pbt
22.508 - TODO: search generalized for subthy (ref.p.69*)
22.509 - (*^^^ WN050912 NOT used during application of the problem,
22.510 - because applied terms may be from 'subthy' as well as from super;
22.511 - thus we take 'maxthy'; see match_ags ! *)
22.512 - cas : term option, (* 'CAS-command' *)
22.513 - prls : Rule.rls, (* for preds in where_ *)
22.514 - where_ : term list, (* where - predicates *)
22.515 - ppc : pat list, (* this is the model-pattern;
22.516 - it contains "#Given","#Where","#Find","#Relate"-patterns
22.517 - for constraints on identifiers see "fun cpy_nam" *)
22.518 - met : metID list} (* methods solving the pbt *)
22.519 -
22.520 -val e_pbt = {guh = "pbl_empty", mathauthors = [], init = e_pblID, thy = Thy_Info.get_theory "Pure",
22.521 - cas = NONE, prls = Rule.Erls, where_ = [], ppc = [], met = []} : pbt
22.522 -fun pbt2str ({cas = cas', guh = guh', init = init', mathauthors = ma', met = met', ppc = ppc',
22.523 - prls = prls', thy = thy', where_ = w'} : pbt)
22.524 - = "{cas = " ^ (Rule.termopt2str cas') ^ ", guh = \"" ^ guh' ^ "\", init = "
22.525 - ^ (strs2str init') ^ ", mathauthors = " ^ (strs2str ma' |> quote) ^ ", met = "
22.526 - ^ (strslist2strs met') ^ ", ppc = " ^ pats2str ppc' ^ ", prls = "
22.527 - ^ (Rule.rls2str prls' |> quote) ^ ", thy = {" ^ (Rule.theory2str thy') ^ "}, where_ = "
22.528 - ^ (Rule.terms2str w') ^ "}" |> linefeed;
22.529 -fun pbts2str pbts = map pbt2str pbts |> list2str;
22.530 -
22.531 -val e_Ptyp = Ptyp ("e_pblID", [e_pbt], [])
22.532 -type ptyps = (pbt ptyp) list
22.533 -
22.534 -fun coll_pblguhs pbls =
22.535 - let
22.536 - fun node coll (Ptyp (_, [n], ns)) = [(#guh : pbt -> guh) n] @ (nodes coll ns)
22.537 - | node _ _ = raise ERROR "coll_pblguhs - node"
22.538 - and nodes coll [] = coll
22.539 - | nodes coll (n :: ns) = (node coll n) @ (nodes coll ns);
22.540 - in nodes [] pbls end;
22.541 -fun check_pblguh_unique guh pbls =
22.542 - if member op = (coll_pblguhs pbls) guh
22.543 - then error ("check_guh_unique failed with \""^ guh ^"\";\n"^
22.544 - "use \"sort_pblguhs()\" for a list of guhs;\n"^
22.545 - "consider setting \"check_guhs_unique := false\"")
22.546 - else ();
22.547 -
22.548 -fun insrt _ pbt [k] [] = [Ptyp (k, [pbt], [])]
22.549 - | insrt d pbt [k] ((Ptyp (k', [p], ps)) :: pys) =
22.550 - ((*writeln ("### insert 1: ks = " ^ strs2str [k] ^ " k'= " ^ k');*)
22.551 - if k = k'
22.552 - then ((Ptyp (k', [pbt], ps)) :: pys)
22.553 - else ((Ptyp (k', [p], ps)) :: (insrt d pbt [k] pys))
22.554 - )
22.555 - | insrt d pbt (k::ks) ((Ptyp (k', [p], ps)) :: pys) =
22.556 - ((*writeln ("### insert 2: ks = "^(strs2str (k::ks))^" k'= "^k');*)
22.557 - if k = k'
22.558 - then ((Ptyp (k', [p], insrt d pbt ks ps)) :: pys)
22.559 - else
22.560 - if length pys = 0
22.561 - then error ("insert: not found " ^ (strs2str (d : pblID)))
22.562 - else ((Ptyp (k', [p], ps)) :: (insrt d pbt (k :: ks) pys))
22.563 - )
22.564 - | insrt _ _ _ _ = raise ERROR "";
22.565 -
22.566 -fun update_ptyps ID _ _ [] =
22.567 - error ("update_ptyps: " ^ strs2str' ID ^ " does not exist")
22.568 - | update_ptyps ID [i] data ((py as Ptyp (key, _, pys)) :: pyss) =
22.569 - if i = key
22.570 - then
22.571 - if length pys = 0
22.572 - then ((Ptyp (key, [data], [])) :: pyss)
22.573 - else error ("update_ptyps: " ^ strs2str' ID ^ " has descendants")
22.574 - else py :: update_ptyps ID [i] data pyss
22.575 - | update_ptyps ID (i :: is) data ((py as Ptyp (key, d, pys)) :: pyss) =
22.576 - if i = key
22.577 - then ((Ptyp (key, d, update_ptyps ID is data pys)) :: pyss)
22.578 - else (py :: (update_ptyps ID (i :: is) data pyss))
22.579 - | update_ptyps _ _ _ _ = raise ERROR "update_ptyps called with undef pattern.";
22.580 -
22.581 -(* this function only works wrt. the way Isabelle evaluates Theories and is not a general merge
22.582 - function for trees / ptyps *)
22.583 -fun merge_ptyps ([], pt) = pt
22.584 - | merge_ptyps (pt, []) = pt
22.585 - | merge_ptyps ((x' as Ptyp (k, _, ps)) :: xs, (xs' as Ptyp (k', y, ps') :: ys)) =
22.586 - if k = k'
22.587 - then Ptyp (k, y, merge_ptyps (ps, ps')) :: merge_ptyps (xs, ys)
22.588 - else x' :: merge_ptyps (xs, xs');
22.589 -
22.590 -(* data for methods stored in 'methods'-database*)
22.591 -type met =
22.592 - {guh : guh, (* unique within this isac-knowledge *)
22.593 - mathauthors: string list, (* copyright *)
22.594 - init : pblID, (* WN060721 introduced mistakenly--TODO.REMOVE! *)
22.595 - rew_ord' : Rule.rew_ord', (* for rules in Detail
22.596 - TODO.WN0509 store fun itself, see 'type pbt' *)
22.597 - erls : Rule.rls, (* the eval_rls for cond. in rules FIXME "rls'
22.598 - instead erls in "fun prep_met" *)
22.599 - srls : Rule.rls, (* for evaluating list expressions in scr *)
22.600 - prls : Rule.rls, (* for evaluating predicates in modelpattern *)
22.601 - crls : Rule.rls, (* for check_elementwise, ie. formulae in calc. *)
22.602 - nrls : Rule.rls, (* canonical simplifier specific for this met *)
22.603 - errpats : Rule.errpat list,(* error patterns expected in this method *)
22.604 - calc : Rule.calc list, (* Theory_Data in fun prep_met *)
22.605 - (*branch : TransitiveB set in append_problem at generation ob pblobj *)
22.606 - ppc : pat list, (* items in given, find, relate;
22.607 - items (in "#Find") which need not occur in the arg-list of a SubProblem
22.608 - are 'copy-named' with an identifier "*'.'".
22.609 - copy-named items are 'generating' if they are NOT "*'''" ?WN120516??
22.610 - see ME/calchead.sml 'fun is_copy_named'. *)
22.611 - pre : term list, (* preconditions in where *)
22.612 - scr : Rule.program (* progam, empty as @{thm refl} or Rfuns *)
22.613 - };
22.614 -val e_met = {guh = "met_empty", mathauthors = [], init = e_metID, rew_ord' = "e_rew_ord'",
22.615 - erls = Rule.e_rls, srls = Rule.e_rls, prls = Rule.e_rls, calc = [], crls = Rule.e_rls,
22.616 - errpats = [], nrls = Rule.e_rls, ppc = [], pre = [], scr = Rule.EmptyScr};
22.617 -val e_Mets = Ptyp ("e_metID", [e_met],[]);
22.618 -
22.619 -type mets = (met ptyp) list;
22.620 -fun coll_metguhs mets =
22.621 - let
22.622 - fun node coll (Ptyp (_, [n], ns)) = [(#guh : met -> guh) n] @ (nodes coll ns)
22.623 - | node _ _ = raise ERROR "coll_pblguhs - node"
22.624 - and nodes coll [] = coll
22.625 - | nodes coll (n :: ns) = (node coll n) @ (nodes coll ns);
22.626 - in nodes [] mets end;
22.627 -fun check_metguh_unique (guh:guh) (mets: (met ptyp) list) =
22.628 - if member op = (coll_metguhs mets) guh
22.629 - then raise ERROR ("check_guh_unique failed with \"" ^ guh ^"\";\n"^
22.630 - (*"use \"sort_metguhs()\" for a list of guhs;\n" ^ ...evaluates to [] ?!?*)
22.631 - "consider setting \"check_guhs_unique := false\"")
22.632 - else ();
22.633 -
22.634 -fun Html_default exist = (Html {guh = theID2guh exist,
22.635 - coursedesign = ["isac team 2006"], mathauthors = [], html = ""})
22.636 -
22.637 -fun fill_parents (_, [i]) thydata = Ptyp (i, [thydata], [])
22.638 - | fill_parents (exist, i :: is) thydata =
22.639 - Ptyp (i, [Html_default (exist @ [i])], [fill_parents (exist @ [i], is) thydata])
22.640 - | fill_parents _ _ = raise ERROR "Html_default: avoid ML warning: Matches are not exhaustive"
22.641 -
22.642 -fun add_thydata (exist, is) thydata [] = [fill_parents (exist, is) thydata]
22.643 - | add_thydata (exist, [i]) data (pys as (py as Ptyp (key, _, _)) :: pyss) =
22.644 - if i = key
22.645 - then pys (* preserve existing thydata *)
22.646 - else py :: add_thydata (exist, [i]) data pyss
22.647 - | add_thydata (exist, iss as (i :: is)) data ((py as Ptyp (key, d, pys)) :: pyss) =
22.648 - if i = key
22.649 - then
22.650 - if length pys = 0
22.651 - then Ptyp (key, d, [fill_parents (exist @ [i], is) data]) :: pyss
22.652 - else Ptyp (key, d, add_thydata (exist @ [i], is) data pys) :: pyss
22.653 - else py :: add_thydata (exist, iss) data pyss
22.654 - | add_thydata _ _ _ = raise ERROR "add_thydata: avoid ML warning: Matches are not exhaustive"
22.655 -
22.656 -fun update_hthm (Hthm {guh, coursedesign, mathauthors, thm, ...}) fillpats' =
22.657 - Hthm {guh = guh, coursedesign = coursedesign, mathauthors = mathauthors,
22.658 - fillpats = fillpats', thm = thm}
22.659 - | update_hthm _ _ = raise ERROR "update_hthm: wrong arguments";
22.660 -
22.661 -(* for dialog-authoring *)
22.662 -fun update_hrls (Hrls {guh, coursedesign, mathauthors, thy_rls = (thyID, rls)}) errpatIDs =
22.663 - let
22.664 - val rls' =
22.665 - case rls of
22.666 - Rule.Rls {id, preconds, rew_ord, erls, srls, calc, rules, scr, ...}
22.667 - => Rule.Rls {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls,
22.668 - calc = calc, rules = rules, scr = scr, errpatts = errpatIDs}
22.669 - | Rule.Seq {id, preconds, rew_ord, erls, srls, calc, rules, scr, ...}
22.670 - => Rule.Seq {id = id, preconds = preconds, rew_ord = rew_ord, erls = erls, srls = srls,
22.671 - calc = calc, rules = rules, scr = scr, errpatts = errpatIDs}
22.672 - | Rule.Rrls {id, prepat, rew_ord, erls, calc, scr, ...}
22.673 - => Rule.Rrls {id = id, prepat = prepat, rew_ord = rew_ord, erls = erls, calc = calc,
22.674 - scr = scr, errpatts = errpatIDs}
22.675 - | Erls => Erls
22.676 - in
22.677 - Hrls {guh = guh, coursedesign = coursedesign, mathauthors = mathauthors,
22.678 - thy_rls = (thyID, rls')}
22.679 - end
22.680 - | update_hrls _ _ = raise ERROR "update_hrls: wrong arguments";
22.681 -
22.682 -fun app_py p f (d:pblID) (k(*:pblRD*)) =
22.683 - let
22.684 - fun py_err _ = raise ERROR ("app_py: not found: " ^ strs2str d);
22.685 - fun app_py' _ [] = py_err ()
22.686 - | app_py' [] _ = py_err ()
22.687 - | app_py' [k0] ((p' as Ptyp (k', _, _ )) :: ps) =
22.688 - if k0 = k' then f p' else app_py' [k0] ps
22.689 - | app_py' (k' as (k0 :: ks)) (Ptyp (k'', _, ps) :: ps') =
22.690 - if k0 = k'' then app_py' ks ps else app_py' k' ps';
22.691 - in app_py' k p end;
22.692 -fun get_py p =
22.693 - let
22.694 - fun extract_py (Ptyp (_, [py], _)) = py
22.695 - | extract_py _ = raise ERROR ("extract_py: Ptyp has wrong format.");
22.696 - in app_py p extract_py end;
22.697 -
22.698 -fun (*KEStore_Elems.*)insert_fillpats th fis = (* for tests bypassing setup KEStore_Elems *)
22.699 - let
22.700 - fun update_elem th (theID, fillpats) =
22.701 - let
22.702 - val hthm = get_py th theID theID
22.703 - val hthm' = update_hthm hthm fillpats
22.704 - handle ERROR _ => error ("insert_fillpats: " ^ strs2str theID ^ "must address a theorem")
22.705 - in update_ptyps theID theID hthm' end
22.706 - in fold (update_elem th) fis end
22.707 -
22.708 -(* group the theories defined in Isac, compare Build_Thydata:
22.709 - section "Get and group the theories defined in Isac" *)
22.710 -fun isabthys () = (*["Complex_Main", "Taylor", .., "Pure"]*)
22.711 - let
22.712 - val allthys = Theory.ancestors_of (Rule.Thy_Info_get_theory "Build_Thydata")
22.713 - in
22.714 - drop ((find_index (curry Context.eq_thy (Thy_Info.get_theory "Complex_Main")) allthys), allthys)
22.715 - end
22.716 -fun knowthys () = (*["Isac", .., "Descript", "Delete"]*)
22.717 - let
22.718 - fun isacthys () = (* ["Isac", .., "KEStore"] without Build_Isac thys: "Interpret" etc *)
22.719 - let
22.720 - val allthys = filter_out (member Context.eq_thy
22.721 - [(*Thy_Info_get_theory "ProgLang",*) Rule.Thy_Info_get_theory "Interpret",
22.722 - Rule.Thy_Info_get_theory "xmlsrc", Rule.Thy_Info_get_theory "Frontend"])
22.723 - (Theory.ancestors_of (Rule.Thy_Info_get_theory "Build_Thydata"))
22.724 - in
22.725 - take ((find_index (curry Context.eq_thy (Thy_Info.get_theory "Complex_Main")) allthys),
22.726 - allthys)
22.727 - end
22.728 - val isacthys' = isacthys ()
22.729 - val proglang_parent = Rule.Thy_Info_get_theory "ProgLang"
22.730 - in
22.731 - take ((find_index (curry Context.eq_thy proglang_parent) isacthys'), isacthys')
22.732 - end
22.733 -
22.734 -fun progthys () = (*["Isac", .., "Descript", "Delete"]*)
22.735 - let
22.736 - fun isacthys () = (* ["Isac", .., "KEStore"] without Build_Isac thys: "Interpret" etc *)
22.737 - let
22.738 - val allthys = filter_out (member Context.eq_thy
22.739 - [(*Thy_Info_get_theory "ProgLang",*) Rule.Thy_Info_get_theory "Interpret",
22.740 - Rule.Thy_Info_get_theory "xmlsrc", Rule.Thy_Info_get_theory "Frontend"])
22.741 - (Theory.ancestors_of (Rule.Thy_Info_get_theory "Build_Thydata"))
22.742 - in
22.743 - take ((find_index (curry Context.eq_thy (Thy_Info.get_theory "Complex_Main")) allthys),
22.744 - allthys)
22.745 - end
22.746 - val isacthys' = isacthys ()
22.747 - val proglang_parent = Rule.Thy_Info_get_theory "ProgLang"
22.748 - in
22.749 - drop ((find_index (curry Context.eq_thy proglang_parent) isacthys') + 1(*ProgLang*), isacthys')
22.750 - end
22.751 -
22.752 -fun partID thy =
22.753 - if member Context.eq_thy (knowthys ()) thy then "IsacKnowledge"
22.754 - else if member Context.eq_thy (progthys ()) thy then "IsacScripts"
22.755 - else if member Context.eq_thy (isabthys ()) thy then "Isabelle"
22.756 - else error ("closure of thys in Isac is broken by " ^ Rule.string_of_thy thy)
22.757 -fun partID' thy' = partID (Rule.Thy_Info_get_theory thy')
22.758 -
22.759 -end (*struct*)
22.760 -
23.1 --- a/src/Tools/isac/library.sml Thu Aug 22 16:48:04 2019 +0200
23.2 +++ /dev/null Thu Jan 01 00:00:00 1970 +0000
23.3 @@ -1,297 +0,0 @@
23.4 -(* library extending Isabelle's library.
23.5 - Author: Walther Neuper 1999
23.6 - (c) copyright due to lincense terms
23.7 -
23.8 -Note: Here many functions reflect changes since Isabelle 98. Changes frequently were resolved
23.9 - quick and dirty by additing Isabelle's old version to the library below.
23.10 -TODO:
23.11 - * remove unused functions
23.12 - * review duplicates with other signatures and re-locate respectively
23.13 - * move unparsing ("*_t0_str", "*2str", etc) somewhere else in ThydataC/
23.14 - * apply Isabelle's coding standards and remove warnings
23.15 - * rename "library.sml" to "libraryC.sml" like many other files, where struct <> filename.
23.16 -*)
23.17 -
23.18 -infix 1 ~~~
23.19 -
23.20 -signature LIBRARYC =
23.21 - sig
23.22 - val and_: bool * bool -> bool
23.23 - val assoc: (''a * 'b) list * ''a -> 'b option
23.24 - val assoc_string: (string * 'a) list * string -> 'a option
23.25 - val bool2str: bool -> string
23.26 - val commas: string list -> string
23.27 - val compare_strs: string -> string -> unit list
23.28 - val dashs: int -> string
23.29 - val de_quote: string -> string
23.30 - val distinct: ''a list -> ''a list
23.31 - val dots: int -> string
23.32 - val drop: int * 'a list -> 'a list
23.33 - val drop_last: 'a list -> 'a list
23.34 - val drop_last_n: int -> 'a list -> 'a list
23.35 - val drop_nth: 'a list -> int * 'a list -> 'a list
23.36 - val dropuntil: ('a -> bool) -> 'a list -> 'a list
23.37 - val dropwhile: ('a -> bool) -> 'a list -> 'a list
23.38 - val foldl: ('a * 'b -> 'a) -> 'a * 'b list -> 'a
23.39 - val foldr: ('a * 'b -> 'b) -> 'a list * 'b -> 'b
23.40 - val fst3: 'a * 'b * 'c -> 'a
23.41 - val gen_distinct: ('a * 'a -> bool) -> 'a list -> 'a list
23.42 - val gen_mem: ('a * 'b -> bool) -> 'a * 'b list -> bool
23.43 - val gen_rems: ('a * 'b -> bool) -> 'a list * 'b list -> 'a list
23.44 - val if_none: 'a option -> 'a -> 'a
23.45 - val indent: int -> string
23.46 - val indt: int -> string
23.47 - val idt: string -> int -> string
23.48 - val int2str: int -> string
23.49 - val ints2str': int list -> string
23.50 - val intsto: int -> int list
23.51 - val last_elem: 'a list -> 'a
23.52 - val list2str: string list -> string
23.53 - val list_update: 'a list -> int -> 'a -> 'a list
23.54 - val maxl: int list -> int
23.55 - val member_swap: ('a * 'b -> bool) -> 'a -> 'b list -> bool
23.56 - val nos: string list -> string
23.57 - val nth: int -> 'a list -> 'a
23.58 - val or_: bool * bool -> bool
23.59 - val overwrite: (''a * 'b) list * (''a * 'b) -> (''a * 'b) list
23.60 - val overwritel: (''a * 'b) list * (''a * 'b) list -> (''a * 'b) list
23.61 - val pair2str: string * string -> string
23.62 - val pair2str_: string * string -> string
23.63 - val pair2tri: ('a * 'b) * 'c -> 'a * 'b * 'c
23.64 - val snd3: 'a * 'b * 'c -> 'b
23.65 - val spair2str: string * string -> string
23.66 - val split_nlast: int * 'a list -> 'a list * 'a list
23.67 - val string_to_bool: string -> bool
23.68 - val strs2str: string list -> string
23.69 - val strs2str': string list -> string
23.70 - val strs2str_: string list -> string (* duplicates in Rule *)
23.71 - val strslist2strs: string list list -> string
23.72 - val take: int * 'a list -> 'a list
23.73 - val take_fromto: int -> int -> 'a list -> 'a list
23.74 - val takelast: int * 'a list -> 'a list
23.75 - val takerest: int * 'a list -> 'a list
23.76 - val takewhile: 'a list -> ('a -> bool) -> 'a list -> 'a list
23.77 - val termless: term * term -> bool
23.78 - val thd3: 'a * 'b * 'c -> 'c
23.79 - val triple2pair: 'a * 'b * 'c -> 'a * 'b
23.80 - val ~~~ : 'a list * 'b list -> ('a * 'b) list
23.81 -(* ---- for tests only: shifted from below to remove the Warning "unused" at fun.def. --------- *)
23.82 - (* NONE *)
23.83 -(*/-------------------------------------------------------- ! aktivate for Test_Isac BEGIN ---\* )
23.84 - val enumerate_strings: string list -> string list
23.85 - val quad2pair: 'a * 'b * 'c * 'd -> 'a * 'b
23.86 -( *\--- ! aktivate for Test_Isac END ----------------------------------------------------------/*)
23.87 -
23.88 -
23.89 -(*///------------------------------>>> thy ------------------------------------------------\\\*)
23.90 - val get_thy: string -> string
23.91 - val strip_thy: string -> string
23.92 -(*\\\------------------------------>>> thy ------------------------------------------------///*)
23.93 -(*///------------------------------>>> term -----------------------------------------------\\\*)
23.94 - val subs2str: string list -> string
23.95 - val id_of: term -> string
23.96 - val ids_of: term -> string list
23.97 -(*\\\------------------------------>>> term -----------------------------------------------///*)
23.98 - end;
23.99 -
23.100 -(**)
23.101 -structure LibraryC(*: RULE*) =
23.102 -struct
23.103 -(**)
23.104 -
23.105 -val foldl = Library.foldl
23.106 -val foldr = Library.foldr
23.107 -fun take (n, xs) = Library.take n xs;;
23.108 -fun drop (n, xs) = Library.drop n xs;
23.109 -
23.110 -fun last_elem [] = raise ERROR "last_elem"
23.111 - | last_elem [x] = x
23.112 - | last_elem (_ :: xs) = last_elem xs;
23.113 -fun member_swap eq x xs = member eq xs x
23.114 -
23.115 -fun gen_mem _ (_, []) = false
23.116 - | gen_mem eq (x, y :: ys) = eq (x, y) orelse gen_mem eq (x, ys);
23.117 -fun gen_rems eq (xs, ys) = filter_out (fn x => gen_mem eq (x, ys)) xs;
23.118 -
23.119 -(* got : string list -> string list with Library.distinct (op =) ?!? *)
23.120 -fun gen_distinct eq lst =
23.121 - let
23.122 - val memb = gen_mem eq;
23.123 -
23.124 - fun dist (rev_seen, []) = rev rev_seen
23.125 - | dist (rev_seen, x :: xs) =
23.126 - if memb (x, rev_seen) then dist (rev_seen, xs)
23.127 - else dist (x :: rev_seen, xs);
23.128 - in dist ([], lst) end;
23.129 -fun distinct l = gen_distinct (op =) l;
23.130 -
23.131 -(*fun nth n xs = Library.nth xs n; exn behaviour different*)
23.132 -fun nth _ [] = raise ERROR "nth _ []" (*Isabelle2002, still saved the hours of update*)
23.133 - | nth 1 (x :: _) = x
23.134 - | nth n (_ :: xs) = nth (n - 1) xs;
23.135 -
23.136 -fun list_update [] _ _ = []
23.137 - | list_update (x :: xs) i v =
23.138 - case i of
23.139 - 0 => v :: xs
23.140 - | j => x :: list_update xs (j - 1) v
23.141 -
23.142 -fun drop_nth ls (_, []) = ls
23.143 - | drop_nth ls (n, x :: xs) =
23.144 - if n = 1
23.145 - then ls @ xs
23.146 - else drop_nth (ls @ [x]) (n - 1, xs);
23.147 -
23.148 -fun and_ (b1, b2) = b1 andalso b2;
23.149 -fun or_ (b1, b2) = b1 orelse b2;
23.150 -
23.151 -fun takerest (i, ls) = (rev o take) (length ls - i, rev ls);
23.152 -fun takelast (i, ls) = (rev o take) (i, rev ls);
23.153 -fun split_nlast (i, ls) = (take (length ls - i, ls), rev (take (i, rev ls)));
23.154 -fun dropwhile _ [] = []
23.155 - | dropwhile P (ys as x :: xs) = if P x then dropwhile P xs else ys;
23.156 -fun takewhile col _ [] = col
23.157 - | takewhile col P (x::xs) =
23.158 - if P x then takewhile (col @ [x]) P xs else col;
23.159 -fun dropuntil _ [] = []
23.160 - | dropuntil P (ys as x :: xs) = if P x then ys else dropuntil P xs;
23.161 -fun drop_last l = ((rev o tl o rev) l);
23.162 -fun drop_last_n n l = rev (takerest (n, rev l));
23.163 -
23.164 -fun pair2tri ((a,b),c) = (a,b,c);
23.165 -fun fst3 (a,_,_) = a;
23.166 -fun snd3 (_,b,_) = b;
23.167 -fun thd3 (_,_,c) = c;
23.168 -
23.169 -fun de_quote str =
23.170 - let fun scan ss' [] = ss'
23.171 - | scan ss' ("\"" :: ss) = scan ss' ss
23.172 - | scan ss' (s :: ss) = scan (ss' @ [s]) ss;
23.173 - in (implode o (scan []) o Symbol.explode) str end;
23.174 -val commas = Library.space_implode ",";
23.175 -
23.176 -fun strs2str strl = "[" ^ (commas (map quote strl)) ^ "]";
23.177 -fun strs2str' strl = "[" ^ commas strl ^ "]";
23.178 -fun list2str strl = "[" ^ commas strl ^ "]";
23.179 -val nos = space_implode "#";
23.180 -fun strs2str_ strl = "#" ^ (nos strl) ^ "#";
23.181 -fun strslist2strs strslist = map strs2str strslist |> strs2str';
23.182 -fun spair2str (s1, s2) = "(" ^ quote s1 ^ ", " ^ quote s2 ^ ")";
23.183 -fun pair2str_ (s1, s2) = s1 ^ "#" ^ s2;
23.184 -fun pair2str (s1, s2) = "(" ^ s1 ^ ", " ^ s2 ^ ")";
23.185 -
23.186 -val int2str = Library.string_of_int;
23.187 -fun ints2str' ints = (strs2str' o (map string_of_int)) ints;
23.188 -
23.189 -fun overwrite (al, p as (key, _)) =
23.190 - let fun over ((q as (keyi, _)) :: pairs) =
23.191 - if keyi = key then p :: pairs else q :: (over pairs)
23.192 - | over [] = [p]
23.193 - in over al end;
23.194 -fun overwritel (al, []) = al
23.195 - | overwritel (al, b::bl) = overwritel (overwrite (al, b), bl);
23.196 -
23.197 -local
23.198 -fun intsto1 0 = []
23.199 - | intsto1 n = (intsto1 (n - 1)) @ [n]
23.200 -in
23.201 -fun intsto n = if n < 0 then (error "intsto < 0") else intsto1 n
23.202 -end;
23.203 -
23.204 -fun bool2str true = "true"
23.205 - | bool2str false = "false";
23.206 -fun string_to_bool "true" = true
23.207 - | string_to_bool "false" = false
23.208 - | string_to_bool str = raise ERROR ("string_to_bool: arg = " ^ str)
23.209 -
23.210 -(* take elements from b to e including both *)
23.211 -fun take_fromto from to l =
23.212 - if from > to
23.213 - then raise ERROR ("take_fromto from=" ^ string_of_int from ^ " > to=" ^ string_of_int to)
23.214 - else drop (from - 1, take (to, l));
23.215 -
23.216 -fun idt _ 0 = " "
23.217 - | idt str n = str ^ idt str (n - 1);
23.218 -fun indt n = if n <= 0 then "" else " " ^ indt (n-1);
23.219 -fun indent i = fold (curry op ^) (replicate i ". ") ""
23.220 -
23.221 -fun dashs i = if 0 < i then "-" ^ dashs (i - 1) else "";
23.222 -fun dots i = if 0 < i then "." ^ dots (i - 1) else "";
23.223 -
23.224 -(*val assoc = AList.lookup (op =) SAME PROBLEM AS WITH Library.distinct *)
23.225 -fun assoc ([], _) = NONE(*cp 2002 Pure/library.ML FIXXXME take AList.lookup*)
23.226 - | assoc ((keyi, xi) :: pairs, key) =
23.227 - if key = keyi then SOME xi else assoc (pairs, key);
23.228 -(* optimized version for strings *)
23.229 -fun assoc_string ([], (_ : string)) = NONE
23.230 - | assoc_string ((keyi, xi) :: pairs, key) =
23.231 - if key = keyi then SOME xi else assoc_string (pairs, key);
23.232 -fun if_none NONE y = y (*cp from 2002 Pure/library.ML FIXXXME replace*)
23.233 - | if_none (SOME x) _ = x;
23.234 -
23.235 -fun compare_strs str1 str2 =
23.236 - let
23.237 - fun comp_char (c1, c2) = tracing ("comp_strs: " ^ c1 ^ " = " ^ c2 ^ " ..." ^ bool2str (c1 = c2))
23.238 - in map comp_char ((Symbol.explode str1) ~~ (Symbol.explode str2)) end;
23.239 -
23.240 -fun triple2pair (a, b, _) = (a, b);
23.241 -fun quad2pair (a, b, _, _) = (a, b);
23.242 -
23.243 -(* append a counter to a string list *)
23.244 -fun enumerate_strings strs =
23.245 - let fun enum _ [] = []
23.246 - | enum i (s :: ss) = (s ^ "--" ^ string_of_int i) :: (enum (i + 1) ss)
23.247 - in enum 1 strs end
23.248 -
23.249 -fun maxl [] = error "maxl of []"
23.250 - | maxl (y :: ys) =
23.251 - let
23.252 - fun mx x [] = x
23.253 - | mx x (y :: ys) = if x < (y: int) then mx y ys else mx x ys
23.254 - in mx y ys end
23.255 -
23.256 -fun xs ~~~ ys =
23.257 - let fun aaa xys [] [] = xys
23.258 - | aaa xys [] (_ :: _) = xys
23.259 - | aaa xys (_ :: _) [] = xys
23.260 - | aaa xys (x :: xs) (y :: ys) = aaa (xys @ [(x, y)]) xs ys
23.261 - in aaa [] xs ys end;
23.262 -
23.263 -(*///------------------------------>>> thy ------------------------------------------------\\\*)
23.264 -fun get_thy str =
23.265 - let
23.266 - fun get strl [] = strl
23.267 - | get strl ("." :: _) = strl
23.268 - | get strl ( s :: ss) = get (strl @ [s]) ss
23.269 - in implode (get [] (Symbol.explode str)) end;
23.270 -
23.271 -fun strip_thy str =
23.272 - let fun strip bdVar [] = implode (rev bdVar)
23.273 - | strip bdVar ("." :: _) = implode (rev bdVar)
23.274 - | strip bdVar (c :: cs) = strip (bdVar @ [c]) cs
23.275 - in strip [] (rev (Symbol.explode str)) end;
23.276 -(*\\\------------------------------>>> thy ------------------------------------------------///*)
23.277 -
23.278 -(*///------------------------------>>> term ----------------------------------------------\\\*)
23.279 -fun id_of (Var ((id,ix),_)) = if ix=0 then id else id^(string_of_int ix)
23.280 - | id_of (Free (id ,_)) = id
23.281 - | id_of (Const(id ,_)) = id
23.282 - | id_of _ = ""; (* never such an identifier *)
23.283 -
23.284 -fun ids_of t =
23.285 - let fun con ss (Const (s,_)) = s::ss
23.286 - | con ss (Free (s,_)) = s::ss
23.287 - | con ss (Abs (s,_,b)) = s::(con ss b)
23.288 - | con ss (t1 $ t2) = (con ss t1) @ (con ss t2)
23.289 - | con ss _ = ss
23.290 - in map strip_thy ((distinct o (con [])) t) end;
23.291 -
23.292 -fun subs2str (subs: string list) = list2str subs;
23.293 -(*> val sss = ["(''bdv'',x)","(err,#0)"];
23.294 -> subs2str sss;
23.295 -val it = "[(bdv,x),(err,#0)]" : string*)
23.296 -(*\\\------------------------------>>> term ----------------------------------------------///*)
23.297 -
23.298 -fun termless tu = (Term_Ord.term_ord tu = LESS);
23.299 -
23.300 -end; (*struct*) open LibraryC