(*  Title:      HOL/ex/Tree23.thy
    Author:     Tobias Nipkow, TU Muenchen
*)

section {* 2-3 Trees *}

theory Tree23
imports Main
begin

text{* This is a very direct translation of some of the functions in table.ML
in the Isabelle source code. That source is due to Makarius Wenzel and Stefan
Berghofer.

So far this file contains only data types and functions, but no proofs. Feel
free to have a go at the latter!

Note that because of complicated patterns and mutual recursion, these
function definitions take a few minutes and can also be seen as stress tests
for the function definition facility.  *}

type_synonym key = int -- {*for simplicity, should be a type class*}

datatype ord = LESS | EQUAL | GREATER

definition "ord i j = (if i<j then LESS else if i=j then EQUAL else GREATER)"

datatype 'a tree23 =
  Empty |
  Branch2 "'a tree23" "key * 'a" "'a tree23" |
  Branch3 "'a tree23" "key * 'a" "'a tree23" "key * 'a" "'a tree23"

datatype 'a growth =
  Stay "'a tree23" |
  Sprout "'a tree23" "key * 'a" "'a tree23"

fun add :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a growth" where
"add key y Empty = Sprout Empty (key,y) Empty" |
"add key y (Branch2 left (k,x) right) =
   (case ord key k of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch2 left' (k,x) right)
         | Sprout left1 q left2
           => Stay (Branch3 left1 q left2 (k,x) right))
    | EQUAL => Stay (Branch2 left (k,y) right)
    | GREATER =>
        (case add key y right of
           Stay right' => Stay (Branch2 left (k,x) right')
         | Sprout right1 q right2
           => Stay (Branch3 left (k,x) right1 q right2)))" |
"add key y (Branch3 left (k1,x1) mid (k2,x2) right) =
   (case ord key k1 of
      LESS =>
        (case add key y left of
           Stay left' => Stay (Branch3 left' (k1,x1) mid (k2,x2) right)
         | Sprout left1 q left2
           => Sprout (Branch2 left1 q left2) (k1,x1) (Branch2 mid (k2,x2) right))
    | EQUAL => Stay (Branch3 left (k1,y) mid (k2,x2) right)
    | GREATER =>
        (case ord key k2 of
           LESS =>
             (case add key y mid of
                Stay mid' => Stay (Branch3 left (k1,x1) mid' (k2,x2) right)
              | Sprout mid1 q mid2
                => Sprout (Branch2 left (k1,x1) mid1) q (Branch2 mid2 (k2,x2) right))
         | EQUAL => Stay (Branch3 left (k1,x1) mid (k2,y) right)
         | GREATER =>
             (case add key y right of
                Stay right' => Stay (Branch3 left (k1,x1) mid (k2,x2) right')
              | Sprout right1 q right2
                => Sprout (Branch2 left (k1,x1) mid) (k2,x2) (Branch2 right1 q right2))))"

definition add0 :: "key \<Rightarrow> 'a \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"add0 k y t =
  (case add k y t of Stay t' => t' | Sprout l p r => Branch2 l p r)"

value "add0 5 e (add0 4 d (add0 3 c (add0 2 b (add0 1 a Empty))))"

fun compare where
"compare None (k2, _) = LESS" |
"compare (Some k1) (k2, _) = ord k1 k2"

fun if_eq where
"if_eq EQUAL x y = x" |
"if_eq _ x y = y"

fun del :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> ((key * 'a) * bool * 'a tree23)option"
where
"del (Some k) Empty = None" |
"del None (Branch2 Empty p Empty) = Some(p, (True, Empty))" |
"del None (Branch3 Empty p Empty q Empty) = Some(p, (False, Branch2 Empty q Empty))" |
"del k (Branch2 Empty p Empty) = (case compare k p of
      EQUAL => Some(p, (True, Empty)) | _ => None)" |
"del k (Branch3 Empty p Empty q Empty) = (case compare k p of
      EQUAL => Some(p, (False, Branch2 Empty q Empty))
    | _ => (case compare k q of
        EQUAL => Some(q, (False, Branch2 Empty p Empty))
      | _ => None))" |
"del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))" |
"del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"

definition del0 :: "key \<Rightarrow> 'a tree23 \<Rightarrow> 'a tree23" where
"del0 k t = (case del (Some k) t of None \<Rightarrow> t | Some(_,(_,t')) \<Rightarrow> t')"

text {* Ordered trees *}

definition opt_less :: "key option \<Rightarrow> key option \<Rightarrow> bool" where
  "opt_less x y = (case x of None \<Rightarrow> True | Some a \<Rightarrow> (case y of None \<Rightarrow> True | Some b \<Rightarrow> a < b))"

lemma opt_less_simps [simp]:
  "opt_less None y = True"
  "opt_less x None = True"
  "opt_less (Some a) (Some b) = (a < b)"
unfolding opt_less_def by (auto simp add: ord_def split: option.split)

primrec ord' :: "key option \<Rightarrow> 'a tree23 \<Rightarrow> key option \<Rightarrow> bool" where
"ord' x Empty y = opt_less x y" |
"ord' x (Branch2 l p r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) r y)" |
"ord' x (Branch3 l p m q r) y = (ord' x l (Some (fst p)) & ord' (Some (fst p)) m (Some (fst q)) & ord' (Some (fst q)) r y)"

definition ord0 :: "'a tree23 \<Rightarrow> bool" where
  "ord0 t = ord' None t None"

text {* Balanced trees *}

inductive full :: "nat \<Rightarrow> 'a tree23 \<Rightarrow> bool" where
"full 0 Empty" |
"\<lbrakk>full n l; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch2 l p r)" |
"\<lbrakk>full n l; full n m; full n r\<rbrakk> \<Longrightarrow> full (Suc n) (Branch3 l p m q r)"

inductive_cases full_elims:
  "full n Empty"
  "full n (Branch2 l p r)"
  "full n (Branch3 l p m q r)"

inductive_cases full_0_elim: "full 0 t"
inductive_cases full_Suc_elim: "full (Suc n) t"

lemma full_0_iff [simp]: "full 0 t \<longleftrightarrow> t = Empty"
  by (auto elim: full_0_elim intro: full.intros)

lemma full_Empty_iff [simp]: "full n Empty \<longleftrightarrow> n = 0"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch2_iff [simp]:
  "full (Suc n) (Branch2 l p r) \<longleftrightarrow> full n l \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

lemma full_Suc_Branch3_iff [simp]:
  "full (Suc n) (Branch3 l p m q r) \<longleftrightarrow> full n l \<and> full n m \<and> full n r"
  by (auto elim: full_elims intro: full.intros)

fun height :: "'a tree23 \<Rightarrow> nat" where
"height Empty = 0" |
"height (Branch2 l _ r) = Suc(max (height l) (height r))" |
"height (Branch3 l _ m _ r) = Suc(max (height l) (max (height m) (height r)))"

text{* Is a tree balanced? *}
fun bal :: "'a tree23 \<Rightarrow> bool" where
"bal Empty = True" |
"bal (Branch2 l _ r) = (bal l & bal r & height l = height r)" |
"bal (Branch3 l _ m _ r) = (bal l & bal m & bal r & height l = height m & height m = height r)"

lemma full_imp_height: "full n t \<Longrightarrow> height t = n"
  by (induct set: full, simp_all)

lemma full_imp_bal: "full n t \<Longrightarrow> bal t"
  by (induct set: full, auto dest: full_imp_height)

lemma bal_imp_full: "bal t \<Longrightarrow> full (height t) t"
  by (induct t, simp_all)

lemma bal_iff_full: "bal t \<longleftrightarrow> (\<exists>n. full n t)"
  by (auto elim!: bal_imp_full full_imp_bal)

text {* The @{term "add0"} function either preserves the height of the
tree, or increases it by one. The constructor returned by the @{term
"add"} function determines which: A return value of the form @{term
"Stay t"} indicates that the height will be the same. A value of the
form @{term "Sprout l p r"} indicates an increase in height. *}

primrec gfull :: "nat \<Rightarrow> 'a growth \<Rightarrow> bool" where
"gfull n (Stay t) \<longleftrightarrow> full n t" |
"gfull n (Sprout l p r) \<longleftrightarrow> full n l \<and> full n r"

lemma gfull_add: "full n t \<Longrightarrow> gfull n (add k y t)"
by (induct set: full, auto split: ord.split growth.split)

text {* The @{term "add0"} operation preserves balance. *}

lemma bal_add0: "bal t \<Longrightarrow> bal (add0 k y t)"
unfolding bal_iff_full add0_def
apply (erule exE)
apply (drule gfull_add [of _ _ k y])
apply (cases "add k y t")
apply (auto intro: full.intros)
done

text {* The @{term "add0"} operation preserves order. *}

lemma ord_cases:
  fixes a b :: int obtains
  "ord a b = LESS" and "a < b" |
  "ord a b = EQUAL" and "a = b" |
  "ord a b = GREATER" and "a > b"
unfolding ord_def by (rule linorder_cases [of a b]) auto

definition gtree :: "'a growth \<Rightarrow> 'a tree23" where
  "gtree g = (case g of Stay t \<Rightarrow> t | Sprout l p r \<Rightarrow> Branch2 l p r)"

lemma gtree_simps [simp]:
  "gtree (Stay t) = t"
  "gtree (Sprout l p r) = Branch2 l p r"
unfolding gtree_def by simp_all

lemma add0: "add0 k y t = gtree (add k y t)"
  unfolding add0_def by (simp split: growth.split)

lemma ord'_add0:
  "\<lbrakk>ord' k1 t k2; opt_less k1 (Some k); opt_less (Some k) k2\<rbrakk> \<Longrightarrow> ord' k1 (add0 k y t) k2"
unfolding add0
 apply (induct t arbitrary: k1 k2)
   apply simp
  apply clarsimp
  apply (rule_tac a=k and b=a in ord_cases)
    apply simp
    apply (case_tac "add k y t1", simp, simp)
   apply simp
  apply simp
  apply (case_tac "add k y t2", simp, simp)
 apply clarsimp
 apply (rule_tac a=k and b=a in ord_cases)
   apply simp
   apply (case_tac "add k y t1", simp, simp)
  apply simp
 apply simp
 apply (rule_tac a=k and b=aa in ord_cases)
   apply simp
   apply (case_tac "add k y t2", simp, simp)
  apply simp
 apply simp
 apply (case_tac "add k y t3", simp, simp)
done

