theory SLTC_Automation
imports
  "HOL-Eisbach.Eisbach" SLTC_More Automatic_Refinement.Automatic_Refinement

begin

subsection \<open>Experiment TOMOVE\<close>
lemma run_and_execute: "(\<forall>\<sigma> t r. run c (Some h) \<sigma> r t \<longrightarrow> \<sigma> \<noteq> None \<and> P (the \<sigma>) r t)
        \<longleftrightarrow> (\<exists>h' t r. execute c h = Some (r, h', t) \<and> P h' r t)"
  apply rule
  subgoal by (metis option.sel run.intros(2) run.intros(3) timeFrame.elims)
  subgoal by (metis (mono_tags) not_None_eq option.sel prod.sel(1) prod.sel(2) run_to_execute)
  done

subsection \<open>stuff for VCG\<close>

lemma is_hoare_triple: "<P> c <Q> \<Longrightarrow> <P> c <Q>" .

theorem normalize_rules:
           "\<And>P. (\<And>x. <P x> f <Q>) \<Longrightarrow> <\<exists>\<^sub>Ax. P x> f <Q>"
           "\<And>P. (b \<Longrightarrow> <P> f <Q>) \<Longrightarrow> <P * \<up> b> f <Q>"
           "\<And>P. (b \<Longrightarrow> <emp> f <Q>) \<Longrightarrow> <\<up> b> f <Q>"
  subgoal using pre_ex_rule by force
  subgoal using norm_pre_pure_iff by blast
  subgoal using norm_pre_pure_iff2 by blast
  done

subsection "Rotate method"

definition gr where "gr A B = A * B"

lemma right_swap: "(A \<Longrightarrow>\<^sub>A B * (C * D)) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A B * (D * C))"
  by (simp add: assn_times_comm)
lemma right_take: "(A \<Longrightarrow>\<^sub>A gr B C * D) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A B * (C * D))"
  by (simp add: gr_def assn_times_assoc)
lemma left_swap: "(B * (C * D) \<Longrightarrow>\<^sub>A A) \<Longrightarrow> (B * (D * C) \<Longrightarrow>\<^sub>A A)"
  by (simp add: assn_times_comm)
lemma left_take: "(gr B C * D \<Longrightarrow>\<^sub>A A) \<Longrightarrow> (B * (C * D) \<Longrightarrow>\<^sub>A A)"
  by (simp add: gr_def assn_times_assoc)

lemma right_move_back: "(A \<Longrightarrow>\<^sub>A B * C) \<Longrightarrow> (A \<Longrightarrow>\<^sub>A C * B)"
  by (simp add: assn_times_comm)
lemma left_move_back: "(B * C \<Longrightarrow>\<^sub>A A) \<Longrightarrow> (C * B \<Longrightarrow>\<^sub>A A)"
  by (simp add: assn_times_comm)
lemma right_move_backt: "(A \<Longrightarrow>\<^sub>t B * C) \<Longrightarrow> (A \<Longrightarrow>\<^sub>t C * B)"
  by (simp add: assn_times_comm)
lemma left_move_backt: "(B * C \<Longrightarrow>\<^sub>t A) \<Longrightarrow> (C * B \<Longrightarrow>\<^sub>t A)"
  by (simp add: assn_times_comm)

thm mult.assoc
method rotater = ( (simp only: mult.assoc)? , rule right_move_back , (simp only: mult.assoc)?  )
method rotatel = ( (simp only: mult.assoc)? , rule left_move_back , (simp only: mult.assoc)?  )

method swapl = ( (simp only: mult.assoc)? ,rule left_swap, (simp only: mult.assoc)?   )
method takel = ( (simp only: mult.assoc)? , rule left_take, (simp only: mult.assoc)?  )

method swapr = ( (simp only: mult.assoc)? , rule right_swap , (simp only: mult.assoc)?  )
method taker = ( (simp only: mult.assoc)? , rule right_take, (simp only: mult.assoc)?  )

method rotatert = ( (simp only: mult.assoc)? , rule right_move_backt , (simp only: mult.assoc)?  )
method rotatelt = ( (simp only: mult.assoc)? , rule left_move_backt , (simp only: mult.assoc)?  )

lemma match_firstt: "A \<Longrightarrow>\<^sub>t B \<Longrightarrow> \<Gamma> * A \<Longrightarrow>\<^sub>t \<Gamma> * B"
  by (simp add: entt_star_mono)

lemma match_restt: "emp \<Longrightarrow>\<^sub>t B \<Longrightarrow> \<Gamma> \<Longrightarrow>\<^sub>t \<Gamma> * B"
  using match_firstt by fastforce

lemma match_first: "A \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<Gamma> * A \<Longrightarrow>\<^sub>A \<Gamma> * B"
  by (simp add: assn_times_comm entails_frame)

lemma match_rest: "emp \<Longrightarrow>\<^sub>A B \<Longrightarrow> \<Gamma> \<Longrightarrow>\<^sub>A \<Gamma> * B"
  using match_first by fastforce

subsection "Simplifier setup"

lemma is_entails: "P\<Longrightarrow>\<^sub>AQ \<Longrightarrow> P \<Longrightarrow>\<^sub>AQ" .

text \<open>Used by existential quantifier extraction tactic\<close>
lemma enorm_exI': (* Incomplete, as chosen x may depend on heap! *)
  "(\<And>x. Z x \<longrightarrow> (P \<Longrightarrow>\<^sub>A Q x)) \<Longrightarrow> (\<exists>x. Z x) \<longrightarrow> (P \<Longrightarrow>\<^sub>A (\<exists>\<^sub>Ax. Q x))"
  by (metis ent_ex_postI)

lemmas solve_ent_preprocess_simps =
  ent_pure_post_iff ent_pure_post_iff_sng ent_pure_pre_iff ent_pure_pre_iff_sng
lemmas ent_refl = entails_triv
lemmas ent_triv = ent_true ent_false
lemmas norm_assertion_simps =
  (* Neutral elements *)
  mult_1[where 'a=assn] mult_1_right[where 'a=assn]

  (* Zero elements *)
  false_absorb star_false_right

  time_credit_add[symmetric]
  ex_assn_move_out(1) pure_conj[symmetric]

  (* Duplicated References *)
  sngr_same_false snga_same_false

(*
theorem solve_ent_preprocess_simps:
            (?P \<Longrightarrow>\<^sub>A ?Q * \<up> ?b) = ((\<forall>h. h \<Turnstile> ?P \<longrightarrow> ?b) \<and> (?P \<Longrightarrow>\<^sub>A ?Q))
            (?P \<Longrightarrow>\<^sub>A \<up> ?b) = ((\<forall>h. h \<Turnstile> ?P \<longrightarrow> ?b) \<and> (?P \<Longrightarrow>\<^sub>A emp))
            (?P * \<up> ?b \<Longrightarrow>\<^sub>A ?Q) = (?b \<longrightarrow> (?P \<Longrightarrow>\<^sub>A ?Q))
            (\<up> ?b \<Longrightarrow>\<^sub>A ?Q) = (?b \<longrightarrow> (emp \<Longrightarrow>\<^sub>A ?Q)) *)

subsection \<open>Frame Matcher\<close>
text \<open>Given star-lists P,Q and a frame F, this method tries to match
  all elements of Q with corresponding elements of P. The result is a
  partial match, that contains matching pairs and the unmatched content.\<close>

text \<open>The frame-matcher internally uses syntactic lists separated by
  star, and delimited by the special symbol \<open>SLN\<close>, which is defined
  to be \<open>emp\<close>.\<close>
definition [simp]: "SLN \<equiv> emp"
lemma SLN_left: "SLN * P = P" by simp
lemma SLN_right: "P * SLN = P" by simp

