(*
 * Copyright 2014, NICTA
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 * See "LICENSE_BSD2.txt" for details.
 *
 * @TAG(NICTA_BSD)
 *)

(*
   A general calculus of refinement in Isabelle.
*)

chapter "Refinement"

theory Simulation
imports "~~/src/HOL/Main"
begin

text {*
  A data type is a collection of three functions on three basic types.
  The three basic types are the private state space @{typ 'a}, the observable
  state space @{typ 'b} and the operations @{typ 'j}.

  The three functions are the initialisation @{term "Init"} which (potentially
  nondeterministically) produces a private state space from an observable one,
  the finalisation @{term Fin} which projects the observable part of
  the state space out of the private one, and finally @{term Step} that gives
  the (potentially nondeterministic) transition relation on the private state
  space for each operation in @{typ 'j}.

  In the simple case, the private state space is something like a
  tuple @{typ "'a \<times> 'b"} fully containing the observable part such
  that @{term Fin} just becomes the projection @{term snd}, and @{term
  "Init s"} constructs an additional private part, e.g. just
  @{term "{(f x, x)}"}.

  Hoare triples on the system and refinement are defined over the observable
  part of the state.
*}

record ('a,'b,'j) data_type =
  Init :: "'b \<Rightarrow> 'a set"
  Fin :: "'a \<Rightarrow> 'b"
  Step :: "'j \<Rightarrow> ('a \<times> 'a) set"

text {*
  A sequence of operations over a transition relation @{term \<delta>} is executed
  by applying the relation repeatedly.
*}
definition
  steps :: "('j \<Rightarrow> ('a \<times> 'a) set) \<Rightarrow> 'a set \<Rightarrow> 'j list \<Rightarrow> 'a set" where
  "steps \<delta> \<equiv> foldl (\<lambda>S j. \<delta> j `` S)"

text {*
  The sequence of operations in the data type is then executed
  in an initial state by initialising the private state, executing
  the transition relation over this private state, and finally
  projecting back out the set of final, observable states.
*}
definition
   execution :: "('a,'b,'j) data_type \<Rightarrow> 'b \<Rightarrow> 'j list \<Rightarrow> 'b set" where
  "execution A s js \<equiv> Fin A ` steps (Step A) (Init A s) js"

text {*
  A Hoare triple over a list of operations in the data type is
  the usual: given a state in the pre-condition, all resulting states
  of the execution must be in the post-condition:
*}
definition
  hoare_triple :: "('a,'b,'j) data_type \<Rightarrow> 'b set \<Rightarrow> 'j list \<Rightarrow> 'b set \<Rightarrow> bool"
where
  "hoare_triple A P js Q \<equiv> \<forall>s \<in> P. execution A s js \<subseteq> Q"

text {*
  Refinement is defined by saying that all concrete behaviours are contained in
  their corresponding abstract ones. Only the private state spaces of the
  data type may differ.
*}
definition
  refines :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infix "\<sqsubseteq>" 60)
where
  "C \<sqsubseteq> A \<equiv> \<forall>js s. execution C s js \<subseteq> execution A s js"

text {*
  Alternatively, one may say that all Hoare triples proved on the abstract data
  type are true for the concrete one.
*}
lemma hoare_triple_refinement:
  "C \<sqsubseteq> A = (\<forall>P Q js. hoare_triple A P js Q \<longrightarrow> hoare_triple C P js Q)"
  by (simp add: refines_def hoare_triple_def) blast

-- "composing two relations"
definition
  rel_semi :: "('a \<times> 'b) set \<Rightarrow> ('b \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set" (infixl ";;;" 65)
where
  "A ;;; B \<equiv> A O B"

text {*
  Refinement is a global property over all executions and/or all
  hoare triples. As this is hard to show, we define the weaker concept
  of forward simulation.
*}
definition
  fw_sim :: "('a \<times> 'c) set \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool"
where
  "fw_sim R C A \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                  (\<forall>j. R ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                  (\<forall>s s'. (s,s') \<in> R \<longrightarrow> Fin C s' = Fin A s)"

definition
  fw_simulates :: "('c,'b,'j) data_type \<Rightarrow> ('a,'b,'j) data_type \<Rightarrow> bool" (infixl "\<sqsubseteq>\<^sub>F" 50)
where
  "C \<sqsubseteq>\<^sub>F A \<equiv> \<exists>R. fw_sim R C A"

lemma fw_sim_steps:
  assumes steps: "t' \<in> steps (Step C) S' js" "S' \<subseteq> R `` S"
  assumes sim: "fw_sim R C A"
  shows "\<exists>t \<in> steps (Step A) S js. (t,t') \<in> R" using steps
proof (induct js arbitrary: S' S)
  case Nil
  thus ?case by (simp add: steps_def) blast
next
  case (Cons j js)
  hence "t' \<in> steps (Step C) (Step C j `` S') js"
    by (clarsimp simp: steps_def)
  moreover {
    from Cons.prems
    have "S' \<subseteq> R `` S" by simp
    moreover
    from sim
    have "R ;;; Step C j \<subseteq> Step A j ;;; R" by (simp add: fw_sim_def)
    ultimately
    have "Step C j `` S' \<subseteq> R `` (Step A j `` S)"
      by (simp add: rel_semi_def) blast
  }
  ultimately
  show ?case using Cons.hyps
    by (auto simp: steps_def)
qed

lemma sim_imp_refines:
  "C \<sqsubseteq>\<^sub>F A \<Longrightarrow> C \<sqsubseteq> A"
  apply (clarsimp simp: refines_def execution_def fw_simulates_def)
  apply (rename_tac t)
  apply (drule fw_sim_steps)
    prefer 2
    apply assumption
   apply (simp add: fw_sim_def)
   apply blast
  apply clarsimp
  apply (erule rev_image_eqI)
  apply (simp add: fw_sim_def)
  done

text {*
  To further aid proofs, we define (private) invariants on data types.
  Private invariants are properties that are true throughout execution
  on the private state space of the state type. The purpose is to exploit
  these properties while showing forward simulation.
*}
definition
  invariant_holds :: "('a,'b,'j) data_type \<Rightarrow> 'a set \<Rightarrow> bool" (infix "\<Turnstile>" 60)
where
  "D \<Turnstile> I \<equiv> (\<forall>s. Init D s \<subseteq> I) \<and> (\<forall>j. Step D j `` I \<subseteq> I)"

lemma invariant_T [iff]: "D \<Turnstile> UNIV"
  by (simp add: invariant_holds_def)

lemma invariantI:
  "\<lbrakk> \<forall>s. Init D s \<subseteq> I; \<forall>j. Step D j `` I \<subseteq> I \<rbrakk> \<Longrightarrow> D \<Turnstile> I"
  by (simp add: invariant_holds_def)

lemma invariant_CollectI [intro?]:
  assumes init: "\<And>s a. s \<in> Init D a \<Longrightarrow> I s"
  assumes step: "\<And>j s s'. \<lbrakk> I s; (s,s') \<in> Step D j \<rbrakk> \<Longrightarrow> I s'"
  shows "D \<Turnstile> Collect I"
proof (rule invariantI)
  show "\<forall>a. Init D a \<subseteq> Collect I" by (fast intro: init)
next
  show "\<forall>j. Step D j `` Collect I \<subseteq> Collect I"
    by (auto simp add: Image_def intro: step)
qed

lemma invariant_conjI:
  "D \<Turnstile> P \<Longrightarrow> D \<Turnstile> Q  \<Longrightarrow> D \<Turnstile> P \<inter> Q"
  by (simp add: invariant_holds_def) blast

lemma invariant_conjI2:
  "\<lbrakk> D \<Turnstile> I; \<And>s. Init D s \<subseteq> I \<Longrightarrow> Init D s \<subseteq> J;
    \<forall>j. Step D j `` (I \<inter> J) \<subseteq> J \<rbrakk> \<Longrightarrow> D \<Turnstile> I \<inter> J"
  by (simp add: invariant_holds_def) blast

text {*
  We can now define forward simulation with an invariant. The proof
  obligation for the step and final case in the correspondence proof
  can now assume that the invariant holds. The invariant itself can be
  shown separately.
*}
definition
  LI :: "('a,'b,'j) data_type \<Rightarrow> ('c,'b,'j) data_type \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> ('a \<times> 'c) set \<Rightarrow> bool"
where
  "LI A C R I \<equiv> (\<forall>s. Init C s \<subseteq> R `` Init A s) \<and>
                (\<forall>j. (R \<inter> I) ;;; Step C j \<subseteq> Step A j ;;; R) \<and>
                (\<forall>s s'. (s,s') \<in> R \<inter> I \<longrightarrow> Fin C s' = Fin A s)"

lemma LI_fw_sim:
  assumes  ia: "A \<Turnstile> I\<^sub>a" and ic: "C \<Turnstile> I\<^sub>c" and li: "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A"
proof -
  from li have
    init: "\<forall>s. Init C s \<subseteq> r `` Init A s" and
    step: "\<forall>j. (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) ;;; Step C j \<subseteq> Step A j ;;; r" and
    fin: "(\<forall>s s'. (s,s') \<in> r \<inter> (I\<^sub>a \<times> I\<^sub>c) \<longrightarrow> Fin C s' = Fin A s)"
    by (auto simp: LI_def)
  from ia have  "\<forall>s. (r \<inter> (UNIV \<times> I\<^sub>c) ) `` Init A s = (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  moreover from init ic have "\<forall>s. Init C s \<subseteq> (r \<inter> (UNIV \<times> I\<^sub>c)) `` Init A s"
    by (simp add: invariant_holds_def, blast)
  ultimately have initI: "\<forall>s. Init C s \<subseteq> (r \<inter> (I\<^sub>a \<times> I\<^sub>c)) `` Init A s" by simp
  moreover {
    fix j
    from step have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r"..
    also
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) = ((UNIV \<times> I\<^sub>a) \<inter> Id) ;;; r ;;; ((I\<^sub>c \<times> UNIV) \<inter> Id)"
      (is "_ = ?I\<^sub>a ;;; r ;;; ?I\<^sub>c")
      by (simp add: rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j \<subseteq> ?I\<^sub>a ;;; Step A j ;;; r"
      by (simp add: rel_semi_def, blast)
    also
    from ia have "\<dots> \<subseteq> Step A j ;;; ?I\<^sub>a ;;; r"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "?I\<^sub>a ;;;  r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c \<subseteq>  Step A j ;;; ?I\<^sub>a ;;; r ;;; ?I\<^sub>c"
      by (simp add: rel_semi_def, blast)
    also
    from ic
    have "?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j;;; ?I\<^sub>c =  ?I\<^sub>a ;;; r ;;; ?I\<^sub>c ;;; Step C j"
      by (simp add: invariant_holds_def rel_semi_def, blast)
    finally
    have "r \<inter> (I\<^sub>a \<times> I\<^sub>c) ;;; Step C j \<subseteq> Step A j ;;; r \<inter> (I\<^sub>a \<times> I\<^sub>c)"
      by (simp add: rel_semi_def, blast)
  }
  ultimately show "fw_sim (r \<inter> I\<^sub>a \<times> I\<^sub>c) C A" using fin
    by (simp add: fw_sim_def)
qed

lemma weaken_LI:
  assumes LI: "LI A C R I'" and weaker: "I \<subseteq> I'" shows "LI A C R I"
proof -
  from weaker have step: "\<And>j. R \<inter> I ;;; Step C j \<subseteq> R \<inter> I' ;;; Step C j"
    by (fastforce simp: rel_semi_def relcomp_def)
  from weaker have fin: "\<And>S. S \<in> R \<inter> I \<Longrightarrow> S \<in> R \<inter> I'" by fastforce
  from subset_trans[OF step] fin LI show ?thesis  by (clarsimp simp: LI_def)
qed

lemma fw_sim_eq_LI: "fw_sim r C A = LI A C r UNIV"
  by (simp add: fw_sim_def LI_def)

lemma fw_sim_LI: "fw_sim r C A \<Longrightarrow> LI A C r I"
  by (simp add: fw_sim_eq_LI weaken_LI[where I'=UNIV])

lemma L_invariantI:
  assumes  "A \<Turnstile> I\<^sub>a" and "C \<Turnstile> I\<^sub>c" and "LI A C r (I\<^sub>a \<times> I\<^sub>c)"
  shows "C \<sqsubseteq>\<^sub>F A"
  using assms
  by (simp add: fw_simulates_def, rule_tac x="r \<inter> I\<^sub>a \<times> I\<^sub>c" in exI,
      simp add: LI_fw_sim)

lemma refinement_refl[simp]:
  "A \<sqsubseteq> A"
  by (simp add: refines_def)

lemma refinement_trans [trans]:
  "\<lbrakk>C \<sqsubseteq> B; B \<sqsubseteq> A\<rbrakk> \<Longrightarrow> C \<sqsubseteq> A"
  by (simp add: refines_def) blast

lemma fw_inv_transport:
  "\<lbrakk> A \<Turnstile> I\<^sub>a; C \<Turnstile> I\<^sub>c; LI A C R (I\<^sub>a \<times> I\<^sub>c) \<rbrakk> \<Longrightarrow> C \<Turnstile> {s'. \<exists>s. (s,s') \<in> R \<and> s \<in> I\<^sub>a \<and> s' \<in> I\<^sub>c}"
  apply (clarsimp simp: LI_def invariant_holds_def)
  apply (rule conjI)
   apply (rule allI)
   apply clarsimp
   apply (subgoal_tac "x \<in> (R `` Init A s)")
    prefer 2
    apply fastforce
   apply blast
  apply clarsimp
  apply (erule_tac x=j in allE)+
  apply (clarsimp simp: rel_semi_def)
  apply (subgoal_tac "(s,x) \<in> Step A j O R")
   prefer 2
   apply blast
  apply blast
  done

lemma fw_sim_refl:
  "fw_sim Id A A"
  apply (simp add: fw_sim_def rel_semi_def)
  done

lemma fw_simulates_refl[simp]:
  "A \<sqsubseteq>\<^sub>F A"
  apply (simp add: fw_simulates_def fw_sim_refl exI[where x="Id"])
  done

lemma fw_sim_trans:
  "\<lbrakk>fw_sim Q C B; fw_sim R B A\<rbrakk> \<Longrightarrow> fw_sim (R O Q) C A"
  apply (clarsimp simp: fw_sim_def)
  apply (intro conjI)
    apply clarsimp
    apply (rename_tac s x)
    apply (erule_tac x="s" in allE)
    apply (drule set_mp)
     apply assumption
    apply clarsimp
    apply (erule_tac x="s" in allE)
    apply (drule set_mp)
     apply assumption
    apply blast
   apply (clarsimp simp: rel_semi_def)
   apply (rename_tac j z' x y z)
   apply (erule_tac x="j" in allE)+
   apply (drule_tac x="(y, z')" in set_mp)
    apply blast
   apply clarsimp
   apply (rename_tac j x z x' y' z')
   apply (drule_tac x="(x, y')" in set_mp)
    apply auto
  done

lemma fw_simulates_trans:
  "\<lbrakk>C \<sqsubseteq>\<^sub>F B; B \<sqsubseteq>\<^sub>F A\<rbrakk> \<Longrightarrow> C \<sqsubseteq>\<^sub>F A"
  apply (auto simp: fw_simulates_def dest: fw_sim_trans)
  done

end


(*  Title:      HOL/Induct/SList.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory

This theory is strictly of historical interest. It illustrates how
recursive datatypes can be constructed in higher-order logic from
first principles. Isabelle's datatype package automates a
construction of this sort.

Enriched theory of lists; mutual indirect recursive data-types.

Definition of type 'a list (strict lists) by a least fixed point

We use          list(A) == lfp(%Z. {NUMB(0)} <+> A \<times> Z)
and not         list    == lfp(%Z. {NUMB(0)} <+> range(Leaf) \<times> Z)

so that list can serve as a "functor" for defining other recursive types.

This enables the conservative construction of mutual recursive datatypes
such as

datatype 'a m = Node 'a * 'a m list
*)

section \<open>Extended List Theory (old)\<close>

theory SList
imports Sexp
begin

(*Hilbert_Choice is needed for the function "inv"*)

(* *********************************************************************** *)
(*                                                                         *)
(* Building up data type                                                   *)
(*                                                                         *)
(* *********************************************************************** *)

(* Defining the Concrete Constructors *)
definition
  NIL  :: "'a item" where
  "NIL = In0(Numb(0))"

definition
  CONS :: "['a item, 'a item] => 'a item" where
  "CONS M N = In1(Scons M N)"

inductive_set
  list :: "'a item set => 'a item set"
  for A :: "'a item set"
  where
    NIL_I:  "NIL: list A"
  | CONS_I: "[| a: A;  M: list A |] ==> CONS a M : list A"

definition "List = list (range Leaf)"

typedef 'a list = "List :: 'a item set"
  morphisms Rep_List Abs_List
  unfolding List_def by (blast intro: list.NIL_I)

abbreviation "Case == Old_Datatype.Case"
abbreviation "Split == Old_Datatype.Split"

definition
  List_case :: "['b, ['a item, 'a item]=>'b, 'a item] => 'b" where
  "List_case c d = Case(%x. c)(Split(d))"

definition
  List_rec  :: "['a item, 'b, ['a item, 'a item, 'b]=>'b] => 'b" where
  "List_rec M c d = wfrec (pred_sexp^+)
                           (%g. List_case c (%x y. d x y (g y))) M"

(* *********************************************************************** *)
(*                                                                         *)
(* Abstracting data type                                                   *)
(*                                                                         *)
(* *********************************************************************** *)

(*Declaring the abstract list constructors*)

no_translations
  "[x, xs]" == "x#[xs]"
  "[x]" == "x#[]"
no_notation
  Nil  ("[]") and
  Cons (infixr "#" 65)

definition
  Nil       :: "'a list"                               ("[]") where
   "Nil  = Abs_List(NIL)"

definition
  "Cons"       :: "['a, 'a list] => 'a list"           (infixr "#" 65) where
   "x#xs = Abs_List(CONS (Leaf x)(Rep_List xs))"

definition
  (* list Recursion -- the trancl is Essential; see list.ML *)
  list_rec  :: "['a list, 'b, ['a, 'a list, 'b]=>'b] => 'b" where
   "list_rec l c d =
      List_rec(Rep_List l) c (%x y r. d(inv Leaf x)(Abs_List y) r)"

definition
  list_case :: "['b, ['a, 'a list]=>'b, 'a list] => 'b" where
   "list_case a f xs = list_rec xs a (%x xs r. f x xs)"

(* list Enumeration *)
translations
  "[x, xs]" == "x#[xs]"
  "[x]"     == "x#[]"

  "case xs of [] => a | y#ys => b" == "CONST list_case(a, %y ys. b, xs)"

(* *********************************************************************** *)
(*                                                                         *)
(* Generalized Map Functionals                                             *)
(*                                                                         *)
(* *********************************************************************** *)

(* Generalized Map Functionals *)

definition
  Rep_map   :: "('b => 'a item) => ('b list => 'a item)" where
   "Rep_map f xs = list_rec xs  NIL(%x l r. CONS(f x) r)"

definition
  Abs_map   :: "('a item => 'b) => 'a item => 'b list" where
   "Abs_map g M  = List_rec M Nil (%N L r. g(N)#r)"

definition
  map       :: "('a=>'b) => ('a list => 'b list)" where
  "map f xs = list_rec xs [] (%x l r. f(x)#r)"

primrec take :: "['a list,nat] => 'a list" where
  take_0:  "take xs 0 = []"
| take_Suc: "take xs (Suc n) = list_case [] (%x l. x # take l n) xs"

lemma ListI: "x : list (range Leaf) ==> x : List"
by (simp add: List_def)

lemma ListD: "x : List ==> x : list (range Leaf)"
by (simp add: List_def)

lemma list_unfold: "list(A) = usum {Numb(0)} (uprod A (list(A)))"
  by (fast intro!: list.intros [unfolded NIL_def CONS_def]
           elim: list.cases [unfolded NIL_def CONS_def])

(*This justifies using list in other recursive type definitions*)
lemma list_mono: "A<=B ==> list(A) <= list(B)"
apply (rule subsetI)
apply (erule list.induct)
apply (auto intro!: list.intros)
done

(*Type checking -- list creates well-founded sets*)
lemma list_sexp: "list(sexp) <= sexp"
apply (rule subsetI)
apply (erule list.induct)
apply (unfold NIL_def CONS_def)
apply (auto intro: sexp.intros sexp_In0I sexp_In1I)
done

(* A <= sexp ==> list(A) <= sexp *)
lemmas list_subset_sexp = subset_trans [OF list_mono list_sexp]

(*Induction for the type 'a list *)
lemma list_induct:
    "[| P(Nil);
        !!x xs. P(xs) ==> P(x # xs) |]  ==> P(l)"
apply (unfold Nil_def Cons_def)
apply (rule Rep_List_inverse [THEN subst])
(*types force good instantiation*)
apply (rule Rep_List [unfolded List_def, THEN list.induct], simp)
apply (erule Abs_List_inverse [unfolded List_def, THEN subst], blast)
done

(*** Isomorphisms ***)

lemma inj_on_Abs_list: "inj_on Abs_List (list(range Leaf))"
apply (rule inj_on_inverseI)
apply (erule Abs_List_inverse [unfolded List_def])
done

(** Distinctness of constructors **)

lemma CONS_not_NIL [iff]: "CONS M N ~= NIL"
by (simp add: NIL_def CONS_def)

lemmas NIL_not_CONS [iff] = CONS_not_NIL [THEN not_sym]
lemmas CONS_neq_NIL = CONS_not_NIL [THEN notE]
lemmas NIL_neq_CONS = sym [THEN CONS_neq_NIL]

lemma Cons_not_Nil [iff]: "x # xs ~= Nil"
apply (unfold Nil_def Cons_def)
apply (rule CONS_not_NIL [THEN inj_on_Abs_list [THEN inj_on_contraD]])
apply (simp_all add: list.intros rangeI Rep_List [unfolded List_def])
done

lemmas Nil_not_Cons = Cons_not_Nil [THEN not_sym]
declare Nil_not_Cons [iff]
lemmas Cons_neq_Nil = Cons_not_Nil [THEN notE]
lemmas Nil_neq_Cons = sym [THEN Cons_neq_Nil]

(** Injectiveness of CONS and Cons **)

lemma CONS_CONS_eq [iff]: "(CONS K M)=(CONS L N) = (K=L & M=N)"
by (simp add: CONS_def)

(*For reasoning about abstract list constructors*)
declare Rep_List [THEN ListD, intro] ListI [intro]
declare list.intros [intro,simp]
declare Leaf_inject [dest!]

lemma Cons_Cons_eq [iff]: "(x#xs=y#ys) = (x=y & xs=ys)"
apply (simp add: Cons_def)
apply (subst Abs_List_inject)
apply (auto simp add: Rep_List_inject)
done

lemmas Cons_inject2 = Cons_Cons_eq [THEN iffD1, THEN conjE]

lemma CONS_D: "CONS M N: list(A) ==> M: A & N: list(A)"
  by (induct L == "CONS M N" rule: list.induct) auto

lemma sexp_CONS_D: "CONS M N: sexp ==> M: sexp & N: sexp"
apply (simp add: CONS_def In1_def)
apply (fast dest!: Scons_D)
done

(*Reasoning about constructors and their freeness*)

lemma not_CONS_self: "N: list(A) ==> !M. N ~= CONS M N"
apply (erule list.induct) apply simp_all done

lemma not_Cons_self2: "\<forall>x. l ~= x#l"
by (induct l rule: list_induct) simp_all

lemma neq_Nil_conv2: "(xs ~= []) = (\<exists>y ys. xs = y#ys)"
by (induct xs rule: list_induct) auto

(** Conversion rules for List_case: case analysis operator **)

lemma List_case_NIL [simp]: "List_case c h NIL = c"
by (simp add: List_case_def NIL_def)

lemma List_case_CONS [simp]: "List_case c h (CONS M N) = h M N"
by (simp add: List_case_def CONS_def)

(*** List_rec -- by wf recursion on pred_sexp ***)

(* The trancl(pred_sexp) is essential because pred_sexp_CONS_I1,2 would not
   hold if pred_sexp^+ were changed to pred_sexp. *)

lemma List_rec_unfold_lemma:
     "(%M. List_rec M c d) ==
      wfrec (pred_sexp^+) (%g. List_case c (%x y. d x y (g y)))"
by (simp add: List_rec_def)

lemmas List_rec_unfold =
    def_wfrec [OF List_rec_unfold_lemma wf_pred_sexp [THEN wf_trancl]]

(** pred_sexp lemmas **)

lemma pred_sexp_CONS_I1:
    "[| M: sexp;  N: sexp |] ==> (M, CONS M N) : pred_sexp^+"
by (simp add: CONS_def In1_def)

lemma pred_sexp_CONS_I2:
    "[| M: sexp;  N: sexp |] ==> (N, CONS M N) : pred_sexp^+"
by (simp add: CONS_def In1_def)

lemma pred_sexp_CONS_D:
    "(CONS M1 M2, N) : pred_sexp^+ ==>
     (M1,N) : pred_sexp^+ & (M2,N) : pred_sexp^+"
apply (frule pred_sexp_subset_Sigma [THEN trancl_subset_Sigma, THEN subsetD])
apply (blast dest!: sexp_CONS_D intro: pred_sexp_CONS_I1 pred_sexp_CONS_I2
                    trans_trancl [THEN transD])
done

(** Conversion rules for List_rec **)

lemma List_rec_NIL [simp]: "List_rec NIL c h = c"
apply (rule List_rec_unfold [THEN trans])
apply (simp add: List_case_NIL)
done

lemma List_rec_CONS [simp]:
     "[| M: sexp;  N: sexp |]
      ==> List_rec (CONS M N) c h = h M N (List_rec N c h)"
apply (rule List_rec_unfold [THEN trans])
apply (simp add: pred_sexp_CONS_I2)
done

(*** list_rec -- by List_rec ***)

lemmas Rep_List_in_sexp =
    subsetD [OF range_Leaf_subset_sexp [THEN list_subset_sexp]
                Rep_List [THEN ListD]]

lemma list_rec_Nil [simp]: "list_rec Nil c h = c"
by (simp add: list_rec_def ListI [THEN Abs_List_inverse] Nil_def)

lemma list_rec_Cons [simp]: "list_rec (a#l) c h = h a l (list_rec l c h)"
by (simp add: list_rec_def ListI [THEN Abs_List_inverse] Cons_def
              Rep_List_inverse Rep_List [THEN ListD] inj_Leaf Rep_List_in_sexp)

(*Type checking.  Useful?*)
lemma List_rec_type:
     "[| M: list(A);
         A<=sexp;
         c: C(NIL);
         !!x y r. [| x: A;  y: list(A);  r: C(y) |] ==> h x y r: C(CONS x y)
      |] ==> List_rec M c h : C(M :: 'a item)"
apply (erule list.induct, simp)
apply (insert list_subset_sexp)
apply (subst List_rec_CONS, blast+)
done

(** Generalized map functionals **)

lemma Rep_map_Nil [simp]: "Rep_map f Nil = NIL"
by (simp add: Rep_map_def)

lemma Rep_map_Cons [simp]:
    "Rep_map f(x#xs) = CONS(f x)(Rep_map f xs)"
by (simp add: Rep_map_def)

lemma Rep_map_type: "(!!x. f(x): A) ==> Rep_map f xs: list(A)"
apply (simp add: Rep_map_def)
apply (rule list_induct, auto)
done

lemma Abs_map_NIL [simp]: "Abs_map g NIL = Nil"
by (simp add: Abs_map_def)

lemma Abs_map_CONS [simp]:
    "[| M: sexp;  N: sexp |] ==> Abs_map g (CONS M N) = g(M) # Abs_map g N"
by (simp add: Abs_map_def)

(*Eases the use of primitive recursion.*)
lemma def_list_rec_NilCons:
    "[| !!xs. f(xs) = list_rec xs c h  |]
     ==> f [] = c & f(x#xs) = h x xs (f xs)"
by simp

lemma Abs_map_inverse:
     "[| M: list(A);  A<=sexp;  !!z. z: A ==> f(g(z)) = z |]
      ==> Rep_map f (Abs_map g M) = M"
apply (erule list.induct, simp_all)
apply (insert list_subset_sexp)
apply (subst Abs_map_CONS, blast)
apply blast
apply simp
done

(*Rep_map_inverse is obtained via Abs_Rep_map and map_ident*)

(** list_case **)

(* setting up rewrite sets *)

text\<open>Better to have a single theorem with a conjunctive conclusion.\<close>
declare def_list_rec_NilCons [OF list_case_def, simp]

(** list_case **)

lemma expand_list_case:
 "P(list_case a f xs) = ((xs=[] --> P a ) & (!y ys. xs=y#ys --> P(f y ys)))"
by (induct xs rule: list_induct) simp_all

(**** Function definitions ****)

declare def_list_rec_NilCons [OF map_def, simp]

(** The functional "map" and the generalized functionals **)

lemma Abs_Rep_map:
     "(!!x. f(x): sexp) ==>
        Abs_map g (Rep_map f xs) = map (%t. g(f(t))) xs"
apply (induct xs rule: list_induct)
apply (simp_all add: Rep_map_type list_sexp [THEN subsetD])
done

(** Additional mapping lemmas **)

lemma map_ident [simp]: "map(%x. x)(xs) = xs"
by (induct xs rule: list_induct) simp_all

lemma map_compose: "map(f o g)(xs) = map f (map g xs)"
apply (simp add: o_def)
apply (induct xs rule: list_induct)
apply simp_all
done

(** take **)

lemma take_Suc1 [simp]: "take [] (Suc x) = []"
by simp

lemma take_Suc2 [simp]: "take(a#xs)(Suc x) = a#take xs x"
by simp

lemma take_Nil [simp]: "take [] n = []"
by (induct n) simp_all

lemma take_take_eq [simp]: "\<forall>n. take (take xs n) n = take xs n"
apply (induct xs rule: list_induct)
apply simp_all
apply (rule allI)
apply (induct_tac n)
apply auto
done

end


theory Chapter7
imports "HOL-IMP.Small_Step" "Short_Theory"
begin

text\<open>
\section*{Chapter 7}

\exercise
Define a function that computes the set of variables that are assigned to
in a command:
\<close>

fun assigned :: "com \<Rightarrow> vname set" where
(* your definition/proof here *)

text\<open>
Prove that if some variable is not assigned to in a command,
then that variable is never modified by the command:
\<close>

lemma "\<lbrakk> (c, s) \<Rightarrow> t; x \<notin> assigned c \<rbrakk> \<Longrightarrow> s x = t x"
(* your definition/proof here *)

text \<open>
\endexercise

\exercise
Define a recursive function that determines if a command behaves like @{const SKIP}
and prove its correctness:
\<close>

fun skip :: "com \<Rightarrow> bool" where
(* your definition/proof here *)

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Define a recursive function
\<close>

fun deskip :: "com \<Rightarrow> com" where
(* your definition/proof here *)

text\<open>
that eliminates as many @{const SKIP}s as possible from a command. For example:
@{prop[display]"deskip (SKIP;; WHILE b DO (x::=a;; SKIP)) = WHILE b DO x::=a"}
Prove its correctness by induction on @{text c}: \<close>

lemma "deskip c \<sim> c"
(* your definition/proof here *)

text\<open>
Remember lemma @{thm[source]sim_while_cong} for the @{text WHILE} case.
\endexercise

\exercise
A small-step semantics for the evaluation of arithmetic expressions
can be defined like this:
\<close>

inductive astep :: "aexp \<times> state \<Rightarrow> aexp \<Rightarrow> bool" (infix "\<leadsto>" 50) where
"(V x, s) \<leadsto> N (s x)" |
"(Plus (N i) (N j), s) \<leadsto> N (i + j)" |
(* your definition/proof here *)

text\<open>
Complete the definition with two rules for @{const Plus}
that model a left-to-right evaluation strategy:
reduce the first argument with @{text"\<leadsto>"} if possible,
reduce the second argument with @{text"\<leadsto>"} if the first argument is a number.
Prove that each @{text"\<leadsto>"} step preserves the value of the expression:
\<close>

lemma "(a, s) \<leadsto> a' \<Longrightarrow> aval a s = aval a' s"
proof (induction rule: astep.induct [split_format (complete)])
(* your definition/proof here *)

text\<open>
Do not use the \isacom{case} idiom but write down explicitly what you assume
and show in each case: \isacom{fix} \dots \isacom{assume} \dots \isacom{show} \dots.
\endexercise

\exercise
Prove or disprove (by giving a counterexample):
\<close>

lemma "IF And b\<^sub>1 b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 \<sim>
          IF b\<^sub>1 THEN IF b\<^sub>2 THEN c\<^sub>1 ELSE c\<^sub>2 ELSE c\<^sub>2"
(* your definition/proof here *)

lemma "WHILE And b\<^sub>1 b\<^sub>2 DO c \<sim> WHILE b\<^sub>1 DO WHILE b\<^sub>2 DO c"
(* your definition/proof here *)

definition Or :: "bexp \<Rightarrow> bexp \<Rightarrow> bexp" where
"Or b\<^sub>1 b\<^sub>2 = Not (And (Not b\<^sub>1) (Not b\<^sub>2))"

lemma "WHILE Or b\<^sub>1 b\<^sub>2 DO c \<sim>
          WHILE Or b\<^sub>1 b\<^sub>2 DO c;; WHILE b\<^sub>1 DO c"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Define a new loop construct @{text "DO c WHILE b"} (where @{text c} is
executed once before @{text b} is tested) in terms of the
existing constructs in @{typ com}:
\<close>

definition Do :: "com \<Rightarrow> bexp \<Rightarrow> com" ("DO _ WHILE _"  [0, 61] 61) where
(* your definition/proof here *)

text\<open>
Define a translation on commands that replaces all @{term "WHILE b DO c"}
by suitable commands that use @{term "DO c WHILE b"} instead:
\<close>

fun dewhile :: "com \<Rightarrow> com" where
(* your definition/proof here *)

text\<open> Prove that your translation preserves the semantics: \<close>

lemma "dewhile c \<sim> c"
(* your definition/proof here *)

text\<open>
\endexercise

\exercise
Let @{text "C :: nat \<Rightarrow> com"} be an infinite sequence of commands and
@{text "S :: nat \<Rightarrow> state"} an infinite sequence of states such that
@{prop"C(0::nat) = c;;d"} and \mbox{@{prop"\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"}}.
Then either all @{text"C n"} are of the form \mbox{@{term"c\<^sub>n;;d"}}
and it is always @{text c\<^sub>n} that is reduced or @{text c\<^sub>n} eventually becomes @{const SKIP}.
Prove
\<close>

lemma assumes "C 0 = c;;d" and "\<forall>n. (C n, S n) \<rightarrow> (C(Suc n), S(Suc n))"
shows "(\<forall>n. \<exists>c\<^sub>1 c\<^sub>2. C n = c\<^sub>1;;d \<and> C(Suc n) = c\<^sub>2;;d \<and>
                         (c\<^sub>1, S n) \<rightarrow> (c\<^sub>2, S(Suc n)))
     \<or> (\<exists>k. C k = SKIP;;d)" (is "(\<forall>i. ?P i) \<or> ?Q")
(* your definition/proof here *)

text\<open>
\endexercise
\bigskip

For the following exercises copy theories
@{short_theory "Com"}, @{short_theory "Big_Step"} and @{short_theory "Small_Step"}
and modify them as required. Those parts of the theories
that do not contribute to the results required in the exercise can be discarded.
If there are multiple proofs of the same result, you may update any one of them.

\begin{exercise}\label{exe:IMP:REPEAT}
Extend IMP with a @{text "REPEAT c UNTIL b"} command by adding the constructor
\begin{alltt}
  Repeat com bexp   ("(REPEAT _/ UNTIL _)"  [0, 61] 61)
\end{alltt}
to datatype @{typ com}.
Adjust the definitions of big-step and small-step semantics,
the proof that the big-step semantics is deterministic and
the equivalence proof between the two semantics.
\end{exercise}

\begin{exercise}\label{exe:IMP:OR}
Extend IMP with a new command @{text "c\<^sub>1 OR c\<^sub>2"} that is a
nondeterministic choice: it may execute either @{text
"c\<^sub>1"} or @{text "c\<^sub>2"}. Add the constructor
\begin{alltt}
  Or com com   ("_ OR/ _" [60, 61] 60)
\end{alltt}
to datatype @{typ com}. Adjust the definitions of big-step
and small-step semantics, prove @{text"(c\<^sub>1 OR c\<^sub>2) \<sim> (c\<^sub>2 OR c\<^sub>1)"}
and update the equivalence proof between the two semantics.
\end{exercise}

\begin{exercise}
Extend IMP with exceptions. Add two constructors @{text THROW} and
@{text "TRY c\<^sub>1 CATCH c\<^sub>2"} to datatype @{typ com}:
\begin{alltt}
  THROW  |  Try com com   ("(TRY _/ CATCH _)"  [0, 61] 61)
\end{alltt}
Command @{text THROW} throws an exception. The only command that can
catch an execption is @{text "TRY c\<^sub>1 CATCH c\<^sub>2"}: if an execption
is thrown by @{text c\<^sub>1}, execution continues with @{text c\<^sub>2},
otherwise @{text c\<^sub>2} is ignored.
Adjust the definitions of big-step and small-step semantics as follows.

The big-step semantics is now of type @{typ "com \<times> state \<Rightarrow> com \<times> state"}.
In a big step @{text "(c,s) \<Rightarrow> (x,t)"}, @{text x} can only be @{term SKIP}
(signalling normal termination) or @{text THROW} (signalling that an exception
was thrown but not caught).

The small-step semantics is of the same type as before. There are two final
configurations now, @{term "(SKIP, t)"} and @{term "(THROW, t)"}.
Exceptions propagate upwards until an enclosing handler is found.
That is, until a configuration @{text "(TRY THROW CATCH c, s)"}
is reached and @{text THROW} can be caught.

Adjust the equivalence proof between the two semantics such that you obtain
@{text "cs \<Rightarrow> (SKIP,t)  \<longleftrightarrow>  cs \<rightarrow>* (SKIP,t)"}
and @{text "cs \<Rightarrow> (THROW,t)  \<longleftrightarrow>  cs \<rightarrow>* (THROW,t)"}.
Also revise the proof of
\noquotes{@{prop [source] "(\<exists>cs'. cs \<Rightarrow> cs')  \<longleftrightarrow>  (\<exists>cs'. cs \<rightarrow>* cs' \<and> final cs')"}}.
\end{exercise}
\<close>

end