lemma ord0_add0: "ord0 t \<Longrightarrow> ord0 (add0 k y t)"
  by (simp add: ord0_def ord'_add0)

text {* The @{term "del"} function preserves balance. *}

lemma del_extra_simps:
"l \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch2 l p r) = (case compare k p of
      LESS => (case del k l of None \<Rightarrow> None |
        Some(p', (False, l')) => Some(p', (False, Branch2 l' p r))
      | Some(p', (True, l')) => Some(p', case r of
          Branch2 rl rp rr => (True, Branch3 l' p rl rp rr)
        | Branch3 rl rp rm rq rr => (False, Branch2
            (Branch2 l' p rl) rp (Branch2 rm rq rr))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(p', (False, r')) => Some(p', (False, Branch2 l (if_eq or p' p) r'))
      | Some(p', (True, r')) => Some(p', case l of
          Branch2 ll lp lr => (True, Branch3 ll lp lr (if_eq or p' p) r')
        | Branch3 ll lp lm lq lr => (False, Branch2
            (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) r')))))"
"l \<noteq> Empty \<or> m \<noteq> Empty \<or> r \<noteq> Empty \<Longrightarrow>
 del k (Branch3 l p m q r) = (case compare k q of
      LESS => (case compare k p of
        LESS => (case del k l of None \<Rightarrow> None |
          Some(p', (False, l')) => Some(p', (False, Branch3 l' p m q r))
        | Some(p', (True, l')) => Some(p', (False, case (m, r) of
            (Branch2 ml mp mr, Branch2 _ _ _) => Branch2 (Branch3 l' p ml mp mr) q r
          | (Branch3 ml mp mm mq mr, _) => Branch3 (Branch2 l' p ml) mp (Branch2 mm mq mr) q r
          | (Branch2 ml mp mr, Branch3 rl rp rm rq rr) =>
              Branch3 (Branch2 l' p ml) mp (Branch2 mr q rl) rp (Branch2 rm rq rr))))
      | or => (case del (if_eq or None k) m of None \<Rightarrow> None |
          Some(p', (False, m')) => Some(p', (False, Branch3 l (if_eq or p' p) m' q r))
        | Some(p', (True, m')) => Some(p', (False, case (l, r) of
            (Branch2 ll lp lr, Branch2 _ _ _) => Branch2 (Branch3 ll lp lr (if_eq or p' p) m') q r
          | (Branch3 ll lp lm lq lr, _) => Branch3 (Branch2 ll lp lm) lq (Branch2 lr (if_eq or p' p) m') q r
          | (_, Branch3 rl rp rm rq rr) => Branch3 l (if_eq or p' p) (Branch2 m' q rl) rp (Branch2 rm rq rr)))))
    | or => (case del (if_eq or None k) r of None \<Rightarrow> None |
        Some(q', (False, r')) => Some(q', (False, Branch3 l p m (if_eq or q' q) r'))
      | Some(q', (True, r')) => Some(q', (False, case (l, m) of
          (Branch2 _ _ _, Branch2 ml mp mr) => Branch2 l p (Branch3 ml mp mr (if_eq or q' q) r')
        | (_, Branch3 ml mp mm mq mr) => Branch3 l p (Branch2 ml mp mm) mq (Branch2 mr (if_eq or q' q) r')
        | (Branch3 ll lp lm lq lr, Branch2 ml mp mr) =>
            Branch3 (Branch2 ll lp lm) lq (Branch2 lr p ml) mp (Branch2 mr (if_eq or q' q) r')))))"
apply -
apply (cases l, cases r, simp_all only: del.simps, simp)
apply (cases l, cases m, cases r, simp_all only: del.simps, simp)
done

fun dfull where
"dfull n None \<longleftrightarrow> True" |
"dfull n (Some (p, (True, t'))) \<longleftrightarrow> full n t'" |
"dfull n (Some (p, (False, t'))) \<longleftrightarrow> full (Suc n) t'"

lemmas dfull_case_intros =
  ord.exhaust [of y "dfull a (case_ord b c d y)"]
  option.exhaust [of y "dfull a (case_option b c y)"]
  prod.exhaust [of y "dfull a (case_prod b y)"]
  bool.exhaust [of y "dfull a (case_bool b c y)"]
  tree23.exhaust [of y "dfull a (Some (b, case_tree23 c d e y))"]
  tree23.exhaust [of y "full a (case_tree23 b c d y)"]
  for a b c d e y

lemma dfull_del: "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
proof -
  { fix n :: "nat" and p :: "key \<times> 'a" and l r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k p = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k p = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch2 l p r)"
    hence "dfull n (del k (Branch2 l p r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     (* This should work, but it is way too slow!
     apply (force split: ord.split option.split bool.split tree23.split) *)
     apply (simp | rule dfull_case_intros)+
     done
  } note A = this
  { fix n :: "nat" and p q :: "key \<times> 'a" and l m r :: "'a tree23" and k
    assume "\<And>n. \<lbrakk>compare k q = LESS; compare k p = LESS; full (Suc n) l\<rbrakk> \<Longrightarrow> dfull n (del k l)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = EQUAL; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) m)"
    and "\<And>n. \<lbrakk>compare k q = LESS; compare k p = GREATER; full (Suc n) m\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) m)"
    and "\<And>n. \<lbrakk>compare k q = EQUAL; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq EQUAL None k) r)"
    and "\<And>n. \<lbrakk>compare k q = GREATER; full (Suc n) r\<rbrakk> \<Longrightarrow> dfull n (del (if_eq GREATER None k) r)"
    and "full (Suc n) (Branch3 l p m q r)"
    hence "dfull n (del k (Branch3 l p m q r))"
     apply clarsimp
     apply (cases n)
      apply (cases k)
       apply simp
      apply (simp split: ord.split)
     apply simp
     apply (subst del_extra_simps, force)
     apply (simp | rule dfull_case_intros)+
     done
  } note B = this
  show "full (Suc n) t \<Longrightarrow> dfull n (del k t)"
  proof (induct k t arbitrary: n rule: del.induct)
    { case goal1 thus "dfull n (del (Some k) Empty)" by simp }
    { case goal2 thus "dfull n (del None (Branch2 Empty p Empty))" by simp }
    { case goal3 thus "dfull n (del None (Branch3 Empty p Empty q Empty))"
        by simp }
    { case goal4 thus "dfull n (del (Some v) (Branch2 Empty p Empty))"
        by (simp split: ord.split) }
    { case goal5 thus "dfull n (del (Some v) (Branch3 Empty p Empty q Empty))"
        by (simp split: ord.split) }
    { case goal26 thus ?case by simp }
  qed (fact A | fact B)+
qed

lemma bal_del0: "bal t \<Longrightarrow> bal (del0 k t)"
unfolding bal_iff_full del0_def
apply (erule exE)
apply (case_tac n, simp, simp)
apply (frule dfull_del [where k="Some k"])
apply (cases "del (Some k) t", force)
apply (rename_tac a, case_tac "a", rename_tac b t', case_tac "b", auto)
done

text{* This is a little test harness and should be commented out once the
above functions have been proved correct. *}

datatype 'a act = Add int 'a | Del int

fun exec where
"exec [] t = t" |
"exec (Add k x # as) t = exec as (add0 k x t)" |
"exec (Del k # as) t = exec as (del0 k t)"

text{* Some quick checks: *}

lemma bal_exec: "bal t \<Longrightarrow> bal (exec as t)"
  by (induct as t arbitrary: t rule: exec.induct,
    simp_all add: bal_add0 bal_del0)

lemma "bal(exec as Empty)"
  by (simp add: bal_exec)

lemma "ord0(exec as Empty)"
quickcheck
oops

end


(*  Title:      HOL/UNITY/Lift_prog.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1999  University of Cambridge

lift_prog, etc: replication of components and arrays of processes.
*)

section{*Replication of Components*}

theory Lift_prog imports Rename begin

definition insert_map :: "[nat, 'b, nat=>'b] => (nat=>'b)" where
    "insert_map i z f k == if k<i then f k
                           else if k=i then z
                           else f(k - 1)"

definition delete_map :: "[nat, nat=>'b] => (nat=>'b)" where
    "delete_map i g k == if k<i then g k else g (Suc k)"

definition lift_map :: "[nat, 'b * ((nat=>'b) * 'c)] => (nat=>'b) * 'c" where
    "lift_map i == %(s,(f,uu)). (insert_map i s f, uu)"

definition drop_map :: "[nat, (nat=>'b) * 'c] => 'b * ((nat=>'b) * 'c)" where
    "drop_map i == %(g, uu). (g i, (delete_map i g, uu))"

definition lift_set :: "[nat, ('b * ((nat=>'b) * 'c)) set] => ((nat=>'b) * 'c) set" where
    "lift_set i A == lift_map i ` A"

definition lift :: "[nat, ('b * ((nat=>'b) * 'c)) program] => ((nat=>'b) * 'c) program" where
    "lift i == rename (lift_map i)"

  (*simplifies the expression of specifications*)
definition sub :: "['a, 'a=>'b] => 'b" where
    "sub == %i f. f i"

declare insert_map_def [simp] delete_map_def [simp]

lemma insert_map_inverse: "delete_map i (insert_map i x f) = f"
by (rule ext, simp)

lemma insert_map_delete_map_eq: "(insert_map i x (delete_map i g)) = g(i:=x)"
apply (rule ext)
apply (auto split add: nat_diff_split)
done

subsection{*Injectiveness proof*}

lemma insert_map_inject1: "(insert_map i x f) = (insert_map i y g) ==> x=y"
by (drule_tac x = i in fun_cong, simp)

lemma insert_map_inject2: "(insert_map i x f) = (insert_map i y g) ==> f=g"
apply (drule_tac f = "delete_map i" in arg_cong)
apply (simp add: insert_map_inverse)
done

lemma insert_map_inject':
     "(insert_map i x f) = (insert_map i y g) ==> x=y & f=g"
by (blast dest: insert_map_inject1 insert_map_inject2)

lemmas insert_map_inject = insert_map_inject' [THEN conjE, elim!]

(*The general case: we don't assume i=i'*)
lemma lift_map_eq_iff [iff]:
     "(lift_map i (s,(f,uu)) = lift_map i' (s',(f',uu')))
      = (uu = uu' & insert_map i s f = insert_map i' s' f')"
by (unfold lift_map_def, auto)

(*The !!s allows the automatic splitting of the bound variable*)
lemma drop_map_lift_map_eq [simp]: "!!s. drop_map i (lift_map i s) = s"
apply (unfold lift_map_def drop_map_def)
apply (force intro: insert_map_inverse)
done

lemma inj_lift_map: "inj (lift_map i)"
apply (unfold lift_map_def)
apply (rule inj_onI, auto)
done

subsection{*Surjectiveness proof*}

lemma lift_map_drop_map_eq [simp]: "!!s. lift_map i (drop_map i s) = s"
apply (unfold lift_map_def drop_map_def)
apply (force simp add: insert_map_delete_map_eq)
done

lemma drop_map_inject [dest!]: "(drop_map i s) = (drop_map i s') ==> s=s'"
by (drule_tac f = "lift_map i" in arg_cong, simp)

lemma surj_lift_map: "surj (lift_map i)"
apply (rule surjI)
apply (rule lift_map_drop_map_eq)
done

lemma bij_lift_map [iff]: "bij (lift_map i)"
by (simp add: bij_def inj_lift_map surj_lift_map)

lemma inv_lift_map_eq [simp]: "inv (lift_map i) = drop_map i"
by (rule inv_equality, auto)

lemma inv_drop_map_eq [simp]: "inv (drop_map i) = lift_map i"
by (rule inv_equality, auto)

lemma bij_drop_map [iff]: "bij (drop_map i)"
by (simp del: inv_lift_map_eq add: inv_lift_map_eq [symmetric] bij_imp_bij_inv)

(*sub's main property!*)
lemma sub_apply [simp]: "sub i f = f i"
by (simp add: sub_def)

lemma all_total_lift: "all_total F ==> all_total (lift i F)"
by (simp add: lift_def rename_def Extend.all_total_extend)

lemma insert_map_upd_same: "(insert_map i t f)(i := s) = insert_map i s f"
by (rule ext, auto)

lemma insert_map_upd:
     "(insert_map j t f)(i := s) =
      (if i=j then insert_map i s f
       else if i<j then insert_map j t (f(i:=s))
       else insert_map j t (f(i - Suc 0 := s)))"
apply (rule ext)
apply (simp split add: nat_diff_split)
 txt{*This simplification is VERY slow*}
done

lemma insert_map_eq_diff:
     "[| insert_map i s f = insert_map j t g;  i\<noteq>j |]
      ==> \<exists>g'. insert_map i s' f = insert_map j t g'"
apply (subst insert_map_upd_same [symmetric])
apply (erule ssubst)
apply (simp only: insert_map_upd if_False split: split_if, blast)
done

lemma lift_map_eq_diff:
     "[| lift_map i (s,(f,uu)) = lift_map j (t,(g,vv));  i\<noteq>j |]
      ==> \<exists>g'. lift_map i (s',(f,uu)) = lift_map j (t,(g',vv))"
apply (unfold lift_map_def, auto)
apply (blast dest: insert_map_eq_diff)
done

subsection{*The Operator @{term lift_set}*}

lemma lift_set_empty [simp]: "lift_set i {} = {}"
by (unfold lift_set_def, auto)

lemma lift_set_iff: "(lift_map i x \<in> lift_set i A) = (x \<in> A)"
apply (unfold lift_set_def)
apply (rule inj_lift_map [THEN inj_image_mem_iff])
done

(*Do we really need both this one and its predecessor?*)
lemma lift_set_iff2 [iff]:
     "((f,uu) \<in> lift_set i A) = ((f i, (delete_map i f, uu)) \<in> A)"
by (simp add: lift_set_def mem_rename_set_iff drop_map_def)

lemma lift_set_mono: "A \<subseteq> B ==> lift_set i A \<subseteq> lift_set i B"
apply (unfold lift_set_def)
apply (erule image_mono)
done

lemma lift_set_Un_distrib: "lift_set i (A \<union> B) = lift_set i A \<union> lift_set i B"
by (simp add: lift_set_def image_Un)

lemma lift_set_Diff_distrib: "lift_set i (A-B) = lift_set i A - lift_set i B"
apply (unfold lift_set_def)
apply (rule inj_lift_map [THEN image_set_diff])
done

subsection{*The Lattice Operations*}

lemma bij_lift [iff]: "bij (lift i)"
by (simp add: lift_def)

lemma lift_SKIP [simp]: "lift i SKIP = SKIP"
by (simp add: lift_def)

lemma lift_Join [simp]: "lift i (F Join G) = lift i F Join lift i G"
by (simp add: lift_def)

lemma lift_JN [simp]: "lift j (JOIN I F) = (\<Squnion>i \<in> I. lift j (F i))"
by (simp add: lift_def)

subsection{*Safety: constrains, stable, invariant*}

lemma lift_constrains:
     "(lift i F \<in> (lift_set i A) co (lift_set i B)) = (F \<in> A co B)"
by (simp add: lift_def lift_set_def rename_constrains)

lemma lift_stable:
     "(lift i F \<in> stable (lift_set i A)) = (F \<in> stable A)"
by (simp add: lift_def lift_set_def rename_stable)

lemma lift_invariant:
     "(lift i F \<in> invariant (lift_set i A)) = (F \<in> invariant A)"
by (simp add: lift_def lift_set_def rename_invariant)

lemma lift_Constrains:
     "(lift i F \<in> (lift_set i A) Co (lift_set i B)) = (F \<in> A Co B)"
by (simp add: lift_def lift_set_def rename_Constrains)

lemma lift_Stable:
     "(lift i F \<in> Stable (lift_set i A)) = (F \<in> Stable A)"
by (simp add: lift_def lift_set_def rename_Stable)

lemma lift_Always:
     "(lift i F \<in> Always (lift_set i A)) = (F \<in> Always A)"
by (simp add: lift_def lift_set_def rename_Always)

subsection{*Progress: transient, ensures*}

lemma lift_transient:
     "(lift i F \<in> transient (lift_set i A)) = (F \<in> transient A)"
by (simp add: lift_def lift_set_def rename_transient)

lemma lift_ensures:
     "(lift i F \<in> (lift_set i A) ensures (lift_set i B)) =
      (F \<in> A ensures B)"
by (simp add: lift_def lift_set_def rename_ensures)

lemma lift_leadsTo:
     "(lift i F \<in> (lift_set i A) leadsTo (lift_set i B)) =
      (F \<in> A leadsTo B)"
by (simp add: lift_def lift_set_def rename_leadsTo)

lemma lift_LeadsTo:
     "(lift i F \<in> (lift_set i A) LeadsTo (lift_set i B)) =
      (F \<in> A LeadsTo B)"
by (simp add: lift_def lift_set_def rename_LeadsTo)

(** guarantees **)

lemma lift_lift_guarantees_eq:
     "(lift i F \<in> (lift i ` X) guarantees (lift i ` Y)) =
      (F \<in> X guarantees Y)"
apply (unfold lift_def)
apply (subst bij_lift_map [THEN rename_rename_guarantees_eq, symmetric])
apply (simp add: o_def)
done

lemma lift_guarantees_eq_lift_inv:
     "(lift i F \<in> X guarantees Y) =
      (F \<in> (rename (drop_map i) ` X) guarantees (rename (drop_map i) ` Y))"
by (simp add: bij_lift_map [THEN rename_guarantees_eq_rename_inv] lift_def)

(*To preserve snd means that the second component is there just to allow
  guarantees properties to be stated.  Converse fails, for lift i F can
  change function components other than i*)
lemma lift_preserves_snd_I: "F \<in> preserves snd ==> lift i F \<in> preserves snd"
apply (drule_tac w1=snd in subset_preserves_o [THEN subsetD])
apply (simp add: lift_def rename_preserves)
apply (simp add: lift_map_def o_def split_def)
done

lemma delete_map_eqE':
     "(delete_map i g) = (delete_map i g') ==> \<exists>x. g = g'(i:=x)"
apply (drule_tac f = "insert_map i (g i) " in arg_cong)
apply (simp add: insert_map_delete_map_eq)
apply (erule exI)
done

lemmas delete_map_eqE = delete_map_eqE' [THEN exE, elim!]

lemma delete_map_neq_apply:
     "[| delete_map j g = delete_map j g';  i\<noteq>j |] ==> g i = g' i"
by force

(*A set of the form (A <*> UNIV) ignores the second (dummy) state component*)

lemma vimage_o_fst_eq [simp]: "(f o fst) -` A = (f-`A) <*> UNIV"
by auto

lemma vimage_sub_eq_lift_set [simp]:
     "(sub i -`A) <*> UNIV = lift_set i (A <*> UNIV)"
by auto

lemma mem_lift_act_iff [iff]:
     "((s,s') \<in> extend_act (%(x,u::unit). lift_map i x) act) =
      ((drop_map i s, drop_map i s') \<in> act)"
apply (unfold extend_act_def, auto)
apply (rule bexI, auto)
done

lemma preserves_snd_lift_stable:
     "[| F \<in> preserves snd;  i\<noteq>j |]
      ==> lift j F \<in> stable (lift_set i (A <*> UNIV))"
apply (auto simp add: lift_def lift_set_def stable_def constrains_def
                      rename_def extend_def mem_rename_set_iff)
apply (auto dest!: preserves_imp_eq simp add: lift_map_def drop_map_def)
apply (drule_tac x = i in fun_cong, auto)
done

(*If i\<noteq>j then lift j F  does nothing to lift_set i, and the
  premise ensures A \<subseteq> B.*)
lemma constrains_imp_lift_constrains:
    "[| F i \<in> (A <*> UNIV) co (B <*> UNIV);
        F j \<in> preserves snd |]
     ==> lift j (F j) \<in> (lift_set i (A <*> UNIV)) co (lift_set i (B <*> UNIV))"
apply (cases "i=j")
apply (simp add: lift_def lift_set_def rename_constrains)
apply (erule preserves_snd_lift_stable[THEN stableD, THEN constrains_weaken_R],
       assumption)
apply (erule constrains_imp_subset [THEN lift_set_mono])
done

(*USELESS??*)
lemma lift_map_image_Times:
     "lift_map i ` (A <*> UNIV) =
      (\<Union>s \<in> A. \<Union>f. {insert_map i s f}) <*> UNIV"
apply (auto intro!: bexI image_eqI simp add: lift_map_def)
apply (rule split_conv [symmetric])
done

lemma lift_preserves_eq:
     "(lift i F \<in> preserves v) = (F \<in> preserves (v o lift_map i))"
by (simp add: lift_def rename_preserves)

(*A useful rewrite.  If o, sub have been rewritten out already then can also
  use it as   rewrite_rule [sub_def, o_def] lift_preserves_sub*)
lemma lift_preserves_sub:
     "F \<in> preserves snd
      ==> lift i F \<in> preserves (v o sub j o fst) =
          (if i=j then F \<in> preserves (v o fst) else True)"
apply (drule subset_preserves_o [THEN subsetD])
apply (simp add: lift_preserves_eq o_def)
apply (auto cong del: if_weak_cong
       simp add: lift_map_def eq_commute split_def o_def)
done

subsection{*Lemmas to Handle Function Composition (o) More Consistently*}

(*Lets us prove one version of a theorem and store others*)
lemma o_equiv_assoc: "f o g = h ==> f' o f o g = f' o h"
by (simp add: fun_eq_iff o_def)

lemma o_equiv_apply: "f o g = h ==> \<forall>x. f(g x) = h x"
by (simp add: fun_eq_iff o_def)

lemma fst_o_lift_map: "sub i o fst o lift_map i = fst"
apply (rule ext)
apply (auto simp add: o_def lift_map_def sub_def)
done

lemma snd_o_lift_map: "snd o lift_map i = snd o snd"
apply (rule ext)
apply (auto simp add: o_def lift_map_def)
done

subsection{*More lemmas about extend and project*}

text{*They could be moved to theory Extend or Project*}

lemma extend_act_extend_act:
     "extend_act h' (extend_act h act) =
      extend_act (%(x,(y,y')). h'(h(x,y),y')) act"
apply (auto elim!: rev_bexI simp add: extend_act_def, blast)
done

lemma project_act_project_act:
     "project_act h (project_act h' act) =
      project_act (%(x,(y,y')). h'(h(x,y),y')) act"
by (auto elim!: rev_bexI simp add: project_act_def)

lemma project_act_extend_act:
     "project_act h (extend_act h' act) =
        {(x,x'). \<exists>s s' y y' z. (s,s') \<in> act &
                 h(x,y) = h'(s,z) & h(x',y') = h'(s',z)}"
by (simp add: extend_act_def project_act_def, blast)

subsection{*OK and "lift"*}

lemma act_in_UNION_preserves_fst:
     "act \<subseteq> {(x,x'). fst x = fst x'} ==> act \<in> UNION (preserves fst) Acts"
apply (rule_tac a = "mk_program (UNIV,{act},UNIV) " in UN_I)
apply (auto simp add: preserves_def stable_def constrains_def)
done

lemma UNION_OK_lift_I:
     "[| \<forall>i \<in> I. F i \<in> preserves snd;
         \<forall>i \<in> I. UNION (preserves fst) Acts \<subseteq> AllowedActs (F i) |]
      ==> OK I (%i. lift i (F i))"
apply (auto simp add: OK_def lift_def rename_def Extend.Acts_extend)
apply (simp add: Extend.AllowedActs_extend project_act_extend_act)
apply (rename_tac "act")
apply (subgoal_tac
       "{(x, x'). \<exists>s f u s' f' u'.
                    ((s, f, u), s', f', u') \<in> act &
                    lift_map j x = lift_map i (s, f, u) &
                    lift_map j x' = lift_map i (s', f', u') }
                \<subseteq> { (x,x') . fst x = fst x'}")
apply (blast intro: act_in_UNION_preserves_fst, clarify)
apply (drule_tac x = j in fun_cong)+
apply (drule_tac x = i in bspec, assumption)
apply (frule preserves_imp_eq, auto)
done

lemma OK_lift_I:
     "[| \<forall>i \<in> I. F i \<in> preserves snd;
         \<forall>i \<in> I. preserves fst \<subseteq> Allowed (F i) |]
      ==> OK I (%i. lift i (F i))"
by (simp add: safety_prop_AllowedActs_iff_Allowed UNION_OK_lift_I)

lemma Allowed_lift [simp]: "Allowed (lift i F) = lift i ` (Allowed F)"
by (simp add: lift_def)

lemma lift_image_preserves:
     "lift i ` preserves v = preserves (v o drop_map i)"
by (simp add: rename_image_preserves lift_def)

end


(* This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_relaxedprefix_is_prefix_1
imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype It = A | B | C

fun x :: "'a list => 'a list => 'a list" where
"x (nil2) z = z"
| "x (cons2 z2 xs) z = cons2 z2 (x xs z)"

fun isPrefix :: "It list => It list => bool" where
"isPrefix (nil2) z = True"
| "isPrefix (cons2 z2 x2) (nil2) = False"
| "isPrefix (cons2 z2 x2) (cons2 x3 x4) =
     ((z2 = x3) & (isPrefix x2 x4))"

fun isRelaxedPrefix :: "It list => It list => bool" where
"isRelaxedPrefix (nil2) z = True"
| "isRelaxedPrefix (cons2 z2 (nil2)) z = True"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (nil2) = False"
| "isRelaxedPrefix (cons2 z2 (cons2 x3 x4)) (cons2 x5 x6) =
     (if (z2 = x5) then isRelaxedPrefix (cons2 x3 x4) x6 else
        isPrefix (cons2 x3 x4) (cons2 x5 x6))"

theorem property0 :
  "isRelaxedPrefix xs (x xs ys)"
  oops

end


(* VDM to Isabelle Translation @2022-12-08T10:15:15.450Z
   Copyright 2019-22, Leo Freitas, leo.freitas@newcastle.ac.uk

   Comment
   Location
*)
theory TemplateTheory
imports Main
begin

type_synonym MyType  = \<open>nat\<close>

datatype MyDType = A | B | C

lemmas LemmasNames  = Lemma1 Lemma2 Lemma3

theorem test [simp, elim]  :
    \<open>x > 0\<close>
  oops

abbreviation
    abbrev :: \<open>nat\<close> where
    \<open>abbrev  \<equiv> 10\<close>

definition
    geqDef :: \<open>nat \<Rightarrow> bool\<close> where
      [simp]  :  \<open>geqDef x  \<equiv> x > 1\<close>

record myRec =
    field1 :: \<open>nat\<close>
    field2 :: \<open>int\<close>

record myRec2 =
    field1 :: \<open>nat\<close>
    field2 :: \<open>int\<close>

definition
  pre_myFunDef :: \<open>nat \<Rightarrow> nat \<Rightarrow> bool\<close>
  where
  \<open>pre_myFunDef x y \<equiv> True\<close>

\<comment>\<open>VDM function definition\<close>
definition
    myFunDef :: \<open>nat \<Rightarrow> nat \<Rightarrow> bool\<close> where
     \<open>myFunDef x y \<equiv>
                    (if pre_myFunDef  x y then
                        x+y > 10
                    else
                        undefined
                    )\<close>

\<comment>\<open>Isabelle automatic recursive definition\<close>
declare pre_fact_def n [simp]

fun (domintros)
    fact :: \<open>nat \<Rightarrow> nat\<close>  where
      [iff]  :  \<open>fact n =
                    (if pre_fact  n then
                        (if n = 0 then 1 else n*fact(n-1))
                    else
                        undefined
                    )\<close>

declare pre_fact_def n [simp del]
\<comment>\<open>Isabelle even\<close>
\<comment>\<open>Isabelle odd\<close>
declare pre_even_def n [simp]
        pre_odd_def n [simp]

fun (domintros)
    even :: \<open>nat \<Rightarrow> bool\<close>  and
    odd :: \<open>nat \<Rightarrow> bool\<close>  where
     \<open>even n =
                    (if pre_even  n then
                        (if n = 0 then True else odd (n-1))
                    else
                        undefined
                    )\<close>
    |    \<open>odd n =
                    (if pre_odd  n then
                        (if n = 0 then False else even (n-1))
                    else
                        undefined
                    )\<close>

declare pre_even_def n [simp del]
pre_odd_def n [simp del]
hide_const \<open>whichever\<close>

end


theory TemporalConditionalMode

imports Main Free_Boolean_Algebra

begin

notation
  bot ("\<bottom>") and
  top ("\<top>") and
  inf  (infixl "\<sqinter>" 70) and
  sup  (infixl "\<squnion>" 65)

type_synonym 'a tval = "'a list set"

primrec before_op_list :: "'a \<Rightarrow> 'a \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "before_op_list _ _ [] = False" |
  "before_op_list a b (x # xs) = ((a = x \<and> b \<in> set xs) \<or> (before_op_list a b xs))"

inductive_set
  ta :: "'a tval set"
where
  tvar: "{ ls . distinct ls \<and> a \<in> set ls } \<in> ta" |
  Compl: "S \<in> ta \<Longrightarrow> - S \<in> ta" |
  inter: "S \<in> ta \<Longrightarrow> T \<in> ta \<Longrightarrow> S \<inter> T \<in> ta"

lemma ta_Diff:
  "S \<in> ta \<Longrightarrow> T \<in> ta \<Longrightarrow> S - T \<in> ta"
unfolding Diff_eq by (intro ta.inter ta.Compl)

lemma ta_union: "S \<in> ta \<Longrightarrow> T \<in> ta \<Longrightarrow>
  S \<union> T \<in> ta"
proof -
  assume "S \<in> ta" and "T \<in> ta"
  hence "- (- S \<inter> - T) \<in> ta" by (intro ta.intros)
  thus "S \<union> T \<in> ta" by simp
qed

lemma ta_empty: "({} :: 'a tval) \<in> ta"
proof -
  obtain S :: "'a tval" where "S \<in> ta"
    by (fast intro: ta.tvar)
  hence "S \<inter> -S \<in> ta" by (intro ta.intros)
  thus ?thesis by simp
qed

lemma ta_UNIV: "(UNIV :: 'a tval) \<in> ta"
proof -
  have "- {} \<in> ta" using ta_empty by (rule ta.Compl)
  thus "UNIV \<in> ta" by simp
qed

(*definition value_prefix :: "'a \<Rightarrow> 'a tval \<Rightarrow> 'a tval"
where
  "value_prefix a R \<equiv> { a # rs | rs . rs \<in> R \<and> a \<notin> set rs  }"

lemma "

lemma "\<lbrakk> R \<in> (ta::'a tval set) \<rbrakk> \<Longrightarrow> value_prefix (a::'a) R \<in> ta"
apply (auto simp add: value_prefix_def )
apply (erule ta.induct)
apply (auto simp add: CollectI)
done
*)

definition safe_concat :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "safe_concat ls rs \<equiv> (set ls \<inter> set rs = {})"

definition tval_prefix :: "'a tval \<Rightarrow> 'a tval \<Rightarrow> 'a tval"
where
  "tval_prefix L R \<equiv>
    { ls @ rs | ls rs . ls \<in> L \<and> rs \<in> R \<and> (safe_concat ls rs) }"

lemmas tval_prefix_defs = tval_prefix_def safe_concat_def

lemma "\<lbrakk> L \<in> ta; R \<in> ta  \<rbrakk> \<Longrightarrow> tval_prefix L R \<in> ta"
apply (auto simp add: tval_prefix_defs )
apply (erule ta.induct)
apply (erule ta.induct)
apply ( simp add: CollectI)
sledgehammer
done

typedef 'a tformula = "ta :: 'a tval set" by (auto intro: ta_empty)

definition tvar :: "'a \<Rightarrow> 'a tformula"
where "tvar a = Abs_tformula { ls . distinct ls \<and> a \<in> set ls }"

lemma Rep_tformula_tvar : "Rep_tformula (tvar a) = { ls . distinct ls \<and> a \<in> set ls }"
unfolding tvar_def using ta.tvar by (rule Abs_tformula_inverse)

definition before :: "'a \<Rightarrow> 'a tformula"
where "before a = Abs_tformula { ls | ls b . distinct ls \<and> before_op_list a b ls }"

text {* @{term tformula } as a @{term boolean_algebra } *}

instantiation tformula :: (type) boolean_algebra
begin

definition
  "x \<sqinter> y = Abs_tformula (Rep_tformula x \<inter> Rep_tformula y)"

definition
  "x \<squnion> y = Abs_tformula (Rep_tformula x \<union> Rep_tformula y)"

definition
  "\<top> = Abs_tformula UNIV"

definition
  "\<bottom> = Abs_tformula {}"

definition
  "x \<le> y \<longleftrightarrow> Rep_tformula x \<subseteq> Rep_tformula y"

definition
  "x < y \<longleftrightarrow> Rep_tformula x \<subset> Rep_tformula y"

definition
  "- x = Abs_tformula (- Rep_tformula x)"

definition
  "x - y = Abs_tformula (Rep_tformula x - Rep_tformula y)"

lemma Rep_tformula_inf:
  "Rep_tformula (x \<sqinter> y) = Rep_tformula x \<inter> Rep_tformula y"
unfolding inf_tformula_def
by (intro Abs_tformula_inverse ta.inter Rep_tformula)

lemma Rep_tformula_sup:
  "Rep_tformula (x \<squnion> y) = Rep_tformula x \<union> Rep_tformula y"
unfolding sup_tformula_def
by (intro Abs_tformula_inverse ta_union Rep_tformula)

lemma Rep_tformula_top: "Rep_tformula \<top> = UNIV"
unfolding top_tformula_def by (intro Abs_tformula_inverse ta_UNIV)

lemma Rep_tformula_bot: "Rep_tformula \<bottom> = {}"
unfolding bot_tformula_def by (intro Abs_tformula_inverse ta_empty)

lemma Rep_tformula_compl: "Rep_tformula (- x) = - Rep_tformula x"
unfolding uminus_tformula_def
by (intro Abs_tformula_inverse ta.Compl Rep_tformula)

lemma Rep_tformula_diff:
  "Rep_tformula (x - y) = Rep_tformula x - Rep_tformula y"
unfolding minus_tformula_def
by (intro Abs_tformula_inverse ta_Diff Rep_tformula)

lemmas eq_tformula_iff = Rep_tformula_inject [symmetric]

lemmas Rep_tformula_simps =
  less_eq_tformula_def less_tformula_def eq_tformula_iff
  Rep_tformula_sup Rep_tformula_inf Rep_tformula_top Rep_tformula_bot
  Rep_tformula_compl Rep_tformula_diff Rep_tformula_tvar

instance proof
qed (unfold Rep_tformula_simps, auto)

end

lemma bot_neq_top_tformula [simp]: "(\<bottom> :: 'a tformula) \<noteq> \<top>"
unfolding Rep_tformula_simps by auto

lemma top_neq_bot_tformula [simp]: "(\<top> :: 'a tformula) \<noteq> \<bottom>"
unfolding Rep_tformula_simps by auto

lemma tvar_le_tvar_simps [simp]:
  "tvar x \<le> tvar y \<longleftrightarrow> x = y"
  "\<not> tvar x \<le> - tvar y"
  "\<not> - tvar x \<le> tvar y "
unfolding Rep_tformula_simps
apply (auto)
apply (auto simp add: subset_iff)
apply (metis distinct_remdups empty_iff in_set_member list.set(1) member_rec(1) set_remdups)
apply (metis distinct_remdups insertCI set_remdups set_simps(2))
apply (metis distinct.simps(2))
done

lemma tvar_eq_tvar_simps [simp]:
  "tvar x = tvar y \<longleftrightarrow> x = y"
  "tvar x \<noteq> - tvar y"
  "- tvar x \<noteq> tvar y"
unfolding Rep_tformula_simps
apply (metis (full_types) tvar_def tvar_le_tvar_simps(1))
apply (metis Rep_tformula_tvar tvar_def uminus_tformula_def tvar_le_tvar_simps(1) tvar_le_tvar_simps(3))
apply (metis Rep_tformula_tvar tvar_def uminus_tformula_def tvar_le_tvar_simps(1) tvar_le_tvar_simps(3))
done

(*  before: "{ ls | ls b . distinct ls \<and> before a b ls } \<in> ta" |
*)
lemma tformula_induct [case_names tvar compl inf , induct type: tformula]:
  fixes P :: "'a tformula \<Rightarrow> bool"
  assumes 1: "\<And>i. P (tvar i)"
  assumes 2: "\<And>x. P x \<Longrightarrow> P (- x)"
  assumes 3: "\<And>x y. P x \<Longrightarrow> P y \<Longrightarrow> P (x \<sqinter> y)"
  shows "P x"
proof (induct x rule: Abs_tformula_induct)
  fix y :: "'a list set"
  assume "y \<in> ta" thus "P (Abs_tformula y)"
  proof (induct rule: ta.induct)
    case (tvar i)
    have "P (tvar i)" by (rule 1)
    thus ?case unfolding tvar_def .
  next
    case (Compl S)
    from `P (Abs_tformula S)` have "P (- Abs_tformula S)" by (rule 2)
    with `S \<in> ta` show ?case
      unfolding uminus_tformula_def by (simp add: Abs_tformula_inverse)
  next
    case (inter S T)
    from `P (Abs_tformula S)` and `P (Abs_tformula T)`
    have "P (Abs_tformula S \<sqinter> Abs_tformula T)" by (rule 3)
    with `S \<in> ta` and `T \<in> ta` show ?case
      unfolding inf_tformula_def by (simp add: Abs_tformula_inverse)
  qed
qed

definition
  tformulas :: "'a set \<Rightarrow> 'a tformula set"
where
  "tformulas S =
    {x. \<forall>as bs. (\<forall>p\<in>S.
      (distinct as \<and> p \<in> set as) \<longleftrightarrow>
      (distinct bs \<and> p \<in> set bs)) \<longrightarrow>
      as \<in> Rep_tformula x \<longleftrightarrow> bs \<in> Rep_tformula x}"

lemma tformulasI:
  assumes "\<And>as bs. \<forall>p\<in>S.
    (distinct as \<and> p \<in> set as) \<longleftrightarrow>
    (distinct bs \<and> p \<in> set bs)
    \<Longrightarrow> as \<in> Rep_tformula x \<longleftrightarrow> bs \<in> Rep_tformula x"
  shows "x \<in> tformulas S"
using assms unfolding tformulas_def by simp

lemma tformulasD:
  assumes "x \<in> tformulas S"
  assumes "\<forall>p\<in>S.
    (distinct as \<and> p \<in> set as) \<longleftrightarrow>
    (distinct bs \<and> p \<in> set bs)"
  shows "as \<in> Rep_tformula x \<longleftrightarrow> bs \<in> Rep_tformula x"
using assms unfolding tformulas_def by simp

lemma tformulas_mono: "S \<subseteq> T \<Longrightarrow> tformulas S \<subseteq> tformulas T"
by (fast intro!: tformulasI elim!: tformulasD)

lemma tformulas_insert: "x \<in> tformulas S \<Longrightarrow> x \<in> tformulas (insert a S)"
unfolding tformulas_def by simp

lemma tformulas_tvar: "i \<in> S \<Longrightarrow> tvar i \<in> tformulas S"
unfolding tformulas_def
apply (auto simp add: Rep_tformula_simps)
done

(* TODO: Problema! *)

(*lemma tformulas_before: "a \<in> S \<Longrightarrow> before a \<in> tformulas S"
unfolding tformulas_def
apply (auto simp add: Rep_tformula_simps)
done*)

lemma tformulas_tvar_iff: "tvar i \<in> tformulas S \<longleftrightarrow> i \<in> S"
unfolding tformulas_def
apply (auto simp add: Rep_tformula_simps)
apply (metis distinct_singleton empty_iff insert_iff list.set(1) set_simps(2))
done

lemma tformulas_bot: "\<bottom> \<in> tformulas S"
unfolding tformulas_def by (simp add: Rep_tformula_simps)

lemma tformulas_top: "\<top> \<in> tformulas S"
unfolding tformulas_def by (simp add: Rep_tformula_simps)

lemma tformulas_compl: "x \<in> tformulas S \<Longrightarrow> - x \<in> tformulas S"
unfolding tformulas_def by (simp add: Rep_tformula_simps)

lemma tformulas_inf:
  "x \<in> tformulas S \<Longrightarrow> y \<in> tformulas S \<Longrightarrow> x \<sqinter> y \<in> tformulas S"
unfolding tformulas_def by (auto simp add: Rep_tformula_simps)

lemma tformulas_sup:
  "x \<in> tformulas S \<Longrightarrow> y \<in> tformulas S \<Longrightarrow> x \<squnion> y \<in> tformulas S"
unfolding tformulas_def by (auto simp add: Rep_tformula_simps)

lemma tformulas_diff:
  "x \<in> tformulas S \<Longrightarrow> y \<in> tformulas S \<Longrightarrow> x - y \<in> tformulas S"
unfolding tformulas_def by (auto simp add: Rep_tformula_simps)

lemma tformulas_ifte:
  "a \<in> tformulas S \<Longrightarrow> x \<in> tformulas S \<Longrightarrow> y \<in> tformulas S \<Longrightarrow>
    ifte a x y \<in> tformulas S"
unfolding ifte_def
by (intro tformulas_sup tformulas_inf tformulas_compl)

lemmas tformulas_intros =
  tformulas_tvar tformulas_bot tformulas_top tformulas_compl
  tformulas_inf tformulas_sup tformulas_diff tformulas_ifte

definition tinsert :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list set"
where
  "tinsert i ls \<equiv> { xs . distinct xs \<and> i \<in> set xs \<and> (\<forall> j \<in> set ls . j \<in> set xs)  }"

definition tdiff :: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list set"
where
  "tdiff i ls \<equiv> { xs . distinct xs \<and> (\<forall> j \<in> set ls . j \<in> set xs \<and> j \<noteq> i)  }"

lemma ifte_inject_t2 :
  "ifte (f i) x y = ifte (f i) x' y' \<Longrightarrow>
  i \<notin> S \<Longrightarrow>
  f i = {A. i \<in> A} \<Longrightarrow>
  x \<in> g S \<Longrightarrow>
  x' \<in> g S \<Longrightarrow>
  y \<in> g S \<Longrightarrow>
  y' \<in> g S \<Longrightarrow>
  x = x' \<and> y = y'"
apply (auto)
done

lemma t_ifte_inject:
  assumes "ifte (tvar i) x y = ifte (tvar i) x' y'"
  assumes "i \<notin> S"
  assumes "x \<in> tformulas S" and "x' \<in> tformulas S"
  assumes "y \<in> tformulas S" and "y' \<in> tformulas S"
  shows "x = x' \<and> y = y'"
proof
  have 1: "\<And>ls. \<lbrakk> distinct ls \<and> i \<in> set ls \<rbrakk> \<Longrightarrow> ls \<in> Rep_tformula x \<longleftrightarrow> ls \<in> Rep_tformula x'"
    using assms(1)
    by (simp add: Rep_tformula_simps ifte_def set_eq_iff, fast)
  have 2: "\<And>ls. \<lbrakk> distinct ls \<and> i \<notin> set ls \<rbrakk> \<Longrightarrow> ls \<in> Rep_tformula y \<longleftrightarrow> ls \<in> Rep_tformula y'"
    using assms(1)
    by (simp add: Rep_tformula_simps ifte_def set_eq_iff, fast)

  show "x = x'"
  unfolding Rep_tformula_simps
  proof (rule set_eqI)
    fix ls
    have "ls \<in> Rep_tformula x \<longleftrightarrow>
        (\<forall> xs . xs \<in> tinsert i ls \<and> xs \<in> Rep_tformula x)"
      using `x \<in> tformulas S` sorry (* by (rule formulasD, force simp add: `i \<notin> S`)*)
    also have "\<dots> \<longleftrightarrow>
        (\<forall> xs . xs \<in> tinsert i ls \<and> xs \<in> Rep_tformula x')"
      sorry (*by (rule 1, simp)*)
    also have "\<dots> \<longleftrightarrow> ls \<in> Rep_tformula x'"
      using `x' \<in> tformulas S` sorry (*by (rule tformulasD, force simp add: `i \<notin> S`) *)
    finally show "ls \<in> Rep_tformula x \<longleftrightarrow> ls \<in> Rep_tformula x'" .
  qed
  show  "y = y'"
  unfolding Rep_tformula_simps
  proof (rule set_eqI)
    fix ls
    have "ls \<in> Rep_tformula y \<longleftrightarrow> (\<forall> xs . xs \<in> tdiff i ls \<and> xs \<in> Rep_tformula y)"
      using `y \<in> tformulas S` sorry (*by (rule tformulasD, force simp add: `i \<notin> S`)*)
    also have "\<dots> \<longleftrightarrow> (\<forall> xs . xs \<in> tdiff i ls \<and> xs \<in> Rep_tformula y')"
      sorry (*by (rule 2, simp)*)
    also have "\<dots> \<longleftrightarrow> ls \<in> Rep_tformula y'"
      using `y' \<in> tformulas S` sorry (*by (rule tformulasD, force simp add: `i \<notin> S`)*)
    finally show "ls \<in> Rep_tformula y \<longleftrightarrow> ls \<in> Rep_tformula y'" .
  qed
qed

inductive
  hom_graph_t ::
    "('a \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> 'a set \<Rightarrow> 'a tformula \<Rightarrow> 'b \<Rightarrow> bool"
  for f :: "'a \<Rightarrow> 'b::boolean_algebra"
where
  bot: "hom_graph_t f {} bot bot"
| top: "hom_graph_t f {} top top"
| ifte: "i \<notin> S \<Longrightarrow> hom_graph_t f S x a \<Longrightarrow> hom_graph_t f S y b \<Longrightarrow>
  hom_graph_t f (insert i S) (ifte (tvar i) x y) (ifte (f i) a b)"

lemma hom_graph_t_dest:
  "hom_graph_t f S x a \<Longrightarrow> k \<in> S \<Longrightarrow> \<exists>y z b c.
    x = ifte (tvar k) y z \<and> a = ifte (f k) b c \<and>
    hom_graph_t f (S - {k}) y b \<and> hom_graph_t f (S - {k}) z c"
proof (induct set: hom_graph_t)
  case (ifte i S x a y b) show ?case
  proof (cases "i = k")
    assume "i = k" with ifte(1,2,4) show ?case by auto
  next
    assume "i \<noteq> k"
    with `k \<in> insert i S` have k: "k \<in> S" by simp
    have *: "insert i S - {k} = insert i (S - {k})"
      using `i \<noteq> k` by (simp add: insert_Diff_if)
    have **: "i \<notin> S - {k}" using `i \<notin> S` by simp
    from ifte(1) ifte(3) [OF k] ifte(5) [OF k]
    show ?case
      unfolding *
      apply clarify
      apply (simp only: ifte_ifte_distrib [of "tvar i"])
      apply (simp only: ifte_ifte_distrib [of "f i"])
      apply (fast intro: hom_graph_t.ifte [OF **])
      done
  qed
qed simp_all

lemma hom_graph_t_insert_elim:
  assumes "hom_graph_t f (insert i S) x a" and "i \<notin> S"
  obtains y z b c
  where "x = ifte (tvar i) y z"
    and "a = ifte (f i) b c"
    and "hom_graph_t f S y b"
    and "hom_graph_t f S z c"
using hom_graph_t_dest [OF assms(1) insertI1]
by (clarify, simp add: assms(2))

lemma hom_graph_t_imp_tformulas:
  "hom_graph_t f S x a \<Longrightarrow> x \<in> tformulas S"
by (induct set: hom_graph_t, simp_all add: tformulas_intros tformulas_insert)

lemma hom_graph_t_unique:
  "hom_graph_t f S x a \<Longrightarrow> hom_graph_t f S x a' \<Longrightarrow> a = a'"
proof (induct arbitrary: a' set: hom_graph_t)
  case (ifte i S y b z c a')
  from ifte(6,1) obtain y' z' b' c'
    where 1: "ifte (tvar i) y z = ifte (tvar i) y' z'"
      and 2: "a' = ifte (f i) b' c'"
      and 3: "hom_graph_t f S y' b'"
      and 4: "hom_graph_t f S z' c'"
    by (rule hom_graph_t_insert_elim)
  from 1 3 4 ifte(1,2,4) have "y = y' \<and> z = z'"
    by (intro t_ifte_inject hom_graph_t_imp_tformulas)
  with 2 3 4 ifte(3,5) show "ifte (f i) b c = a'"
    by simp
qed (erule hom_graph_t.cases, simp_all)+

lemma hom_graph_t_insert:
  assumes "hom_graph_t f S x a"
  shows "hom_graph_t f (insert i S) x a"
proof (cases "i \<in> S")
  assume "i \<in> S" with assms show ?thesis by (simp add: insert_absorb)
next
  assume "i \<notin> S"
  hence "hom_graph_t f (insert i S) (ifte (tvar i) x x) (ifte (f i) a a)"
    by (intro hom_graph_t.ifte assms)
  thus "hom_graph_t f (insert i S) x a"
    by (simp only: ifte_same)
qed

lemma hom_graph_t_finite_superset:
  assumes "hom_graph_t f S x a" and "finite T" and "S \<subseteq> T"
  shows "hom_graph_t f T x a"
proof -
  from `finite T` have "hom_graph_t f (S \<union> T) x a"
    by (induct set: finite, simp add: assms, simp add: hom_graph_t_insert)
  with `S \<subseteq> T` show "hom_graph_t f T x a"
    by (simp only: subset_Un_eq)
qed

lemma hom_graph_t_imp_finite:
  "hom_graph_t f S x a \<Longrightarrow> finite S"
by (induct set: hom_graph_t) simp_all

lemma hom_graph_t_unique':
  assumes "hom_graph_t f S x a" and "hom_graph_t f T x a'"
  shows "a = a'"
proof (rule hom_graph_t_unique)
  have fin: "finite (S \<union> T)"
    using assms by (intro finite_UnI hom_graph_t_imp_finite)
  show "hom_graph_t f (S \<union> T) x a"
    using assms(1) fin Un_upper1 by (rule hom_graph_t_finite_superset)
  show "hom_graph_t f (S \<union> T) x a'"
    using assms(2) fin Un_upper2 by (rule hom_graph_t_finite_superset)
qed

lemma hom_graph_t_tvar: "hom_graph_t f {i} (tvar i) (f i)"
proof -
  have "hom_graph_t f {i} (ifte (tvar i) top bot) (ifte (f i) top bot)"
    by (simp add: hom_graph_t.intros)
  thus "hom_graph_t f {i} (tvar i) (f i)"
    unfolding ifte_def by simp
qed

lemma hom_graph_t_compl:
  "hom_graph_t f S x a \<Longrightarrow> hom_graph_t f S (- x) (- a)"
by (induct set: hom_graph_t, simp_all add: hom_graph_t.intros compl_ifte)

lemma hom_graph_t_inf:
  "hom_graph_t f S x a \<Longrightarrow> hom_graph_t f S y b \<Longrightarrow>
   hom_graph_t f S (x \<sqinter> y) (a \<sqinter> b)"
 apply (induct arbitrary: y b set: hom_graph_t)
   apply (simp add: hom_graph_t.bot)
  apply simp
 apply (erule (1) hom_graph_t_insert_elim)
 apply (auto simp add: inf_ifte_distrib hom_graph_t.ifte)
done

lemma hom_graph_t_union_inf:
  assumes "hom_graph_t f S x a" and "hom_graph_t f T y b"
  shows "hom_graph_t f (S \<union> T) (x \<sqinter> y) (a \<sqinter> b)"
proof (rule hom_graph_t_inf)
  have fin: "finite (S \<union> T)"
    using assms by (intro finite_UnI hom_graph_t_imp_finite)
  show "hom_graph_t f (S \<union> T) x a"
    using assms(1) fin Un_upper1 by (rule hom_graph_t_finite_superset)
  show "hom_graph_t f (S \<union> T) y b"
    using assms(2) fin Un_upper2 by (rule hom_graph_t_finite_superset)
qed

lemma hom_graph_t_exists: "\<exists>a S. hom_graph_t f S x a"
by (induct x)
   (auto intro: hom_graph_t_tvar hom_graph_t_compl hom_graph_t_union_inf)

definition
  hom_t :: "('a \<Rightarrow> 'b::boolean_algebra) \<Rightarrow> 'a tformula \<Rightarrow> 'b"
where
  "hom_t f x = (THE a. \<exists>S. hom_graph_t f S x a)"

lemma hom_graph_t_hom_t: "\<exists>S. hom_graph_t f S x (hom_t f x)"
unfolding hom_t_def
apply (rule theI')
apply (rule ex_ex1I)
apply (rule hom_graph_t_exists)
apply (fast elim: hom_graph_t_unique')
done

lemma hom_t_equality:
  "hom_graph_t f S x a \<Longrightarrow> hom_t f x = a"
unfolding hom_t_def
apply (rule the_equality)
apply (erule exI)
apply (erule exE)
apply (erule (1) hom_graph_t_unique')
done

lemma hom_t_var [simp]: "hom_t f (tvar i) = f i"
by (rule hom_t_equality, rule hom_graph_t_tvar)

lemma hom_t_bot [simp]: "hom_t f \<bottom> = \<bottom>"
by (rule hom_t_equality, rule hom_graph_t.bot)

lemma hom_t_top [simp]: "hom_t f \<top> = \<top>"
by (rule hom_t_equality, rule hom_graph_t.top)

lemma hom_t_compl [simp]: "hom_t f (- x) = - hom_t f x"
proof -
  obtain S where "hom_graph_t f S x (hom_t f x)"
    using hom_graph_t_hom_t ..
  hence "hom_graph_t f S (- x) (- hom_t f x)"
    by (rule hom_graph_t_compl)
  thus "hom_t f (- x) = - hom_t f x"
    by (rule hom_t_equality)
qed

lemma hom_t_inf [simp]: "hom_t f (x \<sqinter> y) = hom_t f x \<sqinter> hom_t f y"
proof -
  obtain S where S: "hom_graph_t f S x (hom_t f x)"
    using hom_graph_t_hom_t ..
  obtain T where T: "hom_graph_t f T y (hom_t f y)"
    using hom_graph_t_hom_t ..
  have "hom_graph_t f (S \<union> T) (x \<sqinter> y) (hom_t f x \<sqinter> hom_t f y)"
    using S T by (rule hom_graph_t_union_inf)
  thus ?thesis by (rule hom_t_equality)
qed

lemma hom_t_sup [simp]: "hom_t f (x \<squnion> y) = hom_t f x \<squnion> hom_t f y"
unfolding sup_conv_inf by (simp only: hom_t_compl hom_t_inf)

lemma hom_t_diff [simp]: "hom_t f (x - y) = hom_t f x - hom_t f y"
unfolding diff_eq by (simp only: hom_t_compl hom_t_inf)

lemma hom_t_ifte [simp]:
  "hom_t f (ifte x y z) = ifte (hom_t f x) (hom_t f y) (hom_t f z)"
unfolding ifte_def by (simp only: hom_t_compl hom_t_inf hom_t_sup)

lemmas hom_t_simps =
  hom_t_var hom_t_bot hom_t_top hom_t_compl
  hom_t_inf hom_t_sup hom_t_diff hom_t_ifte

lemma hom_t_tvar_eq_id: "hom_t tvar x = x"
by (induct x) simp_all

lemma hom_t_hom_t: "hom_t f (hom_t g x) = hom_t (\<lambda>i. hom_t f (g i)) x"
by (induct x) simp_all

definition
  fmap_t :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a tformula \<Rightarrow> 'b tformula"
where
  "fmap_t f = hom_t (\<lambda>i. tvar (f i))"

lemma fmap_t_tvar [simp]: "fmap_t f (tvar i) = tvar (f i)"
unfolding fmap_t_def by simp

lemma fmap_t_bot [simp]: "fmap_t f \<bottom> = \<bottom>"
unfolding fmap_t_def by simp

lemma fmap_t_top [simp]: "fmap_t f \<top> = \<top>"
unfolding fmap_t_def by simp

lemma fmap_t_compl [simp]: "fmap_t f (- x) = - fmap_t f x"
unfolding fmap_t_def by simp

lemma fmap_t_inf [simp]: "fmap_t f (x \<sqinter> y) = fmap_t f x \<sqinter> fmap_t f y"
unfolding fmap_t_def by simp

lemma fmap_t_sup [simp]: "fmap_t f (x \<squnion> y) = fmap_t f x \<squnion> fmap_t f y"
unfolding fmap_t_def by simp

lemma fmap_t_diff [simp]: "fmap_t f (x - y) = fmap_t f x - fmap_t f y"
unfolding fmap_t_def by simp

lemma fmap_t_ifte [simp]:
  "fmap_t f (ifte x y z) = ifte (fmap_t f x) (fmap_t f y) (fmap_t f z)"
unfolding fmap_t_def by simp

lemmas fmap_t_simps =
  fmap_t_tvar fmap_t_bot fmap_t_top fmap_t_compl
  fmap_t_inf fmap_t_sup fmap_t_diff fmap_t_ifte

lemma fmap_t_ident: "fmap_t (\<lambda>i. i) x = x"
by (induct x) simp_all

lemma fmap_t_fmap_t: "fmap_t f (fmap_t g x) = fmap_t (f \<circ> g) x"
by (induct x) simp_all

lemma "hom_t s (tvar A) \<or> hom_t s (- tvar A)"
apply (auto)
done

lemma "hom_t s (tprefix (tvar A) (tvar B)) \<or> hom_t s (- tprefix (tvar A) (tvar B))"
apply (auto)
done

fun prefix :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "prefix ls [] = False" |
  "prefix [] rs = True" |
  "prefix (a # ls) (b # rs) = ((a = b) \<and> prefix ls rs)"

definition safe_concat :: "'a list \<Rightarrow> 'a list \<Rightarrow> bool"
where
  "safe_concat ls rs \<equiv> (set ls \<inter> set rs = {})"

definition tprefix_base :: "'a tformula \<Rightarrow> 'a tformula \<Rightarrow> 'a tval"
where
  "tprefix_base L R \<equiv>
    { ls @ rs | ls rs . ls \<in> Rep_tformula L \<and> rs \<in> Rep_tformula R \<and> (safe_concat ls rs) }"

definition tprefix :: "'a tformula \<Rightarrow> 'a tformula \<Rightarrow> 'a tformula"
where
  "tprefix L R \<equiv> Abs_tformula (tprefix_base L R)"

lemmas tprefix_defs = tprefix_def tprefix_base_def safe_concat_def

lemma "tprefix_base L R \<in> ta"
apply (auto simp add: tprefix_defs)

done

lemma list_tvar: "(xs::'a list) \<in> Rep_tformula (tvar (A::'a)) = (distinct xs \<and> A \<in> set xs)"
unfolding tvar_def
apply (metis  Rep_tformula_tvar mem_Collect_eq tvar_def)
done

lemma tprefix_top_top: "tprefix \<top> \<top> = \<top>"
apply (auto simp add: tprefix_defs)
apply (auto simp add: Rep_tformula_top)
done

lemma "tprefix (tvar A) (tvar A) = \<bottom>"
apply (auto simp add: tprefix_defs list_tvar )
apply (smt2 Collect_cong Collect_empty_eq Set.set_insert bot_set_def bot_tformula_def disjoint_insert(1))
(*using bot_formula_def [symmetric]*)
(*apply (intro Abs_tformula_inverse Rep_tformula)*)
done

lemma "(tvar A \<sqinter> tvar B) = \<top> \<Longrightarrow> tprefix (tvar A) (tvar B) = \<top>"
apply (auto simp add: tprefix_top_top)
done

lemma before_and:
  "((tprefix (tvar A) (tvar B)) \<squnion> (tprefix (tvar B) (tvar A))) =
  (tvar A \<sqinter> tvar B)"
apply (auto simp add: tprefix_defs )
apply (auto simp add: tvar_def)

apply (auto simp add: Rep_tformula_simps)

done

lemma and_neg: "hom_t s (tvar A \<sqinter> tvar B) \<squnion> (- tvar A) \<squnion> hom_t s (- tvar B)"
apply (auto)
done

lemma "hom_t s (tprefix (tvar A) (tvar B)) \<or> hom_t s (tprefix (tvar B) (tvar A)) \<or>
  hom_t s (- tvar A) \<or> hom_t s (- tvar B) "
apply (metis and_neg before_and)
done

datatype 'a TemporalFormula =
  TTrue ("True")
  | TFalse ("False")
  | TVar 'a ("[_]")
  | TAnd "'a TemporalFormula" "'a TemporalFormula" (infixr "T\<and>" 40)
  | TOr "'a TemporalFormula" "'a TemporalFormula" (infixr "T\<or>" 50)
  | TNot "'a TemporalFormula" ("T\<not> _" 40)
  | Before "'a TemporalFormula" "'a TemporalFormula" (infixr "T<" 40)

primrec TF2tformula :: "'a TemporalFormula \<Rightarrow> 'a tformula"
where
  "TF2tformula TTrue = \<top>" |
  "TF2tformula TFalse = \<bottom>" |
  "TF2tformula (TVar a) = tvar a" |
  "TF2tformula (TAnd l r) = TF2tformula l \<sqinter> TF2tformula r" |
  "TF2tformula (TOr l r) = TF2tformula l \<squnion> TF2tformula r" |
  "TF2tformula (TNot f) = - TF2tformula f" |
  "TF2tformula (Before l r) =
    tprefix (TF2tformula l) (TF2tformula r)"

lemma "\<lbrakk> a \<noteq> b \<rbrakk> \<Longrightarrow>
  TF2tformula (Before (TVar a) (TVar b)) = Abs_tformula { [a,b] }"
apply (auto simp add: tprefix_def Rep_tformula_simps)
sorry

lemma "TF2tformula (T\<not> ((TVar a) T< (TVar a))) = \<top>"
sorry

end


(* Property from Case-Analysis for Rippling and Inductive Proof,
   Moa Johansson, Lucas Dixon and Alan Bundy, ITP 2010.
   This Isabelle theory is produced using the TIP tool offered at the following website:
     https://github.com/tip-org/tools
   This file was originally provided as part of TIP benchmark at the following website:
     https://github.com/tip-org/benchmarks
   Yutaka Nagashima at CIIRC, CTU changed the TIP output theory file slightly
   to make it compatible with Isabelle2017.*)
  theory TIP_prop_12
  imports "../../Test_Base"
begin

datatype 'a list = nil2 | cons2 "'a" "'a list"

datatype Nat = Z | S "Nat"

fun map :: "('a => 'b) => 'a list => 'b list" where
  "map x (nil2) = nil2"
| "map x (cons2 z xs) = cons2 (x z) (map x xs)"

fun drop :: "Nat => 'a list => 'a list" where
  "drop (Z) y = y"
| "drop (S z) (nil2) = nil2"
| "drop (S z) (cons2 x2 x3) = drop z x3"

theorem property0 :
  "((drop n (map f xs)) = (map f (drop n xs)))"
  oops

end


theory ProgramList

imports Main "../../ContractSem" "../../RelationalSem" "../../ProgramInAvl"

begin

(* declare cut_memory.simps [simp del] *)

(* Instead of map, make a list first *)
fun  program_list_of_lst  :: "inst list \<Rightarrow> inst list"  where
 " program_list_of_lst [] = []"
|" program_list_of_lst (Stack (PUSH_N bytes) # rest) =
    [Stack (PUSH_N bytes)] @
    map(\<lambda>x. Unknown x) bytes @
   program_list_of_lst rest"
|" program_list_of_lst (i # rest) = i # program_list_of_lst rest"

theorem program_list_append :
  "program_list_of_lst (a@b) =
   program_list_of_lst a @ program_list_of_lst b"
apply(induction a rule:program_list_of_lst.induct)
apply(auto)
done

definition map_tree_eq :: "(nat, inst) map \<Rightarrow> (int*inst) avl_tree \<Rightarrow> bool" where
"map_tree_eq m tree = (\<forall>x. x \<ge> 0 \<longrightarrow> m (nat x) = lookup tree x)"

lemma empty_eq : "map_tree_eq empty Leaf"
apply(auto simp:map_tree_eq_def)
done

lemma update_eq :
  "sorted1(inorder tree) \<Longrightarrow> n \<ge> 0 \<Longrightarrow> map_tree_eq m tree \<Longrightarrow>
   map_tree_eq (m(n:=Some t)) (update n t tree)"
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update)
  by (simp add: AVL_Map.map_update nat_eq_iff)

fun store_byte_list_in_map ::
  "nat (* initial position in the AVL *) \<Rightarrow> byte list (* the data *) \<Rightarrow>
   (nat,inst) map (* original AVL *) \<Rightarrow>
   (nat,inst) map (* result *)"
where
  "store_byte_list_in_map _ [] orig = orig"
| "store_byte_list_in_map pos (h # t) orig =
     store_byte_list_in_map (pos + 1) t
       (orig(pos := Some (Unknown h)))"

lemma nat_suc : "n \<ge> 0 \<Longrightarrow> Suc (nat n) = nat (n+1)"
apply(auto)
done

lemma store_bytes_inv :
  "sorted1(inorder tree) \<Longrightarrow>
   sorted1(inorder (store_byte_list_in_program n lst tree))"
apply(induction lst arbitrary:tree n)
apply(auto)
  by (simp add: invar_update)

lemma store_bytes_eq :
  "sorted1(inorder tree) \<Longrightarrow> n \<ge> 0 \<Longrightarrow> map_tree_eq m tree \<Longrightarrow>
   map_tree_eq (store_byte_list_in_map (nat n) lst m)
               (store_byte_list_in_program n lst tree)"
apply(induction lst arbitrary:tree n m)
apply(simp add:map_tree_eq_def)
apply(auto)
apply(subst nat_suc)
apply(auto)
using update_eq
proof -
  fix a :: "8 word" and lsta :: "8 word list" and treea :: "(int \<times> inst, nat) tree" and na :: int and ma :: "nat \<Rightarrow> inst option"
  assume a1: "sorted1 (inorder treea)"
  assume a2: "map_tree_eq ma treea"
  assume a3: "\<And>tree n m. \<lbrakk>sorted1 (inorder tree); 0 \<le> n; map_tree_eq m tree\<rbrakk> \<Longrightarrow> map_tree_eq (store_byte_list_in_map (nat n) lsta m) (store_byte_list_in_program n lsta tree)"
  assume a4: "0 \<le> na"
  have f5: "na + 1 = 1 + na"
    by auto
  have f6: "- 1 \<le> na"
    using a4 by linarith
  have "(0 \<le> 1 + na) = (- 1 \<le> na)"
    by fastforce
  then show "map_tree_eq (store_byte_list_in_map (nat (na + 1)) lsta (ma(nat na \<mapsto> Unknown a))) (store_byte_list_in_program (na + 1) lsta (update na (Unknown a) treea))"
    using f6 f5 a4 a3 a2 a1 by (metis invar_update le_add2 le_add_same_cancel2 nat_0_le update_eq)
qed

fun program_map_of_lst ::
  "nat (* initial position in the AVL *) \<Rightarrow> inst list (* instructions *)
   \<Rightarrow> (nat, inst) map (* result *)"
where
  "program_map_of_lst _ [] = empty"
  -- {* the empty program is translated into the empty tree. *}
| "program_map_of_lst pos (Stack (PUSH_N bytes) # rest) =
   store_byte_list_in_map (pos + 1) bytes
   ((program_map_of_lst (pos + 1 + length bytes) rest)
       (pos := Some (Stack (PUSH_N bytes))))"
  -- {* The PUSH instruction is translated together with the immediate value. *}
| "program_map_of_lst pos (i # rest) =
   (program_map_of_lst (pos + 1) rest)(pos := Some i)"

lemma program_avl_inv :
  "sorted1(inorder (program_avl_of_lst n lst))"
proof (induction lst arbitrary:n)
case Nil thus ?case by simp
next
case (Cons a tl) thus ?case
proof (cases a)
  case (Unknown x1)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Bits x2)
  then show ?thesis
    by (simp add: Cons.IH invar_update)

next
  case (Sarith x3)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Arith x4)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Info x5)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Dup x6)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Memory x7)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Storage x8)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Pc x9)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Stack x10)
  then show ?thesis proof (cases x10)
    case POP
    then show ?thesis
      by (simp add: Cons.IH Stack invar_update)
  next
    case (PUSH_N x2)
    then show ?thesis
      by (simp add: Cons.IH Stack invar_update store_bytes_inv)
  next
    case CALLDATALOAD
    then show ?thesis by (simp add: Cons.IH Stack invar_update)

  qed

next
  case (Swap x11)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Log x12)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
next
  case (Misc x13)
  then show ?thesis
    by (simp add: Cons.IH invar_update)
qed
qed

lemma nat_suc2 : "n \<ge> 0 \<Longrightarrow> Suc (nat n + length x2) = nat (n + 1 + length x2)"
apply(auto)
done

lemma content_eq :
  "n \<ge> 0 \<Longrightarrow>
   map_tree_eq (program_map_of_lst (nat n) lst)
               (program_avl_of_lst n lst)"
proof (induction lst arbitrary:n)
case Nil thus ?case by (simp add:empty_eq)
next
case (Cons a tl) thus ?case
proof (cases a)
  case (Unknown x1)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Bits x2)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Sarith x3)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Arith x4)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Info x5)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Dup x6)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Memory x7)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Storage x8)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Pc x9)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Stack x10)
  then have "map_tree_eq
     (program_map_of_lst (nat n)
       (Stack x10 # tl))
     (program_avl_of_lst n (Stack x10 # tl))"
  proof (cases x10)
    case POP
    then show ?thesis
    apply(auto simp:map_tree_eq_def)
      apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
      by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_other map_tree_eq_def nat_suc program_avl_inv transfer_nat_int_relations(1))
  next
    case (PUSH_N x2)
    then show ?thesis
    (* apply(auto simp:map_tree_eq_def)
    apply(auto)
    apply(subst nat_suc)
    apply (simp add: Cons.prems)
    apply(subst nat_suc2)
    apply (simp add: Cons.prems) *)
    proof -
     have "map_tree_eq (program_map_of_lst
            (nat
              (n + 1 + int (length x2)))
            tl) (program_avl_of_lst
           (n + 1 + int (length x2))
           tl)" (is "map_tree_eq ?a1 ?b1")
       by (simp add: Cons.IH Cons.prems)
     then have "map_tree_eq (?a1(nat n \<mapsto> Stack (PUSH_N x2)))
                       (update n (Stack (PUSH_N x2)) ?b1)"
          (is "map_tree_eq ?a2 ?b2")
       by (metis Cons.prems le_add2 le_add_same_cancel2 nat_0_le program_avl_inv update_eq)
     then have "map_tree_eq
       (store_byte_list_in_map (nat (n + 1)) x2 ?a2)
       (store_byte_list_in_program (n + 1) x2 ?b2)"
       by (simp add: Cons.prems invar_update program_avl_inv store_bytes_eq)
     then show ?thesis
       by (smt Cons.prems PUSH_N Suc_eq_plus1 nat_0_le nat_int_add nat_suc program_avl_of_lst.simps(2) program_map_of_lst.simps(2))
     qed
  next
    case CALLDATALOAD
    then show ?thesis
    apply(auto simp:map_tree_eq_def)
      apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_other map_tree_eq_def nat_suc program_avl_inv transfer_nat_int_relations(1))
  qed
  then show ?thesis
    using Stack by auto
next
  case (Swap x11)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Log x12)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
next
  case (Misc x13)
  then show ?thesis
apply(auto simp:map_tree_eq_def)
  apply (simp add: AVL_Map.map_update Cons.prems program_avl_inv transfer_nat_int_relations(1))
  by (smt AVL_Map.map_update Cons.IH Cons.prems fun_upd_apply int_eq_iff int_nat_eq map_tree_eq_def nat_eq_iff nat_suc program_avl_inv semiring_1_class.of_nat_simps(2))
qed
qed

theorem content_small_aux_bytes [simp] :
  "k < pos \<Longrightarrow>
   m k = None \<Longrightarrow>
   (store_byte_list_in_map (pos+1) lst m) k = None"
apply(induction lst arbitrary:pos k m)
apply(auto)
done

theorem content_small_aux_stack [simp] :
 "(\<And>pos k.
           k < pos \<Longrightarrow>
           program_map_of_lst pos lst k = None) \<Longrightarrow>
       k < pos \<Longrightarrow>
       a = Stack x10 \<Longrightarrow>
       program_map_of_lst pos (Stack x10 # lst) k =
       None"
apply(cases x10)
apply(auto)
  using Suc_eq_plus1 content_small_aux_bytes by auto

theorem content_small_aux [simp] :
"(\<And>pos k.
           k < pos \<Longrightarrow>
           program_map_of_lst pos lst k = None) \<Longrightarrow>
       k < pos \<Longrightarrow>
       program_map_of_lst pos (a # lst) k = None"
apply(cases a)
apply(auto)
done

theorem content_small [simp] :
   "k < pos \<Longrightarrow> program_map_of_lst pos lst k = None"
apply(induction lst arbitrary:pos k)
apply(auto)
done

theorem update_add :
   "m k = None \<Longrightarrow>
    Set.insert x (ran m) = ran (map_update k x m)"
apply(auto)
done

theorem ran_blargh :
  "m1 = m2 \<Longrightarrow> ran m1 = ran m2"
apply(auto)
done

theorem update_add2 :
   "m k = None \<Longrightarrow>
    Set.insert x (ran m) =
    ran (\<lambda>a. if a = k then Some x else m a)"
apply(subst update_add)
apply(blast)
apply(rule ran_blargh)
apply(auto)
done

fun make_unknown :: "nat \<Rightarrow> byte list \<Rightarrow> (nat,inst) map" where
 "make_unknown pos [] = empty"
|"make_unknown pos (a#t) =
    map_update pos (Unknown a) (make_unknown (pos+1) t)"

theorem make_small [simp] :
  "k < pos \<Longrightarrow> make_unknown pos bytes k = None"
apply(induction bytes arbitrary:pos k)
apply(auto)
done

theorem unfold_update :
   "(m(pos \<mapsto> a)) x = (if x = pos then Some a else m x)"
apply(auto)
done

theorem make_unknown_lemma :
  "m2 pos = None \<Longrightarrow>
   m1(pos \<mapsto> a) ++ m2 = (m1 ++ m2)(pos \<mapsto> a)"
apply(subst map_add_def)
apply(subst map_add_def)
apply(subst unfold_update)
apply(auto)
done

theorem combine_some : "m2 n = Some x \<Longrightarrow> Some x = (m1 ++ m2) n"
apply(auto)
done

theorem combine_none :
   "m2 x = None \<Longrightarrow> m3 x = m1 x \<Longrightarrow> m3 x = (m1 ++ m2) x"
apply(auto)
by (simp add: map_add_def)

theorem program_list_bytes [simp] :
  "store_byte_list_in_map pos bytes m =
   m ++ make_unknown pos bytes"
apply(induction bytes arbitrary: pos m)
apply(auto simp:make_unknown_lemma)
done

theorem unknown_union :
  "(\<forall>k. k < pos + length bytes \<longrightarrow>  m k = None) \<Longrightarrow>
    ran (m ++ make_unknown pos bytes) =
    ran m \<union> Unknown ` set bytes"
apply(induction bytes arbitrary: pos m)
apply(auto)
done

theorem more_lemmas :
"Set.insert x
        (Unknown ` set bytes \<union>
         ran
          (program_map_of_lst
            (Suc (pos + length bytes)) rest)) =
       ran
        (program_map_of_lst
          (Suc (pos + length bytes)) rest
         (pos \<mapsto> x) ++
         make_unknown (Suc pos) bytes)"
apply(subst make_unknown_lemma)
apply(auto simp:unknown_union)
done

theorem index_one [simp] :
  "0 < n \<Longrightarrow> index (x # lst) n = index lst (n-1)"
apply(cases n)
apply(auto)
done

theorem lemma_2 [simp] :
  "0 < n \<Longrightarrow>
   (\<And>t n. index (program_list_of_lst lst) n =
   program_map_of_lst t lst (n + t)) \<Longrightarrow>
   index (program_list_of_lst lst) (n-1) =
   program_map_of_lst (Suc t) lst (n + t)"
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
done

theorem index_append_small [simp] :
  "n < length a \<Longrightarrow> index (a @ b) n = index a n"
apply(auto)
by (simp add: nth_append)

theorem index_append_large1 [simp] :
  "index (a @ b) (n+length a) = index b n"
apply(induction a arbitrary:n b)
apply(auto)
done

theorem index_append_large [simp] :
  "n \<ge> length a \<Longrightarrow> index (a @ b) n = index b (n-length a)"
by (metis index_append_large1 ordered_cancel_comm_monoid_diff_class.diff_add)

fun get_stack :: "inst \<Rightarrow> stack_inst" where
"get_stack (Stack s) = s"

fun get_push_bytes :: "inst \<Rightarrow> byte list" where
"get_push_bytes (Stack (PUSH_N s)) = s"

theorem get_unknown [simp] :
  "n < length lst \<Longrightarrow>
   make_unknown t lst (n+t) = Some (Unknown (lst!n))"
apply(induction lst arbitrary:n t)
apply(simp)
apply(auto)
proof -
  fix lsta :: "8 word list" and na :: nat and ta :: nat
  assume a1: "na < Suc (length lsta)"
  assume a2: "0 < na"
  assume a3: "\<And>n t. n < length lsta \<Longrightarrow> make_unknown t lsta (n + t) = Some (Unknown (lsta ! n))"
  obtain nn :: "nat \<Rightarrow> nat \<Rightarrow> nat" where
    "\<forall>x0 x1. (\<exists>v2. x1 = Suc v2 \<and> v2 < x0) = (x1 = Suc (nn x0 x1) \<and> nn x0 x1 < x0)"
    by moura
  then have f4: "na = Suc (nn (length lsta) na) \<and> nn (length lsta) na < length lsta"
    using a2 a1 less_Suc_eq_0_disj by auto
  then have f5: "na + ta = nn (length lsta) na + Suc ta"
    by (metis add_Suc_shift)
  have "nn (length lsta) na = na - Suc 0"
    using f4 diff_Suc_1 by presburger
  then show "make_unknown (Suc ta) lsta (na + ta) = Some (Unknown (lsta ! (na - Suc 0)))"
    using f5 f4 a3 by presburger
qed

theorem get_unknown2 [simp] :
  "n \<ge> length lst \<Longrightarrow>
   make_unknown t lst (n+t) = None"
apply(induction lst arbitrary:n t)
apply(simp)
apply(auto)
by (metis (mono_tags, lifting) Suc_leD Suc_le_D add_Suc_shift le_SucE)

theorem lemma_3 :
    "(\<And>t n.
           index (program_list_of_lst lst) n =
           program_map_of_lst t lst (n + t)) \<Longrightarrow>
       n \<ge> x2 + 1 \<Longrightarrow>
       index (program_list_of_lst lst) (n - Suc x2) =
       program_map_of_lst (t + Suc x2) lst (n+t)"
apply(auto)
by (smt ab_semigroup_add_class.add_ac(1) add.commute add_Suc_right le_add_diff_inverse2)

theorem lemma_1 :
   "(\<And>t n.
           index (program_list_of_lst lst) n =
           program_map_of_lst t lst (n + t)) \<Longrightarrow>
       index (program_list_of_lst (a # lst)) n =
       program_map_of_lst t (a # lst) (n + t)"
apply(cases a)
apply(auto)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
defer
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply(cases "get_stack a")
apply(auto)
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
defer
apply (metis One_nat_def add_Suc_shift diff_Suc_1 less_imp_Suc_add)
apply(cases "n = 0")
apply(simp add:nth_append make_unknown_lemma)
apply(simp add:nth_append make_unknown_lemma)
apply(cases "n-1 < length (get_push_bytes a)")
apply(simp add:nth_append make_unknown_lemma)
apply(rule combine_some)
apply (metis Suc_pred add_Suc_shift get_unknown)
apply(simp add:nth_append make_unknown_lemma) (* n-1 \<ge> length x2 *)
apply(rule combine_none)
apply (metis Suc_pred add_Suc_shift get_unknown2 linorder_not_less)
using lemma_3
apply (fastforce)
done

theorem program_list_map_eq :
  "index (program_list_of_lst lst) n =
    program_map_of_lst t lst (n+t)"
apply(induction lst arbitrary:t n)
apply(auto simp:lemma_1)
done

theorem program_list_content :
  "set (program_list_of_lst lst) = ran (program_map_of_lst 0 lst)"
apply(induction lst rule:program_map_of_lst.induct)
apply(simp)
defer
apply(simp)
(* apply(simp) *)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(simp)
apply(simp)
apply(rule update_add2)
apply(auto simp:more_lemmas)
done

theorem program_list_content_eq :
  "index (program_list_of_lst lst) n =
   program_content_of_lst lst n"
proof -
  have a: "index (program_list_of_lst lst) n =
         program_map_of_lst 0 lst n"
    by (metis add.right_neutral program_list_map_eq)
  have b: "program_map_of_lst 0 lst n =
           program_content_of_lst lst n"
    by (smt content_eq map_tree_eq_def nat_0 nat_int of_nat_0_le_iff)
  from a and b show ?thesis by auto
qed

end


(*  Title:      HOL/UNITY/Simple/Lift.thy
    Author:     Lawrence C Paulson, Cambridge University Computer Laboratory
    Copyright   1998  University of Cambridge

The Lift-Control Example.
*)

theory Lift
imports "../UNITY_Main"
begin

record state =
  floor :: "int"            --{*current position of the lift*}
  "open" :: "bool"          --{*whether the door is opened at floor*}
  stop  :: "bool"           --{*whether the lift is stopped at floor*}
  req   :: "int set"        --{*for each floor, whether the lift is requested*}
  up    :: "bool"           --{*current direction of movement*}
  move  :: "bool"           --{*whether moving takes precedence over opening*}

axiomatization
  Min :: "int" and   --{*least and greatest floors*}
  Max :: "int"       --{*least and greatest floors*}
where
  Min_le_Max [iff]: "Min \<le> Max"

  --{*Abbreviations: the "always" part*}

definition
  above :: "state set"
  where "above = {s. \<exists>i. floor s < i & i \<le> Max & i \<in> req s}"

definition
  below :: "state set"
  where "below = {s. \<exists>i. Min \<le> i & i < floor s & i \<in> req s}"

definition
  queueing :: "state set"
  where "queueing = above \<union> below"

definition
  goingup :: "state set"
  where "goingup = above \<inter> ({s. up s}  \<union> -below)"

definition
  goingdown :: "state set"
  where "goingdown = below \<inter> ({s. ~ up s} \<union> -above)"

definition
  ready :: "state set"
  where "ready = {s. stop s & ~ open s & move s}"

  --{*Further abbreviations*}

definition
  moving :: "state set"
  where "moving = {s. ~ stop s & ~ open s}"

definition
  stopped :: "state set"
  where "stopped = {s. stop s  & ~ open s & ~ move s}"

definition
  opened :: "state set"
  where "opened = {s. stop s  &  open s  &  move s}"

definition
  closed :: "state set"  --{*but this is the same as ready!!*}
  where "closed = {s. stop s  & ~ open s &  move s}"

definition
  atFloor :: "int => state set"
  where "atFloor n = {s. floor s = n}"

definition
  Req :: "int => state set"
  where "Req n = {s. n \<in> req s}"

  --{*The program*}

definition
  request_act :: "(state*state) set"
  where "request_act = {(s,s'). s' = s (|stop:=True, move:=False|)
                                  & ~ stop s & floor s \<in> req s}"

definition
  open_act :: "(state*state) set"
  where "open_act =
         {(s,s'). s' = s (|open :=True,
                           req  := req s - {floor s},
                           move := True|)
                       & stop s & ~ open s & floor s \<in> req s
                       & ~(move s & s \<in> queueing)}"

definition
  close_act :: "(state*state) set"
  where "close_act = {(s,s'). s' = s (|open := False|) & open s}"

definition
  req_up :: "(state*state) set"
  where "req_up =
         {(s,s'). s' = s (|stop  :=False,
                           floor := floor s + 1,
                           up    := True|)
                       & s \<in> (ready \<inter> goingup)}"

definition
  req_down :: "(state*state) set"
  where "req_down =
         {(s,s'). s' = s (|stop  :=False,
                           floor := floor s - 1,
                           up    := False|)
                       & s \<in> (ready \<inter> goingdown)}"

definition
  move_up :: "(state*state) set"
  where "move_up =
         {(s,s'). s' = s (|floor := floor s + 1|)
                       & ~ stop s & up s & floor s \<notin> req s}"

definition
  move_down :: "(state*state) set"
  where "move_down =
         {(s,s'). s' = s (|floor := floor s - 1|)
                       & ~ stop s & ~ up s & floor s \<notin> req s}"

definition
  button_press  :: "(state*state) set"
      --{*This action is omitted from prior treatments, which therefore are
        unrealistic: nobody asks the lift to do anything!  But adding this
        action invalidates many of the existing progress arguments: various
        "ensures" properties fail. Maybe it should be constrained to only
        allow button presses in the current direction of travel, like in a
        real lift.*}
  where "button_press =
         {(s,s'). \<exists>n. s' = s (|req := insert n (req s)|)
                        & Min \<le> n & n \<le> Max}"

definition
  Lift :: "state program"
    --{*for the moment, we OMIT @{text button_press}*}
  where "Lift = mk_total_program
                ({s. floor s = Min & ~ up s & move s & stop s &
                          ~ open s & req s = {}},
                 {request_act, open_act, close_act,
                  req_up, req_down, move_up, move_down},
                 UNIV)"

  --{*Invariants*}

definition
  bounded :: "state set"
  where "bounded = {s. Min \<le> floor s & floor s \<le> Max}"

definition
  open_stop :: "state set"
  where "open_stop = {s. open s --> stop s}"

definition
  open_move :: "state set"
  where "open_move = {s. open s --> move s}"

definition
  stop_floor :: "state set"
  where "stop_floor = {s. stop s & ~ move s --> floor s \<in> req s}"

definition
  moving_up :: "state set"
  where "moving_up = {s. ~ stop s & up s -->
                   (\<exists>f. floor s \<le> f & f \<le> Max & f \<in> req s)}"

definition
  moving_down :: "state set"
  where "moving_down = {s. ~ stop s & ~ up s -->
                     (\<exists>f. Min \<le> f & f \<le> floor s & f \<in> req s)}"

definition
  metric :: "[int,state] => int"
  where "metric =
       (%n s. if floor s < n then (if up s then n - floor s
                                  else (floor s - Min) + (n-Min))
             else
             if n < floor s then (if up s then (Max - floor s) + (Max-n)
                                  else floor s - n)
             else 0)"

locale Floor =
  fixes n
  assumes Min_le_n [iff]: "Min \<le> n"
      and n_le_Max [iff]: "n \<le> Max"

lemma not_mem_distinct: "[| x \<notin> A;  y \<in> A |] ==> x \<noteq> y"
by blast

declare Lift_def [THEN def_prg_Init, simp]

declare request_act_def [THEN def_act_simp, simp]
declare open_act_def [THEN def_act_simp, simp]
declare close_act_def [THEN def_act_simp, simp]
declare req_up_def [THEN def_act_simp, simp]
declare req_down_def [THEN def_act_simp, simp]
declare move_up_def [THEN def_act_simp, simp]
declare move_down_def [THEN def_act_simp, simp]
declare button_press_def [THEN def_act_simp, simp]

(*The ALWAYS properties*)
declare above_def [THEN def_set_simp, simp]
declare below_def [THEN def_set_simp, simp]
declare queueing_def [THEN def_set_simp, simp]
declare goingup_def [THEN def_set_simp, simp]
declare goingdown_def [THEN def_set_simp, simp]
declare ready_def [THEN def_set_simp, simp]

(*Basic definitions*)
declare bounded_def [simp]
        open_stop_def [simp]
        open_move_def [simp]
        stop_floor_def [simp]
        moving_up_def [simp]
        moving_down_def [simp]

lemma open_stop: "Lift \<in> Always open_stop"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

lemma stop_floor: "Lift \<in> Always stop_floor"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

(*This one needs open_stop, which was proved above*)
lemma open_move: "Lift \<in> Always open_move"
apply (cut_tac open_stop)
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
done

lemma moving_up: "Lift \<in> Always moving_up"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
apply (auto dest: order_le_imp_less_or_eq simp add: add1_zle_eq)
done

lemma moving_down: "Lift \<in> Always moving_down"
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety)
apply (blast dest: order_le_imp_less_or_eq)
done

lemma bounded: "Lift \<in> Always bounded"
apply (cut_tac moving_up moving_down)
apply (rule AlwaysI, force)
apply (unfold Lift_def, safety, auto)
apply (drule not_mem_distinct, assumption, arith)+
done

subsection{*Progress*}

declare moving_def [THEN def_set_simp, simp]
declare stopped_def [THEN def_set_simp, simp]
declare opened_def [THEN def_set_simp, simp]
declare closed_def [THEN def_set_simp, simp]
declare atFloor_def [THEN def_set_simp, simp]
declare Req_def [THEN def_set_simp, simp]

text{*The HUG'93 paper mistakenly omits the Req n from these!*}

(** Lift_1 **)
lemma E_thm01: "Lift \<in> (stopped \<inter> atFloor n) LeadsTo (opened \<inter> atFloor n)"
apply (cut_tac stop_floor)
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_5*)

lemma E_thm02: "Lift \<in> (Req n \<inter> stopped - atFloor n) LeadsTo
                       (Req n \<inter> opened - atFloor n)"
apply (cut_tac stop_floor)
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_1*)

lemma E_thm03: "Lift \<in> (Req n \<inter> opened - atFloor n) LeadsTo
                       (Req n \<inter> closed - (atFloor n - queueing))"
apply (unfold Lift_def, ensures_tac "close_act")
done  (*lem_lift_1_2*)

lemma E_thm04: "Lift \<in> (Req n \<inter> closed \<inter> (atFloor n - queueing))
                       LeadsTo (opened \<inter> atFloor n)"
apply (unfold Lift_def, ensures_tac "open_act")
done  (*lem_lift_1_7*)

(** Lift 2.  Statements of thm05a and thm05b were wrong! **)

lemmas linorder_leI = linorder_not_less [THEN iffD1]

context Floor
begin

lemmas le_MinD = Min_le_n [THEN order_antisym]
  and Max_leD = n_le_Max [THEN [2] order_antisym]

declare le_MinD [dest!]
  and linorder_leI [THEN le_MinD, dest!]
  and Max_leD [dest!]
  and linorder_leI [THEN Max_leD, dest!]

(*lem_lift_2_0
  NOT an ensures_tac property, but a mere inclusion
  don't know why script lift_2.uni says ENSURES*)
lemma E_thm05c:
    "Lift \<in> (Req n \<inter> closed - (atFloor n - queueing))
             LeadsTo ((closed \<inter> goingup \<inter> Req n)  \<union>
                      (closed \<inter> goingdown \<inter> Req n))"
by (auto intro!: subset_imp_LeadsTo simp add: linorder_neq_iff)

(*lift_2*)
lemma lift_2: "Lift \<in> (Req n \<inter> closed - (atFloor n - queueing))
             LeadsTo (moving \<inter> Req n)"
apply (rule LeadsTo_Trans [OF E_thm05c LeadsTo_Un])
apply (unfold Lift_def)
apply (ensures_tac [2] "req_down")
apply (ensures_tac "req_up", auto)
done

(** Towards lift_4 ***)

declare split_if_asm [split]

(*lem_lift_4_1 *)
lemma E_thm12a:
     "0 < N ==>
      Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
              {s. floor s \<notin> req s} \<inter> {s. up s})
             LeadsTo
               (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac moving_up)
apply (unfold Lift_def, ensures_tac "move_up", safe)
(*this step consolidates two formulae to the goal  metric n s' \<le> metric n s*)
apply (erule linorder_leI [THEN order_antisym, symmetric])
apply (auto simp add: metric_def)
done

(*lem_lift_4_3 *)
lemma E_thm12b: "0 < N ==>
      Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
              {s. floor s \<notin> req s} - {s. up s})
             LeadsTo (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac moving_down)
apply (unfold Lift_def, ensures_tac "move_down", safe)
(*this step consolidates two formulae to the goal  metric n s' \<le> metric n s*)
apply (erule linorder_leI [THEN order_antisym, symmetric])
apply (auto simp add: metric_def)
done

(*lift_4*)
lemma lift_4:
     "0<N ==> Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter>
                            {s. floor s \<notin> req s}) LeadsTo
                           (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF E_thm12a E_thm12b]], auto)
done

(** towards lift_5 **)

(*lem_lift_5_3*)
lemma E_thm16a: "0<N
  ==> Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N} \<inter> goingup) LeadsTo
             (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "req_up")
apply (auto simp add: metric_def)
done

(*lem_lift_5_1 has ~goingup instead of goingdown*)
lemma E_thm16b: "0<N ==>
      Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N} \<inter> goingdown) LeadsTo
                   (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "req_down")
apply (auto simp add: metric_def)
done

(*lem_lift_5_0 proves an intersection involving ~goingup and goingup,
  i.e. the trivial disjunction, leading to an asymmetrical proof.*)
lemma E_thm16c:
     "0<N ==> Req n \<inter> {s. metric n s = N} \<subseteq> goingup \<union> goingdown"
by (force simp add: metric_def)

(*lift_5*)
lemma lift_5:
     "0<N ==> Lift \<in> (closed \<inter> Req n \<inter> {s. metric n s = N}) LeadsTo
                     (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF E_thm16a E_thm16b]])
