subsection \<open>ShiftNode Phase\<close>

theory ShiftPhase
  imports
    Common
begin

phase ShiftNode
  terminating size
begin

fun intval_log2 :: "Value \<Rightarrow> Value" where
  "intval_log2 (IntVal b v) = IntVal b (word_of_int (SOME e. v=2^e))" |
  "intval_log2 _ = UndefVal"

fun in_bounds :: "Value \<Rightarrow> int \<Rightarrow> int \<Rightarrow> bool" where
  "in_bounds (IntVal b v) l h = (l < sint v \<and> sint v < h)" |
  "in_bounds _ l h = False"

lemma
  assumes "in_bounds (intval_log2 val_c) 0 32"
  shows "intval_left_shift x (intval_log2 val_c) = intval_mul x val_c"
  apply (cases val_c; auto) using intval_left_shift.simps(1) intval_mul.simps(1) intval_log2.simps(1)
  sorry

lemma e_intval:
  "n = intval_log2 val_c \<and> in_bounds n 0 32 \<longrightarrow>
    intval_left_shift x (intval_log2 val_c) =
    intval_mul x val_c"
proof (rule impI)
  assume "n = intval_log2 val_c \<and> in_bounds n 0 32"
  show "intval_left_shift x (intval_log2 val_c) =
    intval_mul x val_c"
    proof (cases "\<exists> v . val_c = IntVal 32 v")
      case True
      obtain vc where "val_c = IntVal 32 vc"
        using True by blast
      then have "n = IntVal 32 (word_of_int (SOME e. vc=2^e))"
        using \<open>n = intval_log2 val_c \<and> in_bounds n 0 32\<close> intval_log2.simps(1) by presburger
      then show ?thesis sorry
    next
      case False
      then have "\<exists> v . val_c = IntVal 64 v"
        sorry (* no longer true
        by (metis \<open>n = intval_log2 val_c \<and> in_bounds n 0 32\<close> in_bounds.simps(3) intval_log2.elims)*)
      then obtain vc where "val_c = IntVal 64 vc"
        by auto
      then have "n = IntVal 64 (word_of_int (SOME e. vc=2^e))"
        using \<open>n = intval_log2 val_c \<and> in_bounds n 0 32\<close> intval_log2.simps(1) by presburger
      then show ?thesis sorry
qed
qed

optimization e:
  "x * (const c) \<longmapsto> x << (const n) when (n = intval_log2 c \<and> in_bounds n 0 32)"
  using e_intval
  using BinaryExprE ConstantExprE bin_eval.simps(2,7) sorry

end

end


(*
    Author:      Norbert Schirmer
    Maintainer:  Norbert Schirmer, norbert.schirmer at web de
    License:     LGPL
*)

(*  Title:      Closure.thy
    Author:     Norbert Schirmer, TU Muenchen

Copyright (C) 2006-2008 Norbert Schirmer
Some rights reserved, TU Muenchen

This library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2.1 of the
License, or (at your option) any later version.

This library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
USA
*)

section "Experiments with Closures"

theory Closure
imports "../Hoare"
begin

definition
"callClosure upd cl = Seq (Basic (upd (fst cl))) (Call (snd cl))"

definition
"dynCallClosure init upd cl return c =
  DynCom (\<lambda>s. call (upd (fst (cl s)) \<circ> init) (snd (cl s)) return c)"

lemma dynCallClosure_sound:
assumes adapt:
  "P \<subseteq> {s. \<exists>P' Q' A'. \<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A' \<and>
                  init s \<in> P' \<and>
                  (\<forall>t \<in> Q'. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A'. return s t \<in> A)}"
