paulson@7186: (* Title: HOL/UNITY/Lift_prog.thy paulson@7186: Author: Lawrence C Paulson, Cambridge University Computer Laboratory paulson@7186: Copyright 1999 University of Cambridge paulson@7186: paulson@13786: lift_prog, etc: replication of components and arrays of processes. paulson@7186: *) paulson@7186: wenzelm@58889: section{*Replication of Components*} paulson@13798: haftmann@16417: theory Lift_prog imports Rename begin paulson@7186: haftmann@35416: definition insert_map :: "[nat, 'b, nat=>'b] => (nat=>'b)" where paulson@8251: "insert_map i z f k == if k'b] => (nat=>'b)" where paulson@8251: "delete_map i g k == if k'b) * 'c)] => (nat=>'b) * 'c" where paulson@8251: "lift_map i == %(s,(f,uu)). (insert_map i s f, uu)" paulson@8251: haftmann@35416: definition drop_map :: "[nat, (nat=>'b) * 'c] => 'b * ((nat=>'b) * 'c)" where paulson@8251: "drop_map i == %(g, uu). (g i, (delete_map i g, uu))" paulson@7186: haftmann@35416: definition lift_set :: "[nat, ('b * ((nat=>'b) * 'c)) set] => ((nat=>'b) * 'c) set" where nipkow@10834: "lift_set i A == lift_map i ` A" paulson@7186: haftmann@35416: definition lift :: "[nat, ('b * ((nat=>'b) * 'c)) program] => ((nat=>'b) * 'c) program" where paulson@8251: "lift i == rename (lift_map i)" paulson@7186: paulson@7186: (*simplifies the expression of specifications*) haftmann@35416: definition sub :: "['a, 'a=>'b] => 'b" where paulson@13786: "sub == %i f. f i" paulson@13786: paulson@13786: paulson@13786: declare insert_map_def [simp] delete_map_def [simp] paulson@13786: paulson@13786: lemma insert_map_inverse: "delete_map i (insert_map i x f) = f" paulson@13798: by (rule ext, simp) paulson@13786: paulson@13786: lemma insert_map_delete_map_eq: "(insert_map i x (delete_map i g)) = g(i:=x)" paulson@13786: apply (rule ext) paulson@13786: apply (auto split add: nat_diff_split) paulson@13786: done paulson@13786: paulson@13812: subsection{*Injectiveness proof*} paulson@13786: paulson@13786: lemma insert_map_inject1: "(insert_map i x f) = (insert_map i y g) ==> x=y" paulson@13798: by (drule_tac x = i in fun_cong, simp) paulson@13786: paulson@13786: lemma insert_map_inject2: "(insert_map i x f) = (insert_map i y g) ==> f=g" paulson@13786: apply (drule_tac f = "delete_map i" in arg_cong) paulson@13798: apply (simp add: insert_map_inverse) paulson@13786: done paulson@13786: paulson@13786: lemma insert_map_inject': paulson@13786: "(insert_map i x f) = (insert_map i y g) ==> x=y & f=g" paulson@13786: by (blast dest: insert_map_inject1 insert_map_inject2) paulson@13786: paulson@13786: lemmas insert_map_inject = insert_map_inject' [THEN conjE, elim!] paulson@13786: paulson@13786: (*The general case: we don't assume i=i'*) paulson@13786: lemma lift_map_eq_iff [iff]: paulson@13786: "(lift_map i (s,(f,uu)) = lift_map i' (s',(f',uu'))) paulson@13786: = (uu = uu' & insert_map i s f = insert_map i' s' f')" paulson@13798: by (unfold lift_map_def, auto) paulson@13786: paulson@13786: (*The !!s allows the automatic splitting of the bound variable*) paulson@13786: lemma drop_map_lift_map_eq [simp]: "!!s. drop_map i (lift_map i s) = s" paulson@13786: apply (unfold lift_map_def drop_map_def) paulson@13786: apply (force intro: insert_map_inverse) paulson@13786: done paulson@13786: paulson@13786: lemma inj_lift_map: "inj (lift_map i)" paulson@13786: apply (unfold lift_map_def) paulson@13786: apply (rule inj_onI, auto) paulson@13786: done paulson@13786: paulson@13812: subsection{*Surjectiveness proof*} paulson@13786: paulson@13786: lemma lift_map_drop_map_eq [simp]: "!!s. lift_map i (drop_map i s) = s" paulson@13786: apply (unfold lift_map_def drop_map_def) paulson@13786: apply (force simp add: insert_map_delete_map_eq) paulson@13786: done paulson@13786: paulson@13786: lemma drop_map_inject [dest!]: "(drop_map i s) = (drop_map i s') ==> s=s'" paulson@13798: by (drule_tac f = "lift_map i" in arg_cong, simp) paulson@13786: paulson@13786: lemma surj_lift_map: "surj (lift_map i)" paulson@13786: apply (rule surjI) paulson@13786: apply (rule lift_map_drop_map_eq) paulson@13786: done paulson@13786: paulson@13786: lemma bij_lift_map [iff]: "bij (lift_map i)" paulson@13798: by (simp add: bij_def inj_lift_map surj_lift_map) paulson@13786: paulson@13786: lemma inv_lift_map_eq [simp]: "inv (lift_map i) = drop_map i" paulson@13786: by (rule inv_equality, auto) paulson@13786: paulson@13786: lemma inv_drop_map_eq [simp]: "inv (drop_map i) = lift_map i" paulson@13786: by (rule inv_equality, auto) paulson@13786: paulson@13786: lemma bij_drop_map [iff]: "bij (drop_map i)" paulson@13786: by (simp del: inv_lift_map_eq add: inv_lift_map_eq [symmetric] bij_imp_bij_inv) paulson@13786: paulson@13786: (*sub's main property!*) paulson@13786: lemma sub_apply [simp]: "sub i f = f i" paulson@13798: by (simp add: sub_def) paulson@13786: paulson@13812: lemma all_total_lift: "all_total F ==> all_total (lift i F)" paulson@13812: by (simp add: lift_def rename_def Extend.all_total_extend) paulson@13812: paulson@13836: lemma insert_map_upd_same: "(insert_map i t f)(i := s) = insert_map i s f" paulson@13836: by (rule ext, auto) paulson@13836: paulson@13836: lemma insert_map_upd: paulson@13836: "(insert_map j t f)(i := s) = paulson@13836: (if i=j then insert_map i s f paulson@13836: else if ij |] paulson@13836: ==> \g'. insert_map i s' f = insert_map j t g'" paulson@13836: apply (subst insert_map_upd_same [symmetric]) paulson@13836: apply (erule ssubst) paulson@13836: apply (simp only: insert_map_upd if_False split: split_if, blast) paulson@13836: done paulson@13836: paulson@13836: lemma lift_map_eq_diff: paulson@13836: "[| lift_map i (s,(f,uu)) = lift_map j (t,(g,vv)); i\j |] paulson@13836: ==> \g'. lift_map i (s',(f,uu)) = lift_map j (t,(g',vv))" paulson@13836: apply (unfold lift_map_def, auto) paulson@13836: apply (blast dest: insert_map_eq_diff) paulson@13836: done paulson@13836: paulson@13812: paulson@13812: subsection{*The Operator @{term lift_set}*} paulson@13786: paulson@13786: lemma lift_set_empty [simp]: "lift_set i {} = {}" paulson@13786: by (unfold lift_set_def, auto) paulson@13786: paulson@13805: lemma lift_set_iff: "(lift_map i x \ lift_set i A) = (x \ A)" paulson@13786: apply (unfold lift_set_def) paulson@13786: apply (rule inj_lift_map [THEN inj_image_mem_iff]) paulson@13786: done paulson@13786: paulson@13786: (*Do we really need both this one and its predecessor?*) paulson@13786: lemma lift_set_iff2 [iff]: paulson@13805: "((f,uu) \ lift_set i A) = ((f i, (delete_map i f, uu)) \ A)" paulson@13798: by (simp add: lift_set_def mem_rename_set_iff drop_map_def) paulson@13786: paulson@13786: paulson@13805: lemma lift_set_mono: "A \ B ==> lift_set i A \ lift_set i B" paulson@13786: apply (unfold lift_set_def) paulson@13786: apply (erule image_mono) paulson@13786: done paulson@13786: paulson@13805: lemma lift_set_Un_distrib: "lift_set i (A \ B) = lift_set i A \ lift_set i B" paulson@13812: by (simp add: lift_set_def image_Un) paulson@13786: paulson@13786: lemma lift_set_Diff_distrib: "lift_set i (A-B) = lift_set i A - lift_set i B" paulson@13786: apply (unfold lift_set_def) paulson@13786: apply (rule inj_lift_map [THEN image_set_diff]) paulson@13786: done paulson@13786: paulson@13786: paulson@13812: subsection{*The Lattice Operations*} paulson@13786: paulson@13786: lemma bij_lift [iff]: "bij (lift i)" paulson@13798: by (simp add: lift_def) paulson@13786: paulson@13786: lemma lift_SKIP [simp]: "lift i SKIP = SKIP" paulson@13798: by (simp add: lift_def) paulson@13786: wenzelm@60773: lemma lift_Join [simp]: "lift i (F \ G) = lift i F \ lift i G" paulson@13798: by (simp add: lift_def) paulson@13786: paulson@13805: lemma lift_JN [simp]: "lift j (JOIN I F) = (\i \ I. lift j (F i))" paulson@13798: by (simp add: lift_def) paulson@13786: paulson@13812: subsection{*Safety: constrains, stable, invariant*} paulson@13786: paulson@13786: lemma lift_constrains: paulson@13805: "(lift i F \ (lift_set i A) co (lift_set i B)) = (F \ A co B)" paulson@13798: by (simp add: lift_def lift_set_def rename_constrains) paulson@13786: paulson@13786: lemma lift_stable: paulson@13805: "(lift i F \ stable (lift_set i A)) = (F \ stable A)" paulson@13798: by (simp add: lift_def lift_set_def rename_stable) paulson@13786: paulson@13786: lemma lift_invariant: paulson@13805: "(lift i F \ invariant (lift_set i A)) = (F \ invariant A)" paulson@13812: by (simp add: lift_def lift_set_def rename_invariant) paulson@13786: paulson@13786: lemma lift_Constrains: paulson@13805: "(lift i F \ (lift_set i A) Co (lift_set i B)) = (F \ A Co B)" paulson@13812: by (simp add: lift_def lift_set_def rename_Constrains) paulson@13786: paulson@13786: lemma lift_Stable: paulson@13805: "(lift i F \ Stable (lift_set i A)) = (F \ Stable A)" paulson@13812: by (simp add: lift_def lift_set_def rename_Stable) paulson@13786: paulson@13786: lemma lift_Always: paulson@13805: "(lift i F \ Always (lift_set i A)) = (F \ Always A)" paulson@13812: by (simp add: lift_def lift_set_def rename_Always) paulson@13786: paulson@13812: subsection{*Progress: transient, ensures*} paulson@13786: paulson@13786: lemma lift_transient: paulson@13805: "(lift i F \ transient (lift_set i A)) = (F \ transient A)" paulson@13798: by (simp add: lift_def lift_set_def rename_transient) paulson@13786: paulson@13786: lemma lift_ensures: paulson@13805: "(lift i F \ (lift_set i A) ensures (lift_set i B)) = paulson@13805: (F \ A ensures B)" paulson@13798: by (simp add: lift_def lift_set_def rename_ensures) paulson@13786: paulson@13786: lemma lift_leadsTo: paulson@13805: "(lift i F \ (lift_set i A) leadsTo (lift_set i B)) = paulson@13805: (F \ A leadsTo B)" paulson@13798: by (simp add: lift_def lift_set_def rename_leadsTo) paulson@13786: paulson@13786: lemma lift_LeadsTo: paulson@13805: "(lift i F \ (lift_set i A) LeadsTo (lift_set i B)) = paulson@13805: (F \ A LeadsTo B)" paulson@13798: by (simp add: lift_def lift_set_def rename_LeadsTo) paulson@13786: paulson@13786: paulson@13786: (** guarantees **) paulson@13786: paulson@13786: lemma lift_lift_guarantees_eq: paulson@13805: "(lift i F \ (lift i ` X) guarantees (lift i ` Y)) = paulson@13805: (F \ X guarantees Y)" paulson@13786: apply (unfold lift_def) paulson@13786: apply (subst bij_lift_map [THEN rename_rename_guarantees_eq, symmetric]) paulson@13798: apply (simp add: o_def) paulson@13786: done paulson@13786: paulson@13812: lemma lift_guarantees_eq_lift_inv: paulson@13812: "(lift i F \ X guarantees Y) = paulson@13805: (F \ (rename (drop_map i) ` X) guarantees (rename (drop_map i) ` Y))" paulson@13786: by (simp add: bij_lift_map [THEN rename_guarantees_eq_rename_inv] lift_def) paulson@7186: paulson@7186: paulson@13786: (*To preserve snd means that the second component is there just to allow paulson@13786: guarantees properties to be stated. Converse fails, for lift i F can paulson@13786: change function components other than i*) paulson@13805: lemma lift_preserves_snd_I: "F \ preserves snd ==> lift i F \ preserves snd" paulson@13786: apply (drule_tac w1=snd in subset_preserves_o [THEN subsetD]) paulson@13798: apply (simp add: lift_def rename_preserves) wenzelm@46577: apply (simp add: lift_map_def o_def split_def) paulson@13786: done paulson@13786: paulson@13786: lemma delete_map_eqE': paulson@13805: "(delete_map i g) = (delete_map i g') ==> \x. g = g'(i:=x)" paulson@13786: apply (drule_tac f = "insert_map i (g i) " in arg_cong) paulson@13798: apply (simp add: insert_map_delete_map_eq) paulson@13786: apply (erule exI) paulson@13786: done paulson@13786: paulson@13786: lemmas delete_map_eqE = delete_map_eqE' [THEN exE, elim!] paulson@13786: paulson@13786: lemma delete_map_neq_apply: paulson@13805: "[| delete_map j g = delete_map j g'; i\j |] ==> g i = g' i" paulson@13786: by force paulson@13786: wenzelm@61943: (*A set of the form (A \ UNIV) ignores the second (dummy) state component*) paulson@13786: wenzelm@61943: lemma vimage_o_fst_eq [simp]: "(f o fst) -` A = (f-`A) \ UNIV" paulson@13786: by auto paulson@13786: paulson@13786: lemma vimage_sub_eq_lift_set [simp]: wenzelm@61943: "(sub i -`A) \ UNIV = lift_set i (A \ UNIV)" paulson@13786: by auto paulson@13786: paulson@13786: lemma mem_lift_act_iff [iff]: paulson@13805: "((s,s') \ extend_act (%(x,u::unit). lift_map i x) act) = paulson@13805: ((drop_map i s, drop_map i s') \ act)" paulson@13786: apply (unfold extend_act_def, auto) paulson@13786: apply (rule bexI, auto) paulson@13786: done paulson@13786: paulson@13786: lemma preserves_snd_lift_stable: paulson@13805: "[| F \ preserves snd; i\j |] wenzelm@61943: ==> lift j F \ stable (lift_set i (A \ UNIV))" paulson@13798: apply (auto simp add: lift_def lift_set_def stable_def constrains_def paulson@13798: rename_def extend_def mem_rename_set_iff) paulson@13786: apply (auto dest!: preserves_imp_eq simp add: lift_map_def drop_map_def) paulson@13786: apply (drule_tac x = i in fun_cong, auto) paulson@13786: done paulson@13786: paulson@13805: (*If i\j then lift j F does nothing to lift_set i, and the paulson@13805: premise ensures A \ B.*) paulson@13786: lemma constrains_imp_lift_constrains: wenzelm@61943: "[| F i \ (A \ UNIV) co (B \ UNIV); paulson@13805: F j \ preserves snd |] wenzelm@61943: ==> lift j (F j) \ (lift_set i (A \ UNIV)) co (lift_set i (B \ UNIV))" wenzelm@46911: apply (cases "i=j") paulson@13786: apply (simp add: lift_def lift_set_def rename_constrains) paulson@13798: apply (erule preserves_snd_lift_stable[THEN stableD, THEN constrains_weaken_R], paulson@13798: assumption) paulson@13786: apply (erule constrains_imp_subset [THEN lift_set_mono]) paulson@13786: done paulson@13786: paulson@13786: (*USELESS??*) paulson@13812: lemma lift_map_image_Times: wenzelm@61943: "lift_map i ` (A \ UNIV) = wenzelm@61943: (\s \ A. \f. {insert_map i s f}) \ UNIV" paulson@13786: apply (auto intro!: bexI image_eqI simp add: lift_map_def) paulson@13786: apply (rule split_conv [symmetric]) paulson@13786: done paulson@13786: paulson@13786: lemma lift_preserves_eq: paulson@13805: "(lift i F \ preserves v) = (F \ preserves (v o lift_map i))" paulson@13786: by (simp add: lift_def rename_preserves) paulson@13786: paulson@13786: (*A useful rewrite. If o, sub have been rewritten out already then can also paulson@13786: use it as rewrite_rule [sub_def, o_def] lift_preserves_sub*) paulson@13786: lemma lift_preserves_sub: paulson@13805: "F \ preserves snd paulson@13805: ==> lift i F \ preserves (v o sub j o fst) = paulson@13805: (if i=j then F \ preserves (v o fst) else True)" paulson@13786: apply (drule subset_preserves_o [THEN subsetD]) wenzelm@46577: apply (simp add: lift_preserves_eq o_def) paulson@13798: apply (auto cong del: if_weak_cong wenzelm@46577: simp add: lift_map_def eq_commute split_def o_def) paulson@13786: done paulson@13786: paulson@13786: paulson@13812: subsection{*Lemmas to Handle Function Composition (o) More Consistently*} paulson@13786: paulson@13786: (*Lets us prove one version of a theorem and store others*) paulson@13786: lemma o_equiv_assoc: "f o g = h ==> f' o f o g = f' o h" nipkow@39302: by (simp add: fun_eq_iff o_def) paulson@13786: paulson@13805: lemma o_equiv_apply: "f o g = h ==> \x. f(g x) = h x" nipkow@39302: by (simp add: fun_eq_iff o_def) paulson@13786: paulson@13786: lemma fst_o_lift_map: "sub i o fst o lift_map i = fst" paulson@13786: apply (rule ext) paulson@13786: apply (auto simp add: o_def lift_map_def sub_def) paulson@13786: done paulson@13786: paulson@13786: lemma snd_o_lift_map: "snd o lift_map i = snd o snd" paulson@13786: apply (rule ext) paulson@13786: apply (auto simp add: o_def lift_map_def) paulson@13786: done paulson@13786: paulson@13786: paulson@13812: subsection{*More lemmas about extend and project*} paulson@13786: paulson@13812: text{*They could be moved to theory Extend or Project*} paulson@13812: paulson@13812: lemma extend_act_extend_act: paulson@13812: "extend_act h' (extend_act h act) = paulson@13786: extend_act (%(x,(y,y')). h'(h(x,y),y')) act" paulson@13786: apply (auto elim!: rev_bexI simp add: extend_act_def, blast) paulson@13786: done paulson@13786: paulson@13812: lemma project_act_project_act: paulson@13812: "project_act h (project_act h' act) = paulson@13786: project_act (%(x,(y,y')). h'(h(x,y),y')) act" paulson@13786: by (auto elim!: rev_bexI simp add: project_act_def) paulson@13786: paulson@13786: lemma project_act_extend_act: paulson@13786: "project_act h (extend_act h' act) = paulson@13805: {(x,x'). \s s' y y' z. (s,s') \ act & paulson@13786: h(x,y) = h'(s,z) & h(x',y') = h'(s',z)}" paulson@13786: by (simp add: extend_act_def project_act_def, blast) paulson@13786: paulson@13786: paulson@13812: subsection{*OK and "lift"*} paulson@13786: paulson@13786: lemma act_in_UNION_preserves_fst: paulson@13805: "act \ {(x,x'). fst x = fst x'} ==> act \ UNION (preserves fst) Acts" paulson@13786: apply (rule_tac a = "mk_program (UNIV,{act},UNIV) " in UN_I) paulson@13786: apply (auto simp add: preserves_def stable_def constrains_def) paulson@13786: done paulson@13786: paulson@13786: lemma UNION_OK_lift_I: paulson@13805: "[| \i \ I. F i \ preserves snd; paulson@13805: \i \ I. UNION (preserves fst) Acts \ AllowedActs (F i) |] paulson@13786: ==> OK I (%i. lift i (F i))" paulson@13790: apply (auto simp add: OK_def lift_def rename_def Extend.Acts_extend) paulson@13798: apply (simp add: Extend.AllowedActs_extend project_act_extend_act) paulson@13786: apply (rename_tac "act") paulson@13786: apply (subgoal_tac paulson@13786: "{(x, x'). \s f u s' f' u'. paulson@13805: ((s, f, u), s', f', u') \ act & paulson@13786: lift_map j x = lift_map i (s, f, u) & paulson@13786: lift_map j x' = lift_map i (s', f', u') } paulson@13805: \ { (x,x') . fst x = fst x'}") paulson@13786: apply (blast intro: act_in_UNION_preserves_fst, clarify) paulson@13786: apply (drule_tac x = j in fun_cong)+ paulson@13786: apply (drule_tac x = i in bspec, assumption) paulson@13786: apply (frule preserves_imp_eq, auto) paulson@13786: done paulson@13786: paulson@13786: lemma OK_lift_I: paulson@13805: "[| \i \ I. F i \ preserves snd; paulson@13805: \i \ I. preserves fst \ Allowed (F i) |] paulson@13786: ==> OK I (%i. lift i (F i))" paulson@13786: by (simp add: safety_prop_AllowedActs_iff_Allowed UNION_OK_lift_I) paulson@13786: paulson@13786: lemma Allowed_lift [simp]: "Allowed (lift i F) = lift i ` (Allowed F)" wenzelm@46577: by (simp add: lift_def) paulson@13786: paulson@13790: lemma lift_image_preserves: paulson@13790: "lift i ` preserves v = preserves (v o drop_map i)" wenzelm@46577: by (simp add: rename_image_preserves lift_def) paulson@13786: paulson@7186: end