section "Completeness"

theory Completeness
imports Tree Sequents
begin

subsection "pseq: type represents a processed sequent"

type_synonym "atom"  = "(signs * predicate * vbl list)"
type_synonym nform = "(nat * formula)"
type_synonym pseq  = "(atom list * nform list)"

definition
  sequent :: "pseq => formula list" where
  "sequent = (%(atoms,nforms) . map snd nforms @ map (% (z,p,vs) . FAtom z p vs) atoms)"

definition
  pseq :: "formula list => pseq" where
  "pseq fs = ([],map (%f.(0,f)) fs)"

definition atoms :: "pseq => atom list" where "atoms = fst"
definition nforms :: "pseq => nform list" where "nforms = snd"

subsection "subs: SATAxiom"

definition
  SATAxiom :: "formula list => bool" where
  "SATAxiom fs \<longleftrightarrow> (? n vs . FAtom Pos n vs : set fs & FAtom Neg n vs : set fs)"

subsection "subs: a CutFreePC justifiable backwards proof step"

definition
  subsFAtom :: "[atom list,(nat * formula) list,signs,predicate,vbl list] => pseq set" where
  "subsFAtom atms nAs z P vs = { ((z,P,vs)#atms,nAs) }"

definition
  subsFConj :: "[atom list,(nat * formula) list,signs,formula,formula] => pseq set" where
  "subsFConj atms nAs z A0 A1 =
    (case z of
      Pos => { (atms,(0,A0)#nAs),(atms,(0,A1)#nAs) }
    | Neg => { (atms,(0,A0)#(0,A1)#nAs) })"

definition
  subsFAll :: "[atom list,(nat * formula) list,nat,signs,formula,vbl set] => pseq set" where
  "subsFAll atms nAs n z A frees =
    (case z of
      Pos => { let v = freshVar frees in  (atms,(0,instanceF v A)#nAs) }
    | Neg => { (atms,(0,instanceF (X n) A)#nAs @ [(Suc n,FAll Neg A)]) })"

definition
  subs :: "pseq => pseq set" where
  "subs = (% pseq .
             if SATAxiom (sequent pseq) then
                 {}
             else let (atms,nforms) = pseq
                  in  case nforms of
                         []     => {}
                       | nA#nAs => let (n,A) = nA
                                   in  (case A of
                                            FAtom z P vs  => subsFAtom atms nAs z P vs
                                          | FConj z A0 A1 => subsFConj atms nAs z A0 A1
                                          | FAll  z A     => subsFAll  atms nAs n z A (freeVarsFL (sequent pseq))))"

subsection "proofTree(Gamma) says whether tree(Gamma) is a proof"

definition
  proofTree :: "(nat * pseq) set => bool" where
  "proofTree A \<longleftrightarrow> bounded A & founded subs (SATAxiom o sequent) A"

subsection "path: considers, contains, costBarrier"

definition
  considers :: "[nat => pseq,nat * formula,nat] => bool" where
  "considers f nA n = (case (snd (f n)) of [] => False | x#xs => x=nA)"

definition
  "contains" :: "[nat => pseq,nat * formula,nat] => bool" where
  "contains f nA n \<longleftrightarrow> nA : set (snd (f n))"

definition
  costBarrier :: "[nat * formula,pseq] => nat" where
    (******
     costBarrier justifies: eventually contains ==> eventually considers
     with a termination thm, (barrier strictly decreases in |N).
     ******)
  "costBarrier nA = (%(atms,nAs).
    let barrier = takeWhile (%x. nA ~= x) nAs
    in  let costs = map (exp 3 o size o snd) barrier
    in  sumList costs)"

subsection "path: eventually"

(******
 Could do this with composable temporal operators, but following paper proof first.
 ******)

definition
  EV :: "[nat => bool] => bool" where
  "EV f == (? n . f n)"
        (******
         This allows blast_tac like searching to be done without hassle
         of removing exists rules. (hopefully).
         ******)

subsection "path: counter model"

definition
  counterM :: "(nat => pseq) => object set" where
  "counterM f = range obj"

definition
  counterEvalP :: "(nat => pseq) => predicate => object list => bool" where
  "counterEvalP f = (%p args . ! i . ~(EV (contains f (i,FAtom Pos p (map (X o inv obj) args)))))"

definition
  counterModel :: "(nat => pseq) => model" where
  "counterModel f = Abs_model (counterM f, counterEvalP f)"

primrec counterAssign :: "vbl => object"
where "counterAssign (X n) = obj n"  (* just deX *)

subsection "subs: finite"

lemma finite_subs: "finite (subs gamma)"
  apply(simp add: subs_def subsFAtom_def subsFConj_def subsFAll_def Let_def split_beta split: if_splits list.split formula.split signs.split)
  done

lemma fansSubs: "fans subs"
  apply(rule fansI) apply(rule, rule finite_subs) done

lemma subs_def2:
"!!gamma.
   ~ SATAxiom (sequent gamma) ==>
   subs gamma = (case nforms gamma of
                     []     => {}
                   | nA#nAs => let (n,A) = nA
                               in  (case A of
                                        FAtom z P vs  => subsFAtom (atoms gamma) nAs z P vs
                                      | FConj z A0 A1 => subsFConj (atoms gamma) nAs z A0 A1
                                      | FAll  z A     => subsFAll  (atoms gamma) nAs n z A (freeVarsFL (sequent gamma))))"
  apply(simp add: subs_def Let_def nforms_def atoms_def split_beta split: list.split)
  done

subsection "inherited: proofTree"

lemma proofTree_def2: "proofTree = ( % x . bounded x & founded subs (SATAxiom o sequent) x)"
  apply(rule ext)
  apply(simp add: proofTree_def) done

lemma inheritedProofTree: "inherited subs proofTree"
  apply(simp add: proofTree_def2)
  apply(auto intro: inheritedJoinI inheritedBounded inheritedFounded)
  done

lemma proofTreeI: "[| bounded A; founded subs (SATAxiom o sequent) A |] ==> proofTree A"
  apply(simp add: proofTree_def) done

lemma proofTreeBounded: "proofTree A ==> bounded A"
  apply(simp add: proofTree_def) done

lemma proofTreeTerminal: "proofTree A ==> (n,delta) : A ==> terminal subs delta ==> SATAxiom (sequent delta)"
  apply(simp add: proofTree_def founded_def) apply blast done

subsection "pseq: lemma"

lemma snd_o_Pair: "(snd o (Pair x)) = (% x. x)"
  apply(rule ext)
  by simp

lemma sequent_pseq: "sequent (pseq fs) = fs"
  by (simp add: pseq_def sequent_def snd_o_Pair)

subsection "SATAxiom: proofTree"

lemma SATAxiomTerminal[rule_format]: "SATAxiom (sequent gamma) --> terminal subs gamma"
  apply(simp add: subs_def proofTree_def terminal_def founded_def bounded_def)
  done

lemma SATAxiomBounded:"SATAxiom (sequent gamma) ==> bounded (tree subs gamma)"
  apply(frule SATAxiomTerminal)
  apply(subst treeEquation)
  apply(simp add: subs_def proofTree_def terminal_def founded_def bounded_def)
  apply(force simp add: boundedByInsert boundedByEmpty)
  done

lemma SATAxiomFounded: "SATAxiom (sequent gamma) ==> founded subs (SATAxiom o sequent) (tree subs gamma)"
  apply(frule SATAxiomTerminal)
  apply(subst treeEquation)
  apply(simp add: subs_def proofTree_def terminal_def founded_def bounded_def)
  done

lemma SATAxiomEq: "(proofTree (tree subs gamma) & terminal subs gamma) = SATAxiom (sequent gamma)"
  apply(blast intro: SATAxiomProofTree proofTreeTerminal tree.tree0  SATAxiomTerminal)
  done
    \<comment> \<open>FIXME tjr blast sensitive to obj imp vs meta imp for pTT\<close>

subsection "SATAxioms are deductions: - needed"

lemma SAT_deduction: "SATAxiom x ==> x : deductions CutFreePC"
  apply(simp add: SATAxiom_def)
  apply(elim exE)
  apply(rule_tac x="[FAtom Pos n vs,FAtom Neg n vs]" in inDed_mono)
   apply (blast intro!: SATAxiomI rulesInPCs, force)
  done

subsection "proofTrees are deductions: subs respects rules - messy start and end"

lemma subsJustified':
  notes ss = subs_def2 nforms_def Let_def atoms_def sequent_def subsFAtom_def subsFConj_def subsFAll_def
  shows "\<not> SATAxiom (sequent (ats, (n, f) # list)) --> \<not> terminal subs (ats, (n, f) # list)
  --> (\<forall>sigma\<in>subs (ats, (n, f) # list). sequent sigma \<in> deductions CutFreePC)
  --> sequent (ats, (n, f) # list) \<in> deductions CutFreePC"
  apply (rule_tac A=f in formula_signs_cases, clarify) apply(simp add: ss)
       apply(rule PermI) apply assumption apply(rule perm_append_Cons) apply (rule rulesInPCs, clarify) apply(simp add: ss)
      apply(rule PermI) apply assumption apply(rule perm_append_Cons) apply (rule rulesInPCs, clarify) apply(simp add: ss) apply(elim conjE)
     apply(rule ConjI') apply assumption apply assumption apply(rule rulesInPCs)+
    apply clarify apply(simp add: ss)
    apply(rule DisjI) apply assumption apply(rule rulesInPCs)+
   apply clarify apply(simp add: ss)
   apply(rule AllI) apply assumption apply(rule finiteFreshVar) apply(rule finite_freeVarsFL) apply (rule rulesInPCs, clarify) apply(simp add: ss)
  apply(rule ContrI) \<comment> \<open>!\<close>
  apply(rule_tac w = "X n" in ExI) apply(rule inDed_mono) apply assumption apply force apply(rule rulesInPCs)+
  done

lemma subsJustified: "!! gamma. ~ terminal subs gamma
  ==> ! sigma : subs gamma . sequent sigma : deductions (CutFreePC)
  ==> sequent gamma : deductions (CutFreePC)"
  apply(case_tac "SATAxiom (sequent gamma)")
   apply(erule SAT_deduction)
  apply(case_tac gamma) apply(rename_tac ats nfs)
  apply(case_tac nfs)
   apply(simp add: terminal_def subs_def sequent_def Let_def)
  apply(case_tac a)
   apply(blast intro: subsJustified'[rule_format])
  done

subsection "proofTrees are deductions: instance of boundedTreeInduction"

lemmas proofTreeD = proofTree_def [THEN iffD1]

lemma proofTreeDeductionD[rule_format]: "proofTree(tree subs gamma) \<Longrightarrow> sequent gamma : deductions (CutFreePC)"
  apply(rule boundedTreeInduction[OF fansSubs])
    apply(erule proofTreeBounded)
   apply(rule foundedMono)
    apply (force dest: proofTreeD, simp)
   apply(blast intro: SAT_deduction foundedMono subsJustified)
  apply(blast intro:  subsJustified)
  done

subsection "contains, considers:"

lemma contains_def2: "contains f iA n = (iA : set (nforms (f n)))"
  apply(simp add: contains_def nforms_def) done

lemma considers_def2: "considers f iA n = ( ? nAs . nforms (f n) = iA#nAs)"
  apply(simp add: considers_def nforms_def split: list.split) done

lemmas containsI = contains_def2[THEN iffD2]

subsection "path: nforms = [] implies"

lemma nformsNoContains: "[| branch subs gamma f; !n . ~proofTree (tree subs (f n)); nforms (f n) = []  |] ==> ~ contains f iA n"
  apply(simp add: contains_def2) done
    \<comment> \<open>FIXME tjr assumptions not required\<close>

lemma nformsTerminal: "nforms (f n) = [] ==> terminal subs (f n)"
  apply(simp add: subs_def Let_def terminal_def nforms_def split_beta)
  done

lemma nformsStops: "!!f.
  [| branch subs gamma f; !n . ~proofTree (tree subs (f n));
     nforms (f n) = [] |]
  ==> nforms (f (Suc n)) = [] & atoms (f (Suc n)) = atoms (f n)"
  apply(subgoal_tac "f (Suc n) = f n")
  apply simp
  apply(blast intro: branchStops nformsTerminal)
  done

subsection "path: cases"

lemma terminalNFormCases: "!!f. terminal subs (f n) | (? i A nAs . nforms (f n) = (i,A)#nAs)"
  apply (rule disjCI, simp)
  apply(rule nformsTerminal)
  apply(case_tac "nforms (f n)")
  apply simp
  apply force
  done

lemma cases[elim_format]: "terminal subs (f n) | (\<not> (terminal subs (f n) \<and> (? i A nAs . nforms (f n) = (i,A)#nAs)))"
  apply(auto elim: terminalNFormCases[elim_format])
  done

subsection "path: contains not terminal and propagate condition"

lemma containsNotTerminal: "[| branch subs gamma f; !n . ~proofTree (tree subs (f n)); contains f iA n |] ==> ~ (terminal subs (f n))"
  apply(case_tac "SATAxiom (sequent (f n))")
  apply(blast dest: SATAxiomEq[THEN iffD2])
  apply(drule_tac x=n in spec)
  apply (simp add:  subs_def subs_def subsFAtom_def subsFConj_def subsFAll_def Let_def contains_def terminal_def nforms_def split_beta branch_def split: list.split signs.split expand_case_formula, force)
  done

lemma containsPropagates: "!!f.
  [| branch subs gamma f; !n . ~proofTree (tree subs (f n));
     contains f iA n |]
  ==> contains f iA (Suc n) | considers f iA n"
  apply(frule_tac containsNotTerminal) apply force apply force
  apply(frule_tac branchSubs) apply assumption
  apply(case_tac "considers f iA n") apply simp
  apply simp
  apply(simp add: contains_def) apply(case_tac "f n") apply simp apply(drule split_list) apply(elim exE conjE) apply simp
  apply(case_tac ys)
   apply (simp add: considers_def, simp)
  apply(case_tac "SATAxiom (sequent (f n))") apply(blast dest: iffD2[OF SATAxiomEq])
  apply(simp add: subs_def2 nforms_def Let_def)
  apply (case_tac aa, simp)
  apply(case_tac ba)
    apply(simp add: subsFAtom_def)
   apply(rename_tac signs a b)
   apply(case_tac signs) apply(simp add: subsFConj_def) apply force apply(simp add: subsFConj_def)
  apply(rename_tac signs a)
  apply(case_tac signs) apply(simp add: subsFAll_def Let_def) apply(simp add: subsFAll_def Let_def)
  done

subsection "path: no consider lemmas"

lemma noConsidersD: "!!f. ~considers f iA n ==> nforms (f n) = x#xs ==> iA ~= x"
  by(simp add: considers_def2)

lemma considersD: "!!f. considers f iA n ==> ? xs . nforms (f n) = iA#xs"
  by(simp add: considers_def2)

subsection "path: contains initially"

lemma contains_initially:
  "branch subs (pseq gamma) f \<Longrightarrow> A : set gamma \<Longrightarrow> (contains f (0,A) 0)"
  apply(drule branch0)
  apply(simp add: contains_def pseq_def) done

lemma contains_initialEVs:
  "branch subs (pseq gamma) f \<Longrightarrow>  A : set gamma \<Longrightarrow> EV (contains f (0,A))"
  apply(simp add: EV_def)
  apply(fast dest: contains_initially) done

subsection "termination: (for EV contains implies EV considers)"

lemmas r = wf_induct[of "measure msrFn", OF wf_measure] for msrFn
lemmas r' = r[simplified measure_def inv_image_def less_than_def less_eq mem_Collect_eq]

lemma r'': "(\<forall> x. (\<forall> y. ( ((msrFn::'a \<Rightarrow> nat) y) < ((msrFn :: 'a \<Rightarrow> nat) x)) \<longrightarrow> P y) \<longrightarrow> P x) \<Longrightarrow> P a"
  by (blast intro: r' [of _ P])

lemma terminationRule [rule_format]:
  "! n. P n --> (~(P (Suc n)) | (P (Suc n) & msrFn (Suc n) < (msrFn::nat => nat) n)) ==> P m --> (? n . P n & ~(P (Suc n)))"
  (is "_ \<Longrightarrow> ?P m")
  apply (rule r''[of msrFn "?P" m], blast)
  done
    \<comment> \<open>FIXME ugly\<close>

subsection "costBarrier: lemmas"

subsection "costBarrier: exp3 lemmas - bit specific..."

lemma exp3Min: "exp 3 a > 0"
by (induct a, simp, simp)

lemma exp1: "exp 3 (A) + exp 3 (B) < 3 * ((exp 3 A) * (exp 3 B))"
  using exp3Min[of A] exp3Min[of B]
  apply(case_tac "exp 3 A") apply(simp add: exp3Min)
  apply(case_tac "exp 3 B") apply (simp add: exp3Min, simp)
  done

lemma exp1': "exp 3 (A) < 3 * ((exp 3 A) * (exp 3 B)) + C"
  apply(subgoal_tac "exp 3 (A) < 3 * ((exp 3 A) * (exp 3 B))")
  apply arith
  apply(case_tac "exp 3 A") using exp3Min[of A] apply arith
  apply(case_tac "exp 3 B") using exp3Min[of B] apply arith
  apply simp
  done

lemma exp2: "Suc 0 < 3 * exp 3 (B)"
  using exp3Min[of B]
  apply arith
  done

lemma expSum: "exp x (a+b) = (exp x a) * (exp x b)"
  apply(induct a, auto) done

subsection "costBarrier: decreases whilst contains and unconsiders"

lemma costBarrierDecreases':
  notes ss = subs_def2 nforms_def Let_def subsFAtom_def subsFConj_def subsFAll_def costBarrier_def atoms_def exp3Min expSum
  shows "~SATAxiom (sequent
(a, (num,fm) # list)) --> iA ~= (num, fm) --> \<not> proofTree (tree subs (a, (num, fm) # list)) --> fSucn : subs (a, (num, fm) # list) --> iA \<in> set list --> costBarrier iA (fSucn) < costBarrier iA (a, (num, fm) # list)"
  apply(rule_tac A=fm in formula_signs_cases)
    \<comment> \<open>atoms\<close>
       apply(simp add: ss)
      apply(simp add: ss)
        \<comment> \<open>conj\<close>
     apply clarify
     apply(simp add: ss)
     apply(erule disjE)
      apply(simp add: ss exp2)
     apply(simp add: ss exp2)
    \<comment> \<open>disj\<close>
    apply clarify
    apply(simp add: ss exp1 exp1')
    \<comment> \<open>all\<close>
   apply clarify
   apply(simp add: ss size_instance)
  \<comment> \<open>ex\<close>
  apply clarify
  apply(simp add: ss size_instance)
  done

lemma costBarrierDecreases:
  "[| branch subs gamma f;
  !n . ~proofTree (tree subs (f n));
  contains f iA n;
  ~(considers f iA) n
  |] ==> costBarrier iA (f (Suc n)) < costBarrier iA (f n)"
  apply(subgoal_tac "\<not> terminal subs (f n)")
   apply(subgoal_tac "\<not> SATAxiom (sequent (f n))")
    apply(subgoal_tac "f (Suc n) \<in> subs (f n)")
     apply(frule_tac x=n in spec)
     apply(case_tac "f n", simp)
     apply(case_tac b, simp)
      apply(simp add: contains_def)
     apply(case_tac aa) apply(rename_tac num fm) apply simp apply(simp add: contains_def considers_def)
     apply(rule costBarrierDecreases'[rule_format]) apply force+
    apply(rule branchSubs) apply assumption apply assumption
   apply(blast dest: SATAxiomTerminal)
  apply(blast dest: containsNotTerminal)
  done
  \<comment> \<open>FIXME boring splitting etc.\<close>

subsection "path: EV contains implies EV considers"

lemma considersContains: "considers f iA n \<Longrightarrow> contains f iA n"
  apply(simp add: considers_def contains_def)
  apply(cases "snd (f n)", auto) done

lemma containsConsiders: "[| branch subs gamma f; !n . ~ proofTree (tree subs (f n));
     EV (contains f iA) |]
  ==> EV (considers f iA)"
  apply(simp add: EV_def)
  apply(erule exE)
  apply(case_tac "considers f iA n") apply force
  apply(subgoal_tac "\<exists>n. (contains f iA n \<and> \<not> considers f iA n) \<and>
    \<not> (contains f iA (Suc n) \<and> \<not> considers f iA (Suc n))")
   apply(erule exE)
   apply(simp, clarify)
   apply(case_tac "contains f iA (Suc na)")
    apply force apply(force dest!: containsPropagates)
  apply(rule_tac msrFn = "%n. costBarrier iA (f n)" and P = "%n. contains f iA n & ~ considers f iA n" in terminationRule)
  prefer 2 apply force
  apply(case_tac "(contains f iA (Suc na) \<and> \<not> considers f iA (Suc na))")
  apply simp apply(erule costBarrierDecreases) apply simp_all
  done

subsection "EV contains: common lemma"

lemma lemmA:
  "[| branch subs gamma f; ! n. ~ proofTree (tree subs (f n));
    EV (contains f (i,A)) |]
 ==> ? n nAs. ~SATAxiom (sequent (f n)) & (nforms (f n) = (i,A) # nAs & f (Suc n) : subs (f n))"
  apply(frule containsConsiders) apply(assumption+)
  apply(unfold EV_def)
  apply(erule exE, frule considersContains)
  apply(unfold considers_def)
  apply(case_tac "snd (f n)")
  apply force
  apply simp
  apply(rule_tac x=n in exI)
  apply (intro conjI, rule)
  apply(blast dest!: SATAxiomEq[THEN iffD2])
  apply(rule_tac x=list in exI) apply(simp add: nforms_def)
  apply(frule containsNotTerminal) apply force apply(assumption+)
  apply(blast dest!: branchSubs)
  done

subsection "EV contains: FConj,FDisj,FAll"

lemma EV_disj: "(EV P | EV Q) = EV (\<lambda>n. P n | Q n)"
  apply (unfold EV_def, force) done

lemma evContainsConj: "[| EV (contains f (i,FConj Pos A0 A1));
  branch subs gamma f; !n . ~ proofTree (tree subs (f n))
  |] ==> EV (contains f (0,A0)) | EV (contains f (0,A1))"
  apply(drule lemmA) apply(assumption+)
  apply(subgoal_tac "EV (\<lambda> n. contains f (0,A0) n | contains f (0,A1) n)")
  apply(simp add: EV_disj)
  apply(unfold EV_def)
  apply clarify
  apply(rename_tac n n' nAs, rule_tac x="Suc n'" in exI)
  apply(simp add: subs_def2 Let_def)
  apply(simp add: subsFConj_def)
  apply (simp add: contains_def nforms_def, auto)
  done

lemma evContainsDisj: "[| EV (contains f (i,FConj Neg A0 A1));
  branch subs gamma f; !n . ~ proofTree (tree subs (f n))
  |] ==> EV (contains f (0,A0)) & EV (contains f (0,A1))"
  apply(drule lemmA) apply(assumption+)
  apply(rule conjI)
  apply(unfold EV_def)
  apply(erule exE) back
  apply(rule_tac x="Suc n" in exI)
  apply(clarify, simp add: subs_def2 Let_def)
  apply(simp add: subsFConj_def)
  apply(simp add: contains_def nforms_def)
  apply(erule exE) back
  apply(rule_tac x="Suc n" in exI)
  apply(clarify, simp add: subs_def2 Let_def)
  apply(simp add: subsFConj_def)
  apply(simp add: contains_def nforms_def)
  done

lemma evContainsAll:
  "[| EV (contains f (i,FAll Pos body)); branch subs gamma f; !n . ~ proofTree (tree subs (f n))
     |]
   ==> ? v . EV (contains f (0,instanceF v body))"
  apply(drule lemmA) apply(assumption+)
  apply(erule exE)
  apply(rule_tac x="freshVar(freeVarsFL (sequent (f n)))" in exI)
  apply(unfold EV_def)
  apply(rule_tac x="Suc n" in exI)
  apply(clarify, simp add: subs_def2 Let_def)
  apply(simp add: subsFAll_def Let_def)
  apply(simp add: contains_def nforms_def)
  done

lemma evContainsEx_instance:
  "[| EV (contains f (i,FAll Neg body)); branch subs gamma f; !n . ~ proofTree (tree subs (f n))
      |]
  ==> EV (contains f (0,instanceF (X i) body))"
  apply(drule lemmA) apply(assumption+)
  apply(erule exE)
  apply(unfold EV_def)
  apply(rule_tac x="Suc n" in exI)
  apply(clarify, simp add: subs_def2 Let_def)
  apply(simp add: subsFAll_def Let_def)
  apply(simp add: contains_def nforms_def)
  done

lemma evContainsEx_repeat: "
  [| branch subs gamma f; !n . ~ proofTree (tree subs (f n));
     EV (contains f (i,FAll Neg body)) |]
   ==> EV (contains f (Suc i,FAll Neg body))"
  apply(drule lemmA) apply(assumption+)
  apply(erule exE)
  apply(unfold EV_def)
  apply(rule_tac x="Suc n" in exI)
  apply(clarify, simp add: subs_def2 Let_def)
  apply(simp add: subsFAll_def Let_def)
  apply(simp add: contains_def nforms_def)
  done

subsection "EV contains: lemmas (temporal related)"

(******
 Should have abstracted to have temporal ops:
    EV   : (nat -> bool) -> nat -> bool
    AW   : (nat -> bool) -> nat -> bool
    NEXT : (nat -> bool) -> nat -> bool
 then require:
    EV P and EV B imp (\n. A n & B n)

 already think have done similar proofs to this one elsewhere,
 Q: where? share proofs?
 ******)

lemma lemma1: "[| P A n ; !A n. P A n --> P A (Suc n) |]
   ==> P A (n + m)"
  apply (induct m, simp, simp)
  done

lemma lemma2:
  "[| P A n ; P B m ; ! A n. P A n --> P A (Suc n) |]
  ==> ? n . P A n & P B n"
  apply (rule exI[of _ "n+m"], rule)
  apply(blast intro!: lemma1)
  apply(rule subst[OF add.commute])
  apply(blast intro!: lemma1)
  done

subsection "EV contains: FAtoms"

lemma notTerminalNforms: "\<not> terminal subs (f n) \<Longrightarrow> nforms (f n) \<noteq> []"
  apply(erule contrapos_nn) apply(erule nformsTerminal) done

lemma atomsPropagate: "[| branch subs gamma f |]
   ==> x : set (atoms (f n)) --> x : set (atoms (f (Suc n)))"
  apply(cases "terminal subs (f n)")
   apply(drule branchStops) apply assumption apply simp
  apply(drule branchSubs) apply assumption
  apply rule apply(frule notTerminalNotSATAxiom)
  apply(frule notTerminalNforms)
  apply(simp add: subs_def2)
  apply(cases "nforms (f n)") apply simp
  apply(simp add: Let_def)
  apply(case_tac a, auto)
  apply(case_tac ba, auto)
    apply(simp add: subsFAtom_def atoms_def)
   apply(simp add: subsFConj_def atoms_def)
   apply(rename_tac signs a b)
   apply(case_tac signs) apply force apply force
  apply(simp add: subsFAll_def atoms_def)
  apply(rename_tac signs a)
  apply(case_tac signs) apply(force simp: Let_def) apply force
  done

subsection "EV contains: FEx cases"

lemma evContainsEx0_allRepeats:
  "[| branch subs gamma f; !n . ~ proofTree (tree subs (f n));
     EV (contains f (0,FAll Neg A)) |]
  ==> EV (contains f (i,FAll Neg A))"
  apply (induct i, simp)
  apply(blast dest!: evContainsEx_repeat)
  done

lemma evContainsEx0_allInstances:
  "[| branch subs gamma f; !n . ~ proofTree (tree subs (f n));
     EV (contains f (0,FAll Neg A)) |]
  ==> EV (contains f (0,instanceF (X i) A))"
  apply(blast dest!: evContainsEx0_allRepeats intro!: evContainsEx_instance)
  done

subsection "pseq: creates initial pseq"

lemma containsPSeq0D: "branch subs (pseq fs) f \<Longrightarrow> contains f (i,A) 0 \<Longrightarrow> i=0"
  apply(drule branch0)
  apply (simp add: pseq_def contains_def, blast)
  done

subsection "EV contains: contain any (i,FEx y) means contain all (i,FEx y)"

(******
 Now, show (Suc i,FEx v A) present means (i,FEx v A) present (or at start).
 Assumes initial pseq contains only (0,form) pairs.
 ------
 Show that only way of introducing a (Suc i,FEx_) was from (i,FEx_).
 contains n == considers n or contains n+.

 Want to find the point where it was introduced.
 Have, P true all n or fails at 0 or for a (first) successor.

     (!n. P n) | (~P 0) | (P n & ~ P (Suc n))

 Instance this with P n = ~(contains ..FEx.. n).
 ******)

lemma claim: "(A | B | C) = (~C --> ~B --> A)" by auto

lemma natPredCases: "(!n. P n) | (~P 0) | (? n . P n & ~ P (Suc n))"
  apply(rule claim[THEN iffD2])
  apply(intro impI) apply simp
  apply rule apply(induct_tac n) apply auto
  done

lemma containsNotTerminal':
  "\<lbrakk> branch subs gamma f; !n . ~proofTree (tree subs (f n)); contains f iA n \<rbrakk> \<Longrightarrow> ~ (terminal subs (f n))"
  apply (rule containsNotTerminal, auto)
  done

lemma notTerminalSucNotTerminal: "\<lbrakk> \<not> terminal subs (f (Suc n)); branch subs gamma f \<rbrakk> \<Longrightarrow> \<not> terminal subs (f n)"
  apply(erule contrapos_nn)
  apply(rule_tac branchTerminalPropagates[of _ _ _ _ 1, simplified])
  apply(assumption+) done
    \<comment> \<open>FIXME move to Tree?\<close>

lemma evContainsExSuc_containsEx:
  "[| branch subs (pseq fs) f; !n . ~ proofTree (tree subs (f n));
     EV (contains f (Suc i,FAll Neg body)) |]
  ==> EV (contains f (i,FAll Neg body))"
  apply(cut_tac P="%n. ~ contains f (Suc i,FAll Neg body) n" in natPredCases)
  apply simp apply(erule disjE)
  apply(simp add: EV_def)
  apply(erule disjE)
  apply(blast dest!: containsPSeq0D)
  apply(thin_tac "EV _")
  apply(erule exE)
  apply(erule conjE)
  apply(unfold EV_def) apply(rule_tac x=n in exI)
  apply(rule considersContains)
  apply(frule containsNotTerminal') apply(assumption+)
  apply(frule notTerminalSucNotTerminal) apply assumption
  apply(thin_tac "\<not> terminal x y" for x y)
  apply(frule branchSubs) apply assumption
  apply(frule notTerminalNforms)
  apply(case_tac "SATAxiom (sequent (f n))")
  apply(drule SATAxiomTerminal) apply simp
  apply(subgoal_tac "(\<exists>i A nAs. nforms (f n) = (i, A) # nAs)")
  prefer 2 apply(rule_tac f=f and n=n in cases) apply simp
  apply(case_tac "nforms (f n)") apply simp apply(case_tac a, force)
  apply(erule exE)+
  apply(unfold considers_def) apply(simp add: nforms_def)
  \<comment> \<open>shift A into succedent\<close>
  apply(rule_tac P="snd (f n) = (ia, A) # nAs" in rev_mp) apply assumption apply(thin_tac "snd (f n) = (ia, A) # nAs")
  apply(rule_tac A=A in formula_signs_cases)
  apply(auto simp add: subs_def2 nforms_def Let_def subsFAtom_def subsFConj_def subsFAll_def contains_def2 Let_def)
  done
    \<comment> \<open>phew, bit precarious, but not too much going on besides unfolding defns. and computing a bit. Need to set simps up\<close>

subsection "EV contains: contain any (i,FEx y) means contain all (i,FEx y)"

lemma evContainsEx_containsEx0:
  "[| branch subs (pseq fs) f; !n . ~ proofTree (tree subs (f n)) |]
  ==> EV (contains f (i,FAll Neg A)) -->
      EV (contains f (0,FAll Neg A))"
  apply (induct i, simp)
  apply(blast dest!: evContainsExSuc_containsEx)
  done

lemma evContainsExval:
  "[| EV (contains f (i,FAll Neg body)); branch subs (pseq fs) f; !n . ~ proofTree (tree subs (f n))
  |]
  ==> ! v . EV (contains f (0,instanceF v body))"
  apply rule apply(induct_tac v)
  apply(blast intro!: evContainsEx0_allInstances dest!: evContainsEx_containsEx0)
  done

subsection "EV contains: atoms"

lemma atomsInSequentI[rule_format]: "  (z,P,vs) : set (fst ps) -->
     FAtom z P vs : set (sequent ps)"
  apply(simp add: sequent_def)
  apply(cases ps, force)
  done

lemma evContainsAtom1:
  "[| branch subs (pseq fs) f; !n . ~ proofTree (tree subs (f n));
     EV (contains f (i,FAtom z P vs)) |]
  ==> ? n . (z,P,vs) : set (fst (f n))"
  apply(drule lemmA) apply(assumption+)
  apply(erule exE) apply(rule_tac x="Suc n" in exI)
  apply(simp add: subs_def2) apply clarify apply(simp add: subs_def2 Let_def)
  apply(simp add: subsFAtom_def) done

lemmas atomsPropagate'' = atomsPropagate[rule_format]
lemmas atomsPropagate' = atomsPropagate''[simplified atoms_def, simplified]

lemma evContainsAtom:
  "[| branch subs (pseq fs) f; !n . ~ proofTree (tree subs (f n));
   EV (contains f (i,FAtom z P vs)) |]
  ==> ? n . (! m . FAtom z P vs : set (sequent (f (n + m))))"
  apply(frule evContainsAtom1) apply(assumption+)
  apply(erule exE)
  apply (rule_tac x=n in exI, rule)
  apply(rule atomsInSequentI)
  apply (induct_tac m, simp, simp)
  apply(rule atomsPropagate') apply(assumption+) done

lemma notEvContainsBothAtoms:
  "[| branch subs (pseq fs) f; !n . ~ proofTree (tree subs (f n)) |]
  ==> ~ EV (contains f (i,FAtom Pos p vs)) |
      ~ EV (contains f (j,FAtom Neg p vs))"
  apply clarify
  apply(frule evContainsAtom) apply(assumption+) apply(thin_tac "EV (contains f (j, FAtom Neg p vs))")
  apply(frule evContainsAtom) apply(assumption+) apply(thin_tac "EV (contains f (i, FAtom Pos p vs))")
  apply(erule_tac exE)+
  apply(drule_tac x=na in spec) back
  apply(drule_tac x=n in spec) back
  apply(simp add: ac_simps)
  apply(subgoal_tac "SATAxiom (sequent (f (n+na)))")
  apply(force dest: SATAxiomProofTree)
  apply(force simp add: SATAxiom_def) done

subsection "counterModel: lemmas"

lemma counterModelInRepn: "(counterM f,counterEvalP f) : model"
  apply(simp add: model_def counterM_def) done

lemmas Abs_counterModel_inverse = counterModelInRepn[THEN Abs_model_inverse]

lemma inv_obj_obj: "inv obj (obj n) = n"
  using inj_obj apply simp done

lemma map_X_map_counterAssign: "map X (map (inv obj) (map counterAssign xs)) = xs"
  apply(simp)
  apply(subgoal_tac "(X \<circ> (inv obj \<circ> counterAssign)) = (% x . x)")
  apply simp
  apply(rule ext)
  apply(case_tac x)
  apply(simp add: inv_obj_obj)
  done

lemma objectsCounterModel: "objects (counterModel f) =  { z . ? i . z = obj i }"
  apply(simp add: objects_def counterModel_def)
  apply(simp add: Abs_counterModel_inverse)
  apply(simp add: counterM_def)
  by force

lemma inCounterM: "counterAssign v : objects (counterModel f)"
  apply(induct v)
  apply(simp add: objectsCounterModel)
  by blast

lemma counterAssign_eqI[rule_format]: "x : objects (counterModel f) --> z = X (inv obj x) --> counterAssign z = x"
  apply(force simp: objectsCounterModel inj_obj) done

lemma evalPCounterModel: "M = counterModel f ==> evalP M = counterEvalP f"
  apply(simp add: evalP_def counterModel_def Abs_counterModel_inverse) done

subsection "counterModel: all path formula value false - step by step"

lemma path_evalF':
  notes ss = evalPCounterModel counterEvalP_def map_X_map_counterAssign map_map[symmetric]
  and ss1 = instanceF_def evalF_subF_eq comp_vblcase id_def[symmetric]
  shows "[| branch subs (pseq fs) f;
  !n . ~ proofTree (tree subs (f n))
  |] ==> (? i . EV (contains f (i,A))) \<longrightarrow> ~(evalF (counterModel f) counterAssign A)"
  apply (rule_tac strong_formula_induct, rule)
  apply(rule formula_signs_cases)
       \<comment> \<open>atom\<close>
       apply(simp add: ss del: map_map)
      apply(rule, rule)
      apply(simp add: ss del: map_map)
      apply(force dest: notEvContainsBothAtoms)
     \<comment> \<open>conj\<close>
     apply(force dest: evContainsConj)
     \<comment> \<open>disj\<close>
    apply(force dest: evContainsDisj)
   \<comment> \<open>all\<close>
   apply(rule, rule)
   apply(erule exE)
   apply(drule_tac evContainsAll) apply assumption apply assumption
   apply(erule exE)
   apply(drule_tac x="(instanceF v f1)" in spec)
   apply(erule impE, force simp: size_instance)+
   apply simp
   apply(simp add: ss1)
   apply(rule_tac x="counterAssign v" in bexI) apply simp apply(simp add: inCounterM)
  \<comment> \<open>ex\<close>
  apply(rule, rule)
  apply(erule exE)
  apply(drule_tac evContainsExval) apply assumption apply assumption
  apply simp
  apply rule
  apply(simp add: objectsCounterModel) apply(erule exE)
  apply(drule_tac x="X i" in spec)
  apply(drule_tac x="(instanceF (X i) f1)" in spec)
  apply(erule impE, force simp: size_instance)+
  apply(simp add: ss1)
  done

lemmas path_evalF'' = mp[OF path_evalF']

subsection "adequacy"

lemma counterAssignModelAssign: "counterAssign : modelAssigns (counterModel gamma)"
  apply (simp add: modelAssigns_def, rule)
  apply (erule rangeE, simp)
  apply(rule inCounterM)
  done

lemma branch_contains_initially: "branch subs (pseq fs) f \<Longrightarrow> x : set fs \<Longrightarrow> contains f (0,x) 0"
  apply(simp add: contains_def branch0 pseq_def)
  done

lemma path_evalF:
  "[| branch subs (pseq fs) f;
  \<forall>n. \<not> proofTree (tree subs (f n));
  x \<in> set fs
  |] ==> \<not> evalF (counterModel f) counterAssign x"
  apply (rule path_evalF'', assumption, assumption)
  apply(rule_tac x=0 in exI) apply(simp add: EV_def)
  apply(rule_tac x=0 in exI) apply(simp add: branch_contains_initially)
  done

lemma validProofTree: "~proofTree (tree subs (pseq fs)) ==> ~(validS fs)"
  apply(simp add: validS_def evalS_def)
  apply(subgoal_tac "\<exists>f. branch subs (pseq fs) f \<and> (\<forall>n. \<not> proofTree (tree subs (f n)))")
   apply(elim exE conjE)
   apply(rule_tac x="counterModel f" in exI)
   apply(rule_tac x=counterAssign in bexI)
    apply(force dest!: path_evalF)
   apply(rule counterAssignModelAssign)
  apply(rule failingBranchExistence)
    apply(rule inheritedProofTree)
   apply (rule fansSubs, assumption)
  done

end


theory System
imports Main

begin
datatype ('proc, 'msg, 'val) event
  = Receive (msg_sender: 'proc) (recv_msg: 'msg)
  | Request 'val
  | Timeout

type_synonym ('proc, 'state, 'msg, 'val) step_func =
  \<open>'proc \<Rightarrow> 'state \<Rightarrow> ('proc, 'msg, 'val) event \<Rightarrow>
  ('state \<times> ('proc \<times> 'msg) set)\<close>

fun valid_event :: \<open>('proc, 'msg, 'val) event \<Rightarrow> 'proc \<Rightarrow>
                    ('proc \<times> 'proc \<times> 'msg) set \<Rightarrow> bool\<close>
where
  \<open>valid_event (Receive sender msg) recpt msgs =
    ((sender, recpt, msg) \<in> msgs)\<close> |
  \<open>valid_event (Request _) _ _ = True\<close> |
  \<open>valid_event Timeout _ _ = True\<close>

  inductive execute ::
  \<open>('proc, 'state, 'msg, 'val) step_func \<Rightarrow> ('proc \<Rightarrow> 'state) \<Rightarrow>
   'proc set \<Rightarrow> ('proc \<times> ('proc, 'msg, 'val) event) list \<Rightarrow>
   ('proc \<times> 'proc \<times> 'msg) set \<Rightarrow> ('proc \<Rightarrow> 'state) \<Rightarrow> bool\<close>
where
  \<open>execute step init procs [] {} init\<close> |
  \<open>\<lbrakk>execute step init procs events msgs states;
    proc \<in> procs;
    valid_event event proc msgs;
    step proc (states proc) event = (new_state, sent);
    events' = events @ [(proc, event)];
    msgs' = msgs \<union> {m. \<exists>(recpt, msg) \<in> sent.
                       m = (proc, recpt, msg)};
    states' = states (proc := new_state)
   \<rbrakk> \<Longrightarrow> execute step init procs events' msgs' states'\<close>

   theorem prove_invariant:
  assumes \<open>execute step init procs events msgs states\<close>
  shows \<open>some_invariant states\<close>
using assms proof (induction events arbitrary: msgs states
                   rule: List.rev_induct)
  case Nil
  then show \<open>some_invariant states\<close> sorry
next
  case (snoc event events)
  then show ?case sorry
qed

end


theory BExp
imports Main
        "$HIPSTER_HOME/IsaHipster"
(*uses "../HipSpec.ML"*)

begin

datatype Boolex =
  Const bool |
  Var nat |
  Neg Boolex|
  And Boolex Boolex

primrec "valbool" :: "Boolex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "valbool (Const b) env = b" |
  "valbool (Var x) env = env x" |
  "valbool (Neg b) env = (\<not> valbool b env)" |
  "valbool (And b c) env = (valbool b env \<and> valbool c env)"

datatype Ifex = CIF bool | VIF nat | IF Ifex Ifex Ifex

primrec valif :: "Ifex \<Rightarrow> (nat \<Rightarrow> bool) \<Rightarrow> bool"
  where
  "valif (CIF b) env = b" |
  "valif (VIF x) env = env x" |
  "valif (IF b t e) env = (if valif b env then valif t env
                           else valif e env)"

primrec bool2if :: "Boolex \<Rightarrow> Ifex"
where
  "bool2if (Const b) = CIF b" |
  "bool2if (Var x) = VIF x" |
  "bool2if (Neg b) = IF (bool2if b) (CIF False) (CIF True)" |
  "bool2if (And b c) = IF (bool2if b) (bool2if c) (CIF False)"

hipster valbool valif bool2if
lemma blah: "valbool b env = valif (bool2if b) env" (* It doesn't produce this for some reason..*)
apply (induction b)
apply simp_all

ML \<open>val consts = ["BExp.value", "BExp.valif", "BExp.bool2if" ] ;\<close>

ML \<open>
val lemma_strs = Hipster_Explore.hipspec_explore @{theory} consts;
\<close>
ML\<open>
(* This fails because in Haskell, the constructor IF has been renamed If, so
when conjectures are read back in, it goes wrong, and Isabelle thinks it refers to
an actual if-statement. *)
val [c1,c2,c3,c4,c5,c6,c7] =  (Library.split_lines (Library.trim_line lemma_strs));

(*
val conjs = map (Goal.init o (Thm.cterm_of @{theory}) o (Syntax.read_prop @{context})) conjs1;
*)
\<close>

ML \<open>
map Pretty.writeln (map ((Syntax.pretty_term @{context}) o prop_of) thms);
\<close>

end


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

(* License: BSD, terms see file ./LICENSE *)

(*
  Structures supporting CTypes.
  Primarily sets up types, defines pointers and the raw heap view.
*)

theory CTypesBase
imports
  Addr_Type
begin

section "Type setup"

type_synonym byte = "8 word"

type_synonym memory = "addr \<Rightarrow> byte"
type_synonym 'a mem_upd = "addr \<Rightarrow> 'a \<Rightarrow> memory \<Rightarrow> memory"
type_synonym 'a mem_read = "addr \<Rightarrow> memory \<Rightarrow> 'a"

class unit_class =
  assumes there_is_only_one: "x = y"

instantiation unit :: unit_class
begin
instance by (intro_classes, simp)
end

subsection "Pointers"

datatype 'a ptr = Ptr addr

abbreviation
  NULL :: "'a ptr" where
  "NULL \<equiv> Ptr 0"

ML \<open>
structure Ptr_Syntax =
struct

  val show_ptr_types = Attrib.setup_config_bool @{binding show_ptr_types} (K true)

  fun ptr_tr' cnst ctxt typ ts = if Config.get ctxt show_ptr_types then
      case Term.strip_type typ of
        ([@{typ addr}], Type (@{type_name "ptr"}, [T])) =>
          list_comb
            (Syntax.const cnst $ Syntax_Phases.term_of_typ ctxt T
            , ts)
        | _ => raise Match
  else raise Match

  fun ptr_coerce_tr' cnst ctxt typ ts = if Config.get ctxt show_ptr_types then
      case Term.strip_type typ of
        ([Type (@{type_name ptr}, [S])], Type (@{type_name "ptr"}, [T])) =>
          list_comb
            (Syntax.const cnst $ Syntax_Phases.term_of_typ ctxt S
                               $ Syntax_Phases.term_of_typ ctxt T
            , ts)
        | _ => raise Match
  else raise Match
end
\<close>

syntax
  "_Ptr" :: "type \<Rightarrow> logic" ("(1PTR/(1'(_')))")
translations
  "PTR('a)" => "CONST Ptr :: (addr \<Rightarrow> 'a ptr)"
typed_print_translation
  \<open> [(@{const_syntax Ptr}, Ptr_Syntax.ptr_tr' @{syntax_const "_Ptr"})] \<close>

primrec
  ptr_val :: "'a ptr \<Rightarrow> addr"
where
  ptr_val_def: "ptr_val (Ptr a) = a"

primrec
  ptr_coerce :: "'a ptr \<Rightarrow> 'b ptr" where
  "ptr_coerce (Ptr a) = Ptr a"

syntax
  "_Ptr_coerce" :: "type \<Rightarrow> type \<Rightarrow> logic" ("(1PTR'_COERCE/(1'(_ \<rightarrow> _')))")
translations
  "PTR_COERCE('a \<rightarrow> 'b)" => "CONST ptr_coerce :: ('a ptr \<Rightarrow> 'b ptr)"
typed_print_translation
  \<open> [(@{const_syntax ptr_coerce}, Ptr_Syntax.ptr_coerce_tr' @{syntax_const "_Ptr_coerce"})] \<close>

definition
  (* no ctype/memtype-class constraints on these so as to allow comparison of
     void * pointers, which are represented as Isabelle type unit ptr *)
  ptr_less :: "'a ptr \<Rightarrow> 'a ptr \<Rightarrow> bool" (infixl "<\<^sub>p" 50) where
  "p <\<^sub>p q \<equiv> ptr_val p < ptr_val q"

definition
  ptr_le :: "'a ptr \<Rightarrow> 'a ptr \<Rightarrow> bool" (infixl "\<le>\<^sub>p" 50) where
  "p \<le>\<^sub>p q \<equiv> ptr_val p \<le> ptr_val q"

instantiation ptr :: (type) ord
begin

definition
  ptr_less_def': "p < q \<equiv> p <\<^sub>p q"
definition
  ptr_le_def': "p \<le> q \<equiv> p \<le>\<^sub>p q"

instance ..

end

lemma ptr_val_case: "ptr_val p = (case p of Ptr v \<Rightarrow> v)"
  by (cases p) simp

instantiation ptr :: (type) linorder
begin
instance
  by (intro_classes)
     (unfold ptr_le_def' ptr_le_def ptr_less_def' ptr_less_def ptr_val_case,
      auto split: ptr.splits)
end

subsection "Raw heap"

text \<open>A raw map from addresses to bytes\<close>

type_synonym heap_mem = "addr \<Rightarrow> byte"

text \<open>For heap h, pointer p and nat n, (heap_list h n p) returns the list
        of bytes in the heap taken from addresses {p..+n}\<close>

primrec
  heap_list :: "heap_mem \<Rightarrow> nat \<Rightarrow> addr \<Rightarrow> byte list"
where
  heap_list_base: "heap_list h 0 p = []"
| heap_list_rec:  "heap_list h (Suc n) p = h p # heap_list h n (p + 1)"

section "Intervals"

text \<open>
  For word a and nat b, {a..+b} is the set of words x,
  with unat (x - a) < b.\<close>

definition
  intvl :: "'a::len word \<times> nat \<Rightarrow> 'a::len word set" where
  "intvl x \<equiv> {z. \<exists>k. z = fst x + of_nat k \<and> k < snd x}"

abbreviation
  "intvl_abbr" :: "'a::len word \<Rightarrow> nat \<Rightarrow> 'a word set" ("{_..+_}") where
  "{a..+b} \<equiv> intvl (a,b)"

section "dt_pair: a reimplementation of 2 item tuples"

datatype
    ('a,'b) dt_pair = DTPair 'a 'b

primrec
  dt_fst :: "('a,'b) dt_pair \<Rightarrow> 'a"
where
  "dt_fst (DTPair a b) = a"

primrec
  dt_snd :: "('a,'b) dt_pair \<Rightarrow> 'b"
where
  "dt_snd (DTPair a b) = b"

lemma split_DTPair_All:
  "(\<forall>x. P x) = (\<forall>a b. P (DTPair a b))"
  by (rule iffI; clarsimp) (case_tac x, simp)

lemma surjective_dt_pair:
  "p = DTPair (dt_fst p) (dt_snd p)"
  by (cases p) simp

lemmas dt_pair_collapse [simp] = surjective_dt_pair[symmetric]

lemma split_DTPair_all[no_atp]: "(\<And>x. PROP P x) \<equiv> (\<And>a b. PROP P (DTPair a b))"
proof
  fix a b
  assume "\<And>x. PROP P x"
  then show "PROP P (DTPair a b)" .
next
  fix x
  assume "\<And>a b. PROP P (DTPair a b)"
  from \<open>PROP P (DTPair (dt_fst x) (dt_snd x))\<close> show "PROP P x" by simp
qed

type_synonym normalisor = "byte list \<Rightarrow> byte list"

section "Properties of pointers"

lemma Ptr_ptr_val [simp]:
  "Ptr (ptr_val p) = p"
  by (case_tac p) simp

lemma ptr_val_ptr_coerce [simp]:
  "ptr_val (ptr_coerce p) = ptr_val p"
  by (case_tac p) simp

lemma Ptr_ptr_coerce [simp]:
  "Ptr (ptr_val p) = ptr_coerce p"
  by (case_tac p) simp

lemma ptr_coerce_id [simp]:
  "ptr_coerce p = p"
  by (case_tac p) simp

lemma ptr_coerce_idem [simp]:
  "ptr_coerce (ptr_coerce p) = ptr_coerce p"
  by (case_tac p) simp

lemma ptr_val_inj [simp]:
  "(ptr_val p = ptr_val q) = (p = q)"
  by (case_tac p, case_tac q) auto

lemma ptr_coerce_NULL [simp]:
  "(ptr_coerce p = NULL) = (p = NULL)"
  by (case_tac p) simp

lemma NULL_ptr_val:
  "(p = NULL) = (ptr_val p = 0)"
  by (case_tac p) simp

instantiation ptr :: (type) finite
begin
instance
  by (intro_classes)
     (auto intro!: finite_code finite_imageD [where f=ptr_val] injI)
end

section "Properties of the raw heap"

lemma heap_list_length [simp]:
  "length (heap_list h n p) = n"
  by (induct n arbitrary: p) auto

lemma heap_list_split:
  shows "k \<le> n \<Longrightarrow> heap_list h n x = heap_list h k x @ heap_list h (n - k) (x + of_nat k)"
proof (induct n arbitrary: k x)
  case 0 thus ?case by simp
next
  case (Suc n) thus ?case
    by (cases k, auto simp: ac_simps)
qed

lemma heap_list_split2:
  "heap_list h (x + y) p = heap_list h x p @ heap_list h y (p + of_nat x)"
  by (subst heap_list_split [where k=x], auto)

section "Properties of intervals"

lemma intvlI:
  "x < n \<Longrightarrow> p + of_nat x \<in> {p..+n}"
  by (force simp: intvl_def)

lemma intvlD:
  "q \<in> {p..+n} \<Longrightarrow> \<exists>k. q = p + of_nat k \<and> k < n"
  by (force simp: intvl_def)

lemma intvl_empty [simp]:
  "{p..+0} = {}"
  by (fast dest: intvlD)

lemma intvl_Suc:
  "q \<in> {p..+Suc 0} \<Longrightarrow> p = q"
  by (force dest: intvlD)

lemma intvl_self:
  "0 < n \<Longrightarrow> x \<in> {x..+n}"
  by (force simp: intvl_def)

lemma intvl_start_inter:
  "\<lbrakk> 0 < m; 0 < n \<rbrakk> \<Longrightarrow> {p..+m} \<inter> {p..+n} \<noteq> {}"
  by (force simp: disjoint_iff_not_equal dest: intvl_self)

lemma intvl_overflow:
  assumes "2^len_of TYPE('a) \<le> n"
  shows "{(p::'a::len word)..+n} = UNIV"
proof -
  have witness:
    "\<And>x. x = p + of_nat (unat (x - p)) \<and> unat (x - p) < n"
    using assms by simp unat_arith
  show ?thesis unfolding intvl_def by (auto intro!: witness)
qed

lemma intvl_self_offset:
  fixes p::"'a::len word"
  assumes a: "2^len_of TYPE('a) - n < x" and b: "x < 2^len_of TYPE('a)" and
      c: "(p::'a::len word) \<notin> {p + of_nat x..+n}"
  shows False
proof -
  let ?j = "2^len_of TYPE('a) - x"
  from b have b': "of_nat x + of_nat ?j  = (0::'a::len word)" using of_nat_2p by auto
  moreover from a b have "?j < n" by arith
  with b b' c show  ?thesis by (force simp: intvl_def)
qed

lemma intvl_mem_offset:
  "\<lbrakk> q \<in> {p..+unat x}; q \<notin> {p..+unat y}; unat y \<le> unat x \<rbrakk> \<Longrightarrow>
      q \<in> {p + y..+unat x - unat y}"
  by (clarsimp simp: intvl_def) (rule_tac x="k - unat y" in exI, auto)

lemma intvl_plus_sub_offset:
  "x \<in> {p + y..+q - unat y} \<Longrightarrow> x \<in> {p..+q}"
  by (clarsimp simp: intvl_def) (rule_tac x="k + unat y" in exI, auto)

lemma intvl_plus_sub_Suc:
  "x \<in> {p + 1..+q - Suc 0} \<Longrightarrow> x \<in> {p..+q}"
  by (rule intvl_plus_sub_offset [where y=1], simp)

lemma intvl_neq_start:
  "\<lbrakk> (q::'a::len word) \<in> {p..+n}; p \<noteq> q \<rbrakk> \<Longrightarrow> q \<in> {p + 1..+n - Suc 0}"
  apply (clarsimp simp: intvl_def)
  by (metis One_nat_def Suc_eq_plus1 gr0_conv_Suc less_diff_conv not_gr_zero of_nat_Suc
            semiring_1_class.of_nat_0)

lemmas unat_simps' =
  word_arith_nat_defs unat_of_nat len_of_addr_card mod_less

lemma intvl_offset_nmem:
  "\<lbrakk> q \<in> {(p::'a::len word)..+unat x}; y \<le>  2^len_of TYPE('a) - unat x \<rbrakk> \<Longrightarrow>
      q \<notin> {p + x..+y}"
  apply (clarsimp simp: intvl_def)
  apply (simp only: unat_simps')
  apply (subst (asm) word_of_nat_eq_iff)
  using take_bit_nat_eq_self by auto

lemma intvl_Suc_nmem' [simp]:
  "n < 2^len_of TYPE('a) \<Longrightarrow> (p::'a::len word) \<notin> {p + 1..+n - Suc 0}"
  by (clarsimp simp: intvl_def)
     (unat_arith, simp only: unat_simps')

lemma intvl_start_le:
  "x \<le> y \<Longrightarrow> {p..+x} \<subseteq> {p..+y}"
  by (force simp: intvl_def)

lemma intvl_sub_eq:
  assumes "x \<le> y"
  shows "{p + x..+unat (y - x)} = {p..+unat y} - {p..+unat x}"
proof -
  have "unat y - unat x \<le> 2 ^ len_of TYPE('a) - unat x"
    by (meson diff_le_mono less_or_eq_imp_le unsigned_less)
  moreover have "x \<le> y" by fact
  moreover from this have "unat (y - x) = unat y - unat x"
    by (simp add: word_le_nat_alt, unat_arith)
  ultimately show ?thesis
    by (force dest: intvl_offset_nmem intvl_mem_offset elim: intvl_plus_sub_offset
              simp: word_le_nat_alt)

qed

end


(*
 * Copyright (c) 2020, CleanQ Project - Systems Group, ETH Zurich
 * All rights reserved.
 *
 * This software may be distributed and modified according to the terms of
 * the BSD 2-Clause license. Note that NO WARRANTY is provided.
 *
 * See "LICENSE" for details.
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

section \<open>Set Model Simpl proofs\<close>

text \<open>
  Due to problems importing both SIMPL and COMPLX we split the files and have all the proofs
  using SIMPL in this file
\<close>

theory CleanQ_SetModel_Simpl
(*<*)
imports
  Main
  CleanQ_SetModel
  "../Simpl/Simpl"
begin
(*>*)

(*<*)
(* Define some global variables to make Simpl/Complex proofs work *)
record 'g CleanQ_Set_State_vars =
  SetRB_'  :: "nat CleanQ_Set_State"
(*>*)

(* ==================================================================================== *)
subsection \<open>Integration in SIMPL\<close>
(* ==================================================================================== *)

text \<open>
  We now integrate the the CleanQ Set Model into SIMPL. For each of the two operations,
  enqueue and dequeue, we specify a Hoare-triple with pre and post conditions, and
  the operation.
\<close>

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Enqueue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We first show, that we can define a Hoare triple for the enqueue operations from both
  agents X and Y, and that in both cases the invariant is preserved.
\<close>

lemma CleanQ_Set_enq_x_preserves_invariants :
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> SX \<acute>SetRB \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_enq_x b \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, simp only: CleanQ_Set_enq_x_Invariants)

lemma CleanQ_Set_enq_y_preserves_invariants :
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> SY \<acute>SetRB \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_enq_y b \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, simp only: CleanQ_Set_enq_y_Invariants)

text \<open>
  The same applies for the multi-step \verb+eneuque_n+ operation.
\<close>

lemma CleanQ_Set_enq_n_x_preserves_invariants :
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> (\<forall>b \<in> B. b \<in> (SX \<acute>SetRB)) \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_enq_n_x B \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  apply(vcg) using CleanQ_Set_enq_n_x_Invariants by blast

lemma CleanQ_Set_enq_n_y_preserves_invariants :
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> (\<forall>b \<in> B. b \<in> (SY \<acute>SetRB)) \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_enq_n_y B \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  apply(vcg) using CleanQ_Set_enq_n_y_Invariants by blast

text \<open>
  The enqueue operation  happens in two steps. The buffer element is removed
  from one set and added to a new set. We can express this as two sequential operations
  in the next lemma, where we show that the invariant is still preserved and that
  the outcome is the same, as with the definition above.
\<close>

lemma CleanQ_Set_enq_x_two_step:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> SX \<acute>SetRB \<rbrace>
        \<acute>SetRB :== \<acute>SetRB \<lparr> SX := (SX \<acute>SetRB) - {b} \<rparr> ;;
        \<acute>SetRB :== \<acute>SetRB \<lparr> TXY := (TXY \<acute>SetRB) \<union> {b} \<rparr>
      \<lbrace> \<acute>SetRB = CleanQ_Set_enq_x b rb' \<and> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, auto simp:CleanQ_Set_Invariants_simp CleanQ_Set_enq_x_def)

lemma CleanQ_Set_enq_y_two_step:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> SY \<acute>SetRB \<rbrace>
        \<acute>SetRB :== \<acute>SetRB \<lparr> SY := (SY \<acute>SetRB) - {b} \<rparr> ;;
        \<acute>SetRB :== \<acute>SetRB \<lparr> TYX := (TYX \<acute>SetRB) \<union> {b} \<rparr>
      \<lbrace> \<acute>SetRB = CleanQ_Set_enq_y b rb' \<and> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, auto simp:CleanQ_Set_Invariants_simp CleanQ_Set_enq_y_def)

text \<open>
  Next we can define this conditionally, where we only execute the enqueue operation,
  when we are owning the buffer.
\<close>

lemma CleanQ_Set_enq_x_conditional :
  "\<Gamma>\<turnstile> \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>
         IF b \<in> SX \<acute>SetRB THEN
          \<acute>SetRB :== (CleanQ_Set_enq_x b \<acute>SetRB)
         FI
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<notin> (SX \<acute>SetRB) \<rbrace>"
  by(vcg, auto simp:CleanQ_Set_enq_x_Invariants CleanQ_Set_enq_x_def
                    CleanQ_Set_Invariants_simp)

lemma CleanQ_Set_enq_y_conditional :
  "\<Gamma>\<turnstile> \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>
         IF b \<in> SY \<acute>SetRB THEN
          \<acute>SetRB :== (CleanQ_Set_enq_y b \<acute>SetRB)
         FI
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<and>  b \<notin> (SY \<acute>SetRB) \<rbrace>"
  by(vcg, auto simp:CleanQ_Set_enq_y_Invariants CleanQ_Set_enq_y_def
                    CleanQ_Set_Invariants_simp)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Dequeue Operation\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We first show, that we can define a Hoare triple for the dequeue operations from both
  agents X and Y, and that in both cases the invariant is preserved.
\<close>

lemma CleanQ_Set_deq_x_preserves_invariants:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> TYX \<acute>SetRB \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_deq_x b \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, simp only: CleanQ_Set_deq_x_Invariants)

lemma CleanQ_Set_deq_y_preserves_invariants:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> TXY \<acute>SetRB \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_deq_y b \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, simp only: CleanQ_Set_deq_y_Invariants)

text \<open>
  The same applies for the multi-step \verb+eneuque_n+ operation.
\<close>

lemma CleanQ_Set_deq_n_x_preserves_invariants:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> (\<forall> b \<in> B. b \<in> TYX \<acute>SetRB) \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_deq_n_x B \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  apply(vcg) using CleanQ_Set_deq_n_x_Invariants by blast

lemma CleanQ_Set_deq_n_y_preserves_invariants:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> (\<forall> b \<in> B. b \<in> TXY \<acute>SetRB) \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_deq_n_y B \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  apply(vcg) using CleanQ_Set_deq_n_y_Invariants by blast

text \<open>
  The dequeue operation effectively happens in two steps. The buffer element is removed
  from one set and added to a new set. We can express this as two sequential operations
  in the next lemma, where we show that the invariant is still preserved and that
  the outcome is the same, as with the definition above.
\<close>

lemma CleanQ_Set_deq_x_two_step:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> TYX \<acute>SetRB \<rbrace>
        \<acute>SetRB :== \<acute>SetRB \<lparr> TYX := (TYX \<acute>SetRB) - {b} \<rparr> ;;
        \<acute>SetRB :== \<acute>SetRB \<lparr> SX := (SX \<acute>SetRB) \<union> {b} \<rparr>
      \<lbrace> \<acute>SetRB = CleanQ_Set_deq_x b rb' \<and> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, simp add: CleanQ_Set_deq_x_def CleanQ_Set_Invariants_simp, auto)

lemma CleanQ_Set_deq_y_two_step:
  "\<Gamma>\<turnstile> \<lbrace> rb' = \<acute>SetRB \<and> CleanQ_Set_Invariants K \<acute>SetRB \<and> b \<in> TXY \<acute>SetRB \<rbrace>
        \<acute>SetRB :== \<acute>SetRB \<lparr> TXY := (TXY \<acute>SetRB) - {b} \<rparr> ;;
        \<acute>SetRB :== \<acute>SetRB \<lparr> SY := (SY \<acute>SetRB) \<union> {b} \<rparr>
      \<lbrace> \<acute>SetRB = CleanQ_Set_deq_y b rb' \<and> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by(vcg, simp add: CleanQ_Set_deq_y_def CleanQ_Set_Invariants_simp, auto)

text \<open>
  Next we can define this conditionally, where we only execute the enqueue operation,
  when we are owning the buffer
\<close>

lemma CleanQ_Set_deq_x_conditional:
  "\<Gamma>\<turnstile> \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>
         IF b \<in> TYX \<acute>SetRB THEN
          \<acute>SetRB :== (CleanQ_Set_deq_x b \<acute>SetRB)
         FI
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by (vcg, meson CleanQ_Set_deq_x_Invariants)

lemma CleanQ_Set_deq_y_conditional:
  "\<Gamma>\<turnstile> \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>
         IF b \<in> TXY \<acute>SetRB THEN
          \<acute>SetRB :== (CleanQ_Set_deq_y b \<acute>SetRB)
         FI
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<rbrace>"
  by (vcg, meson CleanQ_Set_deq_y_Invariants)

(* ------------------------------------------------------------------------------------ *)
subsubsection \<open>Combining Enqueue and Dequeue\<close>
(* ------------------------------------------------------------------------------------ *)

text \<open>
  We can now combine the enqeueue and dequeue operations and pass a buffer around the
  queue and back to the originator. We prove this by showing the state is the same.
\<close>

lemma CleanQ_Set_ops_combine :
  "\<Gamma>\<turnstile> \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<and> rb = \<acute>SetRB \<and> b \<in> SX \<acute>SetRB \<rbrace>
        \<acute>SetRB :== (CleanQ_Set_enq_x b \<acute>SetRB) ;;
        \<acute>SetRB :== (CleanQ_Set_deq_y b \<acute>SetRB) ;;
        \<acute>SetRB :== (CleanQ_Set_enq_y b \<acute>SetRB) ;;
        \<acute>SetRB :== (CleanQ_Set_deq_x b \<acute>SetRB)
      \<lbrace> CleanQ_Set_Invariants K \<acute>SetRB \<and> rb = \<acute>SetRB \<and> b \<in> SX \<acute>SetRB \<rbrace>"
  apply(vcg, auto simp:CleanQ_Set_ops CleanQ_Set_Invariants_simp)
  using insert_absorb by fastforce

(*<*)
end
(*>*)


theory Short_Theory_8_3_1
  imports "HOL-IMP.Big_Step" "HOL-IMP.Star"
begin
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

subsection "mmap setup"

lemma bij_cancel_r [simp]: "\<lbrakk>bij b; f \<circ> b = g \<circ> b\<rbrakk> \<Longrightarrow> f = g"
  by (metis bij_betw_def surj_fun_eq)

lemma bij_comp_update [simp]: "bij b \<Longrightarrow> (f \<circ> b) (x := y) = (f ((b x) := y)) \<circ> b"
proof
  fix xa
  assume "bij b"
  show "((f \<circ> b)(x := y)) xa = (f(b x := y) \<circ> b) xa"
  proof (cases "xa = x")
    case False
    then have "((f \<circ> b)(x := y)) xa = f (b xa)" by simp
    also from \<open>bij b\<close> False have "b xa \<noteq> b x" by (meson bij_def inj_def)
    then have "f (b xa) = (f(b x := y) \<circ> b) xa" by simp
    finally show ?thesis .
  qed simp
qed

lemma bij_cancel_r2: "bij b \<Longrightarrow> \<exists> g. f = g \<circ> b" by (metis bij_is_inj o_inv_o_cancel)

subsection "List setup"

fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
  "(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))" |
  "[] !! i = undefined"

lemma inth_append [simp]: "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induct xs arbitrary: i) (auto simp: algebra_simps)

abbreviation (output) "isize xs == int (length xs)"

notation isize ("size")

subsection "Instructions and Stack Machine"

type_synonym addr = int

datatype instr =
  LOADI int | LOAD addr |
  ADD |
  STORE addr |
  JMP int | JMPLESS int | JMPGE int

type_synonym stack = "val list"
type_synonym mem_state = "addr \<Rightarrow> val"
type_synonym mmap = "vname \<Rightarrow> addr"
type_synonym config = "int \<times> mem_state \<times> stack"

abbreviation "hd2 xs == hd (tl xs)"
abbreviation "tl2 xs == tl (tl xs)"

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
  "iexec (LOADI n) (i, s, stk) = (i + 1, s, n # stk)" |
  "iexec (LOAD a) (i, s, stk) = (i + 1, s, s a # stk)" |
  "iexec ADD (i, s, stk) = (i + 1, s, (hd2 stk + hd stk) # tl2 stk)" |
  "iexec (STORE a) (i, s, stk) = (i + 1, s(a := hd stk), tl stk)" |
  "iexec (JMP n) (i, s, stk) = (i + 1 + n, s, stk)" |
  "iexec (JMPLESS n) (i, s, stk) = (if hd2 stk < hd stk then i + 1 + n else i + 1, s, tl2 stk)" |
  "iexec (JMPGE n) (i, s, stk) = (if hd2 stk >= hd stk then i + 1 + n else i + 1, s, tl2 stk)"

definition exec1 :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>/ _))" [59,0,59] 60)  where
  "P \<turnstile> c \<rightarrow> c' \<longleftrightarrow>
  (\<exists>i s stk. c = (i, s, stk) \<and> c' = iexec (P !! i) (i, s, stk) \<and> 0 \<le> i \<and> i < size P)"

(* an introduction rule that expects the LHS config parameters to already be known *)
lemma exec1I [intro, code_pred_intro]:
  "c' = iexec (P !! i) (i, s, stk) \<Longrightarrow>
  0 \<le> i \<Longrightarrow> i < size P \<Longrightarrow>
  P \<turnstile> (i, s, stk) \<rightarrow> c'"
  by (simp add: exec1_def)
code_pred exec1 by (metis exec1_def)

abbreviation exec :: "instr list \<Rightarrow> config \<Rightarrow> config \<Rightarrow> bool"
  ("(_/ \<turnstile> (_ \<rightarrow>*/ _))" 50) where
  "exec P \<equiv> star (exec1 P)"

lemmas exec_induct = star.induct [of "exec1 P", split_format(complete)]

subsection\<open>Verification infrastructure\<close>

lemma iexec_shift [simp]:
  "(n + i', s', stk') = iexec x (n + i, s, stk) \<longleftrightarrow>
  (i', s', stk') = iexec x (i, s, stk)"
  by (cases x, auto)

(* trivial: iexec (P !! i) depends only on first i elements of P, and 0 \<le> i < size P *)
lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow> c'"
  by (auto simp add: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P @ P' \<turnstile> c \<rightarrow>* c'"
  by (induct rule: star.induct) (blast intro: star.step exec1_appendR)+

lemma exec1_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow> (i', s', stk') \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow> (size P' + i', s', stk')"
  by (auto simp add: exec1_def)

lemma exec_appendL:
  fixes i i' :: int
  shows "P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')  \<Longrightarrow>
    P' @ P \<turnstile> (size P' + i, s, stk) \<rightarrow>* (size P' + i', s', stk')"
  by (induct rule: exec_induct) (blast intro: star.step exec1_appendL)+

(* specialize append lemmas to discuss execution through concrete instructions
  while assuming the execution of preceding and following code.
*)
lemma exec_Cons_1 [intro]:
  "P \<turnstile> (0, s, stk) \<rightarrow>* (j, t, stk') \<Longrightarrow>
  instr # P \<turnstile> (1, s, stk) \<rightarrow>* (1 + j, t, stk')"
  by (drule exec_appendL [where P'="[instr]"]) simp

(* as exec_appendL, with (i := i - size P'), precondition necessary to satisfy exec1 precondition *)
lemma exec_appendL_if [intro]:
  fixes i i' j :: int
  shows "size P' <= i \<Longrightarrow>
    P \<turnstile> (i - size P', s, stk) \<rightarrow>* (j, s', stk') \<Longrightarrow>
    i' = size P' + j \<Longrightarrow>
    P' @ P \<turnstile> (i, s, stk) \<rightarrow>* (i', s', stk')"
  by (drule exec_appendL [where P'=P']) simp

lemma exec_append_trans[intro]:
  fixes i' i'' j'' :: int
  shows "P \<turnstile> (0, s, stk) \<rightarrow>* (i', s', stk') \<Longrightarrow>
    size P \<le> i' \<Longrightarrow>
    P' \<turnstile>  (i' - size P, s', stk') \<rightarrow>* (i'', s'', stk'') \<Longrightarrow>
    j'' = size P + i'' \<Longrightarrow>
    P @ P' \<turnstile> (0, s, stk) \<rightarrow>* (j'', s'', stk'')"
  by(metis star_trans [OF exec_appendR exec_appendL_if])

declare Let_def[simp]

subsection "Compilation"

fun acomp :: "mmap \<Rightarrow> aexp \<Rightarrow> instr list" where
  "acomp m (N n) = [LOADI n]" |
  "acomp m (V x) = [LOAD (m x)]" |
  "acomp m (Plus a1 a2) = acomp m a1 @ acomp m a2 @ [ADD]"

lemma acomp_correct[intro]:
  "acomp m a \<turnstile> (0, s, stk) \<rightarrow>* (size (acomp m a), s, aval a (s \<circ> m) # stk)"
  by (induction a arbitrary: stk) fastforce+

fun bcomp :: "mmap \<Rightarrow> bexp \<Rightarrow> bool \<Rightarrow> int \<Rightarrow> instr list" where
  "bcomp m (Bc v) f n = (if v = f then [JMP n] else [])" |
  "bcomp m (Not b) f n = bcomp m b (\<not>f) n" |
  "bcomp m (And b1 b2) f n = (let
    cb2 = bcomp m b2 f n;
    n' = if f
      then size cb2
      else size cb2 + n;
    cb1 = bcomp m b1 False n' in
    cb1 @ cb2)" |
  "bcomp m (Less a1 a2) f n =
    acomp m a1 @ acomp m a2 @ (if f then [JMPLESS n] else [JMPGE n])"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp m b f n \<turnstile>
 (0, s, stk) \<rightarrow>* (size (bcomp m b f n) + (if f = bval b (s \<circ> m) then n else 0), s, stk)"
proof (induct b arbitrary: f n)
  case (Not b)
  from Not(1) Not(2) have "bcomp m b (\<not> f) n \<turnstile> (0, s, stk) \<rightarrow>* (size (bcomp m b (\<not> f) n) + (if (\<not> f) = bval b (s \<circ> m) then n else 0), s, stk)" .
  moreover have "?this \<longleftrightarrow> (bcomp m (bexp.Not b) f n \<turnstile> (0, s, stk) \<rightarrow>* (size (bcomp m (bexp.Not b) f n) + (if f = bval (bexp.Not b) (s \<circ> m) then n else 0), s, stk))" by simp
  ultimately show ?case by blast
next
  case (And b1 b2)
  let ?sm = "s \<circ> m"
  let ?bc2 = "bcomp m b2 f n" and ?bv2 = "bval b2 ?sm"
  let ?sizeb2 = "size ?bc2"

  let ?n' = "if f then ?sizeb2 else ?sizeb2 + n"
  let ?bc1 = "bcomp m b1 False ?n'" and ?bv1 = "bval b1 ?sm"
  let ?sizeb1 = "size ?bc1"

  let ?bcAnd = "bcomp m (And b1 b2) f n"
    and ?bvAnd = "bval (And b1 b2) ?sm"
  let ?sizeAnd = "size ?bcAnd"

  from And(2) And(3) have H2: "?bc2 \<turnstile> (0, s, stk) \<rightarrow>* (?sizeb2 + (if f = ?bv2 then n else 0), s, stk)" .
  from And(3) And(1) [of ?n' "False"] have H1: "?bc1 \<turnstile>
    (0, s, stk) \<rightarrow>* (?sizeb1 + (if False = ?bv1 then ?n' else 0), s, stk)" by fastforce
  show "?bcAnd \<turnstile> (0, s, stk) \<rightarrow>* (?sizeAnd + (if f = ?bvAnd then n else 0), s, stk)" (is ?P)
  proof (cases ?bv1)
    case True
    with H1 H2 show ?thesis by auto
  next
    case Hbv1: False
    show ?thesis
    proof (cases f)
      case Hf: True
      with Hbv1 Hf H1 show ?thesis by auto
    next
      case Hf: False
      from Hf Hbv1 H1 have H1': "?bc1 \<turnstile> (0, s, stk) \<rightarrow>* (?sizeAnd + n, s, stk)" by (simp add: add.assoc)
      then have "?bcAnd \<turnstile> (0, s, stk) \<rightarrow>* (?sizeAnd + n, s, stk)" using exec_appendR by auto
      with Hbv1 Hf H1 show ?thesis by auto
    qed
  qed
qed fastforce+

fun ccomp :: "mmap \<Rightarrow> com \<Rightarrow> instr list" where
  "ccomp m SKIP = []" |
  "ccomp m (x ::= a) = acomp m a @ [STORE (m x)]" |
  "ccomp m (c\<^sub>1;; c\<^sub>2) = ccomp m c\<^sub>1 @ ccomp m c\<^sub>2" |
  "ccomp m (IF b THEN c\<^sub>1 ELSE c\<^sub>2) = (let
    cc\<^sub>1 = ccomp m c\<^sub>1;
    cc\<^sub>2 = ccomp m c\<^sub>2;
    cb = bcomp m b False (size cc\<^sub>1 + 1) in
    cb @ cc\<^sub>1 @ JMP (size cc\<^sub>2) # cc\<^sub>2)" |
  "ccomp m (WHILE b DO c) = (let
    cc = ccomp m c;
    cb = bcomp m b False (size cc + 1) in
    cb @ cc @ [JMP (-(size cb + size cc + 1))])"

lemma ccomp_bigstep:
  "\<lbrakk>(c, s \<circ> m) \<Rightarrow> (t \<circ> m); bij m\<rbrakk> \<Longrightarrow> ccomp m c \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp m c), t, stk)"
proof (induct c "s \<circ> m" "t \<circ> m" arbitrary: s t m stk rule: big_step_induct)
  case (Skip s)
  then have "s = t" by simp
  then show ?case by simp
next
  case (Assign x a s)
  then have "s((m x) := aval a (s \<circ> m)) = t" by simp
  then show ?case by fastforce
next
  case (Seq c\<^sub>1 s\<^sub>2m c\<^sub>2)
  from Seq(5) obtain s\<^sub>2 where Hs\<^sub>2: "s\<^sub>2m = s\<^sub>2 \<circ> m" using bij_cancel_r2 by auto
  with Seq(2, 5) have H1: "ccomp m c\<^sub>1 \<turnstile> (0, s, stk) \<rightarrow>* (size (ccomp m c\<^sub>1), s\<^sub>2, stk)" by auto
  from Hs\<^sub>2 Seq(4, 5) have H2: "ccomp m c\<^sub>2 \<turnstile> (0, s\<^sub>2, stk) \<rightarrow>* (size (ccomp m c\<^sub>2), t, stk)" by auto
  from H1 H2 show ?case by auto
next
  case (WhileFalse b c)
  from WhileFalse(2, 3) have "s = t" by simp
  with WhileFalse(1) show ?case by fastforce
next
  case (WhileTrue b c s\<^sub>2m)
  let ?cc = "ccomp m c" and ?cw = "ccomp m (WHILE b DO c)"
  let ?cb = "bcomp m b False (size ?cc + 1)"
  from WhileTrue(1) have "?cw \<turnstile> (0, s, stk) \<rightarrow>* (size ?cb, s, stk)" by fastforce
  moreover from WhileTrue(6) obtain s\<^sub>2 where Hs\<^sub>2: "s\<^sub>2m = s\<^sub>2 \<circ> m" using bij_cancel_r2 by auto
  with WhileTrue(3, 6) have "?cw \<turnstile> (size ?cb, s, stk) \<rightarrow>* (size ?cb + size ?cc, s\<^sub>2, stk)" by fastforce
  moreover have "?cw \<turnstile> (size ?cb + size ?cc, s\<^sub>2, stk) \<rightarrow>* (0, s\<^sub>2, stk)" by fastforce
  moreover from Hs\<^sub>2 WhileTrue(5, 6) have "?cw \<turnstile> (0, s\<^sub>2, stk) \<rightarrow>* (size (ccomp m (WHILE b DO c)), t, stk)" by simp
  ultimately show ?case by (blast intro: star_trans)
qed fastforce+

end


(*  Title:      HOL/Imperative_HOL/Heap_Monad.thy
    Author:     John Matthews, Galois Connections; Alexander Krauss, Lukas Bulwahn & Florian Haftmann, TU Muenchen
*)

section {* A monad with a polymorphic heap and primitive reasoning infrastructure *}

theory Heap_Monad
imports
  Heap
  "~~/src/HOL/Library/Monad_Syntax"
begin

subsection {* The monad *}

subsubsection {* Monad construction *}

text {* Monadic heap actions either produce values
  and transform the heap, or fail *}
datatype 'a Heap = Heap "heap \<Rightarrow> ('a \<times> heap) option"

lemma [code, code del]:
  "(Code_Evaluation.term_of :: 'a::typerep Heap \<Rightarrow> Code_Evaluation.term) = Code_Evaluation.term_of"
  ..

primrec execute :: "'a Heap \<Rightarrow> heap \<Rightarrow> ('a \<times> heap) option" where
  [code del]: "execute (Heap f) = f"

lemma Heap_cases [case_names succeed fail]:
  fixes f and h
  assumes succeed: "\<And>x h'. execute f h = Some (x, h') \<Longrightarrow> P"
  assumes fail: "execute f h = None \<Longrightarrow> P"
  shows P
  using assms by (cases "execute f h") auto

lemma Heap_execute [simp]:
  "Heap (execute f) = f" by (cases f) simp_all

lemma Heap_eqI:
  "(\<And>h. execute f h = execute g h) \<Longrightarrow> f = g"
    by (cases f, cases g) (auto simp: fun_eq_iff)

named_theorems execute_simps "simplification rules for execute"

lemma execute_Let [execute_simps]:
  "execute (let x = t in f x) = (let x = t in execute (f x))"
  by (simp add: Let_def)

subsubsection {* Specialised lifters *}

definition tap :: "(heap \<Rightarrow> 'a) \<Rightarrow> 'a Heap" where
  [code del]: "tap f = Heap (\<lambda>h. Some (f h, h))"

lemma execute_tap [execute_simps]:
  "execute (tap f) h = Some (f h, h)"
  by (simp add: tap_def)

definition heap :: "(heap \<Rightarrow> 'a \<times> heap) \<Rightarrow> 'a Heap" where
  [code del]: "heap f = Heap (Some \<circ> f)"

lemma execute_heap [execute_simps]:
  "execute (heap f) = Some \<circ> f"
  by (simp add: heap_def)

definition guard :: "(heap \<Rightarrow> bool) \<Rightarrow> (heap \<Rightarrow> 'a \<times> heap) \<Rightarrow> 'a Heap" where
  [code del]: "guard P f = Heap (\<lambda>h. if P h then Some (f h) else None)"

lemma execute_guard [execute_simps]:
  "\<not> P h \<Longrightarrow> execute (guard P f) h = None"
  "P h \<Longrightarrow> execute (guard P f) h = Some (f h)"
  by (simp_all add: guard_def)

subsubsection {* Predicate classifying successful computations *}

definition success :: "'a Heap \<Rightarrow> heap \<Rightarrow> bool" where
  "success f h \<longleftrightarrow> execute f h \<noteq> None"

lemma successI:
  "execute f h \<noteq> None \<Longrightarrow> success f h"
  by (simp add: success_def)

lemma successE:
  assumes "success f h"
  obtains r h' where "execute f h = Some (r, h')"
  using assms by (auto simp: success_def)

named_theorems success_intros "introduction rules for success"

lemma success_tapI [success_intros]:
  "success (tap f) h"
  by (rule successI) (simp add: execute_simps)

lemma success_heapI [success_intros]:
  "success (heap f) h"
  by (rule successI) (simp add: execute_simps)

lemma success_guardI [success_intros]:
  "P h \<Longrightarrow> success (guard P f) h"
  by (rule successI) (simp add: execute_guard)

lemma success_LetI [success_intros]:
  "x = t \<Longrightarrow> success (f x) h \<Longrightarrow> success (let x = t in f x) h"
  by (simp add: Let_def)

lemma success_ifI:
  "(c \<Longrightarrow> success t h) \<Longrightarrow> (\<not> c \<Longrightarrow> success e h) \<Longrightarrow>
    success (if c then t else e) h"
  by (simp add: success_def)

subsubsection {* Predicate for a simple relational calculus *}

text {*
  The @{text effect} predicate states that when a computation @{text c}
  runs with the heap @{text h} will result in return value @{text r}
  and a heap @{text "h'"}, i.e.~no exception occurs.
*}

definition effect :: "'a Heap \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> 'a \<Rightarrow> bool" where
  effect_def: "effect c h h' r \<longleftrightarrow> execute c h = Some (r, h')"

lemma effectI:
  "execute c h = Some (r, h') \<Longrightarrow> effect c h h' r"
  by (simp add: effect_def)

lemma effectE:
  assumes "effect c h h' r"
  obtains "r = fst (the (execute c h))"
    and "h' = snd (the (execute c h))"
    and "success c h"
proof (rule that)
  from assms have *: "execute c h = Some (r, h')" by (simp add: effect_def)
  then show "success c h" by (simp add: success_def)
  from * have "fst (the (execute c h)) = r" and "snd (the (execute c h)) = h'"
    by simp_all
  then show "r = fst (the (execute c h))"
    and "h' = snd (the (execute c h))" by simp_all
qed

lemma effect_success:
  "effect c h h' r \<Longrightarrow> success c h"
  by (simp add: effect_def success_def)

lemma success_effectE:
  assumes "success c h"
  obtains r h' where "effect c h h' r"
  using assms by (auto simp add: effect_def success_def)

lemma effect_deterministic:
  assumes "effect f h h' a"
    and "effect f h h'' b"
  shows "a = b" and "h' = h''"
  using assms unfolding effect_def by auto

named_theorems effect_intros "introduction rules for effect"
  and effect_elims "elimination rules for effect"

lemma effect_LetI [effect_intros]:
  assumes "x = t" "effect (f x) h h' r"
  shows "effect (let x = t in f x) h h' r"
  using assms by simp

lemma effect_LetE [effect_elims]:
  assumes "effect (let x = t in f x) h h' r"
  obtains "effect (f t) h h' r"
  using assms by simp

lemma effect_ifI:
  assumes "c \<Longrightarrow> effect t h h' r"
    and "\<not> c \<Longrightarrow> effect e h h' r"
  shows "effect (if c then t else e) h h' r"
  by (cases c) (simp_all add: assms)

lemma effect_ifE:
  assumes "effect (if c then t else e) h h' r"
  obtains "c" "effect t h h' r"
    | "\<not> c" "effect e h h' r"
  using assms by (cases c) simp_all

lemma effect_tapI [effect_intros]:
  assumes "h' = h" "r = f h"
  shows "effect (tap f) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_tapE [effect_elims]:
  assumes "effect (tap f) h h' r"
  obtains "h' = h" and "r = f h"
  using assms by (rule effectE) (auto simp add: execute_simps)

lemma effect_heapI [effect_intros]:
  assumes "h' = snd (f h)" "r = fst (f h)"
  shows "effect (heap f) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_heapE [effect_elims]:
  assumes "effect (heap f) h h' r"
  obtains "h' = snd (f h)" and "r = fst (f h)"
  using assms by (rule effectE) (simp add: execute_simps)

lemma effect_guardI [effect_intros]:
  assumes "P h" "h' = snd (f h)" "r = fst (f h)"
  shows "effect (guard P f) h h' r"
  by (rule effectI) (simp add: assms execute_simps)

lemma effect_guardE [effect_elims]:
  assumes "effect (guard P f) h h' r"
  obtains "h' = snd (f h)" "r = fst (f h)" "P h"
  using assms by (rule effectE)
    (auto simp add: execute_simps elim!: successE, cases "P h", auto simp add: execute_simps)

subsubsection {* Monad combinators *}

definition return :: "'a \<Rightarrow> 'a Heap" where
  [code del]: "return x = heap (Pair x)"

lemma execute_return [execute_simps]:
  "execute (return x) = Some \<circ> Pair x"
  by (simp add: return_def execute_simps)

lemma success_returnI [success_intros]:
  "success (return x) h"
  by (rule successI) (simp add: execute_simps)

lemma effect_returnI [effect_intros]:
  "h = h' \<Longrightarrow> effect (return x) h h' x"
  by (rule effectI) (simp add: execute_simps)

lemma effect_returnE [effect_elims]:
  assumes "effect (return x) h h' r"
  obtains "r = x" "h' = h"
  using assms by (rule effectE) (simp add: execute_simps)

definition raise :: "string \<Rightarrow> 'a Heap" where -- {* the string is just decoration *}
  [code del]: "raise s = Heap (\<lambda>_. None)"

lemma execute_raise [execute_simps]:
  "execute (raise s) = (\<lambda>_. None)"
  by (simp add: raise_def)

lemma effect_raiseE [effect_elims]:
  assumes "effect (raise x) h h' r"
  obtains "False"
  using assms by (rule effectE) (simp add: success_def execute_simps)

definition bind :: "'a Heap \<Rightarrow> ('a \<Rightarrow> 'b Heap) \<Rightarrow> 'b Heap" where
  [code del]: "bind f g = Heap (\<lambda>h. case execute f h of
                  Some (x, h') \<Rightarrow> execute (g x) h'
                | None \<Rightarrow> None)"

adhoc_overloading
  Monad_Syntax.bind Heap_Monad.bind

lemma execute_bind [execute_simps]:
  "execute f h = Some (x, h') \<Longrightarrow> execute (f \<guillemotright>= g) h = execute (g x) h'"
  "execute f h = None \<Longrightarrow> execute (f \<guillemotright>= g) h = None"
  by (simp_all add: bind_def)

lemma execute_bind_case:
  "execute (f \<guillemotright>= g) h = (case (execute f h) of
    Some (x, h') \<Rightarrow> execute (g x) h' | None \<Rightarrow> None)"
  by (simp add: bind_def)

lemma execute_bind_success:
  "success f h \<Longrightarrow> execute (f \<guillemotright>= g) h = execute (g (fst (the (execute f h)))) (snd (the (execute f h)))"
  by (cases f h rule: Heap_cases) (auto elim: successE simp add: bind_def)

lemma success_bind_executeI:
  "execute f h = Some (x, h') \<Longrightarrow> success (g x) h' \<Longrightarrow> success (f \<guillemotright>= g) h"
  by (auto intro!: successI elim: successE simp add: bind_def)

lemma success_bind_effectI [success_intros]:
  "effect f h h' x \<Longrightarrow> success (g x) h' \<Longrightarrow> success (f \<guillemotright>= g) h"
  by (auto simp add: effect_def success_def bind_def)

lemma effect_bindI [effect_intros]:
  assumes "effect f h h' r" "effect (g r) h' h'' r'"
  shows "effect (f \<guillemotright>= g) h h'' r'"
  using assms
  apply (auto intro!: effectI elim!: effectE successE)
  apply (subst execute_bind, simp_all)
  done

lemma effect_bindE [effect_elims]:
  assumes "effect (f \<guillemotright>= g) h h'' r'"
  obtains h' r where "effect f h h' r" "effect (g r) h' h'' r'"
  using assms by (auto simp add: effect_def bind_def split: option.split_asm)

lemma execute_bind_eq_SomeI:
  assumes "execute f h = Some (x, h')"
    and "execute (g x) h' = Some (y, h'')"
  shows "execute (f \<guillemotright>= g) h = Some (y, h'')"
  using assms by (simp add: bind_def)

lemma return_bind [simp]: "return x \<guillemotright>= f = f x"
  by (rule Heap_eqI) (simp add: execute_simps)

lemma bind_return [simp]: "f \<guillemotright>= return = f"
  by (rule Heap_eqI) (simp add: bind_def execute_simps split: option.splits)

lemma bind_bind [simp]: "(f \<guillemotright>= g) \<guillemotright>= k = (f :: 'a Heap) \<guillemotright>= (\<lambda>x. g x \<guillemotright>= k)"
  by (rule Heap_eqI) (simp add: bind_def execute_simps split: option.splits)

lemma raise_bind [simp]: "raise e \<guillemotright>= f = raise e"
  by (rule Heap_eqI) (simp add: execute_simps)

subsection {* Generic combinators *}

subsubsection {* Assertions *}

definition assert :: "('a \<Rightarrow> bool) \<Rightarrow> 'a \<Rightarrow> 'a Heap" where
  "assert P x = (if P x then return x else raise ''assert'')"

lemma execute_assert [execute_simps]:
  "P x \<Longrightarrow> execute (assert P x) h = Some (x, h)"
  "\<not> P x \<Longrightarrow> execute (assert P x) h = None"
  by (simp_all add: assert_def execute_simps)

lemma success_assertI [success_intros]:
  "P x \<Longrightarrow> success (assert P x) h"
  by (rule successI) (simp add: execute_assert)

lemma effect_assertI [effect_intros]:
  "P x \<Longrightarrow> h' = h \<Longrightarrow> r = x \<Longrightarrow> effect (assert P x) h h' r"
  by (rule effectI) (simp add: execute_assert)

lemma effect_assertE [effect_elims]:
  assumes "effect (assert P x) h h' r"
  obtains "P x" "r = x" "h' = h"
  using assms by (rule effectE) (cases "P x", simp_all add: execute_assert success_def)

lemma assert_cong [fundef_cong]:
  assumes "P = P'"
  assumes "\<And>x. P' x \<Longrightarrow> f x = f' x"
  shows "(assert P x >>= f) = (assert P' x >>= f')"
  by (rule Heap_eqI) (insert assms, simp add: assert_def)

subsubsection {* Plain lifting *}

definition lift :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b Heap" where
  "lift f = return o f"

lemma lift_collapse [simp]:
  "lift f x = return (f x)"
  by (simp add: lift_def)

lemma bind_lift:
  "(f \<guillemotright>= lift g) = (f \<guillemotright>= (\<lambda>x. return (g x)))"
  by (simp add: lift_def comp_def)

subsubsection {* Iteration -- warning: this is rarely useful! *}

primrec fold_map :: "('a \<Rightarrow> 'b Heap) \<Rightarrow> 'a list \<Rightarrow> 'b list Heap" where
  "fold_map f [] = return []"
| "fold_map f (x # xs) = do {
     y \<leftarrow> f x;
     ys \<leftarrow> fold_map f xs;
     return (y # ys)
   }"

lemma fold_map_append:
  "fold_map f (xs @ ys) = fold_map f xs \<guillemotright>= (\<lambda>xs. fold_map f ys \<guillemotright>= (\<lambda>ys. return (xs @ ys)))"
  by (induct xs) simp_all

lemma execute_fold_map_unchanged_heap [execute_simps]:
  assumes "\<And>x. x \<in> set xs \<Longrightarrow> \<exists>y. execute (f x) h = Some (y, h)"
  shows "execute (fold_map f xs) h =
    Some (List.map (\<lambda>x. fst (the (execute (f x) h))) xs, h)"
using assms proof (induct xs)
  case Nil show ?case by (simp add: execute_simps)
next
  case (Cons x xs)
  from Cons.prems obtain y
    where y: "execute (f x) h = Some (y, h)" by auto
  moreover from Cons.prems Cons.hyps have "execute (fold_map f xs) h =
    Some (map (\<lambda>x. fst (the (execute (f x) h))) xs, h)" by auto
  ultimately show ?case by (simp, simp only: execute_bind(1), simp add: execute_simps)
qed

subsection {* Partial function definition setup *}

definition Heap_ord :: "'a Heap \<Rightarrow> 'a Heap \<Rightarrow> bool" where
  "Heap_ord = img_ord execute (fun_ord option_ord)"

definition Heap_lub :: "'a Heap set \<Rightarrow> 'a Heap" where
  "Heap_lub = img_lub execute Heap (fun_lub (flat_lub None))"

lemma Heap_lub_empty: "Heap_lub {} = Heap Map.empty"
by(simp add: Heap_lub_def img_lub_def fun_lub_def flat_lub_def)

lemma heap_interpretation: "partial_function_definitions Heap_ord Heap_lub"
proof -
  have "partial_function_definitions (fun_ord option_ord) (fun_lub (flat_lub None))"
    by (rule partial_function_lift) (rule flat_interpretation)
  then have "partial_function_definitions (img_ord execute (fun_ord option_ord))
      (img_lub execute Heap (fun_lub (flat_lub None)))"
    by (rule partial_function_image) (auto intro: Heap_eqI)
  then show "partial_function_definitions Heap_ord Heap_lub"
    by (simp only: Heap_ord_def Heap_lub_def)
qed

interpretation heap!: partial_function_definitions Heap_ord Heap_lub
  where "Heap_lub {} \<equiv> Heap Map.empty"
by (fact heap_interpretation)(simp add: Heap_lub_empty)

lemma heap_step_admissible:
  "option.admissible
      (\<lambda>f:: 'a => ('b * 'c) option. \<forall>h h' r. f h = Some (r, h') \<longrightarrow> P x h h' r)"
proof (rule ccpo.admissibleI)
  fix A :: "('a \<Rightarrow> ('b * 'c) option) set"
  assume ch: "Complete_Partial_Order.chain option.le_fun A"
    and IH: "\<forall>f\<in>A. \<forall>h h' r. f h = Some (r, h') \<longrightarrow> P x h h' r"
  from ch have ch': "\<And>x. Complete_Partial_Order.chain option_ord {y. \<exists>f\<in>A. y = f x}" by (rule chain_fun)
  show "\<forall>h h' r. option.lub_fun A h = Some (r, h') \<longrightarrow> P x h h' r"
  proof (intro allI impI)
    fix h h' r assume "option.lub_fun A h = Some (r, h')"
    from flat_lub_in_chain[OF ch' this[unfolded fun_lub_def]]
    have "Some (r, h') \<in> {y. \<exists>f\<in>A. y = f h}" by simp
    then have "\<exists>f\<in>A. f h = Some (r, h')" by auto
    with IH show "P x h h' r" by auto
  qed
qed

lemma admissible_heap:
  "heap.admissible (\<lambda>f. \<forall>x h h' r. effect (f x) h h' r \<longrightarrow> P x h h' r)"
proof (rule admissible_fun[OF heap_interpretation])
  fix x
  show "ccpo.admissible Heap_lub Heap_ord (\<lambda>a. \<forall>h h' r. effect a h h' r \<longrightarrow> P x h h' r)"
    unfolding Heap_ord_def Heap_lub_def
  proof (intro admissible_image partial_function_lift flat_interpretation)
    show "option.admissible ((\<lambda>a. \<forall>h h' r. effect a h h' r \<longrightarrow> P x h h' r) \<circ> Heap)"
      unfolding comp_def effect_def execute.simps
      by (rule heap_step_admissible)
  qed (auto simp add: Heap_eqI)
qed

lemma fixp_induct_heap:
  fixes F :: "'c \<Rightarrow> 'c" and
    U :: "'c \<Rightarrow> 'b \<Rightarrow> 'a Heap" and
    C :: "('b \<Rightarrow> 'a Heap) \<Rightarrow> 'c" and
    P :: "'b \<Rightarrow> heap \<Rightarrow> heap \<Rightarrow> 'a \<Rightarrow> bool"
  assumes mono: "\<And>x. monotone (fun_ord Heap_ord) Heap_ord (\<lambda>f. U (F (C f)) x)"
  assumes eq: "f \<equiv> C (ccpo.fixp (fun_lub Heap_lub) (fun_ord Heap_ord) (\<lambda>f. U (F (C f))))"
  assumes inverse2: "\<And>f. U (C f) = f"
  assumes step: "\<And>f x h h' r. (\<And>x h h' r. effect (U f x) h h' r \<Longrightarrow> P x h h' r)
    \<Longrightarrow> effect (U (F f) x) h h' r \<Longrightarrow> P x h h' r"
  assumes defined: "effect (U f x) h h' r"
  shows "P x h h' r"
  using step defined heap.fixp_induct_uc[of U F C, OF mono eq inverse2 admissible_heap, of P]
  unfolding effect_def execute.simps
  by blast

declaration {* Partial_Function.init "heap" @{term heap.fixp_fun}
  @{term heap.mono_body} @{thm heap.fixp_rule_uc} @{thm heap.fixp_induct_uc}
  (SOME @{thm fixp_induct_heap}) *}

abbreviation "mono_Heap \<equiv> monotone (fun_ord Heap_ord) Heap_ord"

lemma Heap_ordI:
  assumes "\<And>h. execute x h = None \<or> execute x h = execute y h"
  shows "Heap_ord x y"
  using assms unfolding Heap_ord_def img_ord_def fun_ord_def flat_ord_def
  by blast

lemma Heap_ordE:
  assumes "Heap_ord x y"
  obtains "execute x h = None" | "execute x h = execute y h"
  using assms unfolding Heap_ord_def img_ord_def fun_ord_def flat_ord_def
  by atomize_elim blast

lemma bind_mono [partial_function_mono]:
  assumes mf: "mono_Heap B" and mg: "\<And>y. mono_Heap (\<lambda>f. C y f)"
  shows "mono_Heap (\<lambda>f. B f \<guillemotright>= (\<lambda>y. C y f))"
proof (rule monotoneI)
  fix f g :: "'a \<Rightarrow> 'b Heap" assume fg: "fun_ord Heap_ord f g"
  from mf
  have 1: "Heap_ord (B f) (B g)" by (rule monotoneD) (rule fg)
  from mg
  have 2: "\<And>y'. Heap_ord (C y' f) (C y' g)" by (rule monotoneD) (rule fg)

  have "Heap_ord (B f \<guillemotright>= (\<lambda>y. C y f)) (B g \<guillemotright>= (\<lambda>y. C y f))"
    (is "Heap_ord ?L ?R")
  proof (rule Heap_ordI)
    fix h
    from 1 show "execute ?L h = None \<or> execute ?L h = execute ?R h"
      by (rule Heap_ordE[where h = h]) (auto simp: execute_bind_case)
  qed
  also
  have "Heap_ord (B g \<guillemotright>= (\<lambda>y'. C y' f)) (B g \<guillemotright>= (\<lambda>y'. C y' g))"
    (is "Heap_ord ?L ?R")
  proof (rule Heap_ordI)
    fix h
    show "execute ?L h = None \<or> execute ?L h = execute ?R h"
    proof (cases "execute (B g) h")
      case None
      then have "execute ?L h = None" by (auto simp: execute_bind_case)
      thus ?thesis ..
    next
      case Some
      then obtain r h' where "execute (B g) h = Some (r, h')"
        by (metis surjective_pairing)
      then have "execute ?L h = execute (C r f) h'"
        "execute ?R h = execute (C r g) h'"
        by (auto simp: execute_bind_case)
      with 2[of r] show ?thesis by (auto elim: Heap_ordE)
    qed
  qed
  finally (heap.leq_trans)
  show "Heap_ord (B f \<guillemotright>= (\<lambda>y. C y f)) (B g \<guillemotright>= (\<lambda>y'. C y' g))" .
qed

subsection {* Code generator setup *}

subsubsection {* Logical intermediate layer *}

definition raise' :: "String.literal \<Rightarrow> 'a Heap" where
  [code del]: "raise' s = raise (String.explode s)"

lemma [code_abbrev]: "raise' (STR s) = raise s"
  unfolding raise'_def by (simp add: STR_inverse)

lemma raise_raise': (* FIXME delete candidate *)
  "raise s = raise' (STR s)"
  unfolding raise'_def by (simp add: STR_inverse)

code_datatype raise' -- {* avoid @{const "Heap"} formally *}

subsubsection {* SML and OCaml *}

code_printing type_constructor Heap \<rightharpoonup> (SML) "(unit/ ->/ _)"
code_printing constant bind \<rightharpoonup> (SML) "!(fn/ f'_/ =>/ fn/ ()/ =>/ f'_/ (_/ ())/ ())"
code_printing constant return \<rightharpoonup> (SML) "!(fn/ ()/ =>/ _)"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (SML) "!(raise/ Fail/ _)"

code_printing type_constructor Heap \<rightharpoonup> (OCaml) "(unit/ ->/ _)"
code_printing constant bind \<rightharpoonup> (OCaml) "!(fun/ f'_/ ()/ ->/ f'_/ (_/ ())/ ())"
code_printing constant return \<rightharpoonup> (OCaml) "!(fun/ ()/ ->/ _)"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (OCaml) "failwith"

subsubsection {* Haskell *}

text {* Adaption layer *}

code_printing code_module "Heap" \<rightharpoonup> (Haskell)
{*import qualified Control.Monad;
import qualified Control.Monad.ST;
import qualified Data.STRef;
import qualified Data.Array.ST;

type RealWorld = Control.Monad.ST.RealWorld;
type ST s a = Control.Monad.ST.ST s a;
type STRef s a = Data.STRef.STRef s a;
type STArray s a = Data.Array.ST.STArray s Integer a;

newSTRef = Data.STRef.newSTRef;
readSTRef = Data.STRef.readSTRef;
writeSTRef = Data.STRef.writeSTRef;

newArray :: Integer -> a -> ST s (STArray s a);
newArray k = Data.Array.ST.newArray (0, k - 1);

newListArray :: [a] -> ST s (STArray s a);
newListArray xs = Data.Array.ST.newListArray (0, (fromInteger . toInteger . length) xs - 1) xs;

newFunArray :: Integer -> (Integer -> a) -> ST s (STArray s a);
newFunArray k f = Data.Array.ST.newListArray (0, k - 1) (map f [0..k-1]);

lengthArray :: STArray s a -> ST s Integer;
lengthArray a = Control.Monad.liftM (\(_, l) -> l + 1) (Data.Array.ST.getBounds a);

readArray :: STArray s a -> Integer -> ST s a;
readArray = Data.Array.ST.readArray;

writeArray :: STArray s a -> Integer -> a -> ST s ();
writeArray = Data.Array.ST.writeArray;*}

code_reserved Haskell Heap

text {* Monad *}

code_printing type_constructor Heap \<rightharpoonup> (Haskell) "Heap.ST/ Heap.RealWorld/ _"
code_monad bind Haskell
code_printing constant return \<rightharpoonup> (Haskell) "return"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (Haskell) "error"

subsubsection {* Scala *}

code_printing code_module "Heap" \<rightharpoonup> (Scala)
{*object Heap {
  def bind[A, B](f: Unit => A, g: A => Unit => B): Unit => B = (_: Unit) => g (f ()) ()
}

class Ref[A](x: A) {
  var value = x
}

object Ref {
  def apply[A](x: A): Ref[A] =
    new Ref[A](x)
  def lookup[A](r: Ref[A]): A =
    r.value
  def update[A](r: Ref[A], x: A): Unit =
    { r.value = x }
}

object Array {
  import collection.mutable.ArraySeq
  def alloc[A](n: BigInt)(x: A): ArraySeq[A] =
    ArraySeq.fill(n.toInt)(x)
  def make[A](n: BigInt)(f: BigInt => A): ArraySeq[A] =
    ArraySeq.tabulate(n.toInt)((k: Int) => f(BigInt(k)))
  def len[A](a: ArraySeq[A]): BigInt =
    BigInt(a.length)
  def nth[A](a: ArraySeq[A], n: BigInt): A =
    a(n.toInt)
  def upd[A](a: ArraySeq[A], n: BigInt, x: A): Unit =
    a.update(n.toInt, x)
  def freeze[A](a: ArraySeq[A]): List[A] =
    a.toList
}
*}

code_reserved Scala Heap Ref Array

code_printing type_constructor Heap \<rightharpoonup> (Scala) "(Unit/ =>/ _)"
code_printing constant bind \<rightharpoonup> (Scala) "Heap.bind"
code_printing constant return \<rightharpoonup> (Scala) "('_: Unit)/ =>/ _"
code_printing constant Heap_Monad.raise' \<rightharpoonup> (Scala) "!sys.error((_))"

subsubsection {* Target variants with less units *}

setup {*

let

open Code_Thingol;

val imp_program =
  let
    val is_bind = curry (op =) @{const_name bind};
    val is_return = curry (op =) @{const_name return};
    val dummy_name = "";
    val dummy_case_term = IVar NONE;
    (*assumption: dummy values are not relevant for serialization*)
    val unitT = @{type_name unit} `%% [];
    val unitt =
      IConst { sym = Code_Symbol.Constant @{const_name Unity}, typargs = [], dicts = [], dom = [],
        annotation = NONE };
    fun dest_abs ((v, ty) `|=> t, _) = ((v, ty), t)
      | dest_abs (t, ty) =
          let
            val vs = fold_varnames cons t [];
            val v = singleton (Name.variant_list vs) "x";
            val ty' = (hd o fst o unfold_fun) ty;
          in ((SOME v, ty'), t `$ IVar (SOME v)) end;
    fun force (t as IConst { sym = Code_Symbol.Constant c, ... } `$ t') = if is_return c
          then t' else t `$ unitt
      | force t = t `$ unitt;
    fun tr_bind'' [(t1, _), (t2, ty2)] =
      let
        val ((v, ty), t) = dest_abs (t2, ty2);
      in ICase { term = force t1, typ = ty, clauses = [(IVar v, tr_bind' t)], primitive = dummy_case_term } end
    and tr_bind' t = case unfold_app t
     of (IConst { sym = Code_Symbol.Constant c, dom = ty1 :: ty2 :: _, ... }, [x1, x2]) => if is_bind c
          then tr_bind'' [(x1, ty1), (x2, ty2)]
          else force t
      | _ => force t;
    fun imp_monad_bind'' ts = (SOME dummy_name, unitT) `|=>
      ICase { term = IVar (SOME dummy_name), typ = unitT, clauses = [(unitt, tr_bind'' ts)], primitive = dummy_case_term }
    fun imp_monad_bind' (const as { sym = Code_Symbol.Constant c, dom = dom, ... }) ts = if is_bind c then case (ts, dom)
       of ([t1, t2], ty1 :: ty2 :: _) => imp_monad_bind'' [(t1, ty1), (t2, ty2)]
        | ([t1, t2, t3], ty1 :: ty2 :: _) => imp_monad_bind'' [(t1, ty1), (t2, ty2)] `$ t3
        | (ts, _) => imp_monad_bind (eta_expand 2 (const, ts))
      else IConst const `$$ map imp_monad_bind ts
    and imp_monad_bind (IConst const) = imp_monad_bind' const []
      | imp_monad_bind (t as IVar _) = t
      | imp_monad_bind (t as _ `$ _) = (case unfold_app t
         of (IConst const, ts) => imp_monad_bind' const ts
          | (t, ts) => imp_monad_bind t `$$ map imp_monad_bind ts)
      | imp_monad_bind (v_ty `|=> t) = v_ty `|=> imp_monad_bind t
      | imp_monad_bind (ICase { term = t, typ = ty, clauses = clauses, primitive = t0 }) =
          ICase { term = imp_monad_bind t, typ = ty,
            clauses = (map o apply2) imp_monad_bind clauses, primitive = imp_monad_bind t0 };

  in (Code_Symbol.Graph.map o K o map_terms_stmt) imp_monad_bind end;

in

Code_Target.add_derived_target ("SML_imp", [("SML", imp_program)])
#> Code_Target.add_derived_target ("OCaml_imp", [("OCaml", imp_program)])
#> Code_Target.add_derived_target ("Scala_imp", [("Scala", imp_program)])

end

*}

hide_const (open) Heap heap guard raise' fold_map

end


section \<open>Example for locale-code\<close>
theory Locale_Code_Ex
imports
  Locale_Code
  "../../Lib/Code_Target_ICF"
begin

definition [simp, code del]: "NOCODE \<equiv> id"

locale test =
  fixes a b :: nat
  assumes "a=b"
begin
  text \<open>Mutually recursive functions\<close>
  fun g and f where
    "g 0 = NOCODE a"
  | "g (Suc n) = a + n + f n"
  | "f 0 = a+b"
  | "f (Suc n) = a + f n + b * f n + g n"

  text \<open>Various definitions, depending on more or less parameters\<close>
  definition "k x \<equiv> b + x :: nat"
  definition "j x y \<equiv> NOCODE x + y + f x :: nat"
  definition "i x y \<equiv> x + y :: nat"
  definition "h x y \<equiv> a+x+k y+i x y+j x y"

  lemmas "defs" = k_def j_def i_def h_def g.simps f.simps

  lemma j_alt: "j x y \<equiv> f x + y + x" unfolding j_def by (simp add: ac_simps)

  lemma g_alt:
    "g 0 = a"
    "g (Suc n) = f n + n + a"
    by (auto simp: ac_simps)

  definition "c \<equiv> a + b"

  local_setup \<open>Locale_Code.lc_decl_eq @{thms j_alt}\<close>
  local_setup \<open>Locale_Code.lc_decl_eq @{thms g_alt}\<close>

end

text \<open>Conflicting constant name\<close>
definition "h_zero_zero \<equiv> True"

setup Locale_Code.open_block
  text \<open>Various interpretations, with and without constructor patterns
    and free variables\<close>
  interpretation i0: test 0 0 apply unfold_locales by auto
  interpretation i1: test "Suc n" "Suc n" apply unfold_locales by auto
  interpretation i2: test 1 1 apply unfold_locales by auto
  interpretation i3: test 5 5 apply unfold_locales by auto
  interpretation i4: test "snd (x,3)" "1+2" apply unfold_locales by auto

  interpretation i5: test "i3.c" "i3.c" by unfold_locales simp

  text \<open>Setup some alternative equations\<close>
  lemma i0_f_pat:
    "i0.f 0 = 0"
    "i0.f (Suc n) = i0.f n + i0.g n"
    by simp_all

  lemma i0_h_pat: "i0.h x y = x+i0.k y+i0.i x y+i0.j x y"
    unfolding i0.h_def by auto

  declare [[ lc_add "i0.f" i0_f_pat and "i0.h" i0_h_pat]]
setup Locale_Code.close_block

definition "foo x y \<equiv> i0.h x y + i1.h x x y + i2.h x y + i3.h x y
  + i4.h TYPE(bool) h_zero_zero x y + i5.h x y"

definition "bar x y \<equiv> i0.f x + i1.f x y + i2.f x + i3.f y
  + i4.f TYPE(bool) False x + i5.f y"

code_thms foo
code_thms bar

text \<open>value\<close>
value "foo 3 4"
value "bar 3 4"

text \<open>eval-tactic\<close>
lemma "foo 3 4 = 34578" by eval
lemma "bar 3 4 = 354189" by eval

text \<open>Exported code\<close>
export_code foo bar checking SML
export_code foo bar checking OCaml?
export_code foo bar checking Haskell?
export_code foo bar checking Scala

text \<open>Inlined code\<close>
ML_val \<open>
  @{code foo} (@{code nat_of_integer} 3) (@{code nat_of_integer} 4);
  @{code bar} (@{code nat_of_integer} 3) (@{code nat_of_integer} 4);
\<close>

end