apply (drule E_thm16c, auto)
done

(** towards lift_3 **)

(*lemma used to prove lem_lift_3_1*)
lemma metric_eq_0D [dest]:
     "[| metric n s = 0;  Min \<le> floor s;  floor s \<le> Max |] ==> floor s = n"
by (force simp add: metric_def)

(*lem_lift_3_1*)
lemma E_thm11: "Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = 0}) LeadsTo
                       (stopped \<inter> atFloor n)"
apply (cut_tac bounded)
apply (unfold Lift_def, ensures_tac "request_act", auto)
done

(*lem_lift_3_5*)
lemma E_thm13:
  "Lift \<in> (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
  LeadsTo (stopped \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})"
apply (unfold Lift_def, ensures_tac "request_act")
apply (auto simp add: metric_def)
done

(*lem_lift_3_6*)
lemma E_thm14: "0 < N ==>
      Lift \<in>
        (stopped \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
        LeadsTo (opened \<inter> Req n \<inter> {s. metric n s = N})"
apply (unfold Lift_def, ensures_tac "open_act")
apply (auto simp add: metric_def)
done

(*lem_lift_3_7*)
lemma E_thm15: "Lift \<in> (opened \<inter> Req n \<inter> {s. metric n s = N})
             LeadsTo (closed \<inter> Req n \<inter> {s. metric n s = N})"
apply (unfold Lift_def, ensures_tac "close_act")
apply (auto simp add: metric_def)
done

(** the final steps **)

lemma lift_3_Req: "0 < N ==>
      Lift \<in>
        (moving \<inter> Req n \<inter> {s. metric n s = N} \<inter> {s. floor s \<in> req s})
        LeadsTo (moving \<inter> Req n \<inter> {s. metric n s < N})"
apply (blast intro!: E_thm13 E_thm14 E_thm15 lift_5 intro: LeadsTo_Trans)
done

(*Now we observe that our integer metric is really a natural number*)
lemma Always_nonneg: "Lift \<in> Always {s. 0 \<le> metric n s}"
apply (rule bounded [THEN Always_weaken])
apply (auto simp add: metric_def)
done

lemmas R_thm11 = Always_LeadsTo_weaken [OF Always_nonneg E_thm11]

lemma lift_3: "Lift \<in> (moving \<inter> Req n) LeadsTo (stopped \<inter> atFloor n)"
apply (rule Always_nonneg [THEN integ_0_le_induct])
apply (case_tac "0 < z")
(*If z \<le> 0 then actually z = 0*)
prefer 2 apply (force intro: R_thm11 order_antisym simp add: linorder_not_less)
apply (rule LeadsTo_weaken_R [OF asm_rl Un_upper1])
apply (rule LeadsTo_Trans [OF subset_imp_LeadsTo
                              LeadsTo_Un [OF lift_4 lift_3_Req]], auto)
done

lemma lift_1: "Lift \<in> (Req n) LeadsTo (opened \<inter> atFloor n)"
apply (rule LeadsTo_Trans)
 prefer 2
 apply (rule LeadsTo_Un [OF E_thm04 LeadsTo_Un_post])
 apply (rule E_thm01 [THEN [2] LeadsTo_Trans_Un])
 apply (rule lift_3 [THEN [2] LeadsTo_Trans_Un])
 apply (rule lift_2 [THEN [2] LeadsTo_Trans_Un])
 apply (rule LeadsTo_Trans_Un [OF E_thm02 E_thm03])
apply (rule open_move [THEN Always_LeadsToI])
apply (rule Always_LeadsToI [OF open_stop subset_imp_LeadsTo], clarify)
(*The case split is not essential but makes the proof much faster.*)
apply (case_tac "open x", auto)
done

end

end