assumes res: "\<forall>s t n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows
"\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
proof (rule cnvalidI)
  fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P Call p Q,A"
  assume exec: "\<Gamma>\<turnstile> \<langle>dynCallClosure init upd cl return c,Normal s\<rangle> =n\<Rightarrow> t"
  from execn.Basic [where f="(upd (fst (cl s)))" and s="(init s)"]
  have exec_upd: "\<Gamma>\<turnstile>\<langle>Basic (upd (fst (cl s))),Normal (init s)\<rangle> =n\<Rightarrow>
             Normal (((upd (fst (cl s))) \<circ> init) s)"
      by auto
  assume P: "s \<in> P"
  from P adapt obtain P' Q' A'
      where
      valid: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A'" and
      init_P': "init s \<in> P'"  and
      R: "(\<forall>t \<in> Q'. return s t \<in> R s t)" and
      A: "(\<forall>t \<in> A'. return s t \<in> A)"
      by auto
  assume t_notin_F: "t \<notin> Fault ` F"
  from exec [simplified dynCallClosure_def]
  have exec_call:
      "\<Gamma>\<turnstile>\<langle>call (upd (fst (cl s)) \<circ> init) (snd (cl s)) return c,Normal s\<rangle> =n\<Rightarrow> t"
    by cases
  then
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
  proof (cases rule: execn_call_Normal_elim)
    fix bdy m t'
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Normal t'"
    assume exec_c: "\<Gamma>\<turnstile>\<langle>c s t',Normal (return s t')\<rangle> =Suc m\<Rightarrow> t"
    assume n: "n = Suc m"
    have "\<Gamma>\<turnstile>\<langle>Basic init,Normal s\<rangle> =m\<Rightarrow> Normal (init s)"
      by (rule execn.Basic)
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Normal t'"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n]exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Normal t'"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P']
    have "t' \<in> Q'"
      by auto
    with R have "return s t' \<in> R s t'"
      by auto
    from cnvalidD [OF res [rule_format] ctxt exec_c [simplified n[symmetric]] this
         t_notin_F]
    show ?thesis
      by auto
  next
    fix bdy m t'
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Abrupt t'"
    assume t: "t=Abrupt (return s t')"
    assume n: "n = Suc m"
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Abrupt t'"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Abrupt t'"
      by (simp add: callClosure_def n)

    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P']
    have "t' \<in> A'"
      by auto
    with A have "return s t' \<in> A"
      by auto
    with t show ?thesis
      by auto
  next
    fix bdy m f
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Fault f"
    assume t: "t=Fault f"
    assume n: "n = Suc m"
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Fault f"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Fault f"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  next
    fix bdy m
    assume bdy: "\<Gamma> (snd (cl s)) = Some bdy"
    assume exec_body: "\<Gamma>\<turnstile>\<langle>bdy,Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =m\<Rightarrow> Stuck"
    assume t: "t=Stuck"
    assume n: "n = Suc m"
    from execn.Basic [where f="(upd (fst (cl s)))" and s="(init s)"]
    have exec_upd: "\<Gamma>\<turnstile>\<langle>Basic (upd (fst (cl s))),Normal (init s)\<rangle> =Suc m\<Rightarrow>
             Normal (((upd (fst (cl s))) \<circ> init) s)"
      by auto
    from bdy exec_body
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Stuck"
      by (rule execn.Call)
    from execn.Seq [OF exec_upd [simplified n] exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Stuck"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  next
    fix m
    assume no_bdy: "\<Gamma> (snd (cl s)) = None"
    assume t: "t=Stuck"
    assume n: "n = Suc m"
    from no_bdy
    have exec_callC:
      "\<Gamma>\<turnstile>\<langle>Call (snd (cl s)),Normal ((upd (fst (cl s)) \<circ> init) s)\<rangle> =Suc m\<Rightarrow> Stuck"
      by (rule execn.CallUndefined)
    from execn.Seq [OF exec_upd [simplified n]exec_callC]
    have exec_closure: "\<Gamma>\<turnstile> \<langle>callClosure upd (cl s),Normal (init s)\<rangle> =n\<Rightarrow> Stuck"
      by (simp add: callClosure_def n)
    from cnvalidD [OF valid [rule_format] ctxt exec_closure init_P'] t_notin_F t
    have False
      by auto
    thus ?thesis ..
  qed
qed

lemma dynCallClosure:
assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub> P' (callClosure upd (cl s)) Q',A' \<and>
                  init s \<in> P' \<and>
                  (\<forall>t \<in> Q'. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A'. return s t \<in> A)}"
assumes res: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
shows
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
  apply (rule hoare_complete')
  apply (rule allI)
  apply (rule dynCallClosure_sound [where R=R])
  using adapt
  apply (blast intro: hoare_cnvalid)
  using res
  apply (blast intro: hoare_cnvalid)
  done

lemma dynCallClosureFix:
assumes adapt: "P \<subseteq> {s. \<exists>Z. cl'=cl s \<and>
                  init s \<in> P' Z \<and>
                  (\<forall>t \<in> Q' Z. return s t \<in> R s t) \<and>
                  (\<forall>t \<in> A' Z. return s t \<in> A)}"
assumes res: "\<forall>s t. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (R s t) (c s t) Q,A"
assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub> (P' Z) (callClosure upd cl') (Q' Z),(A' Z)"
shows
"\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F \<^esub>P (dynCallClosure init upd cl return c) Q,A"
  apply (rule dynCallClosure [OF _ res])
  using adapt spec
  apply clarsimp
  apply (drule (1) in_subsetD)
  apply clarsimp
  apply (rule_tac x="P' Z" in exI)
  apply (rule_tac x="Q' Z" in exI)
  apply (rule_tac x="A' Z" in exI)
  apply blast
  done

lemma conseq_extract_pre:
             "\<lbrakk>\<forall>s \<in> P. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> ({s}) c Q,A\<rbrakk>
              \<Longrightarrow>
              \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P c Q,A"
  apply (rule hoarep.Conseq)
  apply clarify
  apply (rule_tac x="{s}" in exI)
  apply (rule_tac x="Q" in exI)
  apply (rule_tac x="A" in exI)
  by simp

lemma app_closure_sound:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P' (callClosure upd (e',p)) Q',A' \<and>
                           upd x s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  shows "\<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
proof (rule cnvalidI)
  fix s t
  assume ctxt: "\<forall>(P, p, Q, A)\<in>\<Theta>. \<Gamma>\<Turnstile>n:\<^bsub>/F\<^esub> P Call p Q,A"
  assume exec_e: "\<Gamma>\<turnstile> \<langle>callClosure upd (e, p),Normal s\<rangle> =n\<Rightarrow> t"
  assume P: "s \<in> P"
  assume t: "t \<notin> Fault ` F"
  from P adapt obtain P' Q' A'
    where
    valid: "\<forall>n. \<Gamma>,\<Theta>\<Turnstile>n:\<^bsub>/F \<^esub> P' (callClosure upd (e',p)) Q',A'" and
    init_P': "upd x s \<in> P'"  and
    Q: "Q' \<subseteq> Q" and
    A: "A' \<subseteq> A"
    by auto
  from exec_e [simplified callClosure_def] obtain s'
    where
    exec_e: "\<Gamma>\<turnstile> \<langle>Basic (upd (fst (e, p))),Normal s\<rangle> =n\<Rightarrow> s'"and
    exec_p: "\<Gamma>\<turnstile> \<langle>Call (snd (e, p)),s'\<rangle> =n\<Rightarrow> t"
    by cases
  from exec_e [simplified]
  have s': "s'=Normal (upd e s)"
    by cases simp
  from ap obtain s'' where
   s'': "upd x s = s''" and upd_e': "upd e' s''=upd e s"
    by auto
  from ap s' execn.Basic [where f="(upd (fst (e', p)))" and s="upd x s" and \<Gamma>=\<Gamma>]
  have exec_e': "\<Gamma>\<turnstile> \<langle>Basic (upd (fst (e', p))),Normal (upd x s)\<rangle> =n\<Rightarrow> s'"
    by simp
  with exec_p
  have "\<Gamma>\<turnstile> \<langle>callClosure upd (e', p),Normal (upd x s)\<rangle> =n\<Rightarrow> t"
    by (auto simp add: callClosure_def intro: execn.Seq)
  from cnvalidD [OF valid [rule_format] ctxt this init_P'] t Q A
  show "t \<in> Normal ` Q \<union> Abrupt ` A"
    by auto
qed

lemma app_closure:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (callClosure upd (e',p)) Q',A' \<and>
                           upd x s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
  apply (rule hoare_complete')
  apply (rule allI)
  apply (rule app_closure_sound [where x=x and e'=e', OF _ ap])
  using adapt
  apply (blast intro: hoare_cnvalid)
  done

lemma app_closure_spec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. upd x s \<in> P' Z \<and> Q' Z \<subseteq> Q \<and> A' Z \<subseteq> A}"
  assumes ap: "upd e = upd e' \<circ> upd x"
  assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (callClosure upd (e',p)) (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure upd (e,p)) Q,A"
  apply (rule app_closure [OF _ ap])
  apply clarsimp
  using adapt spec
  apply -
  apply (drule (1) in_subsetD)
  apply clarsimp
  apply (rule_tac x="P' Z" in exI)
  apply (rule_tac x="Q' Z" in exI)
  apply (rule_tac x="A' Z" in exI)
  apply blast
  done

text \<open>Implementation of closures as association lists.\<close>

definition "gen_upd var es s = foldl (\<lambda>s (x,i). the (var x) i s) s es"
definition "ap es c \<equiv> (es@fst c,snd c)"

lemma gen_upd_app: "\<And>es'. gen_upd var (es@es') = gen_upd var es' \<circ> gen_upd var es"
  apply (induct es)
  apply  (rule ext)
  apply  (simp add: gen_upd_def)
  apply (rule ext)
  apply (simp add: gen_upd_def)
  done

lemma gen_upd_ap:
  "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
  by (simp add: gen_upd_app ap_def)

lemma ap_closure:
  assumes adapt: "P \<subseteq> {s. \<exists>P' Q' A'. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P' (callClosure (gen_upd var) c) Q',A' \<and>
                           gen_upd var es s \<in> P' \<and> Q' \<subseteq> Q \<and> A' \<subseteq> A}"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure (gen_upd var) (ap es c)) Q,A"
proof -
  obtain es' p where c: "c=(es',p)"
    by (cases c)
  have "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
    by (simp add: gen_upd_ap)
  from app_closure [OF adapt [simplified c] this]
  show ?thesis
    by (simp add: c ap_def)
qed

lemma ap_closure_spec:
  assumes adapt: "P \<subseteq> {s. \<exists>Z. gen_upd var es s \<in> P' Z \<and> Q' Z \<subseteq> Q \<and> A' Z \<subseteq> A}"
  assumes spec: "\<forall>Z. \<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> (P' Z) (callClosure (gen_upd var) c) (Q' Z),(A' Z)"
  shows "\<Gamma>,\<Theta>\<turnstile>\<^bsub>/F\<^esub> P (callClosure (gen_upd var) (ap es c)) Q,A"
proof -
  obtain es' p where c: "c=(es',p)"
    by (cases c)
  have "gen_upd var (fst (ap es (es',p))) = gen_upd var es' \<circ> gen_upd var es"
    by (simp add: gen_upd_ap)
  from app_closure_spec [OF adapt [simplified c] this spec [simplified c]]
  show ?thesis
    by (simp add: c ap_def)
qed

end


(*
    Author:      Salomon Sickert
    License:     BSD
*)

section \<open>Auxiliary List Facts\<close>

theory List2
  imports Main "HOL-Library.Omega_Words_Fun" "List-Index.List_Index"
begin

subsection \<open>remdups\_fwd\<close>
\<comment> \<open>Remove duplicates of a list in a forward moving direction\<close>

fun remdups_fwd_acc
where
  "remdups_fwd_acc Acc [] = []"
| "remdups_fwd_acc Acc (x#xs) = (if x \<in> Acc then [] else [x]) @ remdups_fwd_acc (insert x Acc) xs"

lemma remdups_fwd_acc_append[simp]:
  "remdups_fwd_acc Acc (xs@ys) = (remdups_fwd_acc Acc xs) @ (remdups_fwd_acc (Acc \<union> set xs) ys)"
  by (induction xs arbitrary: Acc) simp+

lemma remdups_fwd_acc_set[simp]:
  "set (remdups_fwd_acc Acc xs) = set xs - Acc"
  by (induction xs arbitrary: Acc) force+

lemma remdups_fwd_acc_distinct:
  "distinct (remdups_fwd_acc Acc xs)"
  by (induction xs arbitrary: Acc rule: rev_induct) simp+

lemma remdups_fwd_acc_empty:
  "set xs \<subseteq> Acc \<longleftrightarrow> remdups_fwd_acc Acc xs = []"
  by (metis remdups_fwd_acc_set set_empty Diff_eq_empty_iff Diff_eq_empty_iff)

lemma remdups_fwd_acc_drop:
  "set ys \<subseteq> Acc \<union> set xs \<Longrightarrow> remdups_fwd_acc Acc (xs @ ys @ zs) = remdups_fwd_acc Acc (xs @ zs)"
  by (simp add: remdups_fwd_acc_empty sup.absorb1)

lemma remdups_fwd_acc_filter:
  "remdups_fwd_acc Acc (filter P xs) = filter P (remdups_fwd_acc Acc xs)"
  by (induction xs rule: rev_induct) simp+

fun remdups_fwd
where
  "remdups_fwd xs = remdups_fwd_acc {} xs "

lemma remdups_fwd_eq:
  "remdups_fwd xs = (rev o remdups o rev) xs"
  by (induction xs rule: rev_induct) simp+

lemma remdups_fwd_set[simp]:
  "set (remdups_fwd xs) = set xs"
  by simp

lemma remdups_fwd_distinct:
  "distinct (remdups_fwd xs)"
  using remdups_fwd_acc_distinct by simp

lemma remdups_fwd_filter:
  "remdups_fwd (filter P xs) = filter P (remdups_fwd xs)"
  using remdups_fwd_acc_filter by simp

subsection \<open>Split Lemmas\<close>

lemma map_splitE:
  assumes "map f xs = ys @ zs"
  obtains us vs where "xs = us @ vs" and "map f us = ys" and "map f vs = zs"
  by (insert assms; induction ys arbitrary: xs)
     (simp_all add: map_eq_Cons_conv, metis append_Cons)

lemma filter_split':
  "filter P xs = ys @ zs \<Longrightarrow> \<exists>us vs. xs = us @ vs \<and> filter P us = ys \<and> filter P vs = zs"
proof (induction ys arbitrary: zs xs rule: rev_induct)
  case (snoc y ys)
    obtain us vs where "xs = us @ vs" and "filter P us = ys" and "filter P vs = y # zs"
      using snoc(1)[OF snoc(2)[unfolded append_assoc]] by auto
    moreover
    then obtain vs' vs'' where "vs = vs' @ y # vs''" and "y \<notin> set vs'" and "(\<forall>u\<in>set vs'. \<not> P u)" and "filter P vs'' = zs" and "P y"
      unfolding filter_eq_Cons_iff by blast
    ultimately
    have "xs = (us @ vs' @ [y]) @ vs''" and "filter P (us @ vs' @ [y]) = ys @ [y]" and "filter P (vs'') = zs"
      unfolding filter_append by auto
    thus ?case
      by blast
qed fastforce

lemma filter_splitE:
  assumes "filter P xs = ys @ zs"
  obtains us vs where "xs = us @ vs" and "filter P us = ys" and "filter P vs = zs"
  using filter_split'[OF assms] by blast

lemma filter_map_splitE:
  assumes "filter P (map f xs) = ys @ zs"
  obtains us vs where "xs = us @ vs" and "filter P (map f us) = ys" and "filter P (map f vs) = zs"
  using assms by (fastforce elim: filter_splitE map_splitE)

lemma filter_map_split_iff:
  "filter P (map f xs) = ys @ zs \<longleftrightarrow> (\<exists>us vs. xs = us @ vs \<and> filter P (map f us) = ys \<and> filter P (map f vs) = zs)"
  by (fastforce elim: filter_map_splitE)

lemma list_empty_prefix:
  "xs @ y # zs = y # us \<Longrightarrow> y \<notin> set xs \<Longrightarrow> xs = []"
  by (metis hd_append2 list.sel(1) list.set_sel(1))

lemma remdups_fwd_split:
  "remdups_fwd_acc Acc xs = ys @ zs \<Longrightarrow> \<exists>us vs. xs = us @ vs \<and> remdups_fwd_acc Acc us = ys \<and> remdups_fwd_acc (Acc \<union> set ys) vs = zs"
proof (induction ys arbitrary: zs rule: rev_induct)
  case (snoc y ys)
    then obtain us vs where "xs = us @ vs"
      and "remdups_fwd_acc Acc us = ys"
      and "remdups_fwd_acc (Acc \<union> set ys) vs = y # zs"
      by fastforce
    moreover
    hence "y \<in> set vs" and "y \<notin> Acc \<union> set ys"
      using remdups_fwd_acc_set[of "Acc \<union> set ys" vs] by auto
    moreover
    then obtain vs' vs'' where "vs = vs' @ y # vs''" and "y \<notin> set vs'"
      using split_list_first by metis
    moreover
    hence "remdups_fwd_acc (Acc \<union> set ys) vs' = []"
      using \<open>remdups_fwd_acc (Acc \<union> set ys) vs = y # zs\<close> \<open>y \<notin> Acc \<union> set ys\<close>
      by (force intro: list_empty_prefix)
    ultimately
    have "xs = (us @ vs' @ [y]) @ vs''"
      and "remdups_fwd_acc Acc (us @ vs' @ [y]) = ys @ [y]"
      and "remdups_fwd_acc (Acc \<union> set (ys @ [y])) vs'' = zs"
      by (auto simp add: remdups_fwd_acc_empty sup.absorb1)
    thus ?case
      by blast
qed force

lemma remdups_fwd_split_exact:
  assumes "remdups_fwd_acc Acc xs = ys @ x # zs"
  shows "\<exists>us vs. xs = us @ x # vs \<and> x \<notin> Acc \<and> x \<notin> set ys \<and> remdups_fwd_acc Acc us = ys \<and> remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs = zs"
proof -
  obtain us vs where "xs = us @ vs" and "remdups_fwd_acc Acc us = ys" and "remdups_fwd_acc (Acc \<union> set ys) vs = x # zs"
    using assms by (blast dest: remdups_fwd_split)
  moreover
  hence "x \<in> set vs" and "x \<notin> Acc \<union> set ys"
    using remdups_fwd_acc_set[of "Acc \<union> set ys"] by (fastforce, metis (no_types) Diff_iff list.set_intros(1))
  moreover
  then obtain vs' vs'' where "vs = vs' @ x # vs''" and "x \<notin> set vs'"
    by (blast dest: split_list_first)
  moreover
  hence "set vs' \<subseteq> Acc \<union> set ys"
    using \<open>remdups_fwd_acc (Acc \<union> set ys) vs = x # zs\<close> \<open>x \<notin> Acc \<union> set ys\<close>
    unfolding remdups_fwd_acc_empty by (fastforce intro: list_empty_prefix)
  moreover
  hence "remdups_fwd_acc (Acc \<union> set ys) vs' = []"
    using remdups_fwd_acc_empty by blast
  ultimately
  have "xs = (us @ vs') @ x # vs''"
    and "remdups_fwd_acc Acc (us @ vs') = ys"
    and "remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs'' = zs"
    by (fastforce dest: sup.absorb1)+
  thus ?thesis
    using \<open>x \<notin> Acc \<union> set ys\<close> by blast
qed

lemma remdups_fwd_split_exactE:
  assumes "remdups_fwd_acc Acc xs = ys @ x # zs"
  obtains us vs where "xs = us @ x # vs" and "x \<notin> set us" and "remdups_fwd_acc Acc us = ys" and "remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs = zs"
    using remdups_fwd_split_exact[OF assms] by auto

lemma remdups_fwd_split_exact_iff:
  "remdups_fwd_acc Acc xs = ys @ x # zs \<longleftrightarrow>
    (\<exists>us vs. xs = us @ x # vs \<and> x \<notin> Acc \<and> x \<notin> set us \<and> remdups_fwd_acc Acc us = ys \<and> remdups_fwd_acc (Acc \<union> set ys \<union> {x}) vs = zs)"
  using remdups_fwd_split_exact by fastforce

lemma sorted_pre:
  "(\<And>x y xs ys. zs = xs @ [x, y] @ ys \<Longrightarrow> x \<le> y) \<Longrightarrow> sorted zs"
apply (induction zs)
 apply simp
by (metis append_Nil append_Cons list.exhaust sorted1 sorted2)

lemma sorted_list:
  assumes "x \<in> set xs" and "y \<in> set xs"
  assumes "sorted (map f xs)" and "f x < f y"
  shows "\<exists>xs' xs'' xs'''. xs = xs' @ x # xs'' @ y # xs'''"
proof -
  obtain ys zs where "xs = ys @ y # zs" and "y \<notin> set ys"
    using assms by (blast dest: split_list_first)
  moreover
  hence "sorted (map f (y # zs))"
    using \<open>sorted (map f xs)\<close> by (simp add: sorted_append)
  hence "\<forall>x\<in>set (map f (y # zs)). f y \<le> x"
    by force
  hence "\<forall>x\<in>set (y # zs). f y \<le> f x"
    by auto
  have "x \<in> set ys"
    apply (rule ccontr)
    using \<open>f x < f y\<close> \<open>x \<in> set xs\<close> \<open>\<forall>x\<in>set (y # zs). f y \<le> f x\<close> unfolding \<open>xs = ys @ y # zs\<close> set_append by auto
  then obtain ys' zs' where "ys = ys' @ x # zs'"
    using assms by (blast dest: split_list_first)
  ultimately
  show ?thesis
    by auto
qed

lemma takeWhile_foo:
  "x \<notin> set ys \<Longrightarrow> ys = takeWhile (\<lambda>y. y \<noteq> x) (ys @ x # zs)"
  by (metis (mono_tags, lifting) append_Nil2 takeWhile.simps(2) takeWhile_append2)

lemma takeWhile_split:
  "x \<in> set xs \<Longrightarrow> y \<in> set (takeWhile (\<lambda>y. y \<noteq> x) xs) \<Longrightarrow> \<exists>xs' xs'' xs'''. xs = xs' @ y # xs'' @ x # xs'''"
  using split_list_first by (metis append_Cons append_assoc takeWhile_foo)

lemma takeWhile_distinct:
  "distinct (xs' @ x # xs'') \<Longrightarrow> y \<in> set (takeWhile (\<lambda>y. y \<noteq> x) (xs' @ x # xs'')) \<longleftrightarrow> y \<in> set xs'"
  by (induction xs') simp+

lemma finite_lists_length_eqE:
  assumes "finite A"
  shows "finite {xs. set xs = A \<and> length xs = n}"
proof -
  have "{xs. set xs = A \<and> length xs = n} \<subseteq> {xs. set xs \<subseteq> A \<and> length xs = n}"
    by blast
  thus ?thesis
    using finite_lists_length_eq[OF assms(1), of n] using finite_subset by auto
qed

lemma finite_set2:
  assumes "card A = n" and "finite A"
  shows "finite {xs. set xs = A \<and> distinct xs}"
proof -
  have "{xs. set xs = A \<and> distinct xs} \<subseteq> {xs. set xs = A \<and> length xs = n}"
    using assms(1) distinct_card by fastforce
  thus ?thesis
    by (metis (no_types, lifting) finite_lists_length_eqE[OF \<open>finite A\<close>, of n] finite_subset)
qed

lemma set_list:
  assumes "finite (set ` XS)"
  assumes "\<And>xs. xs \<in> XS \<Longrightarrow> distinct xs"
  shows "finite XS"
proof -
  have "XS \<subseteq> {xs | xs. set xs \<in> set ` XS \<and> distinct xs}"
    using assms by auto
  moreover
  have 1: "{xs |xs. set xs \<in> set ` XS \<and> distinct xs} = \<Union>{{xs | xs. set xs = A \<and> distinct xs} | A. A \<in> set ` XS}"
    by auto
  have "finite {xs |xs. set xs \<in> set ` XS \<and> distinct xs}"
    using finite_set2[OF _ finite_set] distinct_card  assms(1) unfolding 1 by fastforce
  ultimately
  show ?thesis
    using finite_subset by blast
qed

lemma set_foldl_append:
  "set (foldl (@) i xs) = set i \<union> \<Union>{set x | x. x \<in> set xs}"
  by (induction xs arbitrary: i) auto

subsection \<open>Short-circuited Version of @{const foldl}\<close>

fun foldl_break :: "('b \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> ('b \<Rightarrow> bool) \<Rightarrow> 'b \<Rightarrow> 'a list \<Rightarrow> 'b"
where
  "foldl_break f s a [] = a"
| "foldl_break f s a (x # xs) = (if s a then a else foldl_break f s (f a x) xs)"

lemma foldl_break_append:
  "foldl_break f s a (xs @ ys) = (if s (foldl_break f s a xs) then foldl_break f s a xs else (foldl_break f s (foldl_break f s a xs) ys))"
  by (induction xs arbitrary: a) (cases ys, auto)

subsection \<open>Suffixes\<close>

\<comment> \<open>Non empty suffixes of finite words - specialised!\<close>

fun suffixes
where
  "suffixes [] = []"
| "suffixes (x#xs) = (suffixes xs) @ [x#xs]"

lemma suffixes_append:
  "suffixes (xs @ ys) = (suffixes ys) @ (map (\<lambda>zs. zs @ ys) (suffixes xs))"
  by (induction xs) simp_all

lemma suffixes_alt_def:
  "suffixes xs = rev (prefix (length xs) (\<lambda>i. drop i xs))"
proof (induction xs rule: rev_induct)
  case (snoc x xs)
    show ?case
      by (simp add: subsequence_def suffixes_append snoc rev_map)
qed simp

end


(*  Author: Tobias Nipkow  *)

header {* Combining All Completeness Proofs *}

theory Completeness
imports ArchCompProps ArchComp
begin

definition Archive :: "vertex fgraph set" where
"Archive \<equiv> set(Tri @ Quad @ Pent @ Hex)"

theorem TameEnum_Archive:  "fgraph ` TameEnum \<subseteq>\<^sub>\<simeq> Archive"
using combine_evals_filter[OF pre_iso_test3 same3]
      combine_evals_filter[OF pre_iso_test4 same4]
      combine_evals_filter[OF pre_iso_test5 same5]
      combine_evals_filter[OF pre_iso_test6 same6]
by(fastforce simp:TameEnum_def Archive_def image_def qle_gr.defs
       eval_nat_numeral le_Suc_eq)

lemma TameEnum_comp:
assumes "Seed\<^bsub>p\<^esub> [next_plane\<^bsub>p\<^esub>]\<rightarrow>* g" and "final g" and "tame g"
shows "Seed\<^bsub>p\<^esub> [next_tame\<^bsub>p\<^esub>]\<rightarrow>* g"
proof -
  from assms have "Seed\<^bsub>p\<^esub> [next_tame0 p]\<rightarrow>* g" by(rule next_tame0_comp)
  with assms show "Seed\<^bsub>p\<^esub> [next_tame\<^bsub>p\<^esub>]\<rightarrow>* g" by(blast intro: next_tame_comp)
qed

(* final not necessary but slightly simpler because of lemmas *)
lemma tame5:
assumes g: "Seed\<^bsub>p\<^esub> [next_plane0\<^bsub>p\<^esub>]\<rightarrow>* g" and "final g" and "tame g"
shows "p \<le> 3"
proof -
  from `tame g` have bound: "\<forall>f \<in> \<F> g. |vertices f| \<le> 6"
    by (simp add: tame_def tame9a_def)
  show "p \<le> 3"
  proof (rule ccontr)
    assume 6: "\<not> p \<le> 3"
    obtain f where "f \<in> set (finals g) & |vertices f| = p+3"
      using max_face_ex[OF g] by auto
    also from `final g` have "set (finals g) = set (faces g)" by simp
    finally have "f \<in> \<F> g & 6 < |vertices f|" using 6 by arith
    with bound show False by auto
  qed
qed

theorem completeness:
assumes "g \<in> PlaneGraphs" and "tame g" shows "fgraph g \<in>\<^sub>\<simeq> Archive"
proof -
  from `g \<in> PlaneGraphs` obtain p where g1: "Seed\<^bsub>p\<^esub> [next_plane\<^bsub>p\<^esub>]\<rightarrow>* g"
    and "final g"
    by(auto simp:PlaneGraphs_def PlaneGraphsP_def)
  have "Seed\<^bsub>p\<^esub> [next_plane0\<^bsub>p\<^esub>]\<rightarrow>* g"
    by(rule RTranCl_subset2[OF g1])
      (blast intro:inv_mgp inv_Seed mgp_next_plane0_if_next_plane
        dest:RTranCl_inv[OF inv_inv_next_plane])
  with `tame g` `final g` have "p \<le> 3" by(blast intro:tame5)
  with g1 `tame g` `final g` show ?thesis using TameEnum_Archive
    by(simp add: qle_gr.defs TameEnum_def TameEnumP_def)
      (blast intro: TameEnum_comp)
qed

end


(* Title: thys/ComposableTMs_aux.thy
   Author: Franz Regensburger (FABR) 02/2022
 *)

theory ComposableTMs_aux
  imports ComposableTMs
begin

(* --------------------------------------------------- *)
(* Exhaustion-/Case-Lemmas for actions and instr lists *)
(* Currently none of these lemmas is in use            *)
(* --------------------------------------------------- *)

lemma nat_cases_0_1_gt1 (* [case_names Zero One GtOne, cases type: nat] *) :
  assumes "(n::nat) = (0::nat) \<Longrightarrow> P"
    and "(n::nat) = (1::nat) \<Longrightarrow> P"
    and "2 \<le> (n::nat) \<Longrightarrow> P"
  shows P
proof -
  have "n= 0 \<or> n = 1 \<or> (\<exists>m. n = Suc (Suc m))"
    by (induct n) auto
  with assms  show P by auto
qed

lemma list_len_1_is_singleton: "length l = 1 \<Longrightarrow> (\<exists>x. l = [x])"
  by (induct l) auto

lemma action_exhaust2: "actn = WB \<or> actn = WO \<or> actn = L \<or> actn = R \<or> actn = Nop"
  by (rule Turing.action.exhaust) auto

lemma instr_exhaust: "\<exists>nxt. ins = (WB, nxt)  \<or> ins = (WO, nxt) \<or> ins = (L, nxt) \<or> ins = (R, nxt) \<or> ins = (Nop, nxt)"
proof (cases ins)
  case (Pair a b)
  then have "ins = (a, b)" .
  show ?thesis
  proof (rule Turing.action.exhaust)
    assume "a = WB"
    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
    then show ?thesis by auto
  next
    assume "a = WO"
    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
    then show ?thesis by auto
  next
    assume "a = L"
    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
    then show ?thesis by auto
  next
    assume "a = R"
    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
    then show ?thesis by auto
  next
    assume "a = Nop"
    with \<open>ins = (a, b)\<close> have "ins = (WB, b) \<or> ins = (WO, b) \<or> ins = (L, b) \<or> ins = (R, b) \<or> ins = (Nop, b)" by auto
    then show ?thesis by auto
  qed
qed

(* Attention:
    Secifiying  instr_cases  [case_names WB WO L R Nop, cases type: nat] :
    breaks proofs
      seq_tm_exec_after_first
    in Turingomp.thy
*)
lemma instr_cases (* [case_names WB WO L R Nop, cases type: nat] *) :
  assumes "\<And>nxt. ins = (WB, nxt) \<Longrightarrow> P"
    and "\<And>nxt. ins = (WO, nxt) \<Longrightarrow> P"
    and "\<And>nxt. ins = (L, nxt) \<Longrightarrow> P"
    and "\<And>nxt. ins = (R, nxt) \<Longrightarrow> P"
    and "\<And>nxt. ins = (Nop, nxt) \<Longrightarrow> P"
  shows P
proof -
  have "\<exists>nxt. ins = (WB, nxt)  \<or> ins = (WO, nxt) \<or> ins = (L, nxt) \<or> ins = (R, nxt) \<or> ins = (Nop, nxt)"
    by (rule instr_exhaust)
  then obtain nxt where w_nxt: "ins = (WB, nxt)  \<or> ins = (WO, nxt) \<or> ins = (L, nxt) \<or> ins = (R, nxt) \<or> ins = (Nop, nxt)" by blast
  with assms show P by auto
qed

lemma sigleton_tm_exhaust: "length (tm::instr list) = 1 \<Longrightarrow> \<exists>nxt. tm = [(WB, nxt)]  \<or> tm = [(WO, nxt)] \<or> tm = [(L, nxt)] \<or> tm = [(R, nxt)] \<or> tm = [(Nop, nxt)]"
proof -
  assume "length (tm::instr list) = 1"
  then have "(\<exists>instr. tm = [instr])" by (rule list_len_1_is_singleton)
  then obtain instr where w_instr: "tm = [instr]" by blast
  have "\<exists>nxt. instr = (WB, nxt) \<or> instr = (WO, nxt) \<or> instr = (L, nxt) \<or> instr = (R, nxt) \<or> instr = (Nop, nxt)" by (rule instr_exhaust)
  then obtain nxt where w_nxt: "instr = (WB, nxt) \<or> instr = (WO, nxt) \<or> instr = (L, nxt) \<or> instr = (R, nxt) \<or> instr = (Nop, nxt)" by blast
  with w_instr show ?thesis by auto
qed

lemma split_action_all: "(\<forall>nxt. P nxt) \<longleftrightarrow> (\<forall>nxt. P (WB, nxt)) \<and> (\<forall>nxt. P (WO, nxt)) \<and> (\<forall>nxt. P (L, nxt)) \<and> (\<forall>nxt. P (R, nxt)) \<and> (\<forall>nxt. P (Nop, nxt))"
  by (auto intro: action.induct)

(* Attention:
    Secifiying  tm_instr_cases [consumes 1, case_names WB WO L R Nop, cases type: nat] :
    breaks proofs
      modify_tprog_fetch_odd
    in UF.thy
*)
lemma tm_instr_cases (* [consumes 1, case_names WB WO L R Nop, cases type: nat] *):
  assumes  "length (tm::instr list) = 1"
    and "\<And>nxt. tm = [(WB, nxt)] \<Longrightarrow> P"
    and "\<And>nxt. tm = [(WO, nxt)] \<Longrightarrow> P"
    and "\<And>nxt. tm = [(L, nxt)] \<Longrightarrow> P"
    and "\<And>nxt. tm = [(R, nxt)] \<Longrightarrow> P"
    and "\<And>nxt. tm = [(Nop, nxt)] \<Longrightarrow> P"
  shows P
proof -
  from \<open>length tm = 1\<close> have "\<exists>nxt. tm = [(WB, nxt)]  \<or> tm = [(WO, nxt)] \<or> tm = [(L, nxt)] \<or> tm = [(R, nxt)] \<or> tm = [(Nop, nxt)]"
    by (rule sigleton_tm_exhaust)
  then obtain nxt where w_nxt: "tm = [(WB, nxt)]  \<or> tm = [(WO, nxt)] \<or> tm = [(L, nxt)] \<or> tm = [(R, nxt)] \<or> tm = [(Nop, nxt)]" by blast
  with assms show P by auto
qed

end


(*  Title:      HOL/MicroJava/BV/Altern.thy
    Author:     Martin Strecker
*)

section {* Alternative definition of well-typing of bytecode,  used in compiler type correctness proof *}

theory Altern
imports BVSpec
begin

definition check_type :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> JVMType.state \<Rightarrow> bool" where
  "check_type G mxs mxr s \<equiv> s \<in> states G mxs mxr"

definition wt_instr_altern :: "[instr,jvm_prog,ty,method_type,nat,nat,p_count,
                exception_table,p_count] \<Rightarrow> bool" where
  "wt_instr_altern i G rT phi mxs mxr max_pc et pc \<equiv>
  app i G mxs rT pc et (phi!pc) \<and>
  check_type G mxs mxr (OK (phi!pc)) \<and>
  (\<forall>(pc',s') \<in> set (eff i G pc et (phi!pc)). pc' < max_pc \<and> G \<turnstile> s' <=' phi!pc')"

definition wt_method_altern :: "[jvm_prog,cname,ty list,ty,nat,nat,instr list,
                 exception_table,method_type] \<Rightarrow> bool" where
  "wt_method_altern G C pTs rT mxs mxl ins et phi \<equiv>
  let max_pc = length ins in
  0 < max_pc \<and>
  length phi = length ins \<and>
  check_bounded ins et \<and>
  wt_start G C pTs mxl phi \<and>
  (\<forall>pc. pc<max_pc \<longrightarrow> wt_instr_altern (ins!pc) G rT phi mxs (1+length pTs+mxl) max_pc et pc)"

lemma wt_method_wt_method_altern :
  "wt_method G C pTs rT mxs mxl ins et phi \<longrightarrow> wt_method_altern G C pTs rT mxs mxl ins et phi"
apply (simp add: wt_method_def wt_method_altern_def)
apply (intro strip)
apply clarify
apply (drule spec, drule mp, assumption)
apply (simp add: check_types_def wt_instr_def wt_instr_altern_def check_type_def)
apply (auto  intro: imageI)
done

lemma check_type_check_types [rule_format]:
  "(\<forall>pc. pc < length phi \<longrightarrow> check_type G mxs mxr (OK (phi ! pc)))
  \<longrightarrow> check_types G mxs mxr (map OK phi)"
apply (induct phi)
apply (simp add: check_types_def)
apply (simp add: check_types_def)
apply clarify
apply (frule_tac x=0 in spec)
apply (simp add: check_type_def)
apply auto
done

lemma wt_method_altern_wt_method [rule_format]:
  "wt_method_altern G C pTs rT mxs mxl ins et phi \<longrightarrow> wt_method G C pTs rT mxs mxl ins et phi"
apply (simp add: wt_method_def wt_method_altern_def)
apply (intro strip)
apply clarify
apply (rule conjI)
  (* show check_types *)
apply (rule check_type_check_types)
apply (simp add: wt_instr_altern_def)

  (* show wt_instr *)
apply (intro strip)
apply (drule spec, drule mp, assumption)
apply (simp add: wt_instr_def wt_instr_altern_def)
done

end


theory LinearAlgebra_EuclideanVectorSpace_E1
imports "$HETS_LIB/Isabelle/MainHCPairs"
uses "$HETS_LIB/Isabelle/prelude"
begin

ML "Header.initialize
    [\"subtype_def\", \"subtype_pred_def\",
     \"ga_assoc___Xx__\", \"ga_right_unit___Xx__\",
     \"ga_left_unit___Xx__\", \"inv_Group_2\", \"rinv_Group\",
     \"ga_comm___Xx__\", \"ga_assoc___Xx___1\",
     \"ga_right_unit___Xx___1\", \"ga_left_unit___Xx___1\",
     \"distr1_Ring\", \"distr2_Ring\", \"ga_comm___Xx___1\",
     \"noZeroDiv\", \"zeroNeqOne\", \"Ax1\", \"ga_assoc___Xx___2\",
     \"ga_right_unit___Xx___2\", \"ga_left_unit___Xx___2\",
     \"inv_Group_1\", \"rinv_Group_1\", \"binary_inverse\", \"Ax1_1\",
     \"refl\", \"trans\", \"antisym\", \"dichotomy_TotalOrder\",
     \"FWO_plus_left\", \"FWO_times_left\", \"FWO_plus_right\",
     \"FWO_times_right\", \"FWO_plus\", \"inf_def\",
     \"Real_completeness\", \"geq_def_ExtPartialOrder\",
     \"less_def_ExtPartialOrder\", \"greater_def_ExtPartialOrder\",
     \"ga_comm_inf\", \"ga_comm_sup\", \"inf_def_ExtPartialOrder\",
     \"sup_def_ExtPartialOrder\", \"ga_comm_min\", \"ga_comm_max\",
     \"ga_assoc_min\", \"ga_assoc_max\", \"ga_left_comm_min\",
     \"ga_left_comm_max\", \"min_def_ExtTotalOrder\",
     \"max_def_ExtTotalOrder\", \"min_inf_relation\",
     \"max_sup_relation\", \"RealNonNeg_pred_def\",
     \"RealPos_pred_def\", \"Ax3\", \"Ax4\", \"RealNonNeg_subtype\",
     \"RealPos_subtype\", \"abs_def\", \"ga_assoc___Xx___3\",
     \"ga_right_unit___Xx___3\", \"ga_left_unit___Xx___3\",
     \"inv_Group_3\", \"rinv_Group_2\", \"ga_comm___Xx___3\",
     \"binary_inverse_1\", \"unit\", \"mix_assoc\", \"distr_Field\",
     \"distr_Space\", \"zero_by_left_zero\", \"zero_by_right_zero\",
     \"inverse_by_XMinus1\", \"distributive\", \"homogeneous\",
     \"symmetric\", \"pos_definite\", \"right_distributive\",
     \"right_homogeneous\", \"non_degenerate\"]"

typedecl NonZero
typedecl Real
typedecl RealNonNeg
typedecl RealPos
typedecl Space

consts
X0X1 :: "Real" ("0''")
X0X2 :: "Space" ("0''''")
X1X1 :: "NonZero" ("1''")
X1X2 :: "Real" ("1''''")
XMinus__XX1 :: "Real => Real" ("(-''/ _)" [56] 56)
XMinus__XX2 :: "Space => Space" ("(-''''/ _)" [56] 56)
X_RealNonNeg_inj :: "RealNonNeg => Real" ("RealNonNeg'_inj/'(_')" [3] 999)
X_RealNonNeg_pred :: "Real => bool" ("RealNonNeg'_pred/'(_')" [3] 999)
X_RealNonNeg_proj :: "Real => RealNonNeg" ("RealNonNeg'_proj/'(_')" [3] 999)
X_RealPos_inj :: "RealPos => Real" ("RealPos'_inj/'(_')" [3] 999)
X_RealPos_pred :: "Real => bool" ("RealPos'_pred/'(_')" [3] 999)
X_RealPos_proj :: "Real => RealPos" ("RealPos'_proj/'(_')" [3] 999)
X__XGtXEq__X :: "Real => Real => bool" ("(_/ >=''/ _)" [44,44] 42)
X__XGt__X :: "Real => Real => bool" ("(_/ >''/ _)" [44,44] 42)
X__XLtXEq__X :: "Real => Real => bool" ("(_/ <=''/ _)" [44,44] 42)
X__XLt__X :: "Real => Real => bool" ("(_/ <''/ _)" [44,44] 42)
X__XMinus__XX1 :: "Real => Real => Real" ("(_/ -''/ _)" [54,54] 52)
X__XMinus__XX2 :: "Space => Space => Space" ("(_/ -''''/ _)" [54,54] 52)
X__XPlus__XX1 :: "Real => Real => Real" ("(_/ +''/ _)" [54,54] 52)
X__XPlus__XX2 :: "Space => Space => Space" ("(_/ +''''/ _)" [54,54] 52)
X__XSlash__X :: "Real => NonZero => Real" ("(_/ '/''/ _)" [54,54] 52)
X__Xx__XX1 :: "NonZero => NonZero => NonZero" ("(_/ *''/ _)" [54,54] 52)
X__Xx__XX2 :: "Real => Real => Real" ("(_/ *''''/ _)" [54,54] 52)
X__Xx__XX3 :: "Real => Space => Space" ("(_/ *'_3/ _)" [54,54] 52)
X__Xx__XX4 :: "Space => Space => Real" ("(_/ *'_4/ _)" [54,54] 52)
X_abs :: "Real => RealNonNeg" ("abs''/'(_')" [3] 999)
X_gn_inj :: "'a => 'b" ("gn'_inj/'(_')" [3] 999)
X_gn_proj :: "'a => 'b partial" ("gn'_proj/'(_')" [3] 999)
X_inv :: "NonZero => NonZero" ("inv''/'(_')" [3] 999)
X_isSubtype :: "('s => 't) => ('t => 's) => bool" ("isSubtype/'(_,/ _')" [3,3] 999)
X_isSubtypeWithPred :: "('t => bool) => ('s => 't) => ('t => 's) => bool" ("isSubtypeWithPred/'(_,/ _,/ _')" [3,3,3] 999)
X_max :: "Real => Real => Real" ("max''/'(_,/ _')" [3,3] 999)
X_min :: "Real => Real => Real" ("min''/'(_,/ _')" [3,3] 999)
X_sup :: "Real => Real => Real partial" ("sup/'(_,/ _')" [3,3] 999)
infX1 :: "Real => Real => Real partial" ("inf''/'(_,/ _')" [3,3] 999)
infX2 :: "(Real => bool) => Real partial" ("inf''''/'(_')" [3] 999)

axioms
subtype_def [rule_format] :
"ALL injection.
 ALL projection.
 isSubtype(injection, projection) =
 (ALL x. x = projection (injection x))"

subtype_pred_def [rule_format] :
"ALL P.
 ALL injection.
 ALL projection.
 isSubtypeWithPred(P, injection, projection) =
 ((isSubtype(injection, projection) &
   (ALL x. P x --> x = injection (projection x))) &
  (ALL x. P (injection x)))"

ga_assoc___Xx__ [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) +' z = x +' (y +' z)"

ga_right_unit___Xx__ [rule_format] : "ALL x. x +' 0' = x"

ga_left_unit___Xx__ [rule_format] : "ALL x. 0' +' x = x"

inv_Group_2 [rule_format] : "ALL x. -' x +' x = 0'"

rinv_Group [rule_format] : "ALL x. x +' -' x = 0'"

ga_comm___Xx__ [rule_format] : "ALL x. ALL y. x +' y = y +' x"

ga_assoc___Xx___1 [rule_format] :
"ALL x. ALL y. ALL z. (x *'' y) *'' z = x *'' (y *'' z)"

ga_right_unit___Xx___1 [rule_format] : "ALL x. x *'' 1'' = x"

ga_left_unit___Xx___1 [rule_format] : "ALL x. 1'' *'' x = x"

distr1_Ring [rule_format] :
"ALL x. ALL y. ALL z. (x +' y) *'' z = (x *'' z) +' (y *'' z)"

distr2_Ring [rule_format] :
"ALL x. ALL y. ALL z. z *'' (x +' y) = (z *'' x) +' (z *'' y)"

ga_comm___Xx___1 [rule_format] : "ALL x. ALL y. x *'' y = y *'' x"

noZeroDiv [rule_format] :
"ALL x. ALL y. x *'' y = 0' --> x = 0' | y = 0'"

zeroNeqOne [rule_format] : "~ 1'' = 0'"

Ax1 [rule_format] : "ALL x. defOp (gn_proj(x)) = (~ x = 0')"

ga_assoc___Xx___2 [rule_format] :
"ALL x. ALL y. ALL z. (x *' y) *' z = x *' (y *' z)"

ga_right_unit___Xx___2 [rule_format] : "ALL x. x *' 1' = x"

ga_left_unit___Xx___2 [rule_format] : "ALL x. 1' *' x = x"

inv_Group_1 [rule_format] : "ALL x. inv'(x) *' x = 1'"

rinv_Group_1 [rule_format] : "ALL x. x *' inv'(x) = 1'"

binary_inverse [rule_format] : "ALL x. ALL y. x -' y = x +' -' y"

Ax1_1 [rule_format] :
"ALL x. ALL y. x /' y = x *'' gn_inj(inv'(y))"

refl [rule_format] : "ALL x. x <=' x"

trans [rule_format] :
"ALL x. ALL y. ALL z. x <=' y & y <=' z --> x <=' z"

antisym [rule_format] : "ALL x. ALL y. x <=' y & y <=' x --> x = y"

dichotomy_TotalOrder [rule_format] :
"ALL x. ALL y. x <=' y | y <=' x"

FWO_plus_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b --> a +' c <=' b +' c"

FWO_times_left [rule_format] :
"ALL a. ALL b. ALL c. a <=' b & 0' <=' c --> a *'' c <=' b *'' c"

FWO_plus_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c --> a +' b <=' a +' c"

FWO_times_right [rule_format] :
"ALL a. ALL b. ALL c. b <=' c & 0' <=' a --> a *'' b <=' a *'' c"

FWO_plus [rule_format] :
"ALL a.
 ALL b. ALL c. ALL d. a <=' c & b <=' d --> a +' b <=' c +' d"

inf_def [rule_format] :
"ALL S.
 ALL m.
 inf''(S) = makePartial m =
 (ALL m2. (ALL x. S x --> x <=' m2) --> m <=' m2)"

Real_completeness [rule_format] :
"ALL S.
 (EX x. S x) & (EX B. ALL x. S x --> x <=' B) -->
 (EX m. makePartial m = inf''(S))"

geq_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >=' y) = (y <=' x)"

less_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x <' y) = (x <=' y & ~ x = y)"

greater_def_ExtPartialOrder [rule_format] :
"ALL x. ALL y. (x >' y) = (y <' x)"

ga_comm_inf [rule_format] : "ALL x. ALL y. inf'(x, y) = inf'(y, x)"

ga_comm_sup [rule_format] : "ALL x. ALL y. sup(x, y) = sup(y, x)"

inf_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 inf'(x, y) = makePartial z =
 (z <=' x & z <=' y & (ALL t. t <=' x & t <=' y --> t <=' z))"

sup_def_ExtPartialOrder [rule_format] :
"ALL x.
 ALL y.
 ALL z.
 sup(x, y) = makePartial z =
 (x <=' z & y <=' z & (ALL t. x <=' t & y <=' t --> z <=' t))"

ga_comm_min [rule_format] : "ALL x. ALL y. min'(x, y) = min'(y, x)"

ga_comm_max [rule_format] : "ALL x. ALL y. max'(x, y) = max'(y, x)"

ga_assoc_min [rule_format] :
"ALL x. ALL y. ALL z. min'(min'(x, y), z) = min'(x, min'(y, z))"

ga_assoc_max [rule_format] :
"ALL x. ALL y. ALL z. max'(max'(x, y), z) = max'(x, max'(y, z))"

ga_left_comm_min [rule_format] :
"ALL x. ALL y. ALL z. min'(x, min'(y, z)) = min'(y, min'(x, z))"

ga_left_comm_max [rule_format] :
"ALL x. ALL y. ALL z. max'(x, max'(y, z)) = max'(y, max'(x, z))"

min_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. min'(x, y) = (if x <=' y then x else y)"

max_def_ExtTotalOrder [rule_format] :
"ALL x. ALL y. max'(x, y) = (if x <=' y then y else x)"

min_inf_relation [rule_format] :
"ALL x. ALL y. makePartial (min'(x, y)) = inf'(x, y)"

max_sup_relation [rule_format] :
"ALL x. ALL y. makePartial (max'(x, y)) = sup(x, y)"

RealNonNeg_pred_def [rule_format] :
"ALL x. RealNonNeg_pred(x) = (x >=' 0')"

RealPos_pred_def [rule_format] :
"ALL x. RealPos_pred(x) = (x >' 0')"

Ax3 [rule_format] :
"ALL x. defOp (gn_proj(x)) = RealNonNeg_pred(x)"

Ax4 [rule_format] : "ALL x. defOp (gn_proj(x)) = RealPos_pred(x)"

RealNonNeg_subtype [rule_format] :
"isSubtypeWithPred(X_RealNonNeg_pred, X_RealNonNeg_inj,
 X_RealNonNeg_proj)"

RealPos_subtype [rule_format] :
"isSubtypeWithPred(X_RealPos_pred, X_RealPos_inj, X_RealPos_proj)"

abs_def [rule_format] :
"ALL x.
 makePartial (abs'(x)) =
 (if 0' <=' x then gn_proj(x) else gn_proj(-' x))"

ga_assoc___Xx___3 [rule_format] :
"ALL x. ALL y. ALL z. (x +'' y) +'' z = x +'' (y +'' z)"

ga_right_unit___Xx___3 [rule_format] : "ALL x. x +'' 0'' = x"

ga_left_unit___Xx___3 [rule_format] : "ALL x. 0'' +'' x = x"

inv_Group_3 [rule_format] : "ALL x. -'' x +'' x = 0''"

rinv_Group_2 [rule_format] : "ALL x. x +'' -'' x = 0''"

ga_comm___Xx___3 [rule_format] : "ALL x. ALL y. x +'' y = y +'' x"

binary_inverse_1 [rule_format] :
"ALL x. ALL y. x -'' y = x +'' -'' y"

unit [rule_format] : "ALL x. gn_inj(1') *_3 x = x"

mix_assoc [rule_format] :
"ALL r. ALL s. ALL x. (r *'' s) *_3 x = r *_3 (s *_3 x)"

distr_Field [rule_format] :
"ALL r. ALL s. ALL x. (r +' s) *_3 x = (r *_3 x) +'' (s *_3 x)"

distr_Space [rule_format] :
"ALL r. ALL x. ALL y. r *_3 (x +'' y) = (r *_3 x) +'' (r *_3 y)"

zero_by_left_zero [rule_format] : "ALL x. 0' *_3 x = 0''"

zero_by_right_zero [rule_format] : "ALL r. r *_3 0'' = 0''"

inverse_by_XMinus1 [rule_format] :
"ALL x. -' gn_inj(1') *_3 x = -'' x"

distributive [rule_format] :
"ALL v. ALL v'. ALL w. (v +'' v') *_4 w = (v *_4 w) +' (v' *_4 w)"

homogeneous [rule_format] :
"ALL a. ALL v. ALL w. (a *_3 v) *_4 w = a *'' (v *_4 w)"

symmetric [rule_format] : "ALL v. ALL w. v *_4 w = w *_4 v"

pos_definite [rule_format] : "ALL v. ~ v = 0'' --> v *_4 v >' 0'"

declare ga_assoc___Xx__ [simp]
declare ga_right_unit___Xx__ [simp]
declare ga_left_unit___Xx__ [simp]
declare inv_Group_2 [simp]
declare rinv_Group [simp]
declare ga_comm___Xx__ [simp]
declare ga_assoc___Xx___1 [simp]
declare ga_right_unit___Xx___1 [simp]
declare ga_left_unit___Xx___1 [simp]
declare ga_comm___Xx___1 [simp]
declare ga_assoc___Xx___2 [simp]
declare ga_right_unit___Xx___2 [simp]
declare ga_left_unit___Xx___2 [simp]
declare inv_Group_1 [simp]
declare rinv_Group_1 [simp]
declare refl [simp]
declare FWO_plus_left [simp]
declare FWO_plus_right [simp]
declare ga_comm_inf [simp]
declare ga_comm_sup [simp]
declare ga_comm_min [simp]
declare ga_comm_max [simp]
declare ga_assoc_min [simp]
declare ga_assoc_max [simp]
declare ga_left_comm_min [simp]
declare ga_left_comm_max [simp]
declare min_inf_relation [simp]
declare max_sup_relation [simp]
declare Ax3 [simp]
declare Ax4 [simp]
declare RealNonNeg_subtype [simp]
declare RealPos_subtype [simp]
declare ga_assoc___Xx___3 [simp]
declare ga_right_unit___Xx___3 [simp]
declare ga_left_unit___Xx___3 [simp]
declare inv_Group_3 [simp]
declare rinv_Group_2 [simp]
declare ga_comm___Xx___3 [simp]
declare unit [simp]
declare zero_by_left_zero [simp]
declare zero_by_right_zero [simp]
declare inverse_by_XMinus1 [simp]

theorem right_distributive :
"ALL v. ALL v'. ALL w. w *_4 (v +'' v') = (w *_4 v) +' (w *_4 v')"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def
by (auto)

ML "Header.record \"right_distributive\""

theorem right_homogeneous :
"ALL a. ALL v. ALL w. v *_4 (a *_3 w) = a *'' (v *_4 w)"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def
by (auto)

ML "Header.record \"right_homogeneous\""

theorem non_degenerate : "ALL v. v *_4 v = 0' --> v = 0''"
using subtype_def subtype_pred_def Ax1_1 inf_def
      RealNonNeg_pred_def RealPos_pred_def abs_def
by (auto)

ML "Header.record \"non_degenerate\""

end


theory Lifting
  imports "../Mergeable/Mergeable_Instances"
begin

(* (yet another) LiftUtils implementation
   this one makes use of the orderings on data to get a version of the
   "proj, then inj" law that is a compromise between the too-strict one
   for the idempotent part of LiftUtils
*)

(*
  Lifting type definitions
*)

type_synonym ('a, 'b) syn_lifting = "('b \<Rightarrow> 'a)"

record ('syn, 'a, 'b) lifting =
  LUpd :: "('syn \<Rightarrow> 'a \<Rightarrow> 'b :: Pord \<Rightarrow> 'b)"
  LOut :: "('syn \<Rightarrow> 'b \<Rightarrow> 'a)"
  LBase :: "'syn \<Rightarrow> 'b"

declare lifting.defs[simp]

record ('syn, 'a, 'b) liftingv = "('syn, 'a, 'b :: Pord) lifting" +
  LOutS :: "'syn \<Rightarrow> 'b set"
  LInS :: "'syn \<Rightarrow> 'a set"

definition LNew :: "('syn, 'a, 'b :: Pord, 'z) lifting_scheme \<Rightarrow> 'syn \<Rightarrow> 'a \<Rightarrow> 'b"  where
"LNew l s a = LUpd l s a (LBase l s)"

declare lifting.cases [simp]

(* Validity of lifting *)

(* i think we need to take ordering into account here.
   idea is that when we project, _data_ ordering needs to be preserved *)
(* TODO: can these laws be reduced? *)

(* if we get rid of H3 we no longer need the POrd constraint on a.
*)
definition lifting_valid :: "('x, 'a, 'b :: Pord, 'z) liftingv_scheme \<Rightarrow> bool" where
"lifting_valid l =
  ((\<forall> s a b . LUpd l s a b \<in> LOutS l s) \<and>
   (\<forall> s b . LOut l s b \<in> LInS l s) \<and>
   (\<forall> s a b . a \<in> LInS l s \<longrightarrow> a = LOut l s (LUpd l s a b)) \<and>
   (\<forall> s b . b \<in> LOutS l s \<longrightarrow> b <[ LUpd l s (LOut l s b) b))"

lemma lifting_validI :
  assumes HSO : "\<And> s a b . LUpd l s a b \<in> LOutS l s"
  assumes HSI : "\<And> s b . LOut l s b \<in> LInS l s"
  assumes HI : "\<And> s a b . a \<in> LInS l s \<Longrightarrow>  a = LOut l s (LUpd l s a b)"
  assumes HO : "\<And> s b . b \<in> LOutS l s \<Longrightarrow> b <[ LUpd l s (LOut l s b) b"
  shows "lifting_valid l" using assms
  by(auto simp add: lifting_valid_def)

lemma lifting_validDO :
  assumes H : "lifting_valid l"
  assumes HI : "a \<in> LInS l s"
  shows "a = LOut l s (LUpd l s a b)" using assms
  by(auto simp add: lifting_valid_def)

lemma lifting_validDO' :
  assumes H : "lifting_valid l"
  assumes HI : "a \<in> LInS l s"
  shows "a = LOut l s (LNew l s a)" using assms
  by(auto simp add: lifting_valid_def LNew_def)

lemma lifting_validDI :
  assumes H : "lifting_valid l"
  assumes HO : "b \<in> LOutS l s"
  shows "b <[ LUpd l s (LOut l s b) b" using assms
  by(auto simp add:lifting_valid_def)

lemma lifting_validDSO :
  assumes H : "lifting_valid l"
  shows "LUpd l s a b \<in> LOutS l s" using assms
  by(auto simp add: lifting_valid_def)

lemma lifting_validDSI :
  assumes H : "lifting_valid l"
  shows "LOut l s b \<in> LInS l s" using assms
  by(auto simp add: lifting_valid_def)

(* do we need another law relating data in case where we have upd (out )?
   also, what about put-put law? we didn't have that before so we shouldn't need it. *)

(*
  Mapping semantics through a lifting
*)

definition lift_map ::
  "('x, 'a , 'b :: Pord, 'z) lifting_scheme \<Rightarrow>
    ('x \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow>
    ('x \<Rightarrow> 'b \<Rightarrow> 'b)" where
"lift_map l sem syn st =
  (LUpd l syn (sem syn (LOut l syn st)) st)"

declare lift_map_def [simp]

(* trailing s = "with syntax" *)
definition lift_map_s ::
    "('a1, 'b1) syn_lifting \<Rightarrow>
     ('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
     ('a1 \<Rightarrow> 'a2 \<Rightarrow> 'a2) \<Rightarrow>
     ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2)" where
"lift_map_s l' l sem syn st =
  (LUpd l (l' syn) (sem (l' syn) (LOut l (l' syn) st)) st)"

declare lift_map_s_def [simp]

definition lower_map_s ::
  "('a1, 'b1) syn_lifting \<Rightarrow>
   ('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2) \<Rightarrow>
   ('a1 \<Rightarrow> 'a2 \<Rightarrow> 'a2)" where
"lower_map_s l' l sem syn st =
  (let syn' = (SOME x . l' x = syn) :: 'b1 in
  (LOut l syn (sem syn' (LNew l syn st))))"

(*
  "Mapping" predicates through a lifting
*)
declare lower_map_s_def [simp]

definition lift_pred :: "('x, 'a :: Pord, 'b :: Pord, 'z) lifting_scheme \<Rightarrow> ('x \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow> ('x \<Rightarrow> 'b \<Rightarrow> bool)" where
"lift_pred t P =
  (\<lambda> s b . P s (LOut t s b))"

declare lift_pred_def [simp]

definition lower_pred :: "('x, 'a :: Pord, 'b :: Pord, 'z) lifting_scheme \<Rightarrow> ('x \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('x \<Rightarrow> 'a \<Rightarrow> bool)" where
"lower_pred t P =
  (\<lambda> s a . P s (LNew t s a))"

declare lower_pred_def [simp]

definition lift_pred_step ::
  "('x, 'a :: Pord, 'b :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('x \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> bool) \<Rightarrow>
   ('x \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> bool)" where
"lift_pred_step l P s st1 st2 =
        (P s (LOut l s st1) (LOut l s st2))"

definition lift_pred_step_s ::
  "('s1, 's2) syn_lifting \<Rightarrow>
   ('s1, 'b1 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('s1 \<Rightarrow> 'b1 \<Rightarrow> 'b1 \<Rightarrow> bool) \<Rightarrow>
   ('s2 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool)" where
"lift_pred_step_s l1 l2 P syn st1 st2 =
   (P (l1 syn) (LOut l2 (l1 syn) st1) (LOut l2 (l1 syn) st2))"

definition lower_pred_step_s  ::
  "('s1, 's2) syn_lifting \<Rightarrow>
   ('s1, 'b1 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('s2 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool) \<Rightarrow>
   ('s1 \<Rightarrow> 'b1 \<Rightarrow> 'b1 \<Rightarrow> bool)" where
"lower_pred_step_s l1 l2 P syn st1 st2 =
   (\<forall> syn' . l1 syn' = syn \<longrightarrow>
     (P syn' (LNew l2 syn st1) (LUpd l2 syn st2 (LNew l2 syn st1))))"

lemma lower_pred_step_sI :
  assumes H : "\<And> syn' . l1 syn' = syn \<Longrightarrow>
                (P syn' (LNew l2 syn st1) (LUpd l2 syn st2 (LNew l2 syn st1)))"
  shows "lower_pred_step_s l1 l2 P syn st1 st2"
  using H
  unfolding lower_pred_step_s_def
  by auto

lemma lower_pred_step_sD :
  assumes H : "lower_pred_step_s l1 l2 P syn st1 st2"
  assumes H1 : "l1 syn' = syn"
  shows "(P syn' (LNew l2 syn st1) (LUpd l2 syn st2 (LNew l2 syn st1)))"
  using H H1
  unfolding lower_pred_step_s_def
  by auto

(* Increasing-monotonicity (in second argument) for predicates *)
definition pred_mono2 ::
  "('s \<Rightarrow> 'a :: Pord \<Rightarrow> 'a :: Pord \<Rightarrow> bool) \<Rightarrow> bool" where
"pred_mono2 P =
  (\<forall> s x y y' .
    y <[ y' \<longrightarrow>
    P s x y \<longrightarrow>
    P s x y')"

lemma pred_mono2I :
  assumes H : "\<And> s x y y' .
                y <[ y' \<Longrightarrow>
                P s x y \<Longrightarrow>
                P s x y'"
  shows "pred_mono2 P" using assms
  by(auto simp add: pred_mono2_def)

lemma pred_mono2D :
  assumes H : "pred_mono2 P"
  assumes H1 : "y <[ y'"
  assumes H2 : "P s x y"
  shows "P s x y'" using assms
  by(auto simp add: pred_mono2_def)

(* Decreasing-monotonicity (in second argument) for predicates *)
definition pred_dmono2 ::
  "('s \<Rightarrow> 'a :: Pord \<Rightarrow> 'a :: Pord \<Rightarrow> bool) \<Rightarrow> bool" where
"pred_dmono2 P =
  (\<forall> s x y y' .
    y' <[ y \<longrightarrow>
    P s x y \<longrightarrow>
    P s x y')"

lemma pred_dmono2I :
  assumes H : "\<And> s x y y' .
                y' <[ y \<Longrightarrow>
                P s x y \<Longrightarrow>
                P s x y'"
  shows "pred_dmono2 P" using assms
  by(auto simp add: pred_dmono2_def)

lemma pred_dmono2D :
  assumes H : "pred_dmono2 P"
  assumes H1 : "y' <[ y"
  assumes H2 : "P s x y"
  shows "P s x y'" using assms
  by(auto simp add: pred_dmono2_def)

definition respects_InS ::
"('x, 'a, 'b :: Pord, 'z) liftingv_scheme \<Rightarrow> ('x \<Rightarrow> 'a \<Rightarrow> 'a) \<Rightarrow> bool" where
"respects_InS l f =
  (\<forall> x a . a \<in> LInS l x \<longrightarrow> f x a \<in> LInS l x)"

lemma respects_InSI :
  assumes H : "\<And> x a . a \<in> LInS l x \<Longrightarrow> f x a \<in> LInS l x"
  shows "respects_InS l f" using assms
  by(auto simp add: respects_InS_def)

lemma respects_InSD :
  assumes H0 : "respects_InS l f"
  assumes H : "a \<in> LInS l x"
  shows " f x a \<in> LInS l x" using assms
  by(auto simp add: respects_InS_def)

definition respects_OutS ::
"('x, 'a, 'b :: Pord, 'z) liftingv_scheme \<Rightarrow> ('x \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> bool" where
"respects_OutS l f =
  (\<forall> x b . b \<in> LOutS l x \<longrightarrow> f x b \<in> LOutS l x)"

lemma respects_OutSI :
  assumes H : "\<And> x b . b \<in> LOutS l x \<Longrightarrow> f x b \<in> LOutS l x"
  shows "respects_OutS l f" using assms
  by(auto simp add: respects_OutS_def)

lemma respects_OutSD :
  assumes H0 : "respects_OutS l f"
  assumes H : "b \<in> LOutS l x"
  shows "f x b \<in> LOutS l x" using assms
  by(auto simp add: respects_OutS_def)

(* do f and p both need to be monotone?
   just P i think? *)

declare [[show_types = false]]

lemma lift_pred_step_lift_map_s :
  fixes l1 :: "('a1, 'b1) syn_lifting"
  fixes l2 :: "('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) liftingv_scheme"
  assumes Hv : "lifting_valid l2"
  assumes Hsyn : "l1 x1' = x1"
  assumes Hsem : "LOut l2 x1 x2' = x2"
  assumes Hres : "respects_InS l2 f"
  assumes HP : "P x1 x2 (f x1 x2)"
  shows "lift_pred_step_s l1 l2 P x1' x2' (lift_map_s l1 l2 f x1' x2')"
  using Hv Hsyn Hsem HP
proof-
  have In: "x2 \<in> LInS l2 x1" using lifting_validDSI[OF Hv, of x1 x2'] Hsem
    by(auto)

  have In': "f x1 x2 \<in> LInS l2 x1" using respects_InSD[OF Hres] In by auto

  have Up1 : "(f x1 x2) =
              (LOut l2 x1 (LUpd l2 x1 (f x1 x2) x2'))"
    using lifting_validDO[OF Hv In'] by(auto simp add: Hsyn Hsem)

  hence Conc' : "P x1 x2 (LOut l2 x1 (LUpd l2 x1 (f x1 x2) x2'))" using HP by auto

  thus ?thesis
    by(auto simp add: lift_pred_step_s_def pred_mono2_def Hsyn Hsem)
qed

lemma lift_pred_step_lift_map_s_contra :
  fixes l1 :: "('a1, 'b1) syn_lifting"
  fixes l2 :: "('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) liftingv_scheme"
  assumes Hv : "lifting_valid l2"
  assumes Hsyn : "l1 x1' = x1"
  assumes Hsem : "LOut l2 x1 x2' = x2"
  assumes Hres : "respects_InS l2 f"
  assumes HP : "lift_pred_step_s l1 l2 P (x1') (x2') (lift_map_s l1 l2 f (x1') (x2'))"
  shows "P x1 x2 (f x1 x2)"
proof-
  have In: "x2 \<in> LInS l2 x1" using lifting_validDSI[OF Hv, of x1 x2'] Hsem
    by(auto)

  have In': "f x1 x2 \<in> LInS l2 x1" using respects_InSD[OF Hres] In by auto

  have Up1 : "(f x1 x2) =
              (LOut l2 x1 (LUpd l2 x1 (f x1 x2) x2'))"
    using lifting_validDO[OF Hv In'] by(auto simp add: Hsyn Hsem)

  hence Conc' : "P x1 x2 (LOut l2 x1 (LUpd l2 x1 (f x1 x2) x2'))"
    using HP
    by(auto simp add: lift_pred_step_s_def pred_dmono2_def Hsyn Hsem)

  thus ?thesis using Up1
    by(auto simp add: lift_pred_step_s_def pred_dmono2_def Hsyn Hsem)
qed

(*
  We can always lift, but not always lower
  Here we specify when we can lower
*)
definition can_lower_map_s ::
  "('a1, 'b1) syn_lifting \<Rightarrow>
   ('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2) \<Rightarrow>
   bool" where
"can_lower_map_s l' l f =
  (\<forall> b1_1 b2_1 b1_2 b2_2 .
     l' b1_1 = l' b1_2 \<longrightarrow>
     LOut l (l' b1_1) b2_1 = LOut l (l' b1_2) b2_2 \<longrightarrow>
     LOut l (l' b1_1) (f b1_1 b2_1) = LOut l (l' b1_2) (f b1_2 b2_2))"

lemma can_lower_map_sI :
  assumes H :
  "\<And> b1_1 b2_1 b1_2 b2_2 .
     l' b1_1 = l' b1_2 \<Longrightarrow>
     LOut l (l' b1_1) b2_1 = LOut l (l' b1_2) b2_2 \<Longrightarrow>
     LOut l (l' b1_1) (f b1_1 b2_1) = LOut l (l' b1_2) (f b1_2 b2_2)"
shows "can_lower_map_s l' l f"
  unfolding can_lower_map_s_def
proof(clarify)
  fix b1_1 b1_2
  fix b2_1 b2_2
  assume H1 : "l' b1_1 = l' b1_2"
  assume H2 : "LOut l (l' b1_1) b2_1 = LOut l (l' b1_2) b2_2"
  show "LOut l (l' b1_1) (f b1_1 b2_1) = LOut l (l' b1_2) (f b1_2 b2_2)"
    using H[OF H1 H2] by auto
qed

lemma can_lower_map_sD :
  assumes H : "can_lower_map_s l' l f"
  assumes H1 : "l' b1_1 = l' b1_2"
  assumes H2 : "LOut l (l' b1_1) b2_1 = LOut l (l' b1_2) b2_2"
  shows "LOut l (l' b1_1) (f b1_1 b2_1) = LOut l (l' b1_2) (f b1_2 b2_2)"
  using assms unfolding can_lower_map_s_def by blast

(* are we going to run into trouble with being too strict on first component? *)
(* also, we may need to tight this by conditioning the predicate on st1 and st'1 being
   in LOutS *)
definition can_lower_pred_step_s ::
  "('a1, 'b1) syn_lifting \<Rightarrow>
   ('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool) \<Rightarrow>
   bool" where
"can_lower_pred_step_s l' l P =
  (\<forall> syn syn' st1 st2 st'1 st'2.
    l' syn = l' syn' \<longrightarrow>
    LOut l (l' syn) st1 = LOut l (l' syn') st'1 \<longrightarrow>
    LOut l (l' syn) st2 = LOut l (l' syn') st'2 \<longrightarrow>
    P syn st1 st2 \<longrightarrow> P syn' st'1 st'2)"

(* does this need to actually be bi-directional? for now let's just have two definitions
*)
lemma can_lower_pred_step_sI :
  assumes H :
  "\<And> syn syn' st1 st2 st'1 st'2 .
    l' syn = l' syn' \<Longrightarrow>
    LOut l (l' syn) st1 = LOut l (l' syn') st'1 \<Longrightarrow>
    LOut l (l' syn) st2 = LOut l (l' syn') st'2 \<Longrightarrow>
    P syn st1 st2 \<Longrightarrow>
    P syn' st'1 st'2"
  shows "can_lower_pred_step_s l' l P"
  using assms unfolding can_lower_pred_step_s_def by blast

lemma can_lower_pred_step_sD :
  assumes H : "can_lower_pred_step_s l' l P"
  assumes H1 : "l' syn = l' syn'"
  assumes H2 : "LOut l (l' syn) st1 = LOut l (l' syn') st'1"
  assumes H3 : "LOut l (l' syn) st2 = LOut l (l' syn') st'2"
  assumes HP : "P syn st1 st2"
  shows "P syn' st'1 st'2"
  using assms unfolding can_lower_pred_step_s_def by blast

(*
definition can_dlower_pred_step_s ::
  "('a1, 'b1) syn_lifting \<Rightarrow>
   ('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool) \<Rightarrow>
   bool" where
"can_dlower_pred_step_s l' l P =
  (\<forall> syn syn' st1 st2 st'1 st'2.
    l' syn = l' syn' \<longrightarrow>
    LOut l (l' syn) st1 = LOut l (l' syn') st'1 \<longrightarrow>
    LOut l (l' syn) st'2 <[ LOut l (l' syn') st2 \<longrightarrow>
    P syn st1 st2 \<longrightarrow> P syn' st'1 st'2)"

(* does this need to actually be bi-directional? for now let's just have two definitions
*)
lemma can_dlower_pred_step_sI :
  assumes H :
  "\<And> syn syn' st1 st2 st'1 st'2 .
    l' syn = l' syn' \<Longrightarrow>
    LOut l (l' syn) st1 = LOut l (l' syn') st'1 \<Longrightarrow>
    LOut l (l' syn) st'2 <[ LOut l (l' syn') st2 \<Longrightarrow>
    P syn st1 st2 \<Longrightarrow>
    P syn' st'1 st'2"
  shows "can_dlower_pred_step_s l' l P"
  using assms unfolding can_dlower_pred_step_s_def by blast

lemma can_dlower_pred_step_sD :
  assumes H : "can_dlower_pred_step_s l' l P"
  assumes H1 : "l' syn = l' syn'"
  assumes H2 : "LOut l (l' syn) st1 = LOut l (l' syn') st'1"
  assumes H3 : "LOut l (l' syn) st'2 <[ LOut l (l' syn') st2"
  assumes HP : "P syn st1 st2"
  shows "P syn' st'1 st'2"
  using assms unfolding can_dlower_pred_step_s_def by blast
*)

lemma lower_pred_step_s_lower_map_s  :
  assumes Hv : "lifting_valid l2"
  assumes Hunmap : "can_lower_map_s l1 l2 f'"
  assumes Hunpred : "can_lower_pred_step_s l1 l2 P'"
  assumes H: "\<And> x1'' . l1 x1'' = x1 \<Longrightarrow> P' x1'' x2' (f' x1'' x2')"
  shows "lower_pred_step_s l1 l2 P' x1 (LOut l2 x1 x2') (lower_map_s l1 l2 f' x1 (LOut l2 x1 x2'))"
proof(rule lower_pred_step_sI)
  fix syn'
  assume Hsyn : "l1 syn' = x1"

  have Syn : "l1 (SOME x. l1 x = x1) = x1"
    by(rule Hilbert_Choice.someI; rule Hsyn)

  have Syn_eq : "l1 (SOME x. l1 x = x1) = l1 syn'" using Hsyn Syn by simp

  have Eq1 : "LOut l2 (l1 syn') x2' = LOut l2 (l1 syn') (LNew l2 x1 (LOut l2 x1 x2'))"
    using Hsyn lifting_validDO[OF Hv]
               lifting_validDSI[OF Hv]
    unfolding LNew_def by auto

  have Eq2 :
    "(LOut l2 x1 (f' (SOME x. l1 x = x1) (LNew l2 x1 (LOut l2 x1 x2')))) =
      LOut l2 (l1 syn')
        (LUpd l2 x1
          (LOut l2 x1 (f' (SOME x. l1 x = x1) (LNew l2 x1 (LOut l2 x1 x2'))))
          (LNew l2 x1 (LOut l2 x1 x2')))"
    using lifting_validDO[OF Hv] lifting_validDSI[OF Hv] Hsyn
    by(auto)

  have Eq3 :
    "LOut l2 (l1 syn') (f' syn' x2') =
     LOut l2 (l1 (SOME x. l1 x = x1)) (f' (SOME x. l1 x = x1) (LNew l2 x1 (LOut l2 x1 x2')))"
  proof(rule can_lower_map_sD[OF Hunmap])
    show "l1 syn' = l1 (SOME x. l1 x = x1)" using Syn_eq by auto
  next
    show "LOut l2 (l1 syn') x2' =
          LOut l2 (l1 (SOME x. l1 x = x1))
           (LNew l2 x1 (LOut l2 x1 x2'))"
      using Syn Hsyn lifting_validDO[OF Hv] lifting_validDSI[OF Hv]
      unfolding LNew_def
      by(simp)
  qed

  have Eq3' :
    "LOut l2 (l1 syn') (f' syn' x2') =
     LOut l2 x1 (f' (SOME x. l1 x = x1) (LNew l2 x1 (LOut l2 x1 x2')))"
    using Eq3 Syn by simp

  have Eq4 : " LOut l2 (l1 syn') (f' syn' x2') =
    LOut l2 (l1 syn') (LUpd l2 x1 (LOut l2 (l1 syn') (f' syn' x2')) (LNew l2 x1 (LOut l2 x1 x2')))"
    using lifting_validDO[OF Hv] lifting_validDSI[OF Hv] leq_refl unfolding Hsyn by(auto)

  show "P' syn' (LNew l2 x1 (LOut l2 x1 x2'))
        (LUpd l2 x1 (lower_map_s l1 l2 f' x1 (LOut l2 x1 x2'))
          (LNew l2 x1 (LOut l2 x1 x2')))" unfolding lower_map_s_def Let_def
(*    using Eq1 Eq2 Eq3' Eq4 *)

    using
    can_lower_pred_step_sD[OF Hunpred refl Eq1 Eq4 H[OF Hsyn]]
    unfolding LNew_def Syn Syn_eq Eq3
    by(auto)
qed

lemma lower_pred_step_s_lower_map_s_contra :
  assumes Hv : "lifting_valid l2"
  assumes Hunmap : "can_lower_map_s l1 l2 f'"
  assumes Hunpred : "can_lower_pred_step_s l1 l2 P'"
  assumes H: "lower_pred_step_s l1 l2 P' x1 (LOut l2 x1 x2')
              (lower_map_s l1 l2 f' x1 (LOut l2 x1 x2'))"
  assumes Hsyn :  "l1 x1'' = x1"
  shows "P' x1'' x2' (f' x1'' x2')"
proof-

  have Syn : "l1 (SOME x. l1 x = x1) = x1"
    by(rule Hilbert_Choice.someI; rule Hsyn)

  have Syn_eq : "l1 (SOME x. l1 x = x1) = l1 x1''" using Hsyn Syn by simp

  show "P' x1'' x2' (f' x1'' x2')"
  proof(rule can_lower_pred_step_sD[OF Hunpred refl _ _ lower_pred_step_sD[OF H Hsyn]])
    show "LOut l2 (l1 x1'') (LNew l2 x1 (LOut l2 x1 x2')) = LOut l2 (l1 x1'') x2'"
      using lifting_validDO[OF Hv] lifting_validDSI[OF Hv] unfolding LNew_def Hsyn by auto
  next
    have 1 : "lower_map_s l1 l2 f' x1 (LOut l2 x1 x2') =
              LOut l2 (l1 x1'') (LUpd l2 x1 (lower_map_s l1 l2 f' x1 (LOut l2 x1 x2'))
                                            (LNew l2 x1 (LOut l2 x1 x2')))"
      using lifting_validDO[OF Hv] lifting_validDSI[OF Hv] unfolding Hsyn by auto

    have 2 : "LOut l2 (l1 x1'') x2' =
              LOut l2 (l1 (SOME x. l1 x = x1)) (LUpd l2 x1 (LOut l2 x1 x2') (LBase l2 x1))"
      unfolding Syn Hsyn
      using lifting_validDO[OF Hv] lifting_validDSI[OF Hv] by auto

    have 3 : "LOut l2 (l1 x1'') (f' x1'' x2') = lower_map_s l1 l2 f' x1 (LOut l2 x1 x2')"
      unfolding lower_map_s_def Let_def
      using can_lower_map_sD[OF Hunmap sym[OF Syn_eq]
                            , of x2' "(LUpd l2 x1 (LOut l2 x1 x2') (LBase l2 x1))"] 2
      unfolding LNew_def Syn Hsyn Syn_eq
      by(auto)

    show "LOut l2 (l1 x1'') (LUpd l2 x1 (lower_map_s l1 l2 f' x1 (LOut l2 x1 x2'))
                                        (LNew l2 x1 (LOut l2 x1 x2'))) = LOut l2 (l1 x1'') (f' x1'' x2')"
      using leq_trans[of "LOut l2 (l1 x1'') (f' x1'' x2')"] 1 3 leq_refl by auto
  qed
qed

lemma can_lower_lift_map_s :
  assumes Hv : "lifting_valid l2"
  assumes Hres : "respects_InS l2 f"
  shows "can_lower_map_s l1 l2 (lift_map_s l1 l2 f)"
proof(rule can_lower_map_sI)
  fix b1_1 b2_1 b1_2 b2_2
  assume Hsyn : "l1 b1_1 = l1 b1_2"
  assume Hsem : "LOut l2 (l1 b1_1) b2_1 = LOut l2 (l1 b1_2) b2_2"

  have InS1 : "f (l1 b1_1) (LOut l2 (l1 b1_1) b2_1) \<in> LInS l2 (l1 b1_1)"
    using respects_InSD[OF Hres] lifting_validDSI[OF Hv] by(auto)

  have InS2 : "f (l1 b1_2) (LOut l2 (l1 b1_2) b2_2) \<in> LInS l2 (l1 b1_2)"
    using respects_InSD[OF Hres] lifting_validDSI[OF Hv] by(auto)

  show "LOut l2 (l1 b1_1) (lift_map_s l1 l2 f b1_1 b2_1) =
        LOut l2 (l1 b1_2) (lift_map_s l1 l2 f b1_2 b2_2)"
    unfolding lift_map_s_def
    using Hsem lifting_validDO[OF Hv] lifting_validDSI[OF Hv] InS1 InS2
    by(simp add: Hsyn Hsem)
qed

lemma can_lower_lift_pred_step_s :
  assumes Hv : "lifting_valid l2"
  shows "can_lower_pred_step_s l1 l2 (lift_pred_step_s l1 l2 P)"
proof(rule can_lower_pred_step_sI)
  fix syn syn' st1 st2 st'1 st'2
  assume Hsyn : "l1 syn = l1 syn'"
  assume Hsem1 : "LOut l2 (l1 syn) st1 = LOut l2 (l1 syn') st'1"
  assume Hsem2 : "LOut l2 (l1 syn) st2 = LOut l2 (l1 syn') st'2"
  assume H : "lift_pred_step_s l1 l2 P syn st1 st2"
  show "lift_pred_step_s l1 l2 P syn' st'1 st'2"
    using H Hsyn Hsem1 Hsem2 unfolding lift_pred_step_s_def
    by(auto)
qed

(* "Orthogonality" for a pair of lifted values
idea: exists a LUB for the pair (values/liftings) s.t.
  - both projections are equal to the given values
  - this LUB is the true LUB

we can then generalize this to liftings
  - idea: liftings need to be orthogonal for all values
  - the test of this will be our lifting for LambdaInt -
    if it is orthogonal it will be for nontrivial reasons
    (non-overlap of keys?)

*)
definition l_ortho' ::
  "('x, 'a1, 'b :: Pord) lifting \<Rightarrow>
   ('x, 'a2, 'b) lifting \<Rightarrow>
   'x \<Rightarrow> 'a1 \<Rightarrow> 'a2 \<Rightarrow> 'b \<Rightarrow> bool" where
"l_ortho' l1 l2 x a1 a2 b =
  (LOut l1 x b = a1 \<and>
   LOut l2 x b = a2)"

(* Idea: regardless of the state of the "database" (b)
   and how we "query" it (syntax x)
   we can always find compatible a1 and a2 *)
definition l_ortho_strong ::
"('x, 'a1, 'b :: Pord) lifting \<Rightarrow>
 ('x, 'a2, 'b) lifting \<Rightarrow>
 bool" where
"l_ortho_strong l1 l2 =
  (\<forall> b x .
    (\<exists> a1 a2 . l_ortho' l1 l2 x a1 a2 b))"

(*
(*
  how we are going to use these:
  - the idea is that we are considering the general case where we have a predicate on
    a larger state, and some lifting that gets us there
  - the larger state predicate will not be (trivially) lowerable because it will depend
    on some data we don't have in the other state
  - however (I think) with appropriate monotonicity conditions, we can still get something
    this will be a more general (more useful) result corresponding to the situation
    where we are merging (which is basically all the time)
*)

definition can_lower_pred_step_s_weak ::
   "('a1, 'b1) syn_lifting \<Rightarrow>
   ('a1, 'a2 :: Pord, 'b2 :: Pord, 'z) lifting_scheme \<Rightarrow>
   ('b1 \<Rightarrow> 'b2 \<Rightarrow> 'b2 \<Rightarrow> bool) \<Rightarrow>
   bool" where
"can_lower_pred_step_s l' l P =
  (\<forall> syn syn' st1 st2 st'1 st'2.
    l' syn = l' syn' \<longrightarrow>
    LOut l (l' syn) st1 = LOut l (l' syn') st'1 \<longrightarrow>
    LOut l (l' syn) st2 = LOut l (l' syn') st'2 \<longrightarrow>
    P syn st1 st2 \<longrightarrow> P syn' st'1 st'2)"
*)
(* brainstorming examples for reasoning about combined semantics
  - compiler optimizations: arithmetic + something?
  - "constant elimination" in e.g. addition with zero
    - we need another language that has an overlap
    - where it will sometimes just always reset to 0 (with higher priority)
  - then we can think about merging predicates
    - use this to do some kind of interesting proof about merged semantics
    - "modes" for interpreting commands?
    -
  - concurrency-like example (shared memory?)
*)

(*
  what useful operations can we think of as (sometimes) being always 0?

*)

(* other issues: orthogonality in merge lifting *)

end


section "Common Proofs"

theory Common_Proof
imports Common Idle_Proof Current_Proof
begin

lemma reverseN_drop: "reverseN n xs acc = drop (length xs - n) (rev xs) @ acc"
  unfolding reverseN_def using rev_take by blast

lemma reverseN_step: "xs \<noteq> [] \<Longrightarrow> reverseN n (tl xs) (hd xs # acc) = reverseN (Suc n) xs acc"
  by (simp add: take_Suc)

lemma reverseN_finish: "reverseN n [] acc = acc"
  by (simp)

lemma reverseN_tl_hd: "0 < n \<Longrightarrow> xs \<noteq> [] \<Longrightarrow> reverseN n xs ys = reverseN (n - (Suc 0)) (tl xs) (hd xs #ys)"
  by (simp add: reverseN_step del: reverseN_def)

lemma reverseN_nth: "n < length xs \<Longrightarrow> x = xs ! n \<Longrightarrow> x # reverseN n xs ys = reverseN (Suc n) xs ys"
  by (simp add: take_Suc_conv_app_nth)

lemma step_list [simp]: "invar common \<Longrightarrow> list (step common) = list common"
proof(induction common rule: step_state.induct)
  case (1 idle)
  then show ?case by auto
next
  case (2 current aux new moved)

  then show ?case
  proof(cases current)
    case (Current extra added old remained)

    with 2 have aux_not_empty: "aux \<noteq> []"
        by auto

    from 2 Current show ?thesis
    proof(cases "remained \<le> Suc moved")
      case True

      with 2 Current have "remained - length new = 1"
        by auto

      with True Current 2 aux_not_empty show ?thesis
        by(auto simp: )
    next
      case False
      with Current show ?thesis
        by(auto simp: aux_not_empty reverseN_step Suc_diff_Suc simp del: reverseN_def)
    qed
  qed
qed

lemma step_list_current [simp]: "invar common \<Longrightarrow> list_current (step common) = list_current common"
  by(cases common)(auto split: current.splits)

lemma push_list [simp]: "list (push x common) = x # list common"
proof(induction x common rule: push.induct)
  case (1 x stack stackSize)
  then show ?case
    by auto
next
  case (2 x current aux new moved)
  then show ?case
    by(induction x current rule: Current.push.induct) auto
qed

      then show ?thesis
      proof(cases "remained \<le> Suc (length new)")
        case True
        with 2 Current False
          have "take (Suc (length new)) (Stack.list old) = take (size old) (hd aux # new)"
            by(auto simp: le_Suc_eq take_Cons')

        with 2 Current True show ?thesis
          by auto
      next
        case False
        with 2 Current AUX_NOT_EMPTY show ?thesis
          by(auto simp: reverseN_step Suc_diff_Suc simp del: reverseN_def)
      qed
    qed
  qed
qed

lemma invar_push: "invar common \<Longrightarrow> invar (push x common)"
proof(induction x common rule: push.induct)
  case (1 x current stack stackSize)
  then show ?case
  proof(induction x current rule: Current.push.induct)
    case (1 x extra added old remained)
    then show ?case
    proof(induction x stack rule: Stack.push.induct)
      case (1 x left right)
      then show ?case by auto
    qed
  qed
next
  case (2 x current aux new moved)
  then show ?case
  proof(induction x current rule: Current.push.induct)
    case (1 x extra added old remained)
    then show ?case by auto
  qed
qed

lemma invar_pop: "\<lbrakk>
  0 < size common;
  invar common;
  pop common = (x, common')
\<rbrakk> \<Longrightarrow> invar common'"
proof(induction common arbitrary: x rule: pop.induct)
  case (1 current idle)
  then obtain idle' where idle: "Idle.pop idle = (x, idle')"
    by(auto split: prod.splits)

  obtain current' where current: "drop_first current = current'"
    by auto

  from 1 current idle show ?case
    using Idle_Proof.size_pop[of idle x idle', symmetric]
        size_new_pop[of current]
        size_pop_sub[of current _ current']
    by(auto simp: Idle_Proof.invar_pop invar_size_pop eq_snd_iff take_tl size_not_empty)
next
  case (2 current aux new moved)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case
    proof(cases "remained - Suc 0 \<le> length new")
      case True

      with 1 have [simp]:
          "0 < size old"
          "Stack.list old \<noteq> []"
          "aux \<noteq> []"
          "length new = remained - Suc 0"
        by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)

      then have [simp]: "Suc 0 \<le> size old"
        by linarith

      from 1 have "0 < remained"
        by auto

      then have "take remained (Stack.list old)
          = hd (Stack.list old) # take (remained - Suc 0) (tl (Stack.list old))"
        by (metis Suc_pred \<open>Stack.list old \<noteq> []\<close> list.collapse take_Suc_Cons)

      with 1 True show ?thesis
        using Stack_Proof.pop_list[of old]
        by(auto simp: Stack_Proof.size_not_empty)
    next
      case False
      with 1 have "remained - Suc 0 \<le> length aux + length new" by auto

      with 1 False show ?thesis
        using Stack_Proof.pop_list[of old]
        apply(auto simp: Suc_diff_Suc take_tl Stack_Proof.size_not_empty tl_append_if)
        by (simp add: Suc_diff_le rev_take tl_drop_2 tl_take)
    qed
   next
    case (2 x xs added old remained)
    then show ?case by auto
  qed
qed

lemma push_list_current [simp]: "list_current (push x left) = x # list_current left"
  by(induction x left rule: push.induct) auto

lemma pop_list [simp]: "invar common \<Longrightarrow> 0 < size common \<Longrightarrow> pop common = (x, common') \<Longrightarrow>
   x # list common' = list common"
proof(induction common arbitrary: x rule: pop.induct)
  case 1
  then show ?case
    by(auto simp: size_not_empty split: prod.splits)
next
  case (2 current aux new moved)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case
    proof(cases "remained - Suc 0 \<le> length new")
      case True

      from 1 True have [simp]:
          "aux \<noteq> []" "0 < remained"
          "Stack.list old \<noteq> []" "remained - length new = 1"
        by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)

      then have "take remained (Stack.list old) = hd aux # take (size old - Suc 0) new
             \<Longrightarrow> Stack.first old = hd aux"
        by (metis first_hd hd_take list.sel(1))

      with 1 True take_hd[of aux] show ?thesis
        by(auto simp: Suc_leI)
    next
      case False
      then show ?thesis
      proof(cases "remained - length new = length aux")
        case True

        then have length_minus_1: "remained - Suc (length new) = length aux - 1"
          by simp

        from 1 have not_empty: "0 < remained" "0 < size old"  "aux \<noteq> []" "\<not> is_empty old"
          by(auto simp: Stack_Proof.size_not_empty)

        from 1 True not_empty have "take 1 (Stack.list old) = take 1 (rev aux)"
          using take_1[of
                remained
                "size old"
                "Stack.list old"
                "(rev aux) @ take (size old + length new - remained) new"
                ]
          by(simp)

        then have "[last aux] = [Stack.first old]"
          using take_last first_take not_empty
          by fastforce

        then have "last aux = Stack.first old"
          by auto

        with 1 True False show ?thesis
          using not_empty last_drop_rev[of aux]
          by(auto simp: reverseN_drop length_minus_1 simp del: reverseN_def)
       next
        case False

        with 1 have a: "take (remained - length new) aux \<noteq> []"
          by auto

        from 1 False have b: "\<not> is_empty old"
          by(auto simp: Stack_Proof.size_not_empty)

        from 1 have c: "remained - Suc (length new) < length aux"
          by auto

        from 1 have not_empty: "0 < remained" "0 < size old" "0 < remained - length new" "0 < length aux"
          by auto

        with False have "
              take remained (Stack.list old) = take (size old) (reverseN (remained - length new) aux new)
          \<Longrightarrow> take (Suc 0) (Stack.list old) = take (Suc 0) (rev (take (remained - length new) aux))"
          using take_1[of
                remained
                "size old"
                "Stack.list old"
                " (reverseN (remained - length new) aux new)"
              ]
          by(auto simp: not_empty Suc_le_eq)

        with 1 False have "take 1 (Stack.list old) = take 1 (rev (take (remained - length new) aux))"
          by auto

        then have d: "[Stack.first old] = [last (take (remained - length new) aux)]"
          using take_last first_take a b
          by metis

        have "last (take (remained - length new) aux) # rev (take (remained - Suc (length new)) aux)
            = rev (take (remained - length new) aux)"
          using Suc_diff_Suc c not_empty
          by (metis a drop_drop last_drop_rev plus_1_eq_Suc rev_take zero_less_diff)

        with 1(1) 1(3) False not_empty d show ?thesis
          by(cases "remained - length new = 1") (auto)
      qed
    qed
  next
    case 2
    then show ?case by auto
  qed
qed

lemma pop_list_current: "invar common \<Longrightarrow> 0 < size common \<Longrightarrow> pop common = (x, common')
   \<Longrightarrow> x # list_current common' = list_current common"
proof(induction common arbitrary: x rule: pop.induct)
  case (1 current idle)
  then show ?case
  proof(induction idle rule: Idle.pop.induct)
    case (1 stack stackSize)
    then show ?case
    proof(induction current rule: Current.pop.induct)
      case (1 added old remained)
      then have "Stack.first old = Stack.first stack"
        using take_first[of old stack]
        by auto

      with 1 show ?case
        by(auto simp: Stack_Proof.size_not_empty Stack_Proof.list_not_empty)
    next
      case (2 x xs added old remained)
      then have "0 < size stack"
        by auto

      with Stack_Proof.size_not_empty Stack_Proof.list_not_empty
      have not_empty: "\<not> is_empty stack" "Stack.list stack \<noteq> []"
        by auto

      with 2 have "hd (Stack.list stack) = x"
        using take_hd'[of "Stack.list stack" x "xs @ Stack.list old"]
        by auto

      with 2 show ?case
        using first_list[of stack] not_empty
        by auto
    qed
  qed
next
  case (2 current)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then have "\<not> is_empty old"
      by(auto simp: Stack_Proof.size_not_empty)

    with 1 show ?case
      using first_pop
      by(auto simp: Stack_Proof.list_not_empty)
  next
    case 2
    then show ?case by auto
  qed
qed

lemma list_current_size [simp]:
  "\<lbrakk>0 < size common; list_current common = []; invar common\<rbrakk> \<Longrightarrow> False"
proof(induction common rule: invar_state.induct)
  case 1
  then show ?case
    using list_size by auto
next
  case (2 current)
  then have "invar current"
            "Current.list current = []"
            "0 < size current"
    by(auto split: current.splits)

  then show ?case using list_size by auto
qed

lemma list_size [simp]: "\<lbrakk>0 < size common; list common = []; invar common\<rbrakk> \<Longrightarrow> False"
proof(induction common rule: invar_state.induct)
  case 1
  then show ?case
    using list_size Idle_Proof.size_empty
    by auto
next
  case (2 current aux new moved)
  then have "invar current"
            "Current.list current = []"
            "0 < size current"
    by(auto split: current.splits)

  then show ?case using list_size by auto
qed

lemma size_empty: "invar (common :: 'a state) \<Longrightarrow> size common = 0 \<Longrightarrow> is_empty common"
proof(induction common rule: is_empty_state.induct)
  case 1
  then show ?case
    by(auto simp: min_def size_empty size_new_empty split: if_splits)
next
  case (2 current)
  then have "invar current"
    by(auto split: current.splits)

  with 2 show ?case
    by(auto simp: min_def size_empty size_new_empty split: if_splits)
qed

lemma step_size [simp]: "invar (common :: 'a state) \<Longrightarrow> size (step common) = size common"
proof(induction common rule: step_state.induct)
  case 1
  then show ?case by auto
next
  case 2
  then show ?case
    by(auto simp: min_def split: current.splits)
qed

lemma step_size_new [simp]: "invar (common :: 'a state)
   \<Longrightarrow> size_new (step common) = size_new common"
proof(induction common rule: step_state.induct)
  case (1 current idle)
  then show ?case by auto
next
  case (2 current aux new moved)
  then show ?case by(auto split: current.splits)
qed

lemma remaining_steps_step [simp]: "\<lbrakk>invar (common :: 'a state); remaining_steps common > 0\<rbrakk>
   \<Longrightarrow> Suc (remaining_steps (step common)) = remaining_steps common"
  by(induction common)(auto split: current.splits)

lemma remaining_steps_step_sub [simp]: "\<lbrakk>invar (common :: 'a state)\<rbrakk>
 \<Longrightarrow> remaining_steps (step common) = remaining_steps common - 1"
  by(induction common)(auto split: current.splits)

lemma remaining_steps_step_0 [simp]: "\<lbrakk>invar (common :: 'a state); remaining_steps common = 0\<rbrakk>
   \<Longrightarrow> remaining_steps (step common) = 0"
  by(induction common)(auto split: current.splits)

lemma remaining_steps_push [simp]: "invar common
   \<Longrightarrow> remaining_steps (push x common) = remaining_steps common"
  by(induction x common rule: Common.push.induct)(auto split: current.splits)

lemma remaining_steps_pop: "\<lbrakk>invar common; 0 < size common; pop common = (x, common')\<rbrakk>
  \<Longrightarrow> remaining_steps common' \<le> remaining_steps common"
proof(induction common rule: pop.induct)
  case (1 current idle)
  then show ?case
  proof(induction idle rule: Idle.pop.induct)
    case 1
    then show ?case
      by(induction current rule: Current.pop.induct) auto
  qed
next
  case (2 current aux new moved)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_push [simp]: "invar common \<Longrightarrow> size (push x common) = Suc (size common)"
  by(induction x common rule: push.induct) (auto split: current.splits)

lemma size_new_push [simp]: "invar common \<Longrightarrow> size_new (push x common) = Suc (size_new common)"
  by(induction x common rule: Common.push.induct) (auto split: current.splits)

lemma size_pop [simp]: "\<lbrakk>invar common; 0 < size common; pop common = (x, common')\<rbrakk>
   \<Longrightarrow> Suc (size common') = size common"
proof(induction common rule: Common.pop.induct)
  case (1 current idle)
  then show ?case
    using size_drop_first_sub[of current] Idle_Proof.size_pop_sub[of idle]
    by(auto simp: size_not_empty split: prod.splits)
next
  case (2 current aux new moved)
  then show ?case
    by(induction current rule: Current.pop.induct) auto
qed

lemma size_new_pop [simp]: "\<lbrakk>invar common; 0 < size_new common; pop common = (x, common')\<rbrakk>
   \<Longrightarrow>  Suc (size_new common') = size_new common"
proof(induction common rule: Common.pop.induct)
  case (1 current idle)
  then show ?case
    using size_new_pop[of current]
    by(auto split: prod.splits)
next
  case (2 current aux new moved)
  then show ?case
  proof(induction current rule: Current.pop.induct)
    case (1 added old remained)
    then show ?case by auto
  next
    case (2 x xs added old remained)
    then show ?case by auto
  qed
qed

lemma size_size_new: "\<lbrakk>invar (common :: 'a state); 0 < size common\<rbrakk> \<Longrightarrow> 0 < size_new common"
  by(cases common) auto

end


theory LaunchburyAddLog
imports Launchbury LaunchburyLog
begin

lemma add_log: "\<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : v \<Longrightarrow> (\<exists> c. \<Gamma> : e \<Down>\<^bsub>n,L\<^esub> \<Delta> : v c)"
proof(induction arbitrary: n rule:Launchbury.reds.induct)
case (Application y \<Gamma> e x L \<Delta> \<Theta> z e' n)
  hence "atom y \<sharp> x" by (simp add: fresh_Pair)
  with Application.IH LaunchburyLog.reds_ApplicationI
  show ?case by blast
qed  (blast intro: LaunchburyLog.reds.intros)+

lemma remove_log: "\<Gamma> : e \<Down>\<^bsub>n,L\<^esub> \<Delta> : v c \<Longrightarrow> \<Gamma> : e \<Down>\<^bsub>L\<^esub> \<Delta> : v"
proof(induction rule:LaunchburyLog.reds.induct)
case (Application y \<Gamma> e x L \<Delta> \<Theta> z e' n)
  hence "atom y \<sharp> x" by (simp add: fresh_Pair)
  with Application.IH Launchbury.reds_ApplicationI
  show ?case by blast
qed (blast intro: Launchbury.reds.intros)+

end