lemmas SLN_normalize = SLN_right mult.assoc[symmetric, where 'a=assn]
lemmas SLN_strip = SLN_right SLN_left mult.assoc[symmetric, where 'a=assn]

text \<open>A query to the frame matcher. Contains the assertions
  P and Q that shall be matched, as well as a frame F, that is not
  touched.\<close>

definition [simp]: "FI_QUERY P Q F \<equiv> P \<Longrightarrow>\<^sub>A Q*F"

abbreviation "fi_m_fst M \<equiv> foldr ((*)) (map fst M) emp"
abbreviation "fi_m_snd M \<equiv> foldr ((*)) (map snd M) emp"
abbreviation "fi_m_match M \<equiv> (\<forall>(p,q)\<in>set M. p \<Longrightarrow>\<^sub>A q)"

text \<open>A result of the frame matcher. Contains a list of matching pairs,
  as well as the unmatched parts of P and Q, and the frame F.
\<close>
definition [simp]: "FI_RESULT M UP UQ F \<equiv>
  fi_m_match M \<longrightarrow> (fi_m_fst M * UP \<Longrightarrow>\<^sub>A fi_m_snd M * UQ * F)"

text \<open>Internal structure used by the frame matcher:
  m contains the matched pairs; p,q the assertions that still needs to be
  matched; up,uq the assertions that could not be matched; and f the frame.
  p and q are SLN-delimited syntactic lists.
\<close>

definition [simp]: "FI m p q up uq f \<equiv>
  fi_m_match m \<longrightarrow> (fi_m_fst m * p * up \<Longrightarrow>\<^sub>A fi_m_snd m * q * uq * f)"

text \<open>Initialize processing of query\<close>
lemma FI_init:
  assumes "FI [] (SLN*P) (SLN*Q) SLN SLN F"
  shows "FI_QUERY P Q F"
  using assms by simp

text \<open>Construct result from internal representation\<close>
lemma FI_finalize:
  assumes "FI_RESULT m (p*up) (q*uq) f"
  shows "FI m p q up uq f"
  using assms by (simp add: mult.assoc )

text \<open>Auxiliary lemma to show that all matching pairs together form
  an entailment. This is required for most applications.\<close>
lemma fi_match_entails:
  assumes "fi_m_match m"
  shows "fi_m_fst m \<Longrightarrow>\<^sub>A fi_m_snd m"
  using assms apply (induct m)
  apply (simp_all split: prod.split_asm add: ent_star_mono)
  done

text \<open>Internally, the frame matcher tries to match the first assertion
  of q with the first assertion of p. If no match is found, the first
  assertion of p is discarded. If no match for any assertion in p can be
  found, the first assertion of q is discarded.\<close>

text \<open>Match\<close>
lemma FI_match:
  assumes "p \<Longrightarrow>\<^sub>A q"
  assumes "FI ((p,q)#m) (ps*up) (qs*uq) SLN SLN f"
  shows "FI m (ps*p) (qs*q) up uq f"
  using assms unfolding FI_def
  apply (simp add: mult.assoc)
  by (simp add: mult.left_commute)

text \<open>No match\<close>
lemma FI_p_nomatch:
  assumes "FI m ps (qs*q) (p*up) uq f"
  shows "FI m (ps*p) (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: mult.assoc)

text \<open>Head of q could not be matched\<close>
lemma FI_q_nomatch:
  assumes "FI m (SLN*up) qs SLN (q*uq) f"
  shows "FI m SLN (qs*q) up uq f"
  using assms unfolding FI_def
  by (simp add: mult.assoc)

subsection \<open>Frame Inference\<close>
lemma frame_inference_init:
  assumes "FI_QUERY P Q F"
  shows "P \<Longrightarrow>\<^sub>A Q * F"
  using assms by simp

lemma frame_inference_finalize:
  shows "FI_RESULT M F emp F"
  apply simp
  apply rule
  apply (drule fi_match_entails)
  apply (rule ent_star_mono[OF _ ent_refl])
  apply assumption
  done

subsection \<open>Frame Inference\<close>

definition [simp]: "TI_QUERY P Q F \<equiv> P = Q + F"
lemma TI_QUERYD: "P = Q + F \<Longrightarrow> TI_QUERY P Q F" by simp

lemma timeframe_inference_init:
  assumes
      "FI_QUERY P Q FH"   (* first do frame inference in order to instatiate schematics! *)
      "TI_QUERY T T' FT"
      "F = FH * $FT"
  shows "P * $T\<Longrightarrow>\<^sub>A (Q * F) * $T'"
  using assms apply (simp add: time_credit_add mult.assoc)
  apply(rotater) apply rotater apply rotatel apply rotatel apply(rule match_first)  apply rotatel apply (rule match_first)
  .

lemma timeframe_inference_init_normalize:
 "emp * $T\<Longrightarrow>\<^sub>A F * $T' \<Longrightarrow> $T\<Longrightarrow>\<^sub>A F * $T'"
  by auto

lemma dollarD: "a = b \<Longrightarrow> $a \<Longrightarrow>\<^sub>A $b"
  by simp

subsection \<open>Entailment Solver\<close>
lemma entails_solve_init:
  "FI_QUERY P (Q*$T) true \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q * true * $T"
  "FI_QUERY P Q true \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q * true"
  "FI_QUERY P Q emp \<Longrightarrow> P \<Longrightarrow>\<^sub>A Q"
    apply (simp_all add: mult.assoc )
  by (simp add:  mult.commute)

lemma entails_solve_init_time':
  "FI_QUERY P (Q) true \<Longrightarrow> TI_QUERY T T' FT \<Longrightarrow>  P * $T \<Longrightarrow>\<^sub>A Q * true * $T'"
  apply simp
  by (smt ent_star_mono gc_time le_add1 merge_true_star star_aci(2) star_aci(3))

lemma entails_solve_init_time:
  "FI_QUERY P (Q) true \<Longrightarrow> TI_QUERY T T' FT \<Longrightarrow>  P * $T \<Longrightarrow>\<^sub>A Q * true * $T'"
  "FI_QUERY P emp true \<Longrightarrow> TI_QUERY T T' FT \<Longrightarrow>  P * $T \<Longrightarrow>\<^sub>A true * $T'"
  "FI_QUERY emp Q true \<Longrightarrow> TI_QUERY T T' FT \<Longrightarrow>  $T \<Longrightarrow>\<^sub>A Q * true * $T'"
  "FI_QUERY emp Q true \<Longrightarrow> TI_QUERY T T' FT \<Longrightarrow>  $T \<Longrightarrow>\<^sub>A true * $T'"
  subgoal by(fact entails_solve_init_time')
  subgoal using entails_solve_init_time'[where Q=emp] by simp
  subgoal using entails_solve_init_time'[where P=emp] by simp
  subgoal using entails_solve_init_time'[where P=emp and Q=emp] by simp
  done

lemma entails_solve_finalize:
  "FI_RESULT M P emp true"
  "FI_RESULT M emp emp emp"
  by (auto simp add: fi_match_entails intro: ent_star_mono)

named_theorems sep_dflt_simps "Seplogic: Default simplification rules for automated solvers"
named_theorems sep_eintros "Seplogic: Intro rules for entailment solver"
named_theorems sep_heap_rules "Seplogic: VCG heap rules"
named_theorems sep_decon_rules "Seplogic: VCG deconstruct rules"

ML \<open>
infix 1 THEN_IGNORE_NEWGOALS

structure Seplogic_Auto =
struct

  (***********************************)
  (*          Method Setup           *)
  (***********************************)

  val dflt_simps_modifiers = [
    Args.$$$ "dflt_simps" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_dflt_simps}) \<^here>),
    Args.$$$ "dflt_simps" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_dflt_simps}) \<^here>)
  ];
  val heap_modifiers = [
    Args.$$$ "heap" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_heap_rules}) \<^here>),
    Args.$$$ "heap" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_heap_rules}) \<^here>)
  ];
  val decon_modifiers = [
    Args.$$$ "decon" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_decon_rules}) \<^here>),
    Args.$$$ "decon" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_decon_rules}) \<^here>)
  ];

  val eintros_modifiers = [
    Args.$$$ "eintros" -- Scan.option Args.add -- Args.colon
      >> K (Method.modifier (Named_Theorems.add @{named_theorems sep_eintros}) \<^here>),
    Args.$$$ "eintros" -- Scan.option Args.del -- Args.colon
      >> K (Method.modifier (Named_Theorems.del @{named_theorems sep_eintros}) \<^here>)
  ];

  val solve_entails_modifiers = dflt_simps_modifiers @ eintros_modifiers;

  val vcg_modifiers =
    heap_modifiers @ decon_modifiers @ dflt_simps_modifiers;

  val sep_auto_modifiers =
    clasimp_modifiers @ vcg_modifiers @ eintros_modifiers;

  (***********************************)
  (*        Custom Tacticals         *)
  (***********************************)

  (* Apply tac1, and then tac2 with an offset such that anything left
     over by tac1 is skipped.

     The typical usage of this tactic is, if a theorem is instantiated
     with another theorem that produces additional goals that should
     be ignored first. Here, it is used in the vcg to ensure that
     frame inference is done before additional premises (that may
     depend on the frame) are discharged.
  *)
  fun (tac1 THEN_IGNORE_NEWGOALS tac2) i st = let
    val np = Thm.nprems_of st
  in
    (tac1 i THEN (fn st' => let val np' = Thm.nprems_of st' in
      if np'<np then tac2 i st'
      else tac2 (i+(np'-np)+1) st'
    end)) st
  end;

  (***********************************)
  (*     Assertion Normalization     *)
  (***********************************)
  (* Find two terms in a list whose key is equal *)
  fun find_similar (key_of:term -> term) (ts:term list) = let
    fun frec _ [] = NONE
    | frec tab (t::ts) = let val k=key_of t in
      if Termtab.defined tab k then
        SOME (the (Termtab.lookup tab k),t)
      else frec (Termtab.update (k,t) tab) ts
    end
  in
    frec Termtab.empty ts
  end;

  (* Perform DFS over term with binary operator opN, threading through
    a state. Atomic terms are transformed by tr. Supports omission of
    terms from the result structure by transforming them to NONE. *)
  fun dfs_opr opN (tr:'state -> term -> ('state*term option))
    d (t as ((op_t as Const (fN,_))$t1$t2)) =
    if fN = opN then let
        val (d1,t1') = dfs_opr opN tr d t1;
        val (d2,t2') = dfs_opr opN tr d1 t2;
      in
        case (t1',t2') of
          (NONE,NONE) => (d2,NONE)
        | (SOME t1',NONE) => (d2,SOME t1')
        | (NONE,SOME t2') => (d2,SOME t2')
        | (SOME t1',SOME t2') => (d2,SOME (op_t$t1'$t2'))
      end
    else tr d t
  | dfs_opr _ tr d t = tr d t;

  (* Replace single occurrence of (atomic) ot in t by nt.
    Returns new term or NONE if nothing was removed. *)
  fun dfs_replace_atomic opN ot nt t = let
    fun tr d t = if not d andalso t=ot then (true,SOME nt) else (d,SOME t);
    val (success,SOME t') = dfs_opr opN tr false t;
  in
    if success then SOME t' else NONE
  end;

  fun assn_simproc_fun ctxt credex = let
    val ([redex],ctxt') = Variable.import_terms true [Thm.term_of credex] ctxt;
    val export = singleton (Variable.export ctxt' ctxt)

    fun mk_star t1 t2 = @{term "(*)::assn \<Rightarrow> _ \<Rightarrow> _"}$t2$t1;

    fun mk_star' NONE NONE = NONE
    | mk_star' (SOME t1) NONE  = SOME t1
    | mk_star' NONE (SOME t2) = SOME t2
    | mk_star' (SOME t1) (SOME t2) = SOME (mk_star t1 t2);

    fun ptrs_key (_$k$_) = k;

    fun remove_term pt t = case
      dfs_replace_atomic @{const_name "Groups.times_class.times"} pt
        @{term emp} t
    of
      SOME t' => t';

    fun normalize t = let

      fun ep_tr (has_true,ps,ts,ptrs) t = case t of
        Const (@{const_name "pure_assn"},_)$_
        => ((has_true,t::ps,ts,ptrs),NONE)
      | Const (@{const_name "sngr_assn"},_)$_$_
        => ((has_true,ps,ts,t::ptrs),SOME t)
      | Const (@{const_name "snga_assn"},_)$_$_
        => ((has_true,ps,ts,t::ptrs),SOME t)
      | Const (@{const_name "timeCredit_assn"},_)$_
        => ((has_true,ps,t::ts,ptrs),NONE)
      | Const (@{const_name "top_assn"},_)
        => ((true,ps,ts,ptrs),NONE)
      | (inf_op as Const (@{const_name "and_assn"},_))$t1$t2
        => ((has_true,ps,ts,ptrs),SOME (inf_op$normalize t1$normalize t2))
      | _ => ((has_true,ps,ts,ptrs),SOME t);

      fun normalizer t = case dfs_opr @{const_name "Groups.times_class.times"}
        ep_tr (false,[],[],[]) t
      of
        ((has_true,ps,ts,ptrs),rt) =>
            ((has_true,rev ps,rev ts,ptrs),rt);

      fun normalize_core t = let
        val ((has_true,pures,tis,ptrs),rt) = normalizer t;
        val similar =  find_similar ptrs_key ptrs  ;
        val true_t = if has_true then SOME @{term "top_assn"}
          else NONE;
        val pures' = case pures of
            [] => NONE
          | p::ps => SOME (fold mk_star ps p);
        val tis' = case tis of
            [] => NONE
          | p::ps => SOME (fold mk_star ps p);
      in
        case similar of NONE => the ((mk_star' pures' (mk_star' tis' (mk_star' true_t rt))) )
        | SOME (t1,t2) => let
            val t_stripped = remove_term t1 (remove_term t2 t);
          in mk_star t_stripped (mk_star t1 t2)
          end
      end;

      fun skip_ex ((exq as Const (@{const_name "ex_assn"},_))$(Abs (n,ty,t))) =
        exq$Abs (n,ty,skip_ex t)
      | skip_ex t = normalize_core t;

      val (bs,t') = strip_abs t;
      val ty = fastype_of1 (map #2 bs,t');
    in
      if ty = @{typ assn} then
        Logic.rlist_abs (bs,skip_ex t')
      else t
    end;

    (*val _ = tracing (tr_term redex);*)
    val (f,terms) = strip_comb redex;
    val nterms = map (fn t => let
        (*val _ = tracing (tr_term t); *)
        val t'=normalize t;
        (*val _ = tracing (tr_term t');*)
      in t' end) terms;
    val new_form = list_comb (f,nterms);

    val res_ss = (put_simpset HOL_basic_ss ctxt addsimps @{thms star_aci});
    val result = Option.map (export o mk_meta_eq) (Arith_Data.prove_conv_nohyps
      [simp_tac res_ss 1] ctxt' (redex,new_form)
    );

  in
    result
  end handle exc =>
    if Exn.is_interrupt exc then Exn.reraise exc
    else
      (tracing ("assn_simproc failed with exception\n:" ^ Runtime.exn_message exc);
        NONE) (* Fail silently *);

  val assn_simproc =
    Simplifier.make_simproc @{context} "assn_simproc"
     {lhss =
      [@{term "h \<Turnstile> P"},
       @{term "P \<Longrightarrow>\<^sub>A Q"},
       @{term "P \<Longrightarrow>\<^sub>t Q"} ,
       @{term "hoare_triple P c Q"} (*,
       @{term "(P::assn) = Q"} *)],
      proc = K assn_simproc_fun};

  (***********************************)
  (*     Default Simplifications     *)
  (***********************************)

  (* Default simplification. MUST contain assertion normalization!
    Tactic must not fail! *)
  fun dflt_tac ctxt = asm_full_simp_tac
    (put_simpset HOL_ss ctxt
      addsimprocs [assn_simproc]
      addsimps @{thms norm_assertion_simps}
      addsimps (Named_Theorems.get ctxt @{named_theorems sep_dflt_simps})
      |> fold Splitter.del_split @{thms if_split}
    );

  (***********************************)
  (*         Frame Matcher           *)
  (***********************************)

  (* Do frame matching
    imp_solve_tac - tactic used to discharge first assumption of match-rule
      cf. lemma FI_match.
  *)
  fun match_frame_tac imp_solve_tac ctxt = let
    (* Normalize star-lists *)
    val norm_tac = simp_tac (
      put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_normalize});

    (* Strip star-lists *)
    val strip_tac =
      simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_strip}) THEN'
      simp_tac (put_simpset HOL_basic_ss ctxt addsimps @{thms SLN_def});

    (* Do a match step *)
    val match_tac = resolve_tac ctxt @{thms FI_match} (* Separate p,q*)
      THEN' SOLVED' imp_solve_tac (* Solve implication *)
      THEN' norm_tac;

    (* Do a no-match step *)
    val nomatch_tac = resolve_tac ctxt @{thms FI_p_nomatch} ORELSE'
      (resolve_tac ctxt @{thms FI_q_nomatch} THEN' norm_tac);
  in
    resolve_tac ctxt @{thms FI_init} THEN' norm_tac
    THEN' REPEAT_DETERM' (FIRST' [
      CHANGED o dflt_tac ctxt,
      (match_tac ORELSE' nomatch_tac)])
    THEN' resolve_tac ctxt @{thms FI_finalize} THEN' strip_tac
  end;

  (***********************************)
  (*         Frame Inference         *)
  (***********************************)

  fun frame_inference_tac ctxt =
    resolve_tac ctxt @{thms frame_inference_init}
    THEN' match_frame_tac (resolve_tac ctxt @{thms ent_refl}) ctxt
    THEN' resolve_tac ctxt @{thms frame_inference_finalize};

  (***********************************)
  (* Nat splitter  powerd by auto2   *)
  (***********************************)

  fun mytac ctxt a b = let
        val _ = tracing (Syntax.string_of_term ctxt a)
      val _ = tracing (Syntax.string_of_term ctxt b)
      val ths = map snd (SepTimeSteps.split_nat ctxt ([], (a, b)));
   in
         (if length ths > 0 then  (EqSubst.eqsubst_tac ctxt [1] ths
              THEN' FIRST' [ resolve_tac ctxt @{thms refl},
                             SOLVED' (simp_tac (put_simpset HOL_ss ctxt  addsimps @{thms mult.commute})) ] ) 1  else no_tac) end

  fun split_nat_tac ctxt =
     Subgoal.FOCUS_PARAMS (fn {context = ctxt, ...} => ALLGOALS (
        SUBGOAL (fn (t, _) => case Logic.strip_imp_concl t of
          @{mpat "Trueprop (?a = ?b + _)"} =>
            mytac ctxt a b
         |  _ => no_tac
        ))
      ) ctxt

  (* assumes a goal of form "a = b + c",
      normalizes a and b using NatRing.norm_full *)
  fun normalize_time_goal ctxt =
     (CONVERSION (Conv.params_conv ~1 (fn _ =>
              (Conv.concl_conv ~1
               (Conv.arg_conv (Conv.every_conv
              [Conv.arg1_conv(NatRing.norm_full),
             Conv.arg_conv(Conv.arg1_conv(NatRing.norm_full)),
             Conv.all_conv])))) ctxt)
    )

  (***********************************)
  (*         Time Frame Inference   *)
  (***********************************)

  fun print_tac' ctxt i st =
    let val _ = tracing ("..>");
        val _ = tracing (Thm.string_of_thm ctxt st)
    in all_tac st end

  fun time_frame_inference_tac ctxt =
    TRY o resolve_tac ctxt @{thms timeframe_inference_init_normalize}
    THEN'
    resolve_tac ctxt @{thms timeframe_inference_init}
    (* normal frame inference *)
    THEN' match_frame_tac (resolve_tac ctxt @{thms ent_refl}) ctxt

    THEN' (resolve_tac ctxt @{thms frame_inference_finalize})
      (* possible non determinism here, countered by the
        application of safe at the end *)
    (*THEN' (fn k => print_tac ctxt "aaa")*)
    THEN'  TRY o (EqSubst.eqsubst_tac ctxt [0] @{thms One_nat_def[symmetric]} )
    THEN'  TRY o (REPEAT_DETERM' (EqSubst.eqsubst_tac ctxt [0] @{thms Suc_eq_plus1} ))

    THEN' (resolve_tac ctxt @{thms TI_QUERYD})

    THEN' normalize_time_goal ctxt

    THEN' split_nat_tac ctxt

    THEN' FIRST' [resolve_tac ctxt @{thms refl} ,
        TRY o (safe_steps_tac ctxt) THEN' resolve_tac ctxt @{thms refl}  ]

    ;

  (***********************************)
  (*       Entailment Solver         *)
  (***********************************)

  (* Extract existential quantifiers from entailment goal *)
  fun extract_ex_tac ctxt i st = let
    fun count_ex (Const (@{const_name SLTC.entails},_)$_$c) =
      count_ex c RS @{thm HOL.mp}
    | count_ex (Const (@{const_name SLTC.ex_assn},_)$Abs (_,_,t))
      = count_ex t RS @{thm enorm_exI'}
    | count_ex _ = @{thm imp_refl};

    val concl = Logic.concl_of_goal (Thm.prop_of st) i |> HOLogic.dest_Trueprop;
    val thm = count_ex concl;
    (* val _ = tracing (Thm.string_of_thm ctxt thm); *)
  in
    (TRY o REPEAT_ALL_NEW (match_tac ctxt @{thms ent_ex_preI}) THEN'
     resolve_tac ctxt [thm]) i st
  end;

  fun atom_solve_tac ctxt =
        FIRST' [ resolve_tac ctxt @{thms ent_refl},
                 SOLVED' ( resolve_tac ctxt @{thms dollarD} THEN'
                             (SELECT_GOAL (auto_tac ctxt))  )
               ]

  (* Solve Entailment *)
  fun solve_entails_tac ctxt = let
    val preprocess_entails_tac =
      dflt_tac ctxt
      THEN' extract_ex_tac ctxt
      THEN' simp_tac
        (put_simpset HOL_ss ctxt addsimps @{thms solve_ent_preprocess_simps});

    val match_entails_tac =
      FIRST' [

      resolve_tac ctxt @{thms entails_solve_init_time}
      THEN' match_frame_tac (atom_solve_tac ctxt)  ctxt
      THEN' resolve_tac ctxt @{thms entails_solve_finalize}
      THEN'  TRY o (EqSubst.eqsubst_tac ctxt [0] @{thms One_nat_def[symmetric]} )
      THEN'  TRY o (REPEAT_DETERM' (EqSubst.eqsubst_tac ctxt [0] @{thms Suc_eq_plus1} ))

      THEN' (resolve_tac ctxt @{thms TI_QUERYD})
      THEN' normalize_time_goal ctxt
      THEN' SOLVED' (split_nat_tac ctxt),

      resolve_tac ctxt @{thms entails_solve_init}
      THEN' match_frame_tac (atom_solve_tac ctxt)  ctxt
      THEN' resolve_tac ctxt @{thms entails_solve_finalize}
       ];
  in
    preprocess_entails_tac
    THEN' (TRY o
      REPEAT_ALL_NEW (match_tac ctxt (rev (Named_Theorems.get ctxt @{named_theorems sep_eintros}))))
    THEN_ALL_NEW (  dflt_tac ctxt THEN'
      TRY o (match_tac ctxt @{thms ent_triv}
        ORELSE' resolve_tac ctxt @{thms ent_refl}
        ORELSE' match_entails_tac))
  end;

  (***********************************)
  (* Verification Condition Generator*)
  (***********************************)

  fun heap_rule_tac ctxt h_thms =
    resolve_tac ctxt h_thms ORELSE' (
    resolve_tac ctxt @{thms fi_rule} THEN' (resolve_tac ctxt h_thms THEN_IGNORE_NEWGOALS
    ( dflt_tac ctxt (*THEN' (fn k => print_tac ctxt "AAAH")*) THEN'  time_frame_inference_tac ctxt) ))

  (* Apply consequence rule if postcondition is not a schematic var *)
  fun app_post_cons_tac ctxt i st =
    case Logic.concl_of_goal (Thm.prop_of st) i |> HOLogic.dest_Trueprop of
      Const (@{const_name hoare_triple},_)$_$_$qt =>
        if is_Var (head_of qt) then no_tac st
        else resolve_tac ctxt @{thms cons_post_rule} i st
    | _ => no_tac st;

  fun vcg_step_tac ctxt = let
    val h_thms = rev (Named_Theorems.get ctxt @{named_theorems sep_heap_rules});
    val d_thms = rev (Named_Theorems.get ctxt @{named_theorems sep_decon_rules});
    val heap_rule_tac = heap_rule_tac ctxt h_thms

  in
    CSUBGOAL (snd #> (FIRST' [
      CHANGED o dflt_tac ctxt,
      REPEAT_ALL_NEW (resolve_tac ctxt @{thms normalize_rules}),
      CHANGED o (FIRST' [resolve_tac ctxt d_thms, heap_rule_tac]
        ORELSE' (app_post_cons_tac ctxt THEN'
          FIRST' [resolve_tac ctxt d_thms, heap_rule_tac]))
    ]))
  end;
  fun vcg_tac ctxt = REPEAT_DETERM' (  vcg_step_tac ctxt)

  (***********************************)
  (*        Automatic Solver         *)
  (***********************************)

  fun sep_autosolve_tac do_pre do_post ctxt = let
    val pre_tacs = [
      CHANGED o (clarsimp_tac ctxt),
      CHANGED o (REPEAT_ALL_NEW (match_tac ctxt @{thms ballI allI impI conjI}))
    ];
    val main_tacs = [
      match_tac ctxt @{thms is_hoare_triple} THEN' CHANGED o vcg_tac ctxt,
      match_tac ctxt @{thms is_entails} THEN' CHANGED o solve_entails_tac ctxt
    ];
    val post_tacs = [   SELECT_GOAL (auto_tac ctxt)];
    val tacs = (if do_pre then pre_tacs else [])
      @ main_tacs
      @ (if do_post then post_tacs else []);
  in
    REPEAT_DETERM' (CHANGED o FIRST' tacs)
  end;

  fun sep_step_autosolve_tac do_pre do_post ctxt = let
    val pre_tacs = [
      CHANGED o (clarsimp_tac ctxt),
      CHANGED o (REPEAT_ALL_NEW (match_tac ctxt @{thms ballI allI impI conjI}))
    ];
    val main_tacs = [
      match_tac ctxt @{thms is_hoare_triple} THEN' CHANGED o vcg_step_tac ctxt,
      match_tac ctxt @{thms is_entails} THEN' CHANGED o solve_entails_tac ctxt
    ];
    val post_tacs = [   SELECT_GOAL (auto_tac ctxt)];
    val tacs = (if do_pre then pre_tacs else [])
      @ main_tacs
      @ (if do_post then post_tacs else []);
  in
      (CHANGED o FIRST' tacs)
  end;

end; \<open>struct\<close>

\<close>

method_setup vcg = \<open>
  Scan.lift (Args.mode "ss") --
  Method.sections Seplogic_Auto.vcg_modifiers >>
  (fn (ss,_) => fn ctxt => SIMPLE_METHOD' (
  CHANGED o (
    if ss then Seplogic_Auto.vcg_step_tac ctxt
    else Seplogic_Auto.vcg_tac ctxt
  )
))\<close> "Seplogic: Verification Condition Generator"

method_setup sep_auto =
  \<open>Scan.lift (Args.mode "nopre" -- Args.mode "nopost" -- Args.mode "plain")
      --| Method.sections Seplogic_Auto.sep_auto_modifiers >>
  (fn ((nopre,nopost),plain) => fn ctxt => SIMPLE_METHOD' (
    CHANGED o Seplogic_Auto.sep_autosolve_tac
      ((not nopre) andalso (not plain))
      ((not nopost) andalso (not plain)) ctxt
  ))\<close> "Seplogic: Automatic solver"

method_setup sep_auto_step =
  \<open>Scan.lift (Args.mode "nopre" -- Args.mode "nopost" -- Args.mode "plain")
      --| Method.sections Seplogic_Auto.sep_auto_modifiers >>
  (fn ((nopre,nopost),plain) => fn ctxt => SIMPLE_METHOD' (
    CHANGED o Seplogic_Auto.sep_step_autosolve_tac
      ((not nopre) andalso (not plain))
      ((not nopost) andalso (not plain)) ctxt
  ))\<close> "Seplogic: Automatic solver"

method_setup solve_entails = \<open>
  Method.sections Seplogic_Auto.solve_entails_modifiers >>
  (fn _ => fn ctxt => SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.solve_entails_tac ctxt
))\<close> "Seplogic: Entailment Solver"

method_setup time_frame_inference = \<open>
  Method.sections Seplogic_Auto.solve_entails_modifiers >>
  (fn _ => fn ctxt => SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.time_frame_inference_tac ctxt
))\<close> "Seplogic: Frame Inference with Time Inference"

method_setup frame_inference = \<open>
  Method.sections Seplogic_Auto.solve_entails_modifiers >>
  (fn _ => fn ctxt => SIMPLE_METHOD' (
  CHANGED o Seplogic_Auto.frame_inference_tac ctxt
)) \<close> "Seplogic: Frame Inference without Time Inference"

simproc_setup assn_simproc
  ( "h \<Turnstile> P" | "P\<Longrightarrow>\<^sub>AQ" | "P\<Longrightarrow>\<^sub>tQ" | "(P::assn) = Q" )
  = \<open>K Seplogic_Auto.assn_simproc_fun\<close>

subsection \<open>Examples and Regression Tests\<close>

lemma " P * $ 0 \<Longrightarrow>\<^sub>A P * true "
  by (solve_entails)

lemma " P * $ 1 \<Longrightarrow>\<^sub>A P * true * $ 1"
  by (solve_entails)

lemma "QA \<Longrightarrow> (P \<Longrightarrow>\<^sub>A \<exists>\<^sub>Ax. Q x)"
      apply(tactic \<open>IF_EXGOAL (Seplogic_Auto.extract_ex_tac @{context}) 1\<close>)
  oops

  thm new_rule
schematic_goal "\<And>x. P \<Longrightarrow> Q \<Longrightarrow>   <x \<mapsto>\<^sub>a [0..<n] * $ (n * 15 + 11)> Array_Time.new n 0 <?Q18 x>"
  by (sep_auto heap: new_rule)

lemma "\<And>x. x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn ((M * N * 9))  * timeCredit_assn (2) \<Longrightarrow>\<^sub>A x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn (Suc (Suc (9 * (N * M))))"
  by (solve_entails)

schematic_goal "\<And>end start' start_next x' k k_next start'a start_nexta x'a enda start'b start_nextb x'b ka k_nexta start'c start_nextc x'c.
       start_nextc = Some p' \<and>
       k_nexta = enda \<and> k_nexta = Some start'c \<and> p' = start'b \<and> start_nexta = Some q' \<and> k_next = end \<and> k_next = Some start'a \<and> q' = start' \<Longrightarrow>
       <start'b \<mapsto>\<^sub>r Cell x'b start_nextb enda * R a x'b *
        (dll_seg R cs' start_nextb (Some start'b) ka enda *
        (start' \<mapsto>\<^sub>r Cell x' start_next end * R u x' * (dll_seg R vs' start_next (Some start') k end * (start'a \<mapsto>\<^sub>r Cell x'a (Some start') k * R w x'a)))) *
        $ 1>
       !start'b <?Q20 end start' start_next x' k end start'a (Some start') x'a enda start'b start_nextb x'b ka enda start'c (Some start'b) x'c>"
  apply (vcg (ss) heap: lookup_rule) oops

declare entt_refl' [simp]

lemma "\<And>x. M = 0 \<Longrightarrow> (\<And>j i. c (i, j) = 0) \<Longrightarrow> x \<mapsto>\<^sub>a [] \<Longrightarrow>\<^sub>A \<exists>\<^sub>Al. x \<mapsto>\<^sub>a l * true * \<up> (l = []) "
  apply(sep_auto)
  done

schematic_goal "timeCredit_assn (B* A * 10 + 3) \<Longrightarrow>\<^sub>A ?F1 * timeCredit_assn (B* A + 1)"
  by time_frame_inference

schematic_goal "ya \<mapsto>\<^sub>r Cell x' (Some end) (Some end) * (R x x' * end \<mapsto>\<^sub>r Cell y' (Some ya) (Some ya) * R y y') * $ 9 \<Longrightarrow>\<^sub>A
        ?F62 end x' y' (Cell x' (Some end) (Some end)) ya * $ 1"
  by time_frame_inference

schematic_goal "\<And>end x' y' xa ya.
       p = Some ya \<Longrightarrow>
       xa = Cell x' (Some end) (Some end) \<Longrightarrow>
       Some ya \<noteq> Some end \<Longrightarrow>
       ya \<mapsto>\<^sub>r Cell x' (Some end) (Some end) * (R x x' * end \<mapsto>\<^sub>r Cell y' (Some ya) (Some ya) * R y y') * $ 9 \<Longrightarrow>\<^sub>A
       ?F62 end x' y' (Cell x' (Some end) (Some end)) ya * $ 1"
  apply time_frame_inference done

(* timeframeinf can solve problems of that form: A * $T \<Longrightarrow>\<^sub>A B * ?F * $T' *)
schematic_goal "\<up> (i < length xs) * a \<mapsto>\<^sub>a xs *  $2  \<Longrightarrow>\<^sub>A a \<mapsto>\<^sub>a xs * ?F * $1"
  by time_frame_inference

schematic_goal "A * C * $2  \<Longrightarrow>\<^sub>A A * ?F * $1"
  by time_frame_inference

schematic_goal "a \<mapsto>\<^sub>a xs * $ 1 \<Longrightarrow>\<^sub>A a \<mapsto>\<^sub>a xs * ?F24 (xs ! i)   * $ 1"
  by time_frame_inference
thm mult_1

schematic_goal "a \<mapsto>\<^sub>a xs * $ (2 + 3 * ff + (5 * (3*ff+2)))
           \<Longrightarrow>\<^sub>A a \<mapsto>\<^sub>a xs * ?F24   * $ (1 + ff * 2 + 4 * ff)"
  by time_frame_inference

context begin
  definition "fffa = (10::nat)"

lemma "F * $(xx*(3+7+yy)) \<Longrightarrow>\<^sub>A F * $(xx*2+yy*xx) * true"
  by (solve_entails)

  schematic_goal "(3::nat) + 3 * fffa + 6 * 7 = 1 + ?F"
    apply(tactic \<open>Seplogic_Auto.split_nat_tac @{context} 1\<close>)
    done

  schematic_goal "(2::nat) + 3 * fffa  = 1 + ?F"
    apply(tactic \<open>Seplogic_Auto.split_nat_tac @{context} 1\<close>)
    done

  schematic_goal "(2::nat) + fffa * 32 = 1 + fffa * 1 + ?F"
    apply(tactic \<open>Seplogic_Auto.normalize_time_goal @{context} 1\<close>)
    apply(tactic \<open>Seplogic_Auto.split_nat_tac @{context} 1\<close>)
    done

  schematic_goal "(2::nat) + 3 * fffa  = 1 + 2 * fffa + ?F"
    apply(tactic \<open>Seplogic_Auto.normalize_time_goal @{context} 1\<close>)
    apply(tactic \<open>Seplogic_Auto.split_nat_tac @{context} 1\<close>)
    done
end

lemma "A \<Longrightarrow>\<^sub>A A"
  by solve_entails

lemma "A * B \<Longrightarrow>\<^sub>A A * true"
  by solve_entails

lemma "A * B * C \<Longrightarrow>\<^sub>A B * A * true"
  by solve_entails

lemma "$a * $b = $(a+b)"
  by (simp add: time_credit_add)

lemma "$1* \<up>g * G * $2 * $3 *true * F * true * \<up>ff * $4 * $5 = G * F * true * $ 10 * (\<up> g *  $5 * \<up> ff)"
  by (simp add : time_credit_add[symmetric] )

lemma "G * \<up>ff * true *  F   = H"  apply (simp )   oops

lemma "h \<Turnstile> F \<and>\<^sub>A \<up> (a' = None) * F' \<Longrightarrow> G" apply simp oops

lemma "h \<Turnstile> \<up>t * (F \<and>\<^sub>A \<up> (a' = None) * F') * X \<Longrightarrow> G" apply (simp del:  ) oops

lemma p_c[simp]: "\<up> P * \<up> Q = \<up> (P \<and> Q)" using pure_conj by simp

lemma "\<up>a * B * \<up>c \<Longrightarrow>\<^sub>A G" apply (simp add:  del: pure_conj) oops

lemma "\<exists>\<^sub>Ab. \<up> ((b, a) \<in> R) *C *\<up>a \<Longrightarrow>\<^sub>A emp" apply simp oops

lemma "P * $4 \<Longrightarrow>\<^sub>A P * true * $3"
    "P * $3 \<Longrightarrow>\<^sub>A P * true"
    "P * Q *  $(f x * 4 + 3) \<Longrightarrow>\<^sub>A Q * P * true * $(f x * 4)"
    "P * Q *  $(g y * 6 + f x * 4 + 3) \<Longrightarrow>\<^sub>A Q * P * true * $(g y * 2 + f x * 4)"
  by solve_entails+

lemma "\<And>x. x \<mapsto>\<^sub>a replicate (N * M) 0 * $ ((M * N * 9))  * $ (2)
       \<Longrightarrow>\<^sub>A x \<mapsto>\<^sub>a replicate (N * M) 0 * $ (Suc (Suc (9 * (N * M))))"
  by (sep_auto)

lemma "\<And>x. x \<mapsto>\<^sub>a replicate (N * M) 0 * $ ((M * N * 9))  * $ (2)
         \<Longrightarrow>\<^sub>A x \<mapsto>\<^sub>a replicate (N * M) 0 * timeCredit_assn (Suc (Suc (9 * (N * M))))"
  apply(vcg (ss))
  by (sep_auto)

subsection \<open>setup sep_auto rules\<close>

thm sep_eintros

lemma ureturn_rule: "<P> ureturn x <\<lambda>r. P * \<up>(r = x)>"
  apply(rule post_rule)
  apply(rule pre_rule[rotated])
    apply(rule frame_rule[OF return_rule, where R=P] )
  by auto

(* sep auto expects pure assertions to be pulled out in the pre condition TODO: is this correct? *)
lemma nth_rule'[sep_heap_rules]:
  "(i < length xs) \<Longrightarrow> <a \<mapsto>\<^sub>a xs * $ 1 > Array_Time.nth a i <\<lambda>r. a \<mapsto>\<^sub>a xs * \<up> (r = xs ! i)>"
  apply(rule pre_rule[OF _ nth_rule]) by sep_auto

lemma upd_rule': "i < length xs \<Longrightarrow> <a \<mapsto>\<^sub>a xs * timeCredit_assn 1 > Array_Time.upd i x a <\<lambda>r. a \<mapsto>\<^sub>a xs[i := x] * \<up> (r = a)>"
  apply(rule pre_rule[OF _ upd_rule])
  by solve_entails

lemma assert_rule_alt:
  "(Q \<Longrightarrow>\<^sub>A true * \<up>(P x)) \<Longrightarrow>
     <Q * $1> assert P x <\<lambda> _. Q * \<up>(P x)>"
  unfolding assert_def
  apply (sep_auto heap: SLTC.return_rule decon: assert_rule)
  unfolding hoare_triple_def
  using mod_starD by blast

lemma option_rule:
  assumes "p = None \<Longrightarrow> <P> f <Q>"
  assumes "\<And> x. p = Some x \<Longrightarrow> <P> g x <Q>"
  shows "<P> case p of None \<Rightarrow> f | Some x \<Rightarrow> g x <Q>"
  using assms by (sep_auto split: option.splits)

lemma prod_rule:
  assumes "\<And> x y. z = (x, y) \<Longrightarrow> <P> g x y <Q>"
  shows "<P> case z of (x, y) \<Rightarrow> g x y <Q>"
  using assms by (sep_auto split: prod.splits)

lemma prod_pre_split:
  assumes "\<And> x y. <P x y * \<up> (p = (x, y))> f <Q>"
  shows "<case p of (x, y) \<Rightarrow> P x y> f <Q>"
proof (cases p)
  case [simp]: (Pair x y)
  have "P x y * \<up> (p = (x, y)) = (case p of (x, y) \<Rightarrow> P x y)" by simp
  then show ?thesis using assms[of x y] by simp
qed

lemmas prod_split_rule = prod_rule

lemma If_rule:
  "(b \<Longrightarrow> <P> f <Q>) \<Longrightarrow> (\<not> b \<Longrightarrow> <P> g <Q>) \<Longrightarrow> <P> if b then f else g <Q>"
  by auto

lemma Let_rule: "(\<And>x. x = t \<Longrightarrow> <P> f x <Q>) \<Longrightarrow> <P> Let t f <Q>"
  by simp

lemma prod_case_simp[sep_dflt_simps]:
  "(case (a, b) of (c, d) \<Rightarrow> f c d) = f a b" by simp

lemmas [sep_decon_rules] =
          assert_rule bind_rule ureturn_rule Let_rule If_rule
          option_rule prod_rule prod_pre_split

lemmas [sep_heap_rules] =
          length_rule SLTC.return_rule
          new_rule make_rule
          ref_rule lookup_rule upd_rule'
          update_rule
          assert_rule_alt

thm upd_rule'

lemmas [sep_eintros] = impI conjI exI

subsection \<open>examples for sep_auto\<close>

schematic_goal "<$ 1> Array_Time.new 0 0 <?Q8>"
  by sep_auto

subsection \<open>BUGS and Ideas for enhancements\<close>

text \<open>time_frame_inference has the invariant, that the last
    component in the symbolic heap is a time credit.
    once such a time credit is not available the method breaks,
    this occurs for example, when an operation has no advertised cost
    while using sep_auto.
    e.g. in fibonacci/Doubly_Linked_List_With_Time : dll_fold_rule_weak\<close>
schematic_goal " xs\<^sub>2 = [] \<Longrightarrow>
          A * (B * F) * $ (Suc (Suc 0)) \<Longrightarrow>\<^sub>A
          B * F * ?R * $0"
  apply time_frame_inference oops

schematic_goal " xs\<^sub>2 = [] \<Longrightarrow>
          A * (B * F) * $ (Suc (Suc 0)) \<Longrightarrow>\<^sub>A
          B * F * ?R "   oops

end


section \<open>Multiset extension of order pairs in the other direction\<close>

text \<open>Many term orders are formulated in the other direction, i.e., they use
  strong normalization of $>$ instead of well-foundedness of $<$. Here, we
  flip the direction of the multiset extension of two orders, connect it to existing interfaces,
  and prove some further properties of the multiset extension.\<close>

theory Multiset_Extension2
  imports
    List_Order
    Multiset_Extension_Pair
begin

subsection \<open>List based characterization of @{const multpw}\<close>

lemma multpw_listI:
  assumes "length xs = length ys" "X = mset xs" "Y = mset ys"
    "\<forall>i. i < length ys \<longrightarrow> (xs ! i, ys ! i) \<in> ns"
  shows "(X, Y) \<in> multpw ns"
  using assms
proof (induct xs arbitrary: ys X Y)
  case (Nil ys) then show ?case by (cases ys) (auto intro: multpw.intros)
next
  case Cons1: (Cons x xs ys' X Y) then show ?case
  proof (cases ys')
    case (Cons y ys)
    then have "\<forall>i. i < length ys \<longrightarrow> (xs ! i, ys ! i) \<in> ns" using Cons1(5) by fastforce
    then show ?thesis using Cons1(2,5) by (auto intro!: multpw.intros simp: Cons(1) Cons1)
  qed auto
qed

lemma multpw_listE:
  assumes "(X, Y) \<in> multpw ns"
  obtains xs ys where "length xs = length ys" "X = mset xs" "Y = mset ys"
    "\<forall>i. i < length ys \<longrightarrow> (xs ! i, ys ! i) \<in> ns"
  using assms
proof (induct X Y arbitrary: thesis rule: multpw.induct)
  case (add x y X Y)
  then obtain xs ys where "length xs = length ys" "X = mset xs"
    "Y = mset ys" "(\<forall>i. i < length ys \<longrightarrow> (xs ! i, ys ! i) \<in> ns)" by blast
  then show ?case using add(1) by (intro add(4)[of "x # xs" "y # ys"]) (auto, case_tac i, auto)
qed auto

subsection\<open>Definition of the multiset extension of $>$-orders\<close>

text\<open>We define here the non-strict extension of the order pair $(\geqslant, >)$ --
  usually written as (ns, s) in the sources --
  by just flipping the directions twice.\<close>

definition ns_mul_ext :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a multiset rel"
  where "ns_mul_ext ns s \<equiv> (mult2_alt_ns (ns\<inverse>) (s\<inverse>))\<inverse>"

lemma ns_mul_extI:
  assumes "A = A1 + A2" and "B = B1 + B2"
    and "(A1, B1) \<in> multpw ns"
    and "\<And>b. b \<in># B2 \<Longrightarrow> \<exists>a. a \<in># A2 \<and> (a, b) \<in> s"
  shows "(A, B) \<in> ns_mul_ext ns s"
  using assms by (auto simp: ns_mul_ext_def multpw_converse intro!: mult2_alt_nsI)

lemma ns_mul_extE:
  assumes "(A, B) \<in> ns_mul_ext ns s"
  obtains A1 A2 B1 B2 where "A = A1 + A2" and "B = B1 + B2"
    and "(A1, B1) \<in> multpw ns"
    and "\<And>b. b \<in># B2 \<Longrightarrow> \<exists>a. a \<in># A2 \<and> (a, b) \<in> s"
  using assms by (auto simp: ns_mul_ext_def multpw_converse elim!: mult2_alt_nsE)

lemmas ns_mul_extI_old = ns_mul_extI[OF _ _ multpw_listI[OF _ refl refl], rule_format]

text\<open>Same for the "greater than" order on multisets.\<close>

definition s_mul_ext :: "'a rel \<Rightarrow> 'a rel \<Rightarrow> 'a multiset rel"
  where "s_mul_ext ns s \<equiv> (mult2_alt_s (ns\<inverse>) (s\<inverse>))\<inverse>"

lemma s_mul_extI:
  assumes "A = A1 + A2" and "B = B1 + B2"
    and "(A1, B1) \<in> multpw ns"
    and "A2 \<noteq> {#}" and "\<And>b. b \<in># B2 \<Longrightarrow> \<exists>a. a \<in># A2 \<and> (a, b) \<in> s"
  shows "(A, B) \<in> s_mul_ext ns s"
  using assms by (auto simp: s_mul_ext_def multpw_converse intro!: mult2_alt_sI)

lemma s_mul_extE:
  assumes "(A, B) \<in> s_mul_ext ns s"
  obtains A1 A2 B1 B2 where "A = A1 + A2" and "B = B1 + B2"
    and "(A1, B1) \<in> multpw ns"
    and "A2 \<noteq> {#}" and "\<And>b. b \<in># B2 \<Longrightarrow> \<exists>a. a \<in># A2 \<and> (a, b) \<in> s"
  using assms by (auto simp: s_mul_ext_def multpw_converse elim!: mult2_alt_sE)

lemmas s_mul_extI_old = s_mul_extI[OF _ _ multpw_listI[OF _ refl refl], rule_format]

subsection\<open>Basic properties\<close>

lemma s_mul_ext_mono:
  assumes "ns \<subseteq> ns'" "s \<subseteq> s'" shows "s_mul_ext ns s \<subseteq> s_mul_ext ns' s'"
  unfolding s_mul_ext_def using assms mono_mult2_alt[of "ns\<inverse>" "ns'\<inverse>" "s\<inverse>" "s'\<inverse>"] by simp

lemma ns_mul_ext_mono:
  assumes "ns \<subseteq> ns'" "s \<subseteq> s'" shows "ns_mul_ext ns s \<subseteq> ns_mul_ext ns' s'"
  unfolding ns_mul_ext_def using assms mono_mult2_alt[of "ns\<inverse>" "ns'\<inverse>" "s\<inverse>" "s'\<inverse>"] by simp

lemma s_mul_ext_local_mono:
  assumes sub: "(set_mset xs \<times> set_mset ys) \<inter> ns \<subseteq> ns'" "(set_mset xs \<times> set_mset ys) \<inter> s \<subseteq> s'"
    and rel: "(xs,ys) \<in> s_mul_ext ns s"
  shows "(xs,ys) \<in> s_mul_ext ns' s'"
  using rel s_mul_ext_mono[OF sub] mult2_alt_local[of ys xs False "ns\<inverse>" "s\<inverse>"]
  by (auto simp: s_mul_ext_def converse_Int ac_simps converse_Times)

lemma ns_mul_ext_local_mono:
  assumes sub: "(set_mset xs \<times> set_mset ys) \<inter> ns \<subseteq> ns'" "(set_mset xs \<times> set_mset ys) \<inter> s \<subseteq> s'"
    and rel: "(xs,ys) \<in> ns_mul_ext ns s"
  shows "(xs,ys) \<in> ns_mul_ext ns' s'"
  using rel ns_mul_ext_mono[OF sub] mult2_alt_local[of ys xs True "ns\<inverse>" "s\<inverse>"]
  by (auto simp: ns_mul_ext_def converse_Int ac_simps converse_Times)

text\<open>The empty multiset is the minimal element for these orders\<close>

lemma ns_mul_ext_bottom: "(A,{#}) \<in> ns_mul_ext ns s"
  by (auto intro!: ns_mul_extI)

lemma ns_mul_ext_bottom_uniqueness:
  assumes "({#},A) \<in> ns_mul_ext ns s"
  shows "A = {#}"
  using assms by (auto simp: ns_mul_ext_def mult2_alt_ns_def)

lemma ns_mul_ext_bottom2:
  assumes "(A,B) \<in> ns_mul_ext ns s"
    and "B \<noteq> {#}"
  shows "A \<noteq> {#}"
  using assms by (auto simp: ns_mul_ext_def mult2_alt_ns_def)

lemma s_mul_ext_bottom:
  assumes "A \<noteq> {#}"
  shows "(A,{#}) \<in> s_mul_ext ns s"
  using assms by (auto simp: s_mul_ext_def mult2_alt_s_def)

lemma s_mul_ext_bottom_strict:
  "({#},A) \<notin> s_mul_ext ns s"
  by (auto simp: s_mul_ext_def mult2_alt_s_def)

text\<open>Obvious introduction rules.\<close>

lemma all_ns_ns_mul_ext:
  assumes "length as = length bs"
    and "\<forall>i. i < length bs \<longrightarrow> (as ! i, bs ! i) \<in> ns"
  shows "(mset as, mset bs) \<in> ns_mul_ext ns s"
  using assms by (auto intro!: ns_mul_extI[of _ _ "{#}" _ _ "{#}"] multpw_listI)

lemma all_s_s_mul_ext:
  assumes "A \<noteq> {#}"
    and "\<forall>b. b \<in># B \<longrightarrow> (\<exists>a. a \<in># A \<and> (a,b) \<in> s)"
  shows "(A, B) \<in> s_mul_ext ns s"
  using assms by (auto intro!: s_mul_extI[of _ "{#}" _ _ "{#}"] multpw_listI)

text\<open>Being stricly lesser than implies being lesser than\<close>

lemma s_ns_mul_ext:
  assumes "(A, B) \<in> s_mul_ext ns s"
  shows "(A, B) \<in> ns_mul_ext ns s"
  using assms by (simp add: s_mul_ext_def ns_mul_ext_def mult2_alt_s_implies_mult2_alt_ns)

text\<open>The non-strict order is reflexive.\<close>

lemma multpw_refl':
  assumes "locally_refl ns A"
  shows "(A, A) \<in> multpw ns"
proof -
  have "Restr Id (set_mset A) \<subseteq> ns" using assms by (auto simp: locally_refl_def)
  from refl_multpw[of Id] multpw_local[of A A Id] mono_multpw[OF this]
  show ?thesis by (auto simp: refl_on_def)
qed

lemma ns_mul_ext_refl_local:
  assumes "locally_refl ns A"
  shows "(A, A) \<in> ns_mul_ext ns s"
  using assms by (auto intro!:  ns_mul_extI[of A A "{#}" A A "{#}" ns s] multpw_refl')

lemma ns_mul_ext_refl:
  assumes "refl ns"
  shows "(A, A) \<in> ns_mul_ext ns s"
  using assms ns_mul_ext_refl_local[of ns A s] unfolding refl_on_def locally_refl_def by auto

text\<open>The orders are union-compatible\<close>

lemma ns_s_mul_ext_union_multiset_l:
  assumes "(A, B) \<in> ns_mul_ext ns s"
    and "C \<noteq> {#}"
    and "\<forall>d. d \<in># D \<longrightarrow> (\<exists>c. c \<in># C \<and> (c,d) \<in> s)"
  shows "(A + C, B + D) \<in> s_mul_ext ns s"
  using assms unfolding ns_mul_ext_def s_mul_ext_def
  by (auto intro!: converseI mult2_alt_ns_s_add mult2_alt_sI[of _ "{#}" _ _ "{#}"])

lemma s_mul_ext_union_compat:
  assumes "(A, B) \<in> s_mul_ext ns s"
    and "locally_refl ns C"
  shows "(A + C, B + C) \<in> s_mul_ext ns s"
  using assms ns_mul_ext_refl_local[OF assms(2)] unfolding ns_mul_ext_def s_mul_ext_def
  by (auto intro!: converseI mult2_alt_s_ns_add)

lemma ns_mul_ext_union_compat:
  assumes "(A, B) \<in> ns_mul_ext ns s"
    and "locally_refl ns C"
  shows "(A + C, B + C) \<in> ns_mul_ext ns s"
  using assms ns_mul_ext_refl_local[OF assms(2)] unfolding ns_mul_ext_def s_mul_ext_def
  by (auto intro!: converseI mult2_alt_ns_ns_add)

context
  fixes NS :: "'a rel"
  assumes NS: "refl NS"
begin

lemma refl_imp_locally_refl: "locally_refl NS A" using NS unfolding refl_on_def locally_refl_def by auto

lemma supseteq_imp_ns_mul_ext:
  assumes "A \<supseteq># B"
  shows "(A, B) \<in> ns_mul_ext NS S"
  using assms
  by (auto intro!: ns_mul_extI[of A B "A - B" B B "{#}"] multpw_refl' refl_imp_locally_refl
      simp: subset_mset.add_diff_inverse)

lemma supset_imp_s_mul_ext:
  assumes "A \<supset># B"
  shows "(A, B) \<in> s_mul_ext NS S"
  using assms subset_mset.add_diff_inverse[of B A]
  by (auto intro!: s_mul_extI[of A B "A - B" B B "{#}"] multpw_refl' refl_imp_locally_refl
      simp: Diff_eq_empty_iff_mset)

end

definition mul_ext :: "('a \<Rightarrow> 'a \<Rightarrow> bool \<times> bool) \<Rightarrow> 'a list \<Rightarrow> 'a list \<Rightarrow> bool \<times> bool"
  where "mul_ext f xs ys \<equiv> let s = {(x,y). fst (f x y)}; ns = {(x,y). snd (f x y)}
    in ((mset xs,mset ys) \<in> s_mul_ext ns s, (mset xs, mset ys) \<in> ns_mul_ext ns s)"

definition "smulextp f m n \<longleftrightarrow> (m, n) \<in> s_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}"
definition "nsmulextp f m n \<longleftrightarrow> (m, n) \<in> ns_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}"

lemma smulextp_cong[fundef_cong]:
  assumes "xs1 = ys1"
    and "xs2 = ys2"
    and "\<And> x x'. x \<in># ys1 \<Longrightarrow> x' \<in># ys2 \<Longrightarrow> f x x' = g x x'"
  shows "smulextp f xs1 xs2 = smulextp g ys1 ys2"
  unfolding smulextp_def
proof
  assume "(xs1, xs2) \<in> s_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}"
  from s_mul_ext_local_mono[OF _ _ this, of "{(x, y). snd (g x y)}" "{(x, y). fst (g x y)}"]
  show "(ys1, ys2) \<in> s_mul_ext {(x, y). snd (g x y)} {(x, y). fst (g x y)}"
    using assms by force
next
  assume "(ys1, ys2) \<in> s_mul_ext {(x, y). snd (g x y)} {(x, y). fst (g x y)}"
  from s_mul_ext_local_mono[OF _ _ this, of "{(x, y). snd (f x y)}" "{(x, y). fst (f x y)}"]
  show "(xs1, xs2) \<in> s_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}"
    using assms by force
qed

lemma nsmulextp_cong[fundef_cong]:
  assumes "xs1 = ys1"
    and "xs2 = ys2"
    and "\<And> x x'. x \<in># ys1 \<Longrightarrow> x' \<in># ys2 \<Longrightarrow> f x x' = g x x'"
  shows "nsmulextp f xs1 xs2 = nsmulextp g ys1 ys2"
  unfolding nsmulextp_def
proof
  assume "(xs1, xs2) \<in> ns_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}"
  from ns_mul_ext_local_mono[OF _ _ this, of "{(x, y). snd (g x y)}" "{(x, y). fst (g x y)}"]
  show "(ys1, ys2) \<in> ns_mul_ext {(x, y). snd (g x y)} {(x, y). fst (g x y)}"
    using assms by force
next
  assume "(ys1, ys2) \<in> ns_mul_ext {(x, y). snd (g x y)} {(x, y). fst (g x y)}"
  from ns_mul_ext_local_mono[OF _ _ this, of "{(x, y). snd (f x y)}" "{(x, y). fst (f x y)}"]
  show "(xs1, xs2) \<in> ns_mul_ext {(x, y). snd (f x y)} {(x, y). fst (f x y)}"
    using assms by force
qed

definition "mulextp f m n = (smulextp f m n, nsmulextp f m n)"

lemma mulextp_cong[fundef_cong]:
  assumes "xs1 = ys1"
    and "xs2 = ys2"
    and "\<And> x x'. x \<in># ys1 \<Longrightarrow> x' \<in># ys2 \<Longrightarrow> f x x' = g x x'"
  shows "mulextp f xs1 xs2 = mulextp g ys1 ys2"
  unfolding mulextp_def using assms by (auto cong: nsmulextp_cong smulextp_cong)

lemma mset_s_mul_ext:
  "(mset xs, mset ys) \<in> s_mul_ext {(x, y). snd (f x y)} {(x, y).fst (f x y)} \<longleftrightarrow>
    fst (mul_ext f xs ys)"
  by (auto simp: mul_ext_def Let_def)

lemma mset_ns_mul_ext:
  "(mset xs, mset ys) \<in> ns_mul_ext {(x, y). snd (f x y)} {(x, y).fst (f x y)} \<longleftrightarrow>
    snd (mul_ext f xs ys)"
  by (auto simp: mul_ext_def Let_def)

lemma smulextp_mset_code:
  "smulextp f (mset xs) (mset ys) \<longleftrightarrow> fst (mul_ext f xs ys)"
  unfolding smulextp_def mset_s_mul_ext ..

lemma nsmulextp_mset_code:
  "nsmulextp f (mset xs) (mset ys) \<longleftrightarrow> snd (mul_ext f xs ys)"
  unfolding nsmulextp_def mset_ns_mul_ext ..

lemma nstri_mul_ext_map:
  assumes "\<And>s t. s \<in> set ss \<Longrightarrow> t \<in> set ts \<Longrightarrow> fst (order s t) \<Longrightarrow> fst (order' (f s) (f t))"
    and "\<And>s t. s \<in> set ss \<Longrightarrow> t \<in> set ts \<Longrightarrow> snd (order s t) \<Longrightarrow> snd (order' (f s) (f t))"
    and "snd (mul_ext order ss ts)"
  shows "snd (mul_ext order' (map f ss) (map f ts))"
  using assms mult2_alt_map[of "mset ts" "mset ss" "{(t, s). snd (order s t)}" f f
      "{(t, s). snd (order' s t)}" "{(t, s). fst (order s t)}" "{(t, s). fst (order' s t)}" True]
  by (auto simp: mul_ext_def ns_mul_ext_def converse_unfold)

lemma stri_mul_ext_map:
  assumes "\<And>s t. s \<in> set ss \<Longrightarrow> t \<in> set ts \<Longrightarrow> fst (order s t) \<Longrightarrow> fst (order' (f s) (f t))"
    and "\<And>s t. s \<in> set ss \<Longrightarrow> t \<in> set ts \<Longrightarrow> snd (order s t) \<Longrightarrow> snd (order' (f s) (f t))"
    and "fst (mul_ext order ss ts)"
  shows "fst (mul_ext order' (map f ss) (map f ts))"
  using assms mult2_alt_map[of "mset ts" "mset ss" "{(t,s). snd (order s t)}" f f
      "{(t, s). snd (order' s t)}" "{(t, s). fst (order s t)}" "{(t, s). fst (order' s t)}" False]
  by (auto simp: mul_ext_def s_mul_ext_def converse_unfold)

text \<open>The non-strict order is transitive.\<close>

lemma ns_mul_ext_trans:
  assumes "trans s" "trans ns" "compatible_l ns s" "compatible_r ns s" "refl ns"
    and "(A, B) \<in> ns_mul_ext ns s"
    and "(B, C) \<in> ns_mul_ext ns s"
  shows "(A, C) \<in> ns_mul_ext ns s"
  using assms unfolding compatible_l_def compatible_r_def ns_mul_ext_def
  using trans_mult2_ns[of "s\<inverse>" "ns\<inverse>"]
  by (auto simp: mult2_ns_eq_mult2_ns_alt converse_relcomp[symmetric]) (metis trans_def)

text\<open>The strict order is trans.\<close>

lemma s_mul_ext_trans:
  assumes "trans s" "trans ns" "compatible_l ns s" "compatible_r ns s" "refl ns"
    and "(A, B) \<in> s_mul_ext ns s"
    and "(B, C) \<in> s_mul_ext ns s"
  shows "(A, C) \<in> s_mul_ext ns s"
  using assms unfolding compatible_l_def compatible_r_def s_mul_ext_def
  using trans_mult2_s[of "s\<inverse>" "ns\<inverse>"]
  by (auto simp: mult2_s_eq_mult2_s_alt converse_relcomp[symmetric]) (metis trans_def)

text\<open>The strict order is compatible on the left with the non strict one\<close>

lemma s_ns_mul_ext_trans:
  assumes "trans s" "trans ns" "compatible_l ns s" "compatible_r ns s" "refl ns"
    and "(A, B) \<in> s_mul_ext ns s"
    and "(B, C) \<in> ns_mul_ext ns s"
  shows "(A, C) \<in> s_mul_ext ns s"
  using assms unfolding compatible_l_def compatible_r_def s_mul_ext_def ns_mul_ext_def
  using compat_mult2(1)[of "s\<inverse>" "ns\<inverse>"]
  by (auto simp: mult2_s_eq_mult2_s_alt mult2_ns_eq_mult2_ns_alt converse_relcomp[symmetric])

text\<open>The strict order is compatible on the right with the non-strict one.\<close>

lemma ns_s_mul_ext_trans:
  assumes "trans s" "trans ns" "compatible_l ns s" "compatible_r ns s" "refl ns"
    and "(A, B) \<in> ns_mul_ext ns s"
    and "(B, C) \<in> s_mul_ext ns s"
  shows "(A, C) \<in> s_mul_ext ns s"
  using assms unfolding compatible_l_def compatible_r_def s_mul_ext_def ns_mul_ext_def
  using compat_mult2(2)[of "s\<inverse>" "ns\<inverse>"]
  by (auto simp: mult2_s_eq_mult2_s_alt mult2_ns_eq_mult2_ns_alt converse_relcomp[symmetric])

text\<open>@{const s_mul_ext} is strongly normalizing\<close>

lemma SN_s_mul_ext_strong:
  assumes "order_pair s ns"
    and "\<forall>y. y \<in># M \<longrightarrow> SN_on s {y}"
  shows "SN_on (s_mul_ext ns s) {M}"
  using mult2_s_eq_mult2_s_alt[of "ns\<inverse>" "s\<inverse>"] assms wf_below_pointwise[of "s\<inverse>" "set_mset M"]
  unfolding SN_on_iff_wf_below s_mul_ext_def order_pair_def compat_pair_def pre_order_pair_def
  by (auto intro!: wf_below_mult2_s_local simp: converse_relcomp[symmetric])

lemma SN_s_mul_ext:
  assumes "order_pair s ns" "SN s"
  shows "SN (s_mul_ext ns s)"
  using SN_s_mul_ext_strong[OF assms(1)] assms(2)
  by (auto simp: SN_on_def)

lemma (in order_pair) mul_ext_order_pair:
  "order_pair (s_mul_ext NS S) (ns_mul_ext NS S)" (is "order_pair ?S ?NS")
proof
  from s_mul_ext_trans trans_S trans_NS compat_NS_S compat_S_NS refl_NS
  show "trans ?S" unfolding trans_def compatible_l_def compatible_r_def by blast
next
  from ns_mul_ext_trans trans_S trans_NS compat_NS_S compat_S_NS refl_NS
  show "trans ?NS" unfolding trans_def compatible_l_def compatible_r_def by blast
next
  from ns_s_mul_ext_trans trans_S trans_NS compat_NS_S compat_S_NS refl_NS
  show "?NS O ?S \<subseteq> ?S" unfolding trans_def compatible_l_def compatible_r_def by blast
next
  from s_ns_mul_ext_trans trans_S trans_NS compat_NS_S compat_S_NS refl_NS
  show "?S O ?NS \<subseteq> ?S" unfolding trans_def compatible_l_def compatible_r_def by blast
next
  from ns_mul_ext_refl[OF refl_NS, of _ S]
  show "refl ?NS" unfolding refl_on_def by fast
qed

lemma (in SN_order_pair) mul_ext_SN_order_pair: "SN_order_pair (s_mul_ext NS S) (ns_mul_ext NS S)"
  (is "SN_order_pair ?S ?NS")
proof -
  from mul_ext_order_pair
  interpret order_pair ?S ?NS .
  have "order_pair S NS" by unfold_locales
  then interpret SN_ars ?S using SN_s_mul_ext[of S NS] SN by unfold_locales
  show ?thesis by unfold_locales
qed

lemma mul_ext_compat:
  assumes compat: "\<And> s t u. \<lbrakk>s \<in> set ss; t \<in> set ts; u \<in> set us\<rbrakk> \<Longrightarrow>
    (snd (f s t) \<and> fst (f t u) \<longrightarrow> fst (f s u)) \<and>
    (fst (f s t) \<and> snd (f t u) \<longrightarrow> fst (f s u)) \<and>
    (snd (f s t) \<and> snd (f t u) \<longrightarrow> snd (f s u)) \<and>
    (fst (f s t) \<and> fst (f t u) \<longrightarrow> fst (f s u))"
  shows "
    (snd (mul_ext f ss ts) \<and> fst (mul_ext f ts us) \<longrightarrow> fst (mul_ext f ss us)) \<and>
    (fst (mul_ext f ss ts) \<and> snd (mul_ext f ts us) \<longrightarrow> fst (mul_ext f ss us)) \<and>
    (snd (mul_ext f ss ts) \<and> snd (mul_ext f ts us) \<longrightarrow> snd (mul_ext f ss us)) \<and>
    (fst (mul_ext f ss ts) \<and> fst (mul_ext f ts us) \<longrightarrow> fst (mul_ext f ss us)) "
proof -
  let ?s = "{(x, y). fst (f x y)}\<inverse>" and ?ns = "{(x, y). snd (f x y)}\<inverse>"
  have [dest]: "(mset ts, mset ss) \<in> mult2_alt b2 ?ns ?s \<Longrightarrow> (mset us, mset ts) \<in> mult2_alt b1 ?ns ?s \<Longrightarrow>
    (mset us, mset ss) \<in> mult2_alt (b1 \<and> b2) ?ns ?s" for b1 b2
    using assms by (auto intro!: trans_mult2_alt_local[of _ "mset ts"] simp: in_multiset_in_set)
  show ?thesis by (auto simp: mul_ext_def s_mul_ext_def ns_mul_ext_def Let_def)
qed

lemma mul_ext_cong[fundef_cong]:
  assumes "mset xs1 = mset ys1"
    and "mset xs2 = mset ys2"
    and "\<And> x x'. x \<in> set ys1 \<Longrightarrow> x' \<in> set ys2 \<Longrightarrow> f x x' = g x x'"
  shows "mul_ext f xs1 xs2 = mul_ext g ys1 ys2"
  using assms
    mult2_alt_map[of "mset xs2" "mset xs1" "{(x, y). snd (f x y)}\<inverse>" id id "{(x, y). snd (g x y)}\<inverse>"
      "{(x, y). fst (f x y)}\<inverse>" "{(x, y). fst (g x y)}\<inverse>"]
    mult2_alt_map[of "mset ys2" "mset ys1" "{(x, y). snd (g x y)}\<inverse>" id id "{(x, y). snd (f x y)}\<inverse>"
      "{(x, y). fst (g x y)}\<inverse>" "{(x, y). fst (f x y)}\<inverse>"]
  by (auto simp: mul_ext_def s_mul_ext_def ns_mul_ext_def Let_def in_multiset_in_set)

lemma all_nstri_imp_mul_nstri:
  assumes "\<forall>i<length ys. snd (f (xs ! i) (ys ! i))"
    and "length xs = length ys"
  shows "snd (mul_ext f xs ys)"
proof-
  from assms(1) have "\<forall>i. i < length ys \<longrightarrow> (xs ! i, ys ! i) \<in> {(x,y). snd (f x y)}" by simp
  from all_ns_ns_mul_ext[OF assms(2) this] show ?thesis by (simp add: mul_ext_def)
qed

lemma relation_inter:
  shows "{(x,y). P x y} \<inter> {(x,y). Q x y} = {(x,y). P x y \<and> Q x y}"
  by blast

lemma mul_ext_unfold:
  "(x,y) \<in> {(a,b). fst (mul_ext g a b)} \<longleftrightarrow> (mset x, mset y) \<in> (s_mul_ext {(a,b). snd (g a b)} {(a,b). fst (g a b)})"
  unfolding mul_ext_def by (simp add: Let_def)

text \<open>The next lemma is a local version of strong-normalization of
  the multiset extension, where the base-order only has to be strongly normalizing
  on elements of the multisets. This will be crucial for orders that are defined recursively
  on terms, such as RPO or WPO.\<close>
lemma mul_ext_SN:
  assumes "\<forall>x. snd (g x x)"
    and "\<forall>x y z. fst (g x y) \<longrightarrow> snd (g y z) \<longrightarrow> fst (g x z)"
    and "\<forall>x y z. snd (g x y) \<longrightarrow> fst (g y z) \<longrightarrow> fst (g x z)"
    and "\<forall>x y z. snd (g x y) \<longrightarrow> snd (g y z) \<longrightarrow> snd (g x z)"
    and "\<forall>x y z. fst (g x y) \<longrightarrow> fst (g y z) \<longrightarrow> fst (g x z)"
  shows "SN {(ys, xs).
  (\<forall>y\<in>set ys. SN_on {(s ,t). fst (g s t)} {y}) \<and>
  fst (mul_ext g ys xs)}"
proof -
  let ?R1 = "\<lambda>xs ys. \<forall>y\<in> set ys. SN_on {(s ,t). fst (g s t)} {y}"
  let ?R2 = "\<lambda>xs ys. fst (mul_ext g ys xs)"
  let ?s = "{(x,y). fst (g x y)}" and ?ns = "{(x,y). snd (g x y)}"
  have OP: "order_pair ?s ?ns" using assms(1-5)
    by unfold_locales ((unfold refl_on_def trans_def)?, blast)+
  let ?R = "{(ys, xs). ?R1 xs ys \<and> ?R2 xs ys}"
  let ?Sn = "SN_on ?R"
  {
    fix ys xs
    assume R_ys_xs: "(ys, xs) \<in> ?R"
    let ?mys = "mset ys"
    let ?mxs = "mset xs"
    from R_ys_xs have  HSN_ys: "\<forall>y. y \<in> set ys \<longrightarrow> SN_on ?s {y}" by simp
    with in_multiset_in_set[of ys] have "\<forall>y. y \<in># ?mys \<longrightarrow> SN_on ?s {y}" by simp
    from SN_s_mul_ext_strong[OF OP this] and mul_ext_unfold
    have "SN_on {(ys,xs). fst (mul_ext g ys xs)} {ys}" by fast
    from relation_inter[of ?R2 ?R1] and SN_on_weakening[OF this]
    have "SN_on ?R {ys}" by blast
  }
  then have Hyp: "\<forall>ys xs. (ys,xs) \<in> ?R \<longrightarrow> SN_on ?R {ys}" by auto
  {
    fix ys
    have "SN_on ?R {ys}"
    proof (cases "\<exists> xs. (ys, xs) \<in> ?R")
      case True with Hyp show ?thesis by simp
    next
      case False then show ?thesis by auto
    qed
  }
  then show ?thesis unfolding SN_on_def by simp
qed

lemma mul_ext_stri_imp_nstri:
  assumes "fst (mul_ext f as bs)"
  shows "snd (mul_ext f as bs)"
  using assms and s_ns_mul_ext unfolding mul_ext_def by (auto simp: Let_def)

lemma ns_ns_mul_ext_union_compat:
  assumes "(A,B) \<in> ns_mul_ext ns s"
    and "(C,D) \<in> ns_mul_ext ns s"
  shows "(A + C, B + D) \<in> ns_mul_ext ns s"
  using assms by (auto simp: ns_mul_ext_def intro: mult2_alt_ns_ns_add)

lemma s_ns_mul_ext_union_compat:
  assumes "(A,B) \<in> s_mul_ext ns s"
    and "(C,D) \<in> ns_mul_ext ns s"
  shows "(A + C, B + D) \<in> s_mul_ext ns s"
  using assms by (auto simp: s_mul_ext_def ns_mul_ext_def intro: mult2_alt_s_ns_add)

lemma ns_ns_mul_ext_union_compat_rtrancl: assumes refl: "refl ns"
  and AB: "(A, B) \<in> (ns_mul_ext ns s)\<^sup>*"
  and CD: "(C, D) \<in> (ns_mul_ext ns s)\<^sup>*"
shows "(A + C, B + D) \<in> (ns_mul_ext ns s)\<^sup>*"
proof -
  {
    fix A B C
    assume "(A, B) \<in> (ns_mul_ext ns s)\<^sup>*"
    then have "(A + C, B + C) \<in> (ns_mul_ext ns s)\<^sup>*"
    proof (induct rule: rtrancl_induct)
      case (step B D)
      have "(C, C) \<in> ns_mul_ext ns s"
        by (rule ns_mul_ext_refl, insert refl, auto simp: locally_refl_def refl_on_def)
      from ns_ns_mul_ext_union_compat[OF step(2) this] step(3)
      show ?case by auto
    qed auto
  }
  from this[OF AB, of C] this[OF CD, of B]
  show ?thesis by (auto simp: ac_simps)
qed

subsection \<open>Multisets as order on lists\<close>

interpretation mul_ext_list: list_order_extension
  "\<lambda>s ns. {(as, bs). (mset as, mset bs) \<in> s_mul_ext ns s}"
  "\<lambda>s ns. {(as, bs). (mset as, mset bs) \<in> ns_mul_ext ns s}"
proof -
  let ?m = "mset :: ('a list \<Rightarrow> 'a multiset)"
  let ?S = "\<lambda>s ns. {(as, bs). (?m as, ?m bs) \<in> s_mul_ext ns s}"
  let ?NS = "\<lambda>s ns. {(as, bs). (?m as, ?m bs) \<in> ns_mul_ext ns s}"
  show "list_order_extension ?S ?NS"
  proof (rule list_order_extension.intro)
    fix s ns
    let ?s = "?S s ns"
    let ?ns = "?NS s ns"
    assume "SN_order_pair s ns"
    then interpret SN_order_pair s ns .
    interpret SN_order_pair "(s_mul_ext ns s)" "(ns_mul_ext ns s)"
      by (rule mul_ext_SN_order_pair)
    show "SN_order_pair ?s ?ns"
    proof
      show "refl ?ns" using refl_NS unfolding refl_on_def by blast
      show "?ns O ?s \<subseteq> ?s" using compat_NS_S by blast
      show "?s O ?ns \<subseteq> ?s" using compat_S_NS by blast
      show "trans ?ns" using trans_NS unfolding trans_def by blast
      show "trans ?s" using trans_S unfolding trans_def by blast
      show "SN ?s" using SN_inv_image[OF SN, of ?m, unfolded inv_image_def] .
    qed
  next
    fix S f NS as bs
    assume "\<And>a b. (a, b) \<in> S \<Longrightarrow> (f a, f b) \<in> S"
      "\<And>a b. (a, b) \<in> NS \<Longrightarrow> (f a, f b) \<in> NS"
      "(as, bs) \<in> ?S S NS"
    then show "(map f as, map f bs) \<in> ?S S NS"
      using mult2_alt_map[of _ _ "NS\<inverse>" f f "NS\<inverse>" "S\<inverse>" "S\<inverse>"] by (auto simp: mset_map s_mul_ext_def)
  next
    fix S f NS as bs
    assume "\<And>a b. (a, b) \<in> S \<Longrightarrow> (f a, f b) \<in> S"
      "\<And>a b. (a, b) \<in> NS \<Longrightarrow> (f a, f b) \<in> NS"
      "(as, bs) \<in> ?NS S NS"
    then show "(map f as, map f bs) \<in> ?NS S NS"
      using mult2_alt_map[of _ _ "NS\<inverse>" f f "NS\<inverse>" "S\<inverse>" "S\<inverse>"] by (auto simp: mset_map ns_mul_ext_def)
  next
    fix as bs :: "'a list" and NS S :: "'a rel"
    assume ass: "length as = length bs"
      "\<And>i. i < length bs \<Longrightarrow> (as ! i, bs ! i) \<in> NS"
    show "(as, bs) \<in> ?NS S NS"
      by (rule, unfold split, rule all_ns_ns_mul_ext, insert ass, auto)
  qed
qed

lemma s_mul_ext_singleton [simp, intro]:
  assumes "(a, b) \<in> s"
  shows "({#a#}, {#b#}) \<in> s_mul_ext ns s"
  using assms by (auto simp: s_mul_ext_def mult2_alt_s_single)

lemma ns_mul_ext_singleton [simp, intro]:
  "(a, b) \<in> ns \<Longrightarrow> ({#a#}, {#b#}) \<in> ns_mul_ext ns s"
  by (auto simp: ns_mul_ext_def multpw_converse intro: multpw_implies_mult2_alt_ns multpw_single)

lemma ns_mul_ext_singleton2:
  "(a, b) \<in> s \<Longrightarrow> ({#a#}, {#b#}) \<in> ns_mul_ext ns s"
  by (intro s_ns_mul_ext s_mul_ext_singleton)

lemma s_mul_ext_self_extend_left:
  assumes "A \<noteq> {#}" and "locally_refl W B"
  shows "(A + B, B) \<in> s_mul_ext W S"
proof -
  have "(A + B, {#} + B) \<in> s_mul_ext W S"
    using assms by (intro s_mul_ext_union_compat) (auto dest: s_mul_ext_bottom)
  then show ?thesis by simp
qed

lemma s_mul_ext_ne_extend_left:
  assumes "A \<noteq> {#}" and "(B, C) \<in> ns_mul_ext W S"
  shows "(A + B, C) \<in> s_mul_ext W S"
  using assms
proof -
  have "(A + B, {#} + C) \<in> s_mul_ext W S"
    using assms by (intro s_ns_mul_ext_union_compat)
      (auto simp: s_mul_ext_bottom dest: s_ns_mul_ext)
  then show ?thesis by (simp add: ac_simps)
qed

lemma s_mul_ext_extend_left:
  assumes "(B, C) \<in> s_mul_ext W S"
  shows "(A + B, C) \<in> s_mul_ext W S"
  using assms
proof -
  have "(B + A, C + {#}) \<in> s_mul_ext W S"
    using assms by (intro s_ns_mul_ext_union_compat)
      (auto simp: ns_mul_ext_bottom dest: s_ns_mul_ext)
  then show ?thesis by (simp add: ac_simps)
qed

lemma mul_ext_mono:
  assumes "\<And>x y. \<lbrakk>x \<in> set xs; y \<in> set ys; fst (P x y)\<rbrakk> \<Longrightarrow> fst (P' x y)"
    and   "\<And>x y. \<lbrakk>x \<in> set xs; y \<in> set ys; snd (P x y)\<rbrakk> \<Longrightarrow> snd (P' x y)"
  shows
    "fst (mul_ext P xs ys) \<Longrightarrow> fst (mul_ext P' xs ys)"
    "snd (mul_ext P xs ys) \<Longrightarrow> snd (mul_ext P' xs ys)"
  unfolding mul_ext_def Let_def fst_conv snd_conv
proof -
  assume mem: "(mset xs, mset ys) \<in> s_mul_ext {(x, y). snd (P x y)} {(x, y). fst (P x y)}"
  show "(mset xs, mset ys) \<in> s_mul_ext {(x, y). snd (P' x y)} {(x, y). fst (P' x y)}"
    by (rule s_mul_ext_local_mono[OF _ _ mem], insert assms, auto)
next
  assume mem: "(mset xs, mset ys) \<in> ns_mul_ext {(x, y). snd (P x y)} {(x, y). fst (P x y)}"
  show "(mset xs, mset ys) \<in> ns_mul_ext {(x, y). snd (P' x y)} {(x, y). fst (P' x y)}"
    by (rule ns_mul_ext_local_mono[OF _ _ mem], insert assms, auto)
qed

subsection \<open>Special case: non-strict order is equality\<close>

lemma ns_mul_ext_IdE:
  assumes "(M, N) \<in> ns_mul_ext Id R"
  obtains X and Y and Z where "M = X + Z" and "N = Y + Z"
    and "\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. (x, y) \<in> R"
  using assms
  by (auto simp: ns_mul_ext_def elim!: mult2_alt_nsE) (insert union_commute, blast)

lemma ns_mul_ext_IdI:
  assumes "M = X + Z" and "N = Y + Z" and "\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. (x, y) \<in> R"
  shows "(M, N) \<in> ns_mul_ext Id R"
  using assms mult2_alt_nsI[of N Z Y M Z X Id "R\<inverse>"]
  by (auto simp: ns_mul_ext_def)

lemma s_mul_ext_IdE:
  assumes "(M, N) \<in> s_mul_ext Id R"
  obtains X and Y and Z where "X \<noteq> {#}" and "M = X + Z" and "N = Y + Z"
    and "\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. (x, y) \<in> R"
  using assms
  by (auto simp: s_mul_ext_def elim!: mult2_alt_sE) (metis union_commute)

lemma s_mul_ext_IdI:
  assumes "X \<noteq> {#}" and "M = X + Z" and "N = Y + Z"
    and "\<forall>y \<in> set_mset Y. \<exists>x \<in> set_mset X. (x, y) \<in> R"
  shows "(M, N) \<in> s_mul_ext Id R"
  using assms mult2_alt_sI[of N Z Y M Z X Id "R\<inverse>"]
  by (auto simp: s_mul_ext_def ac_simps)

lemma mult_s_mul_ext_conv:
  assumes "trans R"
  shows "(mult (R\<inverse>))\<inverse> = s_mul_ext Id R"
  using mult2_s_eq_mult2_s_alt[of Id "R\<inverse>"] assms
  by (auto simp: s_mul_ext_def refl_Id mult2_s_def)

lemma ns_mul_ext_Id_eq:
  "ns_mul_ext Id R = (s_mul_ext Id R)\<^sup>="
  by (auto simp add: ns_mul_ext_def s_mul_ext_def mult2_alt_ns_conv)

lemma subseteq_mset_imp_ns_mul_ext_Id:
  assumes "A \<subseteq># B"
  shows "(B, A) \<in> ns_mul_ext Id R"
proof -
  obtain C where [simp]: "B = C + A" using assms by (auto simp: mset_subset_eq_exists_conv ac_simps)
  have "(C + A, {#} + A) \<in> ns_mul_ext Id R"
    by (intro ns_mul_ext_IdI [of _ C A _ "{#}"]) auto
  then show ?thesis by simp
qed

lemma subset_mset_imp_s_mul_ext_Id:
  assumes "A \<subset># B"
  shows "(B, A) \<in> s_mul_ext Id R"
  using assms by (intro supset_imp_s_mul_ext) (auto simp: refl_Id)

end


(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

(*<*)
theory Chapter2_HoareHeap
imports "AutoCorres.AutoCorres"
begin

external_file "mult_by_add.c"
(*>*)

section  \<open>More Complex Functions with AutoCorres\<close>

text \<open>

  In the previous section we saw how to use the C-Parser and AutoCorres
  to prove properties about some very simple C programs.

  Real life C programs tend to be far more complex however; they
  read and write to local variables, have loops and use pointers to
  access the heap. In this section we will look at some simple programs
  which use loops and access the heap to show how AutoCorres can
  allow such constructs to be reasoned about.

\<close>

subsection \<open>A simple loop: \texttt{mult\_by\_add}\<close>

text \<open>

  Our C function \texttt{mult\_by\_add} implements a multiply operation
  by successive additions:

\lstinputlisting[language=C, firstline=15]{../../mult_by_add.c}

  We start by translating the program using the C parser and AutoCorres,
  and entering the generated locale \texttt{mult\_by\_add}.
\<close>

install_C_file "mult_by_add.c"
autocorres [ts_rules = nondet] "mult_by_add.c"
(*<*)
context mult_by_add begin
(*>*)

text \<open>
  The C parser produces the SIMPL output as follows:
\<close>

thm mult_by_add_body_def
text \<open>@{thm [display] mult_by_add_body_def}\<close>

text \<open>
  Which is abstracted by AutoCorres to the following:
\<close>

thm mult_by_add'_def
text \<open>@{thm [display] mult_by_add'_def }\<close>

text \<open>

  In this case AutoCorres has abstracted \texttt{mult\_by\_add} into a
  \emph{monadic} form. Monads are a pattern frequently used in
  functional programming to represent imperative-style control-flow; an
  in-depth introduction to monads can be found elsewhere.

  The monads used by AutoCorres in this example is a
  \emph{non-deterministic state monad}; program state is implicitly
  passed between each statement, and results of computations may produce
  more than one (or possibly zero) results\footnote{Non-determinism
  becomes useful when modelling hardware, for example, where the exact
  results of the hardware cannot be determined ahead of time.}.
\<close>
  (* FIXME : probably describe below in further detail. *)
text \<open>
  The bulk of @{term "mult_by_add'"} is wrapped inside the @{term
  "whileLoop"} \emph{monad combinator}, which is really just a fancy way
  of describing the method used by AutoCorres to encode (potentially
  non-terminating) loops using monads.

  If we want to describe the behaviour of this program, we can use
  Hoare logic as follows:

    @{term [display] "\<lbrace> P \<rbrace> mult_by_add' a b \<lbrace> Q \<rbrace>"}

  This predicate states that, assuming @{term "P"} holds on the initial
  program state, if we execute @{term "mult_by_add' a b"}, then
  @{term "Q"} will hold on the final state of the program.

  There are a few details: while @{term "P"} has type
  @{typ "'s \<Rightarrow> bool"} (i.e., takes a state and returns true if
  it satisifies the precondition), @{term "Q"} has an additional
  parameter @{typ "'r \<Rightarrow> 's \<Rightarrow> bool"}. The additional parameter
  @{typ "'r"} is the \emph{return value} of the function; so, in
  our \texttt{mult\_by\_add'} example, it will be the result of
  the multiplication.

  For example one useful property to prove on our program would
  be:

    @{term [display] "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>"}

  That is, for all possible input states, our \texttt{mult\_by\_add'}
  function returns the product of @{term "a"} and @{term "b"}.

  Unfortunately, this is not sufficient. As mentioned in the previous
  section, AutoCorres produces a theorem for each function it abstracts
  stating that, \emph{assuming the function does not fail}, then the
  generated function is a valid abstraction of the concrete function.
  Thus, if we wish to reason about our concrete C function, we must
  also show non-failure on the abstract program. This can be done
  using the predicate @{term "no_fail"} as follows:

    @{term [display] "\<And>a b. no_fail (\<lambda>s. True) (mult_by_add' a b)"}

  Here @{term "\<lambda>s. True"} is the precondition on the input state.

  Instead of proving our Hoare triple and @{term no_fail} separately,
  we can prove them together using the ``valid no fail'' framework
  as follows:

    @{thm [display] validNF_def}

  Our proof of @{term mult_by_add'} could then proceed as follows:

\<close>

lemma mult_by_add_correct:
    "\<lbrace> \<lambda>s. True \<rbrace> mult_by_add' a b \<lbrace> \<lambda>r s. r = a * b \<rbrace>!"
  txt \<open>Unfold abstracted definition\<close>
  apply (unfold mult_by_add'_def)
  txt \<open>Annotate the loop with an invariant and a measure.\<close>
  apply (subst whileLoop_add_inv
    [where I="\<lambda>(a', result) s. result = (a - a') * b"
        and M="\<lambda>((a', result), s). a'"] )
  txt \<open>Run the ``weakest precondition'' tool \texttt{wp}.\<close>
  apply wp
  txt \<open>Solve the program correctness goals.\<close>
     apply (simp add: field_simps)
    apply unat_arith
   apply (auto simp: field_simps not_less)
  done

(* FIXME: Update the following explanation. *)
text \<open>
  The proof is straight-forward, but uses a few different techniques:
  The first is that we annotate the loop with a loop invariant and a
  measure, using the rule @{thm whileLoop_add_inv}. We then run the
  \texttt{wp} tool which applys a large set of
  \emph{weakest precondition} rules on the program\footnote{This set of
  rules includes a rule which can handle annotated @{term whileLoop}
  terms, but will not attempt to process @{term whileLoop} terms without
  annotations.}. We finially discharge the remaining subgoals left from
  the \texttt{wp} tool using \texttt{auto}, and our proof is complete.

  In the next section, we will look at how we can use AutoCorres to
  verify a C program that reads and writes to the heap.

\<close>

(*<*)
end
end
(*>*)


(*  Title:      HOL/HOLCF/IOA/NTP/Lemmas.thy
    Author:     Tobias Nipkow & Konrad Slind
*)

theory Lemmas
imports Main
begin

subsubsection \<open>Logic\<close>

lemma neg_flip: "(X = (~ Y)) = ((~X) = Y)"
  by blast

subsection \<open>Sets\<close>

lemma set_lemmas:
  "f(x) : (UN x. {f(x)})"
  "f x y : (UN x y. {f x y})"
  "!!a. (!x. a ~= f(x)) ==> a ~: (UN x. {f(x)})"
  "!!a. (!x y. a ~= f x y) ==> a ~: (UN x y. {f x y})"
  by auto

subsection \<open>Arithmetic\<close>

lemma pred_suc: "0<x ==> (x - 1 = y) = (x = Suc(y))"
  by (simp add: diff_Suc split: nat.split)

lemmas [simp] = hd_append set_lemmas

end


theory codomain_wall_invariance
imports Link_Algebra
begin

theorem linkrel_codomain_invariance: " linkrel a b \<Longrightarrow> codomain_wall a = codomain_wall b"
proof-
assume 0: "linkrel a b"
have 1:"uncross a b \<Longrightarrow> codomain_wall a = codomain_wall b"
 proof-
  assume 1:"uncross a b"
  have " codomain_wall right_over = codomain_wall straight_line" by auto
  then
   have "uncross_positive_straighten a b \<Longrightarrow> codomain_wall a = codomain_wall b"
   unfolding uncross_positive_straighten_def by metis
  moreover have "codomain_wall right_over = codomain_wall left_over" using codomain_wall.simps by auto
  then have "uncross_positive_flip a b \<Longrightarrow> codomain_wall a = codomain_wall b"
   unfolding uncross_positive_flip_def by auto
  moreover have "uncross_negative_straighten a b \<Longrightarrow> codomain_wall a = codomain_wall b"
   unfolding uncross_negative_straighten_def by auto
  moreover have "uncross_negative_flip a b \<Longrightarrow> codomain_wall a = codomain_wall b"
   unfolding uncross_negative_flip_def by auto
  ultimately have "uncross a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  unfolding uncross_def by auto
  then show ?thesis using 1 by auto
  qed
have 2:"pull a b \<Longrightarrow> codomain_wall a = codomain_wall b"
proof-
 assume 1:"pull a b"
 have "pull_negpos a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  using pull_negpos_def by auto
 moreover have "pull_posneg a b \<Longrightarrow> codomain_wall a = codomain_wall b"
 using pull_posneg_def by auto
 ultimately show ?thesis  using 1 pull_def by auto
 qed
have 3:"straighten a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  using straighten_def straighten_topdown_def straighten_downtop_def codomain_wall.simps
          by (metis codomain.simps(3) codomain_block.simps(2) comm_monoid_add_class.add.left_neutral compose_Nil)
have 4:"rotate a b \<Longrightarrow> codomain_wall a = codomain_wall b"
proof-
assume 1:"rotate a b"
 have "rotate_toppos a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  using rotate_toppos_def codomain.simps
  by auto
 moreover have "rotate_topneg a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  using rotate_topneg_def codomain.simps
  by auto
  moreover have "rotate_downneg a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  using rotate_downneg_def codomain.simps
  by auto
  moreover have "rotate_downpos a b \<Longrightarrow> codomain_wall a = codomain_wall b"
  using rotate_downpos_def codomain.simps
  by auto
  ultimately show ?thesis using 1 rotate_def by auto
 qed
have 5:"swing a b \<Longrightarrow> codomain_wall a = codomain_wall b"
 using swing_def swing_pos_def swing_neg_def codomain_wall.simps
     proof-
       assume 0: "swing a b"
       have "swing_pos a b \<Longrightarrow> codomain_wall a = codomain_wall b"
              using swing_pos_def codomain_wall.simps    by auto
       moreover have "swing_neg a b \<Longrightarrow> codomain_wall a = codomain_wall b"
              using swing_neg_def codomain_wall.simps    by auto
       ultimately have "swing_pos a b \<or> swing_neg a b \<Longrightarrow> codomain_wall a = codomain_wall b"
                       by auto
       then show ?thesis  using swing_def 0 by auto
     qed
have 6:"compress a b \<Longrightarrow> codomain_wall a = codomain_wall b"
 proof-
  assume 1: "compress a b"
  have "compress_top a b \<Longrightarrow> codomain_wall a = codomain_wall b"
     using compress_top_def codomain_wall_def codomain_block.simps(1) codomain_wall.simps(1)
     codomain_wall_compose by (metis )
  moreover have "compress_bottom a b \<Longrightarrow> codomain_wall a = codomain_wall b"
     using compress_bottom_def codomain_wall.simps
     proof-
     assume 1: "compress_bottom a b"
     have " \<exists>B. ((a = B \<circ> basic (make_vert_block (nat (codomain_wall B)))) \<and>
               (b = basic [] \<circ> B) \<and> domain_wall B = 0)"
                 using compress_bottom_def 1 by auto
     then obtain B where " ((a = B \<circ> basic (make_vert_block (nat (codomain_wall B)))) \<and>
               (b = basic [] \<circ> B) \<and> domain_wall B = 0)"
                 by auto
     have "codomain_block (make_vert_block (nat (codomain_wall B))) = codomain_wall B"
          proof-
           have "codomain_block (make_vert_block n)
                         = int n"
                       using codomain_block_def make_vert_block_def codomain_make_vert  by (metis )
           moreover have "(codomain_wall B \<ge> 0)"
                        apply(induct_tac B)
                        apply(auto)
                        using codomain_block_nonnegative by (metis )
           moreover then have "int (nat (codomain_wall B)) = codomain_wall B"
                      by auto
           ultimately show ?thesis by (metis codomain_make_vert)
          qed
    then have " codomain_wall (B \<circ>basic (make_vert_block (nat (codomain_wall B))))
                    = codomain_wall ((basic []) \<circ>B)"
                    using codomain_wall.simps codomain_wall_compose make_vert_block.simps(1) nat_0
                      by (metis)
    then have "codomain_wall a = codomain_wall b"
            using exI by (metis `a = B \<circ> basic (make_vert_block (nat (codomain_wall B))) \<and> b = basic [] \<circ> B \<and> domain_wall B = 0`)
     then show ?thesis using 1 by auto
    qed
  ultimately show ?thesis using 1 compress_def by auto
 qed
have 7:"slide a b \<Longrightarrow> codomain_wall a = codomain_wall b"
 using slide_def
   proof-
   assume 1: "slide a b"
   have "codomain_block (make_vert_block (nat (codomain_wall B))) = codomain_wall B"
         proof-
          have "codomain_block (make_vert_block n)
                         = int n"
                       using codomain_block_def make_vert_block_def codomain_make_vert  by (metis )
          moreover have "(codomain_wall B \<ge> 0)"
                        apply(induct_tac B)
                        apply(auto)
                        using codomain_block_nonnegative by (metis )
          moreover then have "int (nat (codomain_wall B)) = codomain_wall B"
                      by auto
          ultimately show ?thesis by (metis codomain_make_vert)
        qed
   then have "
  (\<exists>B. (x = basic (make_vert_block (nat (codomain_block B))) \<circ> basic B \<and>
       y = basic B \<circ> basic (make_vert_block (nat (codomain_block B)))) \<and>
      codomain_block B \<noteq> 0) \<Longrightarrow> (codomain_wall x = codomain_wall y)"
       using exI codomain_wall.simps by (metis codomain_block_nonnegative codomain_make_vert codomain_wall_compose int_nat_eq)
  then have "slide a b \<Longrightarrow> codomain_wall a  = codomain_wall b"
          unfolding slide_def by (metis codomain_block_nonnegative codomain_make_vert codomain_wall.simps(1) codomain_wall_compose int_nat_eq)
  then show ?thesis using 1 by auto
 qed
 then have "linkrel a b \<Longrightarrow> codomain_wall a = codomain_wall b"
            using 1 2 3 4 5 6 7 linkrel_def by auto
 then show ?thesis using 0 by auto
qed

theorem "x ~ y \<Longrightarrow> codomain_wall x = codomain_wall y"
proof(induction rule:Tangle_Equivalence.induct)
 case refl
     show ?case by simp
 next
 case codomain_compose
      show ?case using codomain_compose by (metis codomain_block.simps(1) codomain_wall.simps(1) codomain_wall_compose)
 next
 case domain_compose
      show ?case using codomain_wall.simps  codomain_wall_compose by auto
 next
 case compose_eq
      show ?case  using codomain_wall_compose compose_eq.IH by auto
 next
 case sym
      show ?case using sym.IH by auto
 next
 case trans
      show ?case using trans.IH by auto
 next
 case tensor_eq
     show ?case using tensor_codomain_wall_additivity tensor_eq.IH by auto
 next
 case equality
     show ?case using linkrel_codomain_invariance equality.hyps by auto

 qed

end


theory TelephoneExchange_pfun
  imports "Z_Machines.Z_Machine"
begin unbundle Z_Syntax

type_synonym digit = integer
type_synonym subs = "digit list"

definition Digit :: "\<bbbP> digit" where "Digit = integer_of_int ` {0..9}"

consts
  Subs :: "\<bbbP> (digit list)"

definition "Valid = {n \<in> blists 6 Digit. \<exists> s \<in> Subs. n \<le> s}"

definition
  "TelephoneExchange_axioms = (Subs \<in> \<bbbP> (seq Digit))"

enumtype Status = seize | dialling | unobtainable | connecting | ringing | speech | engaged | suspended

definition "Connected = {ringing , speech, suspended}"

definition "Established = Connected \<union> {connecting , engaged}"

type_synonym subrec = "Status \<times> digit list"

definition SubRec :: "Status \<leftrightarrow> digit list" where
"SubRec = {(s, n). (s = seize \<longleftrightarrow> n = [])
                 \<and> (s = dialling \<longleftrightarrow> n \<in> Valid - Subs - {[]})
                 \<and> (s = unobtainable \<longleftrightarrow> n \<notin> Valid)
                 \<and> (s \<in> Established \<longleftrightarrow> n \<in> Subs)}"

definition st :: "subrec \<Zpfun> Status" where "st = (\<lambda> x \<bullet> first x)"
definition num :: "subrec \<Zpfun> subs" where "num = (\<lambda> x \<bullet> second x)"

no_syntax
  "_kleisli_comp" :: "logic \<Rightarrow> logic \<Rightarrow> logic" (infixl "\<Zcomp>" 54)

schema Exchange =
  Free :: "\<bbbP> subs"
  Unavailable :: "\<bbbP> subs"
  Callers :: "\<bbbP> subs"
  cal :: "subs \<Zpfun> subrec"
  connected :: "subs \<Zpinj> subs"
where
  "[Free, Unavailable, dom cal \<union> dom [connected]\<^sub>\<Zpinj>] partitions Subs"
  "dom ((cal \<Zcomp> st) \<Zrres> Connected) = Callers"
  "Callers \<Zdres> (cal \<Zcomp> num) = connected"
  "dom [connected]\<^sub>\<Zpinj> \<inter> ran [connected]\<^sub>\<Zpinj> = {}" \<comment> \<open> Added by SF: no self connections \<close>

record_default Exchange

definition "InitExchange = [Free\<Zprime> = Subs, Unavailable\<Zprime> = {}, Callers\<Zprime> = {}, cal\<Zprime> = {\<mapsto>}, connected\<Zprime> = 0]"

zoperation LiftFree =
  params s \<in> Subs
  pre "s \<in> Free"
  update "[Free\<Zprime> = Free - {s}
          ,cal\<Zprime> = cal \<oplus> {s \<mapsto> (seize, [])}]"

declare list_partitions_def [simp]

lemma "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange_inv\<^bold>}LiftFree s\<^bold>{Exchange_inv\<^bold>}"
  unfolding  LiftFree_def
  apply (hoare_wlp_auto)
    apply (auto simp add: st_def num_def Connected_def Un_absorb2 disjoint_iff)
  apply (metis (no_types, lifting) pdom_pranres pdom_res_upd_out pranres_pdom subsetD)
  done

zoperation LiftSuspended =
  params s \<in> Subs
  pre "(s, suspended) \<in> connected\<^sup>\<sim> \<Zcomp> cal \<Zcomp> st"
  update "[cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (speech, s)}]"

lemma "`Exchange \<longrightarrow> dom [connected]\<^sub>\<Zpinj> \<subseteq> dom cal`"
  apply (expr_auto)
  by (metis pdom_comp pdom_pranres subsetD)

lemma "`Exchange \<longrightarrow> dom [connected]\<^sub>\<Zpinj> = Callers`"
  apply (expr_auto)
  apply (simp_all add: num_def st_def)
  apply (metis (no_types, lifting) insert_subset pdom_comp pdom_pranres pdom_upd pfun_upd_ext)
  apply (smt (z3) Int_UNIV UNIV_def mem_Collect_eq pdom_UNIV_comp pdom_pabs ppreimageE)
  apply (smt (z3) UNIV_def fst_conv inf_eq_top_iff mem_Collect_eq pdom_UNIV_comp pdom_pabs ppreimageI)
  done

text \<open> I think we need an invariant that those who have suspended a call did not initiate that call. \<close>

lemma "`Exchange \<longrightarrow> dom [connected]\<^sub>\<Zpinj> \<inter> ran [connected]\<^sub>\<Zpinj> = {}`"
  apply (expr_auto)
  oops

lemma "st \<Zrres> {suspended} \<le> st \<Zrres> Connected"

  oops

lemma dom_num [simp]: "dom num = UNIV"
  by (metis Int_absorb UNIV_def num_def pdom_pabs)

lemma dom_st [simp]: "dom st = UNIV"
  by (simp add: st_def)

lemma suspended_Connected [simp]: "suspended \<in> Connected"
  by (simp add: Connected_def)

lemma suspended_le_Connected [simp]: "{suspended} \<subseteq> Connected"
  by (simp add: Connected_def)

syntax
  "_image_syn" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("(_\<^sup>\<rightarrow> _)" 999)
  "_preimage_syn" :: "logic \<Rightarrow> logic \<Rightarrow> logic" ("(_\<^sup>\<leftarrow> _)" 999)

translations
  "_image_syn f A" == "CONST ran (CONST dom_res A f)"
  "_preimage_syn f A" == "CONST dom (CONST ran_res f A)"

lemma "`Exchange \<longrightarrow> dom ((cal \<Zcomp> st) \<Zrres> {suspended}) \<subseteq> dom [connected]\<^sub>\<Zpinj>`"
  apply expr_auto
  apply (metis UNIV_I dom_num dom_st pdom_UNIV_comp ppreimageI suspended_Connected)
  done

lemma "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange \<and> dom [connected]\<^sub>\<Zpinj> \<subseteq> dom cal \<and> dom [connected]\<^sub>\<Zpinj> = Callers\<^bold>}LiftSuspended s\<^bold>{Exchange\<^bold>}"
  unfolding LiftSuspended_def Exchange_inv_def
  apply (hoare_wlp_auto)
  apply (auto simp add: st_def num_def ppreimageI pfun_eq_iff pinv_f_f_apply)
  done

zoperation Answer =
  params s \<in> Subs
  pre "(s, ringing) \<in> connected\<^sup>\<sim> \<Zcomp> cal \<Zcomp> st"
  update "[ Free\<Zprime> = Free - {s}
          , cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (speech, s)}]"

lemma "s \<in> Subs \<Longrightarrow> \<^bold>{Exchange\<^bold>}Answer s\<^bold>{Exchange\<^bold>}"
  unfolding Answer_def Exchange_inv_def
  apply (hoare_wlp_auto)
  oops

definition "nextstate n =
  (if n \<in> Subs then connecting
   else if n \<in> Valid - Subs then dialling
   else unobtainable)"

zoperation Dial =
  params s \<in> Subs d \<in> Digit
  pre "(s, seize) \<in> cal \<Zcomp> st \<or> (s, dialling) \<in> cal \<Zcomp> st"
  update "[cal\<Zprime> = (let newnum = (cal \<Zcomp> num) s @ [d] in cal \<oplus> {s \<mapsto> (nextstate newnum, newnum)})]"

zoperation ClearAttempt =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {seize, dialling , connecting , engaged, unobtainable}"
  update "[Free\<Zprime> = Free \<union> {s}, cal\<Zprime> = {s} \<Zndres> cal]"

zoperation ClearLine =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {ringing , suspended}"
  update "[ Free\<Zprime> = Free \<union> {s, connected s}, cal\<Zprime> = {s} \<Zndres> cal
          , Callers\<Zprime> = Callers - {s, connected s}
          , connected\<Zprime> = {s} \<Zndres> connected]"

zoperation ClearConnect =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = speech"
  update "[ Free\<Zprime> = Free \<union> {s}
          , cal\<Zprime> = ({s} \<Zndres> cal) \<oplus> {connected s \<mapsto> (seize, [])}
          , Callers\<Zprime> = Callers - {s}
          , connected\<Zprime> = {s} \<Zndres> connected]"

zoperation ClearSuspend =
  params s \<in> Subs
  pre "s \<in> ran connected"
  update "[cal\<Zprime> = cal \<oplus> {(connected\<^sup>\<sim>) s \<mapsto> (suspended, s)}]"

zoperation ClearUnavail =
  params s \<in> Subs
  pre "s \<in> Unavailable"
  update "[Free\<Zprime> = Free \<union> {s}, Unavailable\<Zprime> = Unavailable - {s}]"

zoperation MakeUnavail =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s \<in> {seize, dialling}"
  update "[Unavailable\<Zprime> = Unavailable \<union> {s}, cal\<Zprime> = {s} \<Zndres> cal]"

zoperation Connect2Ringing =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = connecting \<and> s \<notin> dom connected \<and> (cal \<Zcomp> num) s \<in> Free \<and> (cal \<Zcomp> num) s \<notin> ran connected"
  update "[ Free\<Zprime> = Free - {s}
          , cal\<Zprime> = cal \<oplus> {s \<mapsto> (ringing, (cal \<Zcomp> num) s)}
          , Callers\<Zprime> = Callers \<union> {s}
          , connected\<Zprime> = connected \<oplus> {s \<mapsto> (cal \<Zcomp> num) s}]"

zoperation Connect2Engaged =
  params s \<in> Subs
  pre "s \<in> dom cal \<and> (cal \<Zcomp> st) s = connecting \<and> s \<notin> dom connected \<and> (cal \<Zcomp> num) s \<notin> Free"
  update "[ cal\<Zprime> = cal \<oplus> {s \<mapsto> (engaged, (cal \<Zcomp> num) s)} ]"

zmachine TelephoneExchange =
  over Exchange
  init "InitExchange"
  operations
    LiftFree LiftSuspended Answer Dial
    ClearAttempt ClearLine ClearConnect ClearSuspend ClearUnavail
    MakeUnavail
    Connect2Ringing Connect2Engaged

def_consts Subs = "{[1,2,3], [3,4,5], [6,7,8]}"

animate TelephoneExchange

end