theory GabrielaLimonta2
imports Main "Repeat_Big_Step" "~~/src/HOL/IMP/Star"
begin
subsection "List setup"

text {*
  In the following, we use the length of lists as integers
  instead of natural numbers. Instead of converting @{typ nat}
  to @{typ int} explicitly, we tell Isabelle to coerce @{typ nat}
  automatically when necessary.
*}
declare [[coercion_enabled]]
declare [[coercion "int :: nat \<Rightarrow> int"]]

text {*
  Similarly, we will want to access the ith element of a list,
  where @{term i} is an @{typ int}.
*}
fun inth :: "'a list \<Rightarrow> int \<Rightarrow> 'a" (infixl "!!" 100) where
"(x # xs) !! i = (if i = 0 then x else xs !! (i - 1))"

text {*
  The only additional lemma we need about this function
  is indexing over append:
*}
lemma inth_append [simp]:
  "0 \<le> i \<Longrightarrow>
  (xs @ ys) !! i = (if i < size xs then xs !! i else ys !! (i - size xs))"
by (induction xs arbitrary: i) (auto simp: algebra_simps)

text{* We hide coercion @{const int} applied to @{const length}: *}

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

notation isize ("size")

subsection "Instructions and Stack Machine"

text_raw{*\snip{instrdef}{0}{1}{% *}
datatype instr =
  LOADI int | LOAD vname | ADD | STORE vname |
  JMP int | JMPLESS int | JMPGE int
text_raw{*}%endsnip*}

type_synonym stack = "val list"
type_synonym config = "int \<times> state \<times> stack"

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

fun iexec :: "instr \<Rightarrow> config \<Rightarrow> config" where
"iexec instr (i,s,stk) = (case instr of
  LOADI n \<Rightarrow> (i+1,s, n#stk) |
  LOAD x \<Rightarrow> (i+1,s, s x # stk) |
  ADD \<Rightarrow> (i+1,s, (hd2 stk + hd stk) # tl2 stk) |
  STORE x \<Rightarrow> (i+1,s(x := hd stk),tl stk) |
  JMP n \<Rightarrow>  (i+1+n,s,stk) |
  JMPLESS n \<Rightarrow> (if hd2 stk < hd stk then i+1+n else i+1,s,tl2 stk) |
  JMPGE n \<Rightarrow> (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' =
  (\<exists>i s stk. c = (i,s,stk) \<and> c' = iexec(P!!i) (i,s,stk) \<and> 0 \<le> i \<and> i < size P)"

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)

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

declare star.step[intro]

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

code_pred exec1 by (metis exec1_def)

values
  "{(i,map t [''x'',''y''],stk) | i t stk.
    [LOAD ''y'', STORE ''x''] \<turnstile>
    (0, <''x'' := 3, ''y'' := 4>, []) \<rightarrow>* (i,t,stk)}"

subsection{* Verification infrastructure *}

text{* Below we need to argue about the execution of code that is embedded in
larger programs. For this purpose we show that execution is preserved by
appending code to the left or right of a program. *}

lemma iexec_shift [simp]:
  "((n+i',s',stk') = iexec x (n+i,s,stk)) = ((i',s',stk') = iexec x (i,s,stk))"
by(auto split:instr.split)

lemma exec1_appendR: "P \<turnstile> c \<rightarrow> c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow> c'"
by (auto simp: exec1_def)

lemma exec_appendR: "P \<turnstile> c \<rightarrow>* c' \<Longrightarrow> P@P' \<turnstile> c \<rightarrow>* c'"
by (induction rule: star.induct) (fastforce intro: 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')"
  unfolding exec1_def
  by (auto simp del: iexec.simps)

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 (induction rule: exec_induct) (blast intro!: exec1_appendL)+

text{* Now we specialise the above lemmas to enable automatic proofs of
@{prop "P \<turnstile> c \<rightarrow>* c'"} where @{text P} is a mixture of concrete instructions and
pieces of code that we already know how they execute (by induction), combined
by @{text "@"} and @{text "#"}. Backward jumps are not supported.
The details should be skipped on a first reading.

If we have just executed the first instruction of the program, drop it: *}

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

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

text{* Split the execution of a compound program up into the excution of its
parts: *}

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 :: "aexp \<Rightarrow> instr list" where
"acomp (N n) = [LOADI n]" |
"acomp (V x) = [LOAD x]" |
"acomp (Plus a1 a2) = acomp a1 @ acomp a2 @ [ADD]"

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

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

value
  "bcomp (And (Less (V ''x'') (V ''y'')) (Not(Less (V ''u'') (V ''v''))))
     False 3"

lemma bcomp_correct[intro]:
  fixes n :: int
  shows
  "0 \<le> n \<Longrightarrow>
  bcomp b f n \<turnstile>
 (0,s,stk)  \<rightarrow>*  (size(bcomp b f n) + (if f = bval b s then n else 0),s,stk)"
proof(induction b arbitrary: f n)
  case Not
  from Not(1)[where f="~f"] Not(2) show ?case by fastforce
next
  case (And b1 b2)
  from And(1)[of "if f then size(bcomp b2 f n) else size(bcomp b2 f n) + n"
                 "False"]
       And(2)[of n f] And(3)
  show ?case by fastforce
qed fastforce+

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

value "ccomp (REPEAT ''u'' ::= Plus (V ''u'') (N 1) UNTIL Less (N 0) (V ''u''))"

subsection "Preservation of semantics"

lemma ccomp_bigstep:
  "(c,s) \<Rightarrow> t \<Longrightarrow> ccomp c \<turnstile> (0,s,stk) \<rightarrow>* (size(ccomp c),t,stk)"
proof(induction arbitrary: stk rule: big_step_induct)
  case (Assign x a s)
  show ?case by (fastforce simp:fun_upd_def cong: if_cong)
next
  case (Seq c1 s1 s2 c2 s3)
  let ?cc1 = "ccomp c1"  let ?cc2 = "ccomp c2"
  have "?cc1 @ ?cc2 \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cc1,s2,stk)"
    using Seq.IH(1) by fastforce
  moreover
  have "?cc1 @ ?cc2 \<turnstile> (size ?cc1,s2,stk) \<rightarrow>* (size(?cc1 @ ?cc2),s3,stk)"
    using Seq.IH(2) by fastforce
  ultimately show ?case by simp (blast intro: star_trans)
next
  case (WhileTrue b s1 c s2 s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b False (size ?cc + 1)"
  let ?cw = "ccomp(WHILE b DO c)"
  have "?cw \<turnstile> (0,s1,stk) \<rightarrow>* (size ?cb,s1,stk)"
    using `bval b s1` by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb,s1,stk) \<rightarrow>* (size ?cb + size ?cc,s2,stk)"
    using WhileTrue.IH(1) by fastforce
  moreover
  have "?cw \<turnstile> (size ?cb + size ?cc,s2,stk) \<rightarrow>* (0,s2,stk)"
    by fastforce
  moreover
  have "?cw \<turnstile> (0,s2,stk) \<rightarrow>* (size ?cw,s3,stk)" by(rule WhileTrue.IH(2))
  ultimately show ?case by(blast intro: star_trans)
next
  case (RepeatTrue c s1 s2 b)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b True 1"
  let ?cr = "ccomp(REPEAT c UNTIL b)"
  have "?cr \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cc, s2, stk)"
    using RepeatTrue.IH and ccomp.simps(6) by fastforce
  moreover
  have "?cr \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cr, s2, stk)"
    using `bval b s2` by fastforce
  ultimately
  show ?case by(blast intro: star_trans)
next
  case (RepeatFalse c s1 s2 b s3)
  let ?cc = "ccomp c"
  let ?cb = "bcomp b True 1"
  let ?cr = "ccomp(REPEAT c UNTIL b)"
  have "?cr \<turnstile> (0, s1, stk) \<rightarrow>* (size ?cc, s2, stk)"
    using RepeatFalse.IH by fastforce
  moreover
  have "?cr \<turnstile> (size ?cc, s2, stk) \<rightarrow>* (size ?cc + size ?cb, s2, stk)"
    using `\<not>bval b s2` by fastforce
  moreover
  have "?cr \<turnstile> (size ?cc + size ?cb, s2, stk) \<rightarrow>* (0, s2, stk)"
    using RepeatFalse.IH by fastforce
  moreover
  have "?cr \<turnstile> (0, s2, stk) \<rightarrow>* (size ?cr, s3, stk)"
    using RepeatFalse.IH by fastforce
  ultimately
  show ?case by(blast intro: star_trans)
qed fastforce+

end


theory simp_expr_unambig2
imports Main
        "$HIPSTER_HOME/IsaHipster"
begin
  datatype 'a list = Nil2 | Cons2 "'a" "'a list"
  datatype Tok = C | D | X | Y | Pl
  datatype E = Plus "E" "E" | Ex | EY
  fun append :: "'a list => 'a list => 'a list" where
  "append (Nil2) y = y"
  | "append (Cons2 z xs) y = Cons2 z (append xs y)"
  fun lin :: "E => Tok list" where
  "lin (Plus a b) =
     append
       (append
          (append
             (append (Cons2 C (Nil2)) (lin a))
             (Cons2 D (Cons2 Pl (Cons2 C (Nil2)))))
          (lin b))
       (Cons2 D (Nil2))"
  | "lin (Ex) = Cons2 X (Nil2)"
  | "lin (EY) = Cons2 Y (Nil2)"
  (*hipster append lin*)
  theorem x0 :
    "!! (u :: E) (v :: E) . ((lin u) = (lin v)) ==> (u = v)"
    oops
end


theory Exercise7p2
imports Bigstep_sseefried
begin

fun skip :: "com \<Rightarrow> bool" where
    "skip SKIP         = True"
  | "skip (Assign v e) = False"
  | "skip (Seq c1 c2)  = (skip c1 \<and> skip c2)"
  | "skip (If b c1 c2) = (skip c1 \<and> skip c2)"
  | "skip (While b c)  = False"

lemma "skip c \<Longrightarrow> c \<sim> SKIP"
proof (induction c)
  case (Seq c1 c2)
  hence  "skip c1" and "skip c2" by auto
  hence "c1 \<sim> SKIP" and "c2 \<sim> SKIP" using Seq.IH by auto
  thus "c1 ;; c2 \<sim> SKIP" by fastforce
next
  case (If b c1 c2)
  hence "skip c1" and "skip c2" by auto
  hence "c1 \<sim> SKIP" and "c2 \<sim> SKIP" and "c1 \<sim> c2" using If.IH by auto
  thus "IF b THEN c1 ELSE c2 \<sim> SKIP" by blast
qed auto+

end


theory Examples
  imports Hoare GCD
begin

no_notation Set.image (infixr "`" 90)
  and times (infixl "*" 70)

record state =
  x :: nat
  y :: nat
  z :: nat
  w :: nat

(* Assignments *)
lemma "\<turnstile> true (`x := 2) \<lbrace> `x = 2 \<rbrace>"
  by hoare auto

(* Sequential composition *)
lemma swap:
  "\<turnstile> \<lbrace> `x = xo \<and> `y = yo \<rbrace> (
    `z := `x;
    `x := `y;
    `y := `z
  ) \<lbrace> `x = yo \<and> `y = xo \<rbrace>"
  by hoare auto

(* If statement *)
lemma maximum: "\<turnstile> true (if `x \<ge> `y then `z := `x else `z := `y fi) \<lbrace> `z = max `x `y \<rbrace>"
  by hoare auto

(* While statement *)
lemma euclids:
  "\<turnstile> \<lbrace> `x = xo \<and> `y = yo \<rbrace> (
    while `y \<noteq> 0
    inv \<lbrace> gcd `x `y = gcd xo yo \<rbrace>
    do
      `z := `y;
      `y := `x mod `y;
      `x := `z
    od
  ) \<lbrace> `x = gcd xo yo \<rbrace>"
  by (hoare, auto) (metis gcd_red_nat)

(* Pointers *)
lemma "\<turnstile> (\<lbrace> `x \<mapsto> `y \<rbrace> * \<lbrace> `z \<mapsto> `w \<rbrace>) skip \<lbrace> `x \<noteq> `z \<rbrace>"
  by hoare (auto simp: sep_conj_def ortho_def is_singleton_def)

lemma "emp * emp \<le> skip emp"
  by (auto simp: emp_def sep_conj_def ortho_def)

lemma "\<lbrace> `x \<mapsto> `y \<rbrace> * \<lbrace> `z \<mapsto> `w \<rbrace> \<le> (`y := `w) \<lbrace> `x \<noteq> `z \<rbrace>"
  by (auto simp: sep_conj_def ortho_def is_singleton_def)

hide_const x y z w
end


(*  Title:      HOL/HOLCF/IMP/Denotational.thy
    Author:     Tobias Nipkow and Robert Sandner, TUM
    Copyright   1996 TUM
*)

section "Denotational Semantics of Commands in HOLCF"

theory Denotational imports HOLCF "~~/src/HOL/IMP/Big_Step" begin

subsection "Definition"

definition
  dlift :: "(('a::type) discr -> 'b::pcpo) => ('a lift -> 'b)" where
  "dlift f = (LAM x. case x of UU => UU | Def y => f\<cdot>(Discr y))"

primrec D :: "com => state discr -> state lift"
where
  "D(SKIP) = (LAM s. Def(undiscr s))"
| "D(X ::= a) = (LAM s. Def((undiscr s)(X := aval a (undiscr s))))"
| "D(c0 ;; c1) = (dlift(D c1) oo (D c0))"
| "D(IF b THEN c1 ELSE c2) =
        (LAM s. if bval b (undiscr s) then (D c1)\<cdot>s else (D c2)\<cdot>s)"
| "D(WHILE b DO c) =
        fix\<cdot>(LAM w s. if bval b (undiscr s) then (dlift w)\<cdot>((D c)\<cdot>s)
                      else Def(undiscr s))"

subsection
  "Equivalence of Denotational Semantics in HOLCF and Evaluation Semantics in HOL"

lemma dlift_Def [simp]: "dlift f\<cdot>(Def x) = f\<cdot>(Discr x)"
  by (simp add: dlift_def)

lemma cont_dlift [iff]: "cont (%f. dlift f)"
  by (simp add: dlift_def)

lemma dlift_is_Def [simp]:
    "(dlift f\<cdot>l = Def y) = (\<exists>x. l = Def x \<and> f\<cdot>(Discr x) = Def y)"
  by (simp add: dlift_def split: lift.split)

lemma eval_implies_D: "(c,s) \<Rightarrow> t ==> D c\<cdot>(Discr s) = (Def t)"
apply (induct rule: big_step_induct)
      apply (auto)
 apply (subst fix_eq)
 apply simp
apply (subst fix_eq)
apply simp
done

lemma D_implies_eval: "!s t. D c\<cdot>(Discr s) = (Def t) --> (c,s) \<Rightarrow> t"
apply (induct c)
    apply fastforce
   apply fastforce
  apply force
 apply (simp (no_asm))
 apply force
apply (simp (no_asm))
apply (rule fix_ind)
  apply (fast intro!: adm_lemmas adm_chfindom ax_flat)
 apply (simp (no_asm))
apply (simp (no_asm))
apply force
done

theorem D_is_eval: "(D c\<cdot>(Discr s) = (Def t)) = ((c,s) \<Rightarrow> t)"
by (fast elim!: D_implies_eval [rule_format] eval_implies_D)

end


theory max imports Main       (* Suzumura: C. Benzmüller & X. Parent, 2021 *)

(* The Suzumura condition is a weakening of the condition of transitivity of the betterness relation.
It is coined after his inventor. The condition rules out cycles with at least one strict betterness. This is
exactly what is needed to avoid Davidson's money pump argument.

In the infinite case the condition does not have any import on the logic.
In the finite case, it is supposed to validate *)

begin
typedecl i (*Possible worlds.*)
type_synonym \<sigma> = "(i\<Rightarrow>bool)"
type_synonym \<alpha> = "i\<Rightarrow>\<sigma>" (*Type of betterness relation between worlds.*)
type_synonym \<tau> = "\<sigma>\<Rightarrow>\<sigma>"

consts aw::i (*Actual world.*)
abbreviation etrue  :: "\<sigma>" ("\<^bold>\<top>") where "\<^bold>\<top> \<equiv> \<lambda>w. True"
abbreviation efalse :: "\<sigma>" ("\<^bold>\<bottom>")  where "\<^bold>\<bottom> \<equiv> \<lambda>w. False"
abbreviation enot :: "\<sigma>\<Rightarrow>\<sigma>" ("\<^bold>\<not>_"[52]53)  where "\<^bold>\<not>\<phi> \<equiv> \<lambda>w. \<not>\<phi>(w)"
abbreviation eand :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<and>"51) where "\<phi>\<^bold>\<and>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<and>\<psi>(w)"
abbreviation eor  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<or>"50) where "\<phi>\<^bold>\<or>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<or>\<psi>(w)"
abbreviation eimp :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<rightarrow>"49) where "\<phi>\<^bold>\<rightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longrightarrow>\<psi>(w)"
abbreviation eequ :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" (infixr"\<^bold>\<leftrightarrow>"48) where "\<phi>\<^bold>\<leftrightarrow>\<psi> \<equiv> \<lambda>w. \<phi>(w)\<longleftrightarrow>\<psi>(w)"

(*Possibilist--constant domain--quantification.*)
abbreviation eforall ("\<^bold>\<forall>") where "\<^bold>\<forall>\<Phi> \<equiv> \<lambda>w.\<forall>x. (\<Phi> x w)"
abbreviation eforallB (binder"\<^bold>\<forall>"[8]9) where "\<^bold>\<forall>x. \<phi>(x) \<equiv> \<^bold>\<forall>\<phi>"
abbreviation eexists ("\<^bold>\<exists>") where "\<^bold>\<exists>\<Phi> \<equiv> \<lambda>w.\<exists>x. (\<Phi> x w)"
abbreviation eexistsB (binder"\<^bold>\<exists>"[8]9) where "\<^bold>\<exists>x. \<phi>(x) \<equiv> \<^bold>\<exists>\<phi>"

abbreviation ebox :: "\<sigma>\<Rightarrow>\<sigma>" ("\<box>") where "\<box> \<equiv> \<lambda>\<phi> w.  \<forall>v. \<phi>(v)"
abbreviation ediam :: "\<sigma>\<Rightarrow>\<sigma>" ("\<diamond>") where "\<diamond> \<equiv> \<lambda>\<phi> w.  \<exists>v. \<phi>(v)"

(* Some useful relations for constraining accessibility relations*)

definition transitive :: "\<alpha>\<Rightarrow>bool" where "transitive R \<equiv> \<forall>x y z. R x y \<and> R y z \<longrightarrow> R x z"
definition sub_rel :: "\<alpha>\<Rightarrow>\<alpha>\<Rightarrow>bool" where "sub_rel R Q \<equiv> \<forall>u v. R u v \<longrightarrow> Q u v"

(*In HOL the transitive closure of a relation can be defined in a single line.*)
definition tc :: "\<alpha>\<Rightarrow>\<alpha>" where "tc R \<equiv> \<lambda>x y.\<forall>Q. transitive Q \<longrightarrow> (sub_rel R Q \<longrightarrow> Q x y)"

consts BRel :: "\<alpha>" (infixr "R" 70) (*Betterness relation, cf. def. of \<circle><_|_>.*)
(*Original Max, wrt to R*)

abbreviation max  :: "\<sigma>\<Rightarrow>\<sigma>" ("max<_>")
  where "max<\<phi>> \<equiv> (\<lambda>v. ( (\<phi>)(v) \<and> (\<forall>x. ((\<phi>)(x)\<and> x R v  \<longrightarrow>  v  R x))) )"

abbreviation subset :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>bool" (infix "\<^bold>\<subseteq>" 53)
  where "\<phi> \<^bold>\<subseteq> \<psi> \<equiv> \<forall>x. \<phi> x \<longrightarrow> \<psi> x"

abbreviation cond  :: "\<sigma>\<Rightarrow>\<sigma>\<Rightarrow>\<sigma>" ("\<circle><_|_>")
  where "\<circle><\<psi>|\<phi>> \<equiv>  \<lambda>w. max<\<phi>> \<^bold>\<subseteq> \<psi>"

abbreviation evalid :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>"[8]109)  (*Global validity.*)
  where "\<lfloor>p\<rfloor> \<equiv> \<forall>w. p w"
abbreviation ecjactual :: "\<sigma>\<Rightarrow>bool" ("\<lfloor>_\<rfloor>\<^sub>l"[7]105) (*Local validity — in world aw.*)
  where "\<lfloor>p\<rfloor>\<^sub>l \<equiv> p(aw)"

lemma True nitpick [satisfy,user_axioms,expect=genuine] oops (*Consistency conf.*)

(*

text \<open>We define Suzumura consistency:\<close>
abbreviation Suzumura
  where "Suzumura R \<equiv> \<forall>x y. (tc R x  y \<longrightarrow> ( R y x \<rightarrow> R x y))"

this is the def of the condition *)

lemma assumes "Suzumura r"
  shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  nitpick oops

lemma assumes "Suzumura r"
  shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> (\<circle><\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  nitpick
  oops

(*Suzumura should validate the axiom below. The counter-example outputed by Nitpick is incorrect *)
lemma assumes "Suzumura r"
  shows "\<lfloor>\<diamond>\<phi> \<^bold>\<rightarrow> \<^bold>\<not>(\<circle><\<psi>|\<phi>>\<^bold>\<and>\<circle><\<^bold>\<not>\<psi>|\<phi>>)\<rfloor>" nitpick

lemma assumes "Suzumara r"
  shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> (\<circle><\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"  nitpick

lemma CM: "\<lfloor>(\<circle><\<psi>|\<phi>>\<^bold>\<and>(\<circle><\<xi>|\<phi>>) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>)\<rfloor>" nitpick  [show_all,format=2] oops

lemma RM: "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>" nitpick oops

lemma OR: "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> (\<circle><\<psi>|\<xi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<or>\<xi>>\<rfloor>" sledgehammer oops

lemma S: "\<lfloor>\<circle><\<xi>|\<phi>\<^bold>\<and>\<psi>> \<^bold>\<rightarrow> \<circle><\<psi>\<^bold>\<rightarrow>\<xi>|\<phi>>\<rfloor>" sledgehammer oops

lemma assumes "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
      shows "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
  using assms by blast

lemma assumes "\<lfloor>((\<circle><\<psi>|\<phi>>) \<^bold>\<and> \<^bold>\<not>(\<circle><\<^bold>\<not>\<xi>|\<phi>>)) \<^bold>\<rightarrow> \<circle><\<psi>|\<phi>\<^bold>\<and>\<xi>>\<rfloor>"
      shows "\<forall>x y z. x R y \<and> y R z \<longrightarrow> x R z"
  nitpick [show_all,format=2] oops (*Countermodel presented by Nitpick.*)

end


theory functions_ imports Main
begin

fun fib:: "nat\<Rightarrow>nat" where
"fib 0 = 1"
| "fib (Suc 0) = 1"
| "fib (Suc (Suc n)) = fib n + fib (Suc n)"

fun sep:: "'a \<Rightarrow> 'a list \<Rightarrow> 'a list" where
"sep a (h1#h2#t) = h1 # a # (sep a (h2#t))"
| "sep a xs = xs"

thm sep.simps

lemma "sep 0 [1, 2, 3] = [1, 0, 2, 0, 3]" by simp

thm sep.induct

lemma "map f (sep x ys) = sep (f x) (map f ys)"
proof (induction x ys rule:sep.induct)
case (1 a h1 h2 t)
then show ?case by auto
next
case ("2_1" a)
then show ?case by auto
next
case ("2_2" a)
then show ?case by auto
qed

function sum:: "nat\<Rightarrow>nat\<Rightarrow>nat" where
"sum i N = (if i>N then 0 else i+ (sum (Suc i) N))"
by pat_completeness auto

function check:: "string \<Rightarrow> bool" where
"check (''good'') = True"
| "s\<noteq>''good'' \<Longrightarrow> check s = False"
by auto
termination by (relation "{}") simp

end


section {* Demonstrating the interface SVC *}

theory svc_test
imports SVC_Oracle
begin

subsubsection {* Propositional Logic *}

text {*
  @{text "blast"}'s runtime for this type of problem appears to be exponential
  in its length, though @{text "fast"} manages.
*}
lemma "P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P=P"
  by svc

subsection {* Some big tautologies supplied by John Harrison *}

text {*
  @{text "auto"} manages; @{text "blast"} and @{text "fast"} take a minute or more.
*}
lemma puz013_1: "~(~v12 &
   v0 &
   v10 &
   (v4 | v5) &
   (v9 | v2) &
   (v8 | v1) &
   (v7 | v0) &
   (v3 | v12) &
   (v11 | v10) &
   (~v12 | ~v6 | v7) &
   (~v10 | ~v3 | v1) &
   (~v10 | ~v0 | ~v4 | v11) &
   (~v5 | ~v2 | ~v8) &
   (~v12 | ~v9 | ~v7) &
   (~v0 | ~v1 | v4) &
   (~v4 | v7 | v2) &
   (~v12 | ~v3 | v8) &
   (~v4 | v5 | v6) &
   (~v7 | ~v8 | v9) &
   (~v10 | ~v11 | v12))"
  by svc

lemma dk17_be:
  "(GE17 <-> ~IN4 & ~IN3 & ~IN2 & ~IN1) &
    (GE0 <-> GE17 & ~IN5) &
    (GE22 <-> ~IN9 & ~IN7 & ~IN6 & IN0) &
    (GE19 <-> ~IN5 & ~IN4 & ~IN3 & ~IN0) &
    (GE20 <-> ~IN7 & ~IN6) &
    (GE18 <-> ~IN6 & ~IN2 & ~IN1 & ~IN0) &
    (GE21 <-> IN9 & ~IN7 & IN6 & ~IN0) &
    (GE23 <-> GE22 & GE0) &
    (GE25 <-> ~IN9 & ~IN7 & IN6 & ~IN0) &
    (GE26 <-> IN9 & ~IN7 & ~IN6 & IN0) &
    (GE2 <-> GE20 & GE19) &
    (GE1 <-> GE18 & ~IN7) &
    (GE24 <-> GE23 | GE21 & GE0) &
    (GE5 <-> ~IN5 & IN4 | IN5 & ~IN4) &
    (GE6 <-> GE0 & IN7 & ~IN6 & ~IN0) &
    (GE12 <-> GE26 & GE0 | GE25 & GE0) &
    (GE14 <-> GE2 & IN8 & ~IN2 & IN1) &
    (GE27 <-> ~IN8 & IN5 & ~IN4 & ~IN3) &
    (GE9 <-> GE1 & ~IN5 & ~IN4 & IN3) &
    (GE7 <-> GE24 | GE2 & IN2 & ~IN1) &
    (GE10 <-> GE6 | GE5 & GE1 & ~IN3) &
    (GE15 <-> ~IN8 | IN9) &
    (GE16 <-> GE12 | GE14 & ~IN9) &
    (GE4 <->
     GE5 & GE1 & IN8 & ~IN3 |
     GE0 & ~IN7 & IN6 & ~IN0 |
     GE2 & IN2 & ~IN1) &
    (GE13 <-> GE27 & GE1) &
    (GE11 <-> GE9 | GE6 & ~IN8) &
    (GE8 <-> GE1 & ~IN5 & IN4 & ~IN3 | GE2 & ~IN2 & IN1) &
    (OUT0 <-> GE7 & ~IN8) &
    (OUT1 <-> GE7 & IN8) &
    (OUT2 <-> GE8 & ~IN9 | GE10 & IN8) &
    (OUT3 <-> GE8 & IN9 & ~IN8 | GE11 & ~IN9 | GE12 & ~IN8) &
    (OUT4 <-> GE11 & IN9 | GE12 & IN8) &
    (OUT5 <-> GE14 & IN9) &
    (OUT6 <-> GE13 & ~IN9) &
    (OUT7 <-> GE13 & IN9) &
    (OUT8 <-> GE9 & ~IN8 | GE15 & GE6 | GE4 & IN9) &
    (OUT9 <-> GE9 & IN8 | ~GE15 & GE10 | GE16) &
    (OUT10 <-> GE7) &
    (WRES0 <-> ~IN5 & ~IN4 & ~IN3 & ~IN2 & ~IN1) &
    (WRES1 <-> ~IN7 & ~IN6 & ~IN2 & ~IN1 & ~IN0) &
    (WRES2 <-> ~IN7 & ~IN6 & ~IN5 & ~IN4 & ~IN3 & ~IN0) &
    (WRES5 <-> ~IN5 & IN4 | IN5 & ~IN4) &
    (WRES6 <-> WRES0 & IN7 & ~IN6 & ~IN0) &
    (WRES9 <-> WRES1 & ~IN5 & ~IN4 & IN3) &
    (WRES7 <->
     WRES0 & ~IN9 & ~IN7 & ~IN6 & IN0 |
     WRES0 & IN9 & ~IN7 & IN6 & ~IN0 |
     WRES2 & IN2 & ~IN1) &
    (WRES10 <-> WRES6 | WRES5 & WRES1 & ~IN3) &
    (WRES12 <->
     WRES0 & IN9 & ~IN7 & ~IN6 & IN0 |
     WRES0 & ~IN9 & ~IN7 & IN6 & ~IN0) &
    (WRES14 <-> WRES2 & IN8 & ~IN2 & IN1) &
    (WRES15 <-> ~IN8 | IN9) &
    (WRES4 <->
     WRES5 & WRES1 & IN8 & ~IN3 |
     WRES2 & IN2 & ~IN1 |
     WRES0 & ~IN7 & IN6 & ~IN0) &
    (WRES13 <-> WRES1 & ~IN8 & IN5 & ~IN4 & ~IN3) &
    (WRES11 <-> WRES9 | WRES6 & ~IN8) &
    (WRES8 <-> WRES1 & ~IN5 & IN4 & ~IN3 | WRES2 & ~IN2 & IN1)
    --> (OUT10 <-> WRES7) &
        (OUT9 <-> WRES9 & IN8 | WRES12 | WRES14 & ~IN9 | ~WRES15 & WRES10) &
        (OUT8 <-> WRES9 & ~IN8 | WRES15 & WRES6 | WRES4 & IN9) &
        (OUT7 <-> WRES13 & IN9) &
        (OUT6 <-> WRES13 & ~IN9) &
        (OUT5 <-> WRES14 & IN9) &
        (OUT4 <-> WRES11 & IN9 | WRES12 & IN8) &
        (OUT3 <-> WRES8 & IN9 & ~IN8 | WRES11 & ~IN9 | WRES12 & ~IN8) &
        (OUT2 <-> WRES8 & ~IN9 | WRES10 & IN8) &
        (OUT1 <-> WRES7 & IN8) &
        (OUT0 <-> WRES7 & ~IN8)"
  by svc

text {* @{text "fast"} only takes a couple of seconds. *}

lemma sqn_be: "(GE0 <-> IN6 & IN1 | ~IN6 & ~IN1) &
   (GE8 <-> ~IN3 & ~IN1) &
   (GE5 <-> IN6 | IN5) &
   (GE9 <-> ~GE0 | IN2 | ~IN5) &
   (GE1 <-> IN3 | ~IN0) &
   (GE11 <-> GE8 & IN4) &
   (GE3 <-> ~IN4 | ~IN2) &
   (GE34 <-> ~GE5 & IN4 | ~GE9) &
   (GE2 <-> ~IN4 & IN1) &
   (GE14 <-> ~GE1 & ~IN4) &
   (GE19 <-> GE11 & ~GE5) &
   (GE13 <-> GE8 & ~GE3 & ~IN0) &
   (GE20 <-> ~IN5 & IN2 | GE34) &
   (GE12 <-> GE2 & ~IN3) &
   (GE27 <-> GE14 & IN6 | GE19) &
   (GE10 <-> ~IN6 | IN5) &
   (GE28 <-> GE13 | GE20 & ~GE1) &
   (GE6 <-> ~IN5 | IN6) &
   (GE15 <-> GE2 & IN2) &
   (GE29 <-> GE27 | GE12 & GE5) &
   (GE4 <-> IN3 & ~IN0) &
   (GE21 <-> ~GE10 & ~IN1 | ~IN5 & ~IN2) &
   (GE30 <-> GE28 | GE14 & IN2) &
   (GE31 <-> GE29 | GE15 & ~GE6) &
   (GE7 <-> ~IN6 | ~IN5) &
   (GE17 <-> ~GE3 & ~IN1) &
   (GE18 <-> GE4 & IN2) &
   (GE16 <-> GE2 & IN0) &
   (GE23 <-> GE19 | GE9 & ~GE1) &
   (GE32 <-> GE15 & ~IN6 & ~IN0 | GE21 & GE4 & ~IN4 | GE30 | GE31) &
   (GE33 <->
    GE18 & ~GE6 & ~IN4 |
    GE17 & ~GE7 & IN3 |
    ~GE7 & GE4 & ~GE3 |
    GE11 & IN5 & ~IN0) &
   (GE25 <-> GE14 & ~GE6 | GE13 & ~GE5 | GE16 & ~IN5 | GE15 & GE1) &
   (GE26 <->
    GE12 & IN5 & ~IN2 |
    GE10 & GE4 & IN1 |
    GE17 & ~GE6 & IN0 |
    GE2 & ~IN6) &
   (GE24 <-> GE23 | GE16 & GE7) &
   (OUT0 <->
    GE6 & IN4 & ~IN1 & IN0 | GE18 & GE0 & ~IN5 | GE12 & ~GE10 | GE24) &
   (OUT1 <-> GE26 | GE25 | ~GE5 & GE4 & GE3 | GE7 & ~GE1 & IN1) &
   (OUT2 <-> GE33 | GE32) &
   (WRES8 <-> ~IN3 & ~IN1) &
   (WRES0 <-> IN6 & IN1 | ~IN6 & ~IN1) &
   (WRES2 <-> ~IN4 & IN1) &
   (WRES3 <-> ~IN4 | ~IN2) &
   (WRES1 <-> IN3 | ~IN0) &
   (WRES4 <-> IN3 & ~IN0) &
   (WRES5 <-> IN6 | IN5) &
   (WRES11 <-> WRES8 & IN4) &
   (WRES9 <-> ~WRES0 | IN2 | ~IN5) &
   (WRES10 <-> ~IN6 | IN5) &
   (WRES6 <-> ~IN5 | IN6) &
   (WRES7 <-> ~IN6 | ~IN5) &
   (WRES12 <-> WRES2 & ~IN3) &
   (WRES13 <-> WRES8 & ~WRES3 & ~IN0) &
   (WRES14 <-> ~WRES1 & ~IN4) &
   (WRES15 <-> WRES2 & IN2) &
   (WRES17 <-> ~WRES3 & ~IN1) &
   (WRES18 <-> WRES4 & IN2) &
   (WRES19 <-> WRES11 & ~WRES5) &
   (WRES20 <-> ~IN5 & IN2 | ~WRES5 & IN4 | ~WRES9) &
   (WRES21 <-> ~WRES10 & ~IN1 | ~IN5 & ~IN2) &
   (WRES16 <-> WRES2 & IN0)
   --> (OUT2 <->
        WRES11 & IN5 & ~IN0 |
        ~WRES7 & WRES4 & ~WRES3 |
        WRES12 & WRES5 |
        WRES13 |
        WRES14 & IN2 |
        WRES14 & IN6 |
        WRES15 & ~WRES6 |
        WRES15 & ~IN6 & ~IN0 |
        WRES17 & ~WRES7 & IN3 |
        WRES18 & ~WRES6 & ~IN4 |
        WRES20 & ~WRES1 |
        WRES21 & WRES4 & ~IN4 |
        WRES19) &
       (OUT1 <->
        ~WRES5 & WRES4 & WRES3 |
        WRES7 & ~WRES1 & IN1 |
        WRES2 & ~IN6 |
        WRES10 & WRES4 & IN1 |
        WRES12 & IN5 & ~IN2 |
        WRES13 & ~WRES5 |
        WRES14 & ~WRES6 |
        WRES15 & WRES1 |
        WRES16 & ~IN5 |
        WRES17 & ~WRES6 & IN0) &
       (OUT0 <->
        WRES6 & IN4 & ~IN1 & IN0 |
        WRES9 & ~WRES1 |
        WRES12 & ~WRES10 |
        WRES16 & WRES7 |
        WRES18 & WRES0 & ~IN5 |
        WRES19)"
  by svc

subsection {* Linear arithmetic *}

lemma "x ~= 14 & x ~= 13 & x ~= 12 & x ~= 11 & x ~= 10 & x ~= 9 &
      x ~= 8 & x ~= 7 & x ~= 6 & x ~= 5 & x ~= 4 & x ~= 3 &
      x ~= 2 & x ~= 1 & 0 < x & x < 16 --> 15 = (x::int)"
  by svc

text {*merely to test polarity handling in the presence of biconditionals*}
lemma "(x < (y::int)) = (x+1 <= y)"
  by svc

subsection {* Natural number examples requiring implicit "non-negative" assumptions *}

lemma "(3::nat)*a <= 2 + 4*b + 6*c  & 11 <= 2*a + b + 2*c &
      a + 3*b <= 5 + 2*c  --> 2 + 3*b <= 2*a + 6*c"
  by svc

lemma "(n::nat) < 2 ==> (n = 0) | (n = 1)"
  by svc

end


(*  Title:      PSL/UR/Bottom_Up_Conjecturing.thy
    Author:     Yutaka Nagashima, Czech Technical University in Prague, the University of Innsbruck

A part of this file is copied from Pure/Tools/find_consts.ML.
The authors of that part are Timothy Bourke and Gerwin Klein, NICTA.
*)

theory Bottom_Up_Conjecturing
  imports Main "PSL.PSL"
begin

ML_file "Pretty_Consts.ML"

ML\<open> signature BOTTOM_UP_CONJECTURING =
sig

datatype bottom_up_for_binary_function =
  Associativity
| Identity
| Invertibility
| Commutativity
| Idempotent_Elemen
| Idempotency;

datatype bottom_up_for_two_functions =
  Distributivity
| Ant_Distributivity
| Homomorphism_2;

datatype bottom_up_for_relations =
  Transitivity
| Symmetry
| Connexity
| Reflexivity;

(* non-algebraic bottom-up conjecturing involving multiple constants.
datatype non_algebraic_bottom_up_for_binary_function =
  Unary_Fun_To_Different_Args
| Unary_Fun_To_
*)

(*
Is_Bottom.
*)

val ctxt_n_typ_to_typs: Proof.context -> typ -> typ list;

val ctxt_n_typ_to_consts:        Proof.context -> typ -> terms;
val ctxt_n_typ_to_nullary_const: Proof.context -> typ -> terms;
val ctxt_n_typ_to_unary_const:   Proof.context -> typ -> terms;
val ctxt_n_typ_to_binary_const:  Proof.context -> typ -> terms;

(*bottom_up_for_binary_function*)
(*f (f (x, y), z) = f (x, f (y, z))*)
val ctxt_n_const_to_associativity:Proof.context -> term -> term list;
(*left identity : f (e, x) = x*)
(*right identity: f (x, e) = x*)
val ctxt_n_const_to_identity: Proof.context -> term -> term list;
(*f (x, y) = f (y, x)*)
val ctxt_n_const_to_commutativity:       Proof.context -> term -> term list;
val ctxt_n_const_to_idempotent_element:  Proof.context -> term -> term list;
val ctxt_n_const_to_idempotence:         Proof.context -> term -> term list;

(*bottom_up_for_two_functions*)
(*f (x, g (y, z)) = g(f (x, y), f (x, z)) *)
val ctxt_n_consts_to_distributivity:     Proof.context -> term -> term list;
val ctxt_n_consts_to_anti_distributivity:Proof.context -> term -> term list;
(*f is homomorphism: f (g (x, y)) = g (f (x), f (y))*)
val ctxt_n_consts_to_homomorphism_2:     Proof.context -> term -> term list;

(*bottom_up_for_relations*)
val term_is_relation:                    term -> bool;
val ctxt_n_consts_to_symmetry:           Proof.context -> term -> term list;
val ctxt_n_consts_to_reflexibility:      Proof.context -> term -> term list;
val ctxt_n_consts_to_transitivity:       Proof.context -> term -> term list;
val ctxt_n_consts_to_connexity:          Proof.context -> term -> term list;

val ctxt_n_const_to_all_conjecture_term: Proof.context -> term -> term list;

end;
\<close>

ML\<open> structure Bottom_Up_Conjecturing: BOTTOM_UP_CONJECTURING =
struct

val strip_atyp        = Isabelle_Utils.strip_atyp;
val takes_n_arguments = Isabelle_Utils.takes_n_arguments;

datatype direction = Left | Right;

datatype bottom_up_for_binary_function =
  Associativity
| Identity
| Invertibility
| Commutativity
| Idempotent_Elemen
| Idempotency;

datatype bottom_up_for_two_functions =
  Distributivity     (*2,2*)
| Ant_Distributivity (*1,2*)
| Homomorphism_2;    (*1,2*)

datatype bottom_up_for_relations =
  Transitivity
| Symmetry
| Connexity
| Reflexivity;

val ctxt_n_typ_to_typs = undefined: Proof.context -> typ -> typ list;

fun ctxt_n_typ_to_consts ctxt typ =
  let
    fun ctxt_n_typ_to_nullary_const' (ctxt:Proof.context) (typ:typ) =
      let
        val typ_as_string   = Syntax.string_of_typ ctxt typ
            |> YXML.parse_body
            |> XML.content_of : string;
        val const_typ_pairs = Pretty_Consts.pretty_consts ctxt [(true, Find_Consts.Strict typ_as_string)]: (string * typ) list;
        val const_names     = map fst const_typ_pairs                                      : strings;
        val consts_w_dummyT = map (fn cname => Const (cname, dummyT)) const_names          : terms;
      in
        consts_w_dummyT: terms
      end;
  in try (ctxt_n_typ_to_nullary_const' ctxt) typ |> Utils.is_some_null end;

(*to find candidates for the identity element*)
fun ctxt_n_typ_to_nullary_const ctxt typ = ctxt_n_typ_to_consts ctxt typ;

(*to find candidates for the inverse function*)
fun ctxt_n_typ_to_unary_const ctxt typ = ctxt_n_typ_to_consts ctxt (typ --> typ);

(*to find candidates for the distributive property*)
fun ctxt_n_typ_to_binary_const ctxt typ = ctxt_n_typ_to_consts ctxt ([typ, typ] ---> typ);

fun mk_free_variable_of_typ (typ:typ) (i:int) = Free ("var_" ^ Int.toString i, typ);

fun mk_free_variable_of_dummyT (i:int) = mk_free_variable_of_typ dummyT i;

(*assume binary*)(*TODO: Do not assume.*)
val list_comb = Term.list_comb;

fun all_args_are_same_typ (funcs:terms) =(*TODO: rename?*)
  let
    fun get_arg_typs (f:typ)      = (snd (strip_type f)::fst (strip_type f))   : typ list;
    val typs                      = map (get_arg_typs o type_of) funcs |> flat : typ list;
    val numb_of_distinct_elements = distinct (op =) typs |> length             : int;
  in
    numb_of_distinct_elements = 1
  end;

(*bottom_up_for_binary_function*)

fun mk_eq (lhs:term, rhs:term) = strip_atyp @{term "HOL.eq"} $ strip_atyp lhs $ strip_atyp rhs;

fun ctxt_n_const_to_associativity (ctxt:Proof.context) (func:term) =
(*f (f (x, y), z) = f (x, f (y, z))*)
if takes_n_arguments func 2 andalso all_args_are_same_typ [func]
then
 (let
    val func_w_dummyT      = map_types (K dummyT) func                   : term;
    val [var1, var2, var3] = map mk_free_variable_of_dummyT [1,2,3]      : terms;
    val lhs                = list_comb (func_w_dummyT, [var1, list_comb (func_w_dummyT, [var2, var3])]) |> strip_atyp;
    val rhs                = list_comb (func_w_dummyT, [list_comb (func_w_dummyT, [var1, var2]), var3]) |> strip_atyp;
    val assoc              = mk_eq (lhs, rhs) |> Syntax.check_term ctxt: term;
  in
    [assoc]
  end)
else []: term list;

fun ctxt_n_direct_n_trm_to_identity (ctxt:Proof.context) (direct:direction) (func as Const (_, typ):term) =
(*left identity : f (e, x) = x*)
(*right identity: f (x, e) = x*)
  if takes_n_arguments func 2 andalso all_args_are_same_typ [func]
  then
    let
      val typ_of_arg     = binder_types typ |> (case direct of
                            Left  =>  List.hd
                          | Right => (Utils.the' "ctxt_n_trm_to_identity in Bottom_Up_Conjecturing.ML failed"
                                    o try (fn args => nth args 1)))   : typ;
      val nullary_consts = ctxt_n_typ_to_nullary_const ctxt typ_of_arg: terms;
      val func_w_dummyT  = strip_atyp func                            : term;
      val free_var       = mk_free_variable_of_dummyT     1           : term;
      fun mk_equation (identity_element:term) =
        let
          val lhs = case direct of
              Left  => list_comb (func_w_dummyT, [identity_element, free_var]): term
            | Right => list_comb (func_w_dummyT, [free_var, identity_element]): term;
          val rhs = free_var                                                  : term;
          val eq  = mk_eq (lhs, rhs)                                          : term;
        in
          Syntax.check_term ctxt eq
        end;
    in
      map mk_equation nullary_consts
    end
  else []
  | ctxt_n_direct_n_trm_to_identity _ _ _ = [];

fun ctxt_n_const_to_identity ctxt trm =
  ctxt_n_direct_n_trm_to_identity ctxt Left trm @ ctxt_n_direct_n_trm_to_identity ctxt Right trm

fun ctxt_n_const_to_commutativity (ctxt:Proof.context) (func:term) =
  (*f (x, y) = f (y, x)*)
  if takes_n_arguments func 2 andalso all_args_are_same_typ [func]
  then
    let
      val func_w_dummyT = strip_atyp func                                : term;
      val (var1,var2)   = Utils.map_pair mk_free_variable_of_dummyT (1,2): (term * term);
      val lhs           = list_comb (func_w_dummyT, [var1,var2])         : term;
      val rhs           = list_comb (func_w_dummyT, [var2,var1])         : term;
      val eq            = mk_eq (lhs, rhs)                               : term;
      val commutativity = Syntax.check_term ctxt eq                      : term;
    in [commutativity] end
  else [];

fun ctxt_n_const_to_idempotent_element (ctxt:Proof.context) (func as Const (_, typ): term) =
  (*f (e, e) = e for some e*)
  if takes_n_arguments func 2 andalso all_args_are_same_typ [func]
  then
    let
      val typ_of_arg     = binder_types typ |> List.hd                : typ;
      val nullary_consts = ctxt_n_typ_to_nullary_const ctxt typ_of_arg: terms;
      val func_w_dummyT  = strip_atyp func                            : term;
      fun mk_equation (identity_element:term) =
        let
          val lhs = list_comb (func_w_dummyT, [identity_element, identity_element]): term;
          val eq  = mk_eq (lhs, identity_element)                                  : term;
        in
          Syntax.check_term ctxt eq
        end;
    in
      map mk_equation nullary_consts
    end
  else []
  | ctxt_n_const_to_idempotent_element _ _ = [];

fun ctxt_n_const_to_idempotence (ctxt:Proof.context) (func as Const(_, _)) =
  (* f (x, x) = x *)
  if takes_n_arguments func 2 andalso all_args_are_same_typ [func]
  then
    let
      val func_wo_typ = strip_atyp func                 : term;
      val var         = mk_free_variable_of_dummyT 1    : term;
      val idempotence = mk_eq (list_comb (func_wo_typ, [var, var]), var) |> Syntax.check_term ctxt;
    in
      [idempotence]
    end
  else []
 | ctxt_n_const_to_idempotence _ _ = [];

(*bottom_up_for_two_functions*)
fun ctxt_n_consts_to_distributivity' (ctxt:Proof.context) (func1:term) (func2:term) =
  let
    val (func1_wo_typ, func2_wo_typ) = Utils.map_pair strip_atyp (func1, func2): (term * term);
    val [var1, var2, var3]           = map mk_free_variable_of_dummyT [1,2,3]  : terms;
    val (left_lhs, right_lhs)        =  (list_comb (func1_wo_typ, [var1, list_comb (func2_wo_typ, [var2, var3])]),
                                         list_comb (func1_wo_typ, [list_comb (func2_wo_typ, [var1, var2]), var3])
                                         );
    val (left_rhs, right_rhs)        =  (list_comb
                                          (func2_wo_typ,
                                           [list_comb (func1_wo_typ, [var1, var2]),
                                            list_comb (func1_wo_typ, [var1, var3])
                                            ]
                                           ),
                                         list_comb
                                          (func2_wo_typ,
                                           [list_comb (func1_wo_typ, [var1, var3]),
                                            list_comb (func1_wo_typ, [var2, var3])
                                            ]
                                           )
                                         );
    val (left, right)                = (mk_eq (left_lhs, left_rhs), mk_eq (right_lhs, right_rhs)) |> Utils.map_pair (Syntax.check_term ctxt);
  in
    [left, right]
  end;

fun ctxt_n_consts_to_distributivity (ctxt:Proof.context) (func1 as Const (_, typ)) =
(* left-distributive:  f (x, g (y, z)) = g (f (x, y), f (x, z))
 * right-distributive: f (g (x, y), z) = g (f (x, y), f (x, z))
 *)
  if takes_n_arguments func1 2 andalso all_args_are_same_typ [func1]
  then
    let
      val return_typ = strip_type typ |> snd                  : typ;
      val b_funcs = ctxt_n_typ_to_binary_const ctxt return_typ: terms;
    in
      map (ctxt_n_consts_to_distributivity' ctxt func1) b_funcs |> flat
    end
  else []
  | ctxt_n_consts_to_distributivity _ _ = [];

fun ctxt_n_consts_to_anti_distributivity' (ctxt:Proof.context) binary_func unary_func =
    let
      val (unary_wo_typ, binary_wo_typ) = Utils.map_pair strip_atyp (unary_func, binary_func)                : (term * term);
      val (var1, var2)                  = Utils.map_pair mk_free_variable_of_dummyT (1,2)                    : (term * term);
      val lhs                           = list_comb (unary_wo_typ, [list_comb (binary_wo_typ, [var1, var2])]): term;
      val rhs                           = list_comb
                                          (binary_wo_typ,
                                           [list_comb (unary_wo_typ, [var2]),
                                            list_comb (unary_wo_typ, [var1])
                                            ]
                                           )
                                          ;
      val anti_distributivity           = mk_eq (lhs, rhs) |> Syntax.check_term ctxt: term;
    in
      [anti_distributivity]
    end;

fun ctxt_n_consts_to_anti_distributivity (ctxt:Proof.context) (binary_func as (Const (_, typ))) =
  if takes_n_arguments binary_func 2 andalso
     all_args_are_same_typ [binary_func]
  then
    let
      val return_typ = strip_type typ |> snd                 : typ;
      val u_funcs = ctxt_n_typ_to_unary_const ctxt return_typ: terms;
    in
     map (ctxt_n_consts_to_anti_distributivity' ctxt binary_func) u_funcs |> flat
    end
  else []
  | ctxt_n_consts_to_anti_distributivity _ _ = [];

fun ctxt_n_consts_to_homomorphism_2' (ctxt:Proof.context) (preserved_binary:term) (homomorphism:term) =
  if all_args_are_same_typ [homomorphism, preserved_binary]
  then
    let
      val (homomorphism_wo_typ, preserved_binary_wo_typ) = Utils.map_pair strip_atyp (homomorphism, preserved_binary) : term * term;
      val (var1, var2) = Utils.map_pair mk_free_variable_of_dummyT (1,2)                                              : term * term;
      val lhs          = homomorphism_wo_typ $ list_comb (preserved_binary_wo_typ, [var1, var2])                      : term;
      val rhs          = list_comb (preserved_binary_wo_typ, [homomorphism_wo_typ $ var1, homomorphism_wo_typ $ var2]): term;
      val proprerty    = mk_eq (lhs, rhs) |> Syntax.check_term ctxt                                                   : term;
    in
      [proprerty]
    end
  else [];

fun ctxt_n_consts_to_homomorphism_2 (ctxt:Proof.context) (preserved_binary as (Const (_, typ)):term) =
(*f is homomorphism.*)
(*f (g (x, y)) = g (f (x), f (y))*)
  if takes_n_arguments preserved_binary 2 andalso
     all_args_are_same_typ [preserved_binary]
  then
    let
      val homomorphisms = ctxt_n_typ_to_unary_const ctxt (strip_type typ |> snd)                          : terms;
      val preserved_binary_wo_typ::homomorphisms_wo_typ = map strip_atyp (preserved_binary::homomorphisms): terms;
      val (var1, var2) = Utils.map_pair mk_free_variable_of_dummyT (1,2)                                  : term * term;
      fun get_property (homomorphism_wo_typ:term) =
        let
          val lhs       = homomorphism_wo_typ $ list_comb (preserved_binary_wo_typ, [var1, var2])                      : term;
          val rhs       = list_comb (preserved_binary_wo_typ, [homomorphism_wo_typ $ var1, homomorphism_wo_typ $ var2]): term;
          val proprerty = mk_eq (lhs, rhs) |> Syntax.check_term ctxt                                                   : term;
        in
          proprerty
        end
    in
      map get_property homomorphisms_wo_typ
    end
  else []
  | ctxt_n_consts_to_homomorphism_2 _ _ = [];

(*bottom_up_for_relations*)
fun term_is_relation (Const (_, typ)) = body_type typ = @{typ "HOL.bool"}
  | term_is_relation  _               = false;

fun condition_for_relation (func:term) =
  term_is_relation func andalso
  takes_n_arguments func 2 andalso
  all_args_are_same_typ [func]

fun mk_implies (ctxt:Proof.context) (prem, cncl) =
   Logic.mk_implies (prem, cncl)
|> Syntax.check_term ctxt: term;

fun ctxt_n_consts_to_symmetry (ctxt:Proof.context) (func as (Const _):term) =
    if condition_for_relation func
    then
      let
        val func_wo_typ  = strip_atyp func                                : term;
        val (var1, var2) = Utils.map_pair mk_free_variable_of_dummyT (1,2): (term * term);
        val premise      = list_comb (func_wo_typ, [var1, var2])          : term;
        val conclusion   = list_comb (func_wo_typ, [var2, var1])          : term;
        val imply        = mk_implies ctxt (premise, conclusion)          : term;
      in [imply] end
    else []
  | ctxt_n_consts_to_symmetry _ _ = [];

fun ctxt_n_consts_to_reflexibility (ctxt:Proof.context) (func as (Const _):term) =
    if condition_for_relation func
    then
      let
        val func_wo_typ  = strip_atyp func                      : term;
        val fvar         = mk_free_variable_of_dummyT 1         : term;
        val premise      = list_comb (func_wo_typ, [fvar, fvar]): term;
        val imply        = mk_implies ctxt (premise, premise)   : term;
      in [imply] end
    else []
  | ctxt_n_consts_to_reflexibility _ _ = [];

fun list_implies (ctxt:Proof.context) (prems: terms, cncl) =
   Logic.list_implies (prems, cncl)
|> Syntax.check_term ctxt: term;

fun ctxt_n_consts_to_transitivity (ctxt:Proof.context) (func as (Const _):term) =
    if condition_for_relation func
    then
      let
        val func_wo_typ        = strip_atyp func                         : term;
        val [var1, var2, var3] = map mk_free_variable_of_dummyT [1, 2, 3]: terms;
        val prem1              = list_comb (func_wo_typ, [var1, var2])   : term;
        val prem2              = list_comb (func_wo_typ, [var2, var3])   : term;
        val cncl               = list_comb (func_wo_typ, [var1, var3])   : term;
        val imply              = list_implies ctxt ([prem1, prem2], cncl): term;
      in [imply] end
    else []
  | ctxt_n_consts_to_transitivity _ _ = [];

val mk_holdisj = HOLogic.mk_disj;

fun ctxt_n_consts_to_connexity (ctxt:Proof.context) (func as (Const _)) =
    if condition_for_relation func
    then
      let
        val func_wo_typ  = strip_atyp func                                : term;
        val (var1, var2) = Utils.map_pair mk_free_variable_of_dummyT (1,2): (term * term);
        val x_R_y        = list_comb (func_wo_typ, [var1, var2])          : term;
        val y_R_x        = list_comb (func_wo_typ, [var2, var1])          : term;
        val x_is_y       = HOLogic.mk_eq (var1, var2)                     : term;
        val disjuncts    = mk_holdisj (mk_holdisj (x_R_y, y_R_x), x_is_y)
                        |> Syntax.check_term ctxt                         : term;
      in [disjuncts] end
    else []
  | ctxt_n_consts_to_connexity _ _ = [];

fun ctxt_n_const_to_all_conjecture_term (ctxt:Proof.context) (func as (Const _)) =
  ctxt_n_const_to_associativity        ctxt func
@ ctxt_n_const_to_identity             ctxt func
@ ctxt_n_const_to_commutativity        ctxt func
@ ctxt_n_const_to_idempotent_element   ctxt func
@ ctxt_n_const_to_idempotence          ctxt func
@ ctxt_n_consts_to_distributivity      ctxt func
@ ctxt_n_consts_to_anti_distributivity ctxt func
@ ctxt_n_consts_to_homomorphism_2      ctxt func
@ ctxt_n_consts_to_symmetry            ctxt func
@ ctxt_n_consts_to_reflexibility       ctxt func
@ ctxt_n_consts_to_transitivity        ctxt func
@ ctxt_n_consts_to_connexity           ctxt func;
     (*
     [ctxt_consts_string_trm_to_conjecture ctxt [func1, func2] "left_distributivity"  left,
      ctxt_consts_string_trm_to_conjecture ctxt [func1, func2] "right_distributivity" right]
     *)
end;
\<close>

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

print_theorems

datatype Nat = Z | S "Nat"

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

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

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

lemma "qrev var_1 nil2 = var_1"
  quickcheck
  oops

lemma "qrev nil2 var_1 = var_1"
  try_hard
  oops

lemma "qrev var_1 Bottom_Up_Conjecturing.list.wit_list = var_1 \<Longrightarrow> False"
  oops

end


section \<open>\isaheader{Array-Based Maps with Natural Number Keys}\<close>
theory Impl_Array_Map
imports
  Automatic_Refinement.Automatic_Refinement
  "../../Lib/Diff_Array"
  "../../Iterator/Iterator"
  "../Gen/Gen_Map"
  "../Intf/Intf_Comp"
  "../Intf/Intf_Map"
begin

type_synonym 'v iam = "'v option array"

subsection \<open>Definitions\<close>

definition iam_\<alpha> :: "'v iam \<Rightarrow> nat \<rightharpoonup> 'v" where
  "iam_\<alpha> a i \<equiv> if i < array_length a then array_get a i else None"

abbreviation iam_invar :: "'v iam \<Rightarrow> bool" where "iam_invar \<equiv> \<lambda>_. True"

definition iam_empty :: "unit \<Rightarrow> 'v iam"
  where "iam_empty \<equiv> \<lambda>_::unit. array_of_list []"

definition iam_lookup :: "nat \<Rightarrow> 'v iam \<rightharpoonup> 'v"
  where [code_unfold]: "iam_lookup k a \<equiv> iam_\<alpha> a k"

definition "iam_increment (l::nat) idx \<equiv>
  max (idx + 1 - l) (2 * l + 3)"

lemma incr_correct: "\<not> idx < l \<Longrightarrow> idx < l + iam_increment l idx"
  unfolding iam_increment_def by auto

definition iam_update :: "nat \<Rightarrow> 'v \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
  where "iam_update k v a \<equiv> let
    l = array_length a;
    a = if k < l then a else array_grow a (iam_increment l k) None
  in
    array_set a k (Some v)"

lemma [code]: "iam_update k v a \<equiv> array_set_oo
  (\<lambda>_. let l=array_length a in
         array_set (array_grow a (iam_increment l k) None) k (Some v))
  a k (Some v)"
  unfolding iam_update_def array_set_oo_def
  apply (rule eq_reflection)
  by auto

definition iam_delete :: "nat \<Rightarrow> 'v iam \<Rightarrow> 'v iam"
  where "iam_delete k a \<equiv>
  if k<array_length a then array_set a k None else a"

lemma [code]: "iam_delete k a \<equiv> array_set_oo (\<lambda>_. a) a k None"
  unfolding iam_delete_def array_set_oo_def by auto

primrec iam_iteratei_aux
  :: "nat \<Rightarrow> ('v iam) \<Rightarrow> ('\<sigma>\<Rightarrow>bool) \<Rightarrow> (nat \<times> 'v\<Rightarrow>'\<sigma>\<Rightarrow>'\<sigma>) \<Rightarrow> '\<sigma> \<Rightarrow> '\<sigma>"
  where
    "iam_iteratei_aux 0 a c f \<sigma> = \<sigma>"
  | "iam_iteratei_aux (Suc i) a c f \<sigma> = (
      if c \<sigma> then
        iam_iteratei_aux i a c f (
          case array_get a i of None \<Rightarrow> \<sigma> | Some x \<Rightarrow> f (i, x) \<sigma>
        )
      else \<sigma>)"

definition iam_iteratei :: "'v iam \<Rightarrow> (nat \<times> 'v,'\<sigma>) set_iterator" where
  "iam_iteratei a = iam_iteratei_aux (array_length a) a"

subsection \<open>Parametricity\<close>

definition iam_rel_def_internal:
  "iam_rel R \<equiv> \<langle>\<langle>R\<rangle> option_rel\<rangle> array_rel"
lemma iam_rel_def: "\<langle>R\<rangle> iam_rel = \<langle>\<langle>R\<rangle> option_rel\<rangle> array_rel"
    by (simp add: iam_rel_def_internal relAPP_def)

lemma iam_rel_sv[relator_props]:
  "single_valued Rv \<Longrightarrow> single_valued (\<langle>Rv\<rangle>iam_rel)"
  unfolding iam_rel_def
  by tagged_solver

lemma param_iam_\<alpha>[param]:
  "(iam_\<alpha>, iam_\<alpha>) \<in> \<langle>R\<rangle> iam_rel \<rightarrow> nat_rel \<rightarrow> \<langle>R\<rangle> option_rel"
  unfolding iam_\<alpha>_def[abs_def] iam_rel_def by parametricity

lemma param_iam_invar[param]:
  "(iam_invar, iam_invar) \<in> \<langle>R\<rangle> iam_rel \<rightarrow> bool_rel"
  unfolding iam_rel_def by parametricity

lemma param_iam_empty[param]:
  "(iam_empty, iam_empty) \<in> unit_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
    unfolding iam_empty_def[abs_def] iam_rel_def by parametricity

lemma param_iam_lookup[param]:
  "(iam_lookup, iam_lookup) \<in> nat_rel \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>option_rel"
  unfolding iam_lookup_def[abs_def]
  by parametricity

(* TODO: why does parametricity fail here? *)
lemma param_iam_increment[param]:
  "(iam_increment, iam_increment) \<in> nat_rel \<rightarrow> nat_rel \<rightarrow> nat_rel"
  unfolding iam_increment_def[abs_def]
  by simp

(* TODO: The builtin "Let" rule for parametricity does some unpleasant things
         here, leading to an unprovable subgoal. Investigate this. *)
lemma param_iam_update[param]:
  "(iam_update, iam_update) \<in> nat_rel \<rightarrow> R \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
unfolding iam_update_def[abs_def] iam_rel_def Let_def
apply parametricity
done

lemma param_iam_delete[param]:
  "(iam_delete, iam_delete) \<in> nat_rel \<rightarrow> \<langle>R\<rangle>iam_rel \<rightarrow> \<langle>R\<rangle>iam_rel"
  unfolding iam_delete_def[abs_def] iam_rel_def by parametricity

lemma param_iam_iteratei_aux[param]:
  assumes I: "i \<le> array_length a"
  assumes IR: "(i,i') \<in> nat_rel"
  assumes AR: "(a,a') \<in> \<langle>Ra\<rangle>iam_rel"
  assumes CR: "(c,c') \<in> Rb \<rightarrow> bool_rel"
  assumes FR: "(f,f') \<in> \<langle>nat_rel,Ra\<rangle>prod_rel \<rightarrow> Rb \<rightarrow> Rb"
  assumes \<sigma>R: "(\<sigma>,\<sigma>') \<in> Rb"
  shows "(iam_iteratei_aux i a c f \<sigma>, iam_iteratei_aux i' a' c' f' \<sigma>') \<in> Rb"
  using assms
  unfolding iam_rel_def
  apply (induct i' arbitrary: i \<sigma> \<sigma>')
  apply (simp_all only: pair_in_Id_conv iam_iteratei_aux.simps)
  apply parametricity
  apply simp_all
  done

lemma param_iam_iteratei[param]:
  "(iam_iteratei,iam_iteratei) \<in> \<langle>Ra\<rangle>iam_rel \<rightarrow> (Rb \<rightarrow> bool_rel) \<rightarrow>
      (\<langle>nat_rel,Ra\<rangle>prod_rel \<rightarrow> Rb \<rightarrow> Rb) \<rightarrow> Rb \<rightarrow> Rb"
  unfolding iam_iteratei_def[abs_def]
  by parametricity (simp_all add: iam_rel_def)

subsection \<open>Correctness\<close>

definition "iam_rel' \<equiv> br iam_\<alpha> iam_invar"

lemma iam_empty_correct:
  "(iam_empty (), Map.empty) \<in>  iam_rel'"
   by (simp add: iam_rel'_def br_def iam_\<alpha>_def[abs_def] iam_empty_def)

lemma iam_update_correct:
  "(iam_update,op_map_update) \<in> nat_rel \<rightarrow> Id \<rightarrow> iam_rel'  \<rightarrow> iam_rel'"
   by (auto simp: iam_rel'_def br_def Let_def array_get_array_set_other
                  incr_correct iam_\<alpha>_def[abs_def] iam_update_def)

lemma iam_lookup_correct:
  "(iam_lookup,op_map_lookup) \<in> Id \<rightarrow> iam_rel' \<rightarrow> \<langle>Id\<rangle>option_rel"
   by (auto simp: iam_rel'_def br_def iam_lookup_def[abs_def])

lemma array_get_set_iff: "i<array_length a \<Longrightarrow>
  array_get (array_set a i x) j = (if i=j then x else array_get a j)"
  by (auto simp: array_get_array_set_other)

lemma iam_delete_correct:
  "(iam_delete,op_map_delete) \<in> Id \<rightarrow> iam_rel' \<rightarrow> iam_rel'"
  unfolding iam_\<alpha>_def[abs_def] iam_delete_def[abs_def] iam_rel'_def br_def
  by (auto simp: Let_def array_get_set_iff)

definition iam_map_rel_def_internal:
  "iam_map_rel Rk Rv \<equiv>
    if Rk=nat_rel then \<langle>Rv\<rangle>iam_rel O iam_rel' else {}"
lemma iam_map_rel_def:
  "\<langle>nat_rel,Rv\<rangle>iam_map_rel \<equiv> \<langle>Rv\<rangle>iam_rel O iam_rel'"
  unfolding iam_map_rel_def_internal relAPP_def by simp

lemmas [autoref_rel_intf] = REL_INTFI[of "iam_map_rel" i_map]

lemma iam_map_rel_sv[relator_props]:
  "single_valued Rv \<Longrightarrow> single_valued (\<langle>nat_rel,Rv\<rangle>iam_map_rel)"
  unfolding iam_map_rel_def iam_rel'_def by tagged_solver

lemma iam_empty_impl:
    "(iam_empty (), op_map_empty) \<in> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def op_map_empty_def
  apply (intro relcompI)
  apply (rule param_iam_empty[THEN fun_relD], simp)
  apply (rule iam_empty_correct)
  done

lemma iam_lookup_impl:
    "(iam_lookup, op_map_lookup)
  \<in> nat_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>R\<rangle>option_rel"
unfolding iam_map_rel_def
apply (intro fun_relI)
apply (elim relcompE)
apply (frule iam_lookup_correct[param_fo], assumption)
apply (frule param_iam_lookup[param_fo], assumption)
apply simp
done

lemma iam_update_impl:
   "(iam_update, op_map_update) \<in>
     nat_rel \<rightarrow> R \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (2) param_iam_update[param_fo])
  apply (rule iam_update_correct[param_fo])
  apply simp_all
  done

lemma iam_delete_impl:
    "(iam_delete, op_map_delete) \<in>
        nat_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel \<rightarrow> \<langle>nat_rel,R\<rangle>iam_map_rel"
  unfolding iam_map_rel_def
  apply (intro fun_relI, elim relcompEpair, intro relcompI)
  apply (erule (1) param_iam_delete[param_fo])
  apply (rule iam_delete_correct[param_fo])
  by simp_all

lemmas iam_map_impl =
  iam_empty_impl
  iam_lookup_impl
  iam_update_impl
  iam_delete_impl

declare iam_map_impl[autoref_rules]

subsection \<open>Iterator proofs\<close>

abbreviation "iam_to_list a \<equiv> it_to_list iam_iteratei a"

lemma distinct_iam_to_list_aux:
  shows "\<lbrakk>distinct xs; \<forall>(i,_)\<in>set xs. i \<ge> n\<rbrakk> \<Longrightarrow>
        distinct (iam_iteratei_aux n a
            (\<lambda>_.True) (\<lambda>x y. y @ [x]) xs)"
   (is "\<lbrakk>_;_\<rbrakk> \<Longrightarrow> distinct (?iam_to_list_aux n xs)")
proof (induction n arbitrary: xs)
  case (0 xs) thus ?case by simp
next
  case (Suc i xs)
    show ?case
    proof (cases "array_get a i")
      case None
        with Suc.IH[OF Suc.prems(1)] Suc.prems(2)
            show ?thesis by force
    next
      case (Some x)
        let ?xs' = "xs @ [(i,x)]"
        from Suc.prems have "distinct ?xs'" and
            "\<forall>(i',x)\<in>set ?xs'. i' \<ge> i" by force+
        from Some and Suc.IH[OF this] show ?thesis by simp
  qed
qed

lemma distinct_iam_to_list:
  "distinct (iam_to_list a)"
unfolding it_to_list_def iam_iteratei_def
  by (force intro: distinct_iam_to_list_aux)

lemma iam_to_list_set_correct_aux:
  assumes "(a, m) \<in> iam_rel'"
  shows "\<lbrakk>n \<le> array_length a; map_to_set m - {(k,v). k < n} = set xs\<rbrakk>
         \<Longrightarrow> map_to_set m =
             set (iam_iteratei_aux n a (\<lambda>_.True) (\<lambda>x y. y @ [x]) xs)"
proof (induction n arbitrary: xs)
  case (0 xs)
    thus ?case by simp
next
  case (Suc n xs)
    with assms have [simp]: "array_get a n = m n"
        unfolding iam_rel'_def br_def iam_\<alpha>_def[abs_def] by simp
    show ?case
    proof (cases "m n")
      case None
        with Suc.prems(2) have "map_to_set m - {(k,v). k < n} = set xs"
        unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from None and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    next
      case (Some x)
        let ?xs' = "xs @ [(n,x)]"
        from Some and Suc.prems(2)
            have "map_to_set m - {(k,v). k < n} = set ?xs'"
            unfolding map_to_set_def by (fastforce simp: less_Suc_eq)
        from Some and Suc.IH[OF _ this] and Suc.prems(1)
            show ?thesis by simp
    qed
qed

lemma iam_to_list_set_correct:
  assumes "(a, m) \<in> iam_rel'"
  shows "map_to_set m = set (iam_to_list a)"
proof-
  from assms
      have A: "map_to_set m - {(k, v). k < array_length a} = set []"
      unfolding map_to_set_def iam_rel'_def br_def iam_\<alpha>_def[abs_def]
      by (force split: if_split_asm)
  with iam_to_list_set_correct_aux[OF assms _ A] show ?thesis
    unfolding it_to_list_def iam_iteratei_def by simp
qed

lemma iam_iteratei_aux_append:
  "n \<le> length xs \<Longrightarrow> iam_iteratei_aux n (Array (xs @ ys)) =
             iam_iteratei_aux n (Array xs)"
apply (induction n)
apply force
apply (intro ext, auto split: option.split simp: nth_append)
done

lemma iam_iteratei_append:
  "iam_iteratei (Array (xs @ [None])) c f \<sigma> =
       iam_iteratei (Array xs) c f \<sigma>"
  "iam_iteratei (Array (xs @ [Some x])) c f \<sigma> =
       iam_iteratei (Array xs) c f
       (if c \<sigma> then (f (length xs, x) \<sigma>) else \<sigma>)"
unfolding  iam_iteratei_def
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force simp: nth_append iam_iteratei_aux_append) []
apply (cases "length xs")
apply (simp add: iam_iteratei_aux_append)
apply (force split: option.split
             simp: nth_append iam_iteratei_aux_append) []
done

lemma iam_iteratei_aux_Cons:
  "n < array_length a \<Longrightarrow>
      iam_iteratei_aux n a (\<lambda>_. True) (\<lambda>x l. l @ [x]) (x#xs) =
      x # iam_iteratei_aux n a (\<lambda>_. True) (\<lambda>x l. l @ [x]) xs"
    by (induction n arbitrary: xs, auto split: option.split)

lemma iam_to_list_append:
  "iam_to_list (Array (xs @ [None])) = iam_to_list (Array xs)"
  "iam_to_list (Array (xs @ [Some x])) =
       (length xs, x) # iam_to_list (Array xs)"
unfolding  it_to_list_def iam_iteratei_def
apply (simp add: iam_iteratei_aux_append)
apply (simp add: iam_iteratei_aux_Cons)
apply (simp add: iam_iteratei_aux_append)
done

lemma autoref_iam_is_iterator[autoref_ga_rules]:
  shows "is_map_to_list nat_rel Rv iam_map_rel iam_to_list"
  unfolding is_map_to_list_def is_map_to_sorted_list_def
proof (clarify)
  fix a m'
  assume "(a,m') \<in> \<langle>nat_rel,Rv\<rangle>iam_map_rel"
  then obtain a' where [param]: "(a,a')\<in>\<langle>Rv\<rangle>iam_rel"
    and "(a',m')\<in>iam_rel'" unfolding iam_map_rel_def by blast

  have "(iam_to_list a, iam_to_list a')
            \<in> \<langle>\<langle>nat_rel, Rv\<rangle>prod_rel\<rangle>list_rel" by parametricity

  moreover from distinct_iam_to_list and
                iam_to_list_set_correct[OF \<open>(a',m')\<in>iam_rel'\<close>]
      have "RETURN (iam_to_list a') \<le> it_to_sorted_list
               (key_rel (\<lambda>_ _. True)) (map_to_set m')"
      unfolding it_to_sorted_list_def key_rel_def[abs_def]
          by (force intro: refine_vcg)

  ultimately show "\<exists>l'. (iam_to_list a, l') \<in>
                            \<langle>\<langle>nat_rel, Rv\<rangle>prod_rel\<rangle>list_rel
                    \<and> RETURN l' \<le> it_to_sorted_list (
                        key_rel (\<lambda>_ _. True)) (map_to_set m')" by blast
qed

(* We provide a ,,sorted'' iterator to simplify derivations of the
    generic algorithm library *)
lemmas [autoref_ga_rules] =
  autoref_iam_is_iterator[unfolded is_map_to_list_def]

lemma iam_iteratei_altdef:
    "iam_iteratei a = foldli (iam_to_list a)"
     (is "?f a = ?g (iam_to_list a)")
proof-
  obtain l where "a = Array l" by (cases a)
  have "?f (Array l) = ?g (iam_to_list (Array l))"
  proof (induction "length l" arbitrary: l)
    case (0 l)
      thus ?case by (intro ext,
          simp add: iam_iteratei_def it_to_list_def)
  next
    case (Suc n l)
      hence "l \<noteq> []" and [simp]: "length l = Suc n" by force+
      with append_butlast_last_id have [simp]:
          "butlast l @ [last l] = l" by simp
      with Suc have [simp]: "length (butlast l) = n" by simp
      note IH = Suc(1)[OF this[symmetric]]
      let ?l' = "iam_to_list (Array l)"

      show ?case
      proof (cases "last l")
        case None
          have "?f (Array l) =
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list (Array (butlast l)))"
              by (force simp: None iam_iteratei_append IH)
          also have "iam_to_list (Array (butlast l)) =
              iam_to_list (Array (butlast l @ [last l]))"
              using None by (simp add: iam_to_list_append)
          finally show "?f (Array l) = ?g ?l'" by simp
      next
        case (Some x)
          have "?f (Array l) =
              ?f (Array (butlast l @ [last l]))" by simp
          also have "... = ?g (iam_to_list
              (Array (butlast l @ [last l])))"
              by (force simp: IH iam_iteratei_append
                      iam_to_list_append Some)
          finally show ?thesis by simp
      qed
  qed
  thus ?thesis by (simp add: \<open>a = Array l\<close>)
qed

lemma pi_iam[icf_proper_iteratorI]:
  "proper_it (iam_iteratei a) (iam_iteratei a)"
unfolding proper_it_def by (force simp: iam_iteratei_altdef)

lemma pi'_iam[icf_proper_iteratorI]:
  "proper_it' iam_iteratei iam_iteratei"
  by (rule proper_it'I, rule pi_iam)

end