1 (* Title: ../contextC.sml
2 Author: Walther Neuper, Mathias Lehnfeld
3 (c) due to copyright terms
5 (* Extension to Isabelle's naming conventions: "C" indicates Isac add-ons to an Isabelle module *)
8 val empty : Proof.context
9 val is_empty : Proof.context -> bool
10 val isac_ctxt : 'a -> Proof.context
11 val declare_constraints: term -> Proof.context -> Proof.context
12 val add_constraints: term list -> Proof.context -> Proof.context
13 val build_while_parsing: Formalise.model -> theory -> term list * Proof.context
14 val initialise : Proof.context -> term list -> Proof.context
15 val initialise' : theory -> TermC.as_string list -> Proof.context
16 val get_assumptions : Proof.context -> term list
17 val insert_assumptions : term list -> Proof.context -> Proof.context
18 val avoid_contradict: term -> term list -> term * term list
19 val subpbl_to_caller : Proof.context -> term -> Proof.context -> term * Proof.context
22 val transfer_asms_from_to : Proof.context -> Proof.context -> Proof.context
23 val contradict : term list -> term -> bool
24 val insert_assumptions_cao : Proof.context -> term list -> Proof.context
28 structure ContextC(**) : CONTEXT_C(**) =
31 val empty = Proof_Context.init_global @{theory "Pure"};
32 (* ATTENTION: does _not_ recognise Variable.declare_constraints, etc...*)
34 fun is_empty ctxt = Context.eq_thy (Proof_Context.theory_of ctxt, @{theory "Pure"});
35 fun isac_ctxt xxx = Proof_Context.init_global (ThyC.Isac xxx)
37 val declare_constraints = Variable.declare_constraints
38 fun add_constraints ts ctxt =
39 fold Variable.declare_constraints (TermC.vars' ts) ctxt
41 fun build_while_parsing_ [] (ts, ctxt) = (ts, ctxt)
42 | build_while_parsing_ (str :: strs) (ts, ctxt) =
44 val t as (_ $ tm) = Syntax.read_term ctxt str
45 handle ERROR msg => raise ERROR ("ContextC.build_while_parsing " ^ quote str ^ " " ^ msg)
46 val vars = TermC.vars tm
47 val ctxt' = add_constraints vars ctxt
48 in build_while_parsing_ strs (ts @ [t], ctxt') end
49 (* shouldn't that be done by fold ?
50 fn: string * Proof.context -> term list * Proof.context -> term list * Proof.context *)
51 fun build_while_parsing strs thy = build_while_parsing_ strs ([], Proof_Context.init_global thy)
53 (* in Subproblem take respective actual arguments from program *)
54 (* FIXME: should be replaced by build_while_parsing *)
55 fun initialise ctxt ts =
57 val frees = TermC.vars' ts
58 val _ = TermC.raise_type_conflicts frees
60 fold Variable.declare_constraints frees ctxt
62 (* in root-problem take respective formalisation *)
63 fun initialise' thy fmz =
65 val ctxt = thy |> Proof_Context.init_global
66 val frees = map (TermC.parseNEW' ctxt) fmz |> TermC.vars'
67 val _ = TermC.raise_type_conflicts frees
69 fold Variable.declare_constraints frees ctxt
72 structure Context_Data = Proof_Data (type T = term list fun init _ = []);
73 fun get_assumptions ctxt = Context_Data.get ctxt
74 fun insert_assumptions asms = Context_Data.map (fn xs => distinct op = (asms @ xs))
77 transfer assumptions from one to another ctxt.
78 does NOT respect scope: in a calculation identifiers are unique.
79 but environments are scoped as usual in Luacs-interpretation.
81 fun transfer_asms_from_to from_ctxt to_ctxt =
83 val to_vars = get_assumptions to_ctxt |> map TermC.vars |> flat
84 fun transfer [] to_ctxt = to_ctxt
85 | transfer (from_asm :: fas) to_ctxt =
86 if inter op = (TermC.vars from_asm) to_vars = []
87 then transfer fas to_ctxt
88 else transfer fas (insert_assumptions [from_asm] to_ctxt)
90 transfer (get_assumptions from_ctxt) to_ctxt
93 (* there is still much TODO: factorise polynomials, etc *)
94 fun contradict asm res = fold (curry or_) (map (fn p => TermC.negates res p) asm) false;
97 Check a term for contradiction with a predicate list.
98 This makes only sense for types bool and bool list. In these cases return
99 the probably updated term together with
100 a respective list of non-contradicting predicates
102 fun avoid_contradict t preds =
103 if TermC.is_bool_list t then
105 val no_contra = t |> TermC.dest_list' |> filter_out (contradict preds)
107 (no_contra |> TermC.list2isalist HOLogic.boolT, no_contra)
109 else if Term.type_of t = HOLogic.boolT then
110 if contradict preds t then (@{term bool_undef}, []) else (t, [t])
111 else (t (* type_of t \<noteq> bool *), [(* no predicate to add *)])
113 (* for Canonical Argument Order used by |> below *)
114 fun insert_assumptions_cao ctxt tms = insert_assumptions tms ctxt
116 fun subpbl_to_caller sub_ctxt expr_val caller_ctxt = caller_ctxt
118 |> avoid_contradict expr_val
119 |> apsnd (insert_assumptions_cao caller_ctxt)
120 |> apsnd (transfer_asms_from_to sub_ctxt)