theory Hex
  imports Main HOL.String "HOL-Word.Word"
begin

(* this file is going to contain some miscellaneous tools
such as hex reading/writing *)
definition hexread1_dom :: "char \<Rightarrow> bool" where
"hexread1_dom c = (c = CHR ''0'' \<or> c = CHR ''1'' \<or> c = CHR ''2'' \<or>
                   c = CHR ''3'' \<or> c = CHR ''4'' \<or> c = CHR ''5'' \<or>
                   c = CHR ''6'' \<or> c = CHR ''7'' \<or> c = CHR ''8'' \<or>
                   c = CHR ''9'' \<or> c = CHR ''A'' \<or> c = CHR ''B'' \<or>
                   c = CHR ''D'' \<or> c = CHR ''E'' \<or> c = CHR ''F'' \<or>
                   c = CHR ''a'' \<or> c = CHR ''b'' \<or> c = CHR ''d'' \<or>
                   c = CHR ''e'' \<or> c = CHR ''f'')"

definition hexread1 :: "char \<Rightarrow> nat" where
"hexread1 c = (if c = (CHR ''0'') then 0 else
               if c = (CHR ''1'') then 1 else
               if c = (CHR ''2'') then 2 else
               if c = (CHR ''3'') then 3 else
               if c = (CHR ''4'') then 4 else
               if c = (CHR ''5'') then 5 else
               if c = (CHR ''6'') then 6 else
               if c = (CHR ''7'') then 7 else
               if c = (CHR ''8'') then 8 else
               if c = (CHR ''9'') then 9 else
               if c = (CHR ''A'') then 10 else
               if c = (CHR ''B'') then 11 else
               if c = (CHR ''C'') then 12 else
               if c = (CHR ''D'') then 13 else
               if c = (CHR ''E'') then 14 else
               if c = (CHR ''F'') then 15 else
               if c = (CHR ''a'') then 10 else
               if c = (CHR ''b'') then 11 else
               if c = (CHR ''c'') then 12 else
               if c = (CHR ''d'') then 13 else
               if c = (CHR ''e'') then 14 else
               if c = (CHR ''f'') then 15 else
               undefined)"

definition hexwrite1_dom :: "nat \<Rightarrow> bool" where
"hexwrite1_dom n = (n < 16)"

definition hexwrite1_upper :: "nat \<Rightarrow> char" where
"hexwrite1_upper c = (if c = 0 then CHR ''0'' else
                if c = 1 then CHR ''1'' else
                if c = 2 then CHR ''2'' else
                if c = 3 then CHR ''3'' else
                if c = 4 then CHR ''4'' else
                if c = 5 then CHR ''5'' else
                if c = 6 then CHR ''6'' else
                if c = 7 then CHR ''7'' else
                if c = 8 then CHR ''8'' else
                if c = 9 then CHR ''9'' else
                if c = 10 then CHR ''A'' else
                if c = 11 then CHR ''B'' else
                if c = 12 then CHR ''C'' else
                if c = 13 then CHR ''D'' else
                if c = 14 then CHR ''E'' else
                if c = 15 then CHR ''F'' else undefined)"

definition hexwrite1 :: "nat \<Rightarrow> char" where
"hexwrite1 c = (if c = 0 then CHR ''0'' else
                if c = 1 then CHR ''1'' else
                if c = 2 then CHR ''2'' else
                if c = 3 then CHR ''3'' else
                if c = 4 then CHR ''4'' else
                if c = 5 then CHR ''5'' else
                if c = 6 then CHR ''6'' else
                if c = 7 then CHR ''7'' else
                if c = 8 then CHR ''8'' else
                if c = 9 then CHR ''9'' else
                if c = 10 then CHR ''a'' else
                if c = 11 then CHR ''b'' else
                if c = 12 then CHR ''c'' else
                if c = 13 then CHR ''d'' else
                if c = 14 then CHR ''e'' else
                if c = 15 then CHR ''f'' else undefined)"

value "(1 < (0::nat))"

(*
lemma hexread1_hexwrite1 : "hexread1_dom c \<Longrightarrow> hexwrite1 (hexread1 c) = c"
  apply (auto simp add:hexread1_dom_def hexread1_def hexwrite1_def)
  done
*)
lemma hexwrite1_help :
"n < 16 \<Longrightarrow>
    n \<noteq> 15 \<Longrightarrow>
    n \<noteq> 14 \<Longrightarrow>
    n \<noteq> 13 \<Longrightarrow>
    n \<noteq> 12 \<Longrightarrow>
    n \<noteq> 11 \<Longrightarrow>
    n \<noteq> 10 \<Longrightarrow>
    n \<noteq> 9 \<Longrightarrow>
    n \<noteq> 8 \<Longrightarrow>
    n \<noteq> 7 \<Longrightarrow>
    n \<noteq> 6 \<Longrightarrow>
    n \<noteq> 5 \<Longrightarrow>
    n \<noteq> 4 \<Longrightarrow>
    n \<noteq> 3 \<Longrightarrow>
    n \<noteq> 2 \<Longrightarrow>
    n \<noteq> Suc 0 \<Longrightarrow>
    0 < n \<Longrightarrow> False"
proof(induction n, auto)
qed

(*
lemma hexwrite1_hexread1 : "hexwrite1_dom n \<Longrightarrow> hexread1 (hexwrite1 n) = n"
  apply(auto simp add:hexwrite1_dom_def hexwrite1_def)
                  apply(auto simp add:hexread1_def)
                  apply(insert hexwrite1_help, auto)
  done
*)

definition hexread2 :: "char \<Rightarrow> char \<Rightarrow> int" where
"hexread2 c1 c2 = (16 * (int (hexread1 c1)) + int (hexread1 c2))"

(* we need to reverse the input list? *)
(* TODO: later handle zero padding for odd numbers of bytes *)
fun hexread' :: "char list \<Rightarrow> int \<Rightarrow> int" where
"hexread' [] n = n"
| "hexread' [_] _ = undefined"
| "hexread' (n1#n2#t) a = hexread' t (hexread2 n1 n2 + 256 * a)"

definition hexread :: "char list \<Rightarrow> int" where
"hexread ls = hexread' ls 0"

fun hexwrite2 :: "8 word \<Rightarrow> (char * char)" where
"hexwrite2 w =
  (case Divides.divmod_nat (Word.unat w) 16 of
       (d,m) \<Rightarrow> (hexwrite1 d, hexwrite1 m))"

(* TODO: make sure we aren't supposed to do the reverse of this *)
fun hexwrite :: "8 word list \<Rightarrow> char list" where
"hexwrite [] = []"
| "hexwrite (h#t) = (case hexwrite2 h of
                     (c1, c2) \<Rightarrow> c1#c2#(hexwrite t))"

value "List.n_lists 2 [1 :: nat, 2, 3]"

(* splitting a hex string into bytes *)

fun hex_split_bytes' :: "char list \<Rightarrow> char list list" where
"hex_split_bytes' [] = []"
| "hex_split_bytes' [h] = [[h]]" (* should never happen *)
| "hex_split_bytes' (h1#h2#t) =
    (h1#h2#[])#(hex_split_bytes' t)"

fun hex_split_bytes ::
  "char list \<Rightarrow> char list list" where
"hex_split_bytes ls =
  (case divmod_nat (length ls) 2 of
    (_, 0) \<Rightarrow> hex_split_bytes' ls
  | (_, _) \<Rightarrow> hex_split_bytes' ((CHR ''0'') # ls))"

value "hex_split_bytes
''000000000000000000000000000000000000000000000000000000000000002a''"

(* TODO: this will still choke if given non-hex characters. *)
fun hex_splits :: "char list \<Rightarrow> 8 word list" where
"hex_splits l =
  List.map (\<lambda> x . Word.word_of_int (hexread x)) (hex_split_bytes l)"

value "hex_splits
''000000000000000000000000000000000000000000000000000000000000002a''"

(* decimal reading/writing - for use in generating error messages *)

definition decwrite1_dom :: "nat \<Rightarrow> bool" where
"decwrite1_dom n = (n < 10)"

definition decwrite1 :: "nat \<Rightarrow> char" where
"decwrite1 c = (if c = 0 then CHR ''0'' else
                if c = 1 then CHR ''1'' else
                if c = 2 then CHR ''2'' else
                if c = 3 then CHR ''3'' else
                if c = 4 then CHR ''4'' else
                if c = 5 then CHR ''5'' else
                if c = 6 then CHR ''6'' else
                if c = 7 then CHR ''7'' else
                if c = 8 then CHR ''8'' else
                if c = 9 then CHR ''9'' else undefined)"

(*
lemma hexread1_hexwrite1 : "hexread1_dom c \<Longrightarrow> hexwrite1 (hexread1 c) = c"
  apply (auto simp add:hexread1_dom_def hexread1_def hexwrite1_def)
  done
*)
lemma decwrite1_help :
"n < 10 \<Longrightarrow>
    n \<noteq> 9 \<Longrightarrow>
    n \<noteq> 8 \<Longrightarrow>
    n \<noteq> 7 \<Longrightarrow>
    n \<noteq> 6 \<Longrightarrow>
    n \<noteq> 5 \<Longrightarrow>
    n \<noteq> 4 \<Longrightarrow>
    n \<noteq> 3 \<Longrightarrow>
    n \<noteq> 2 \<Longrightarrow>
    n \<noteq> Suc 0 \<Longrightarrow>
    0 < n \<Longrightarrow> False"
proof(induction n, auto)
qed

fun decwrite2 :: "nat \<Rightarrow> (char * char)" where
"decwrite2 w =
  (case Divides.divmod_nat w 10 of
       (d,m) \<Rightarrow> (decwrite1 d, decwrite1 m))"

function(sequential) decwrite' :: "nat \<Rightarrow> char list" where
"decwrite' n = (if n < 10 then [decwrite1 n] else
              (case Divides.divmod_nat n 10 of
                     (d, m) \<Rightarrow> (decwrite1 m # (decwrite' d))))"
  by pat_completeness auto

termination
  apply(relation "(measure (\<lambda> n . if n < 10 then 1 else Suc n))")
   apply(clarsimp)
  apply(clarsimp) apply(simp add:divmod_nat_def)
  done

fun decwrite :: "nat \<Rightarrow> char list" where
"decwrite n = rev (decwrite' n)"

(*
lemma hexwrite1_hexread1 : "hexwrite1_dom n \<Longrightarrow> hexread1 (hexwrite1 n) = n"
  apply(auto simp add:hexwrite1_dom_def hexwrite1_def)
                  apply(auto simp add:hexread1_def)
                  apply(insert hexwrite1_help, auto)
  done
*)

end


(*  Title:      HOL/MicroJava/BV/Altern.thy
    Author:     Martin Strecker
*)

section \<open>Alternative definition of well-typing of bytecode,  used in compiler type correctness proof\<close>

theory Altern
imports BVSpec
begin

definition check_type :: "jvm_prog \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> JVMType.state \<Rightarrow> bool" where
  "check_type G mxs mxr s \<equiv> s \<in> states G mxs mxr"

definition wt_instr_altern :: "[instr,jvm_prog,ty,method_type,nat,nat,p_count,
                exception_table,p_count] \<Rightarrow> bool" where
  "wt_instr_altern i G rT phi mxs mxr max_pc et pc \<equiv>
  app i G mxs rT pc et (phi!pc) \<and>
  check_type G mxs mxr (OK (phi!pc)) \<and>
  (\<forall>(pc',s') \<in> set (eff i G pc et (phi!pc)). pc' < max_pc \<and> G \<turnstile> s' <=' phi!pc')"

definition wt_method_altern :: "[jvm_prog,cname,ty list,ty,nat,nat,instr list,
                 exception_table,method_type] \<Rightarrow> bool" where
  "wt_method_altern G C pTs rT mxs mxl ins et phi \<equiv>
  let max_pc = length ins in
  0 < max_pc \<and>
  length phi = length ins \<and>
  check_bounded ins et \<and>
  wt_start G C pTs mxl phi \<and>
  (\<forall>pc. pc<max_pc \<longrightarrow> wt_instr_altern (ins!pc) G rT phi mxs (1+length pTs+mxl) max_pc et pc)"

lemma wt_method_wt_method_altern :
  "wt_method G C pTs rT mxs mxl ins et phi \<longrightarrow> wt_method_altern G C pTs rT mxs mxl ins et phi"
apply (simp add: wt_method_def wt_method_altern_def)
apply (intro strip)
apply clarify
apply (drule spec, drule mp, assumption)
apply (simp add: check_types_def wt_instr_def wt_instr_altern_def check_type_def)
apply (auto  intro: imageI)
done

lemma check_type_check_types [rule_format]:
  "(\<forall>pc. pc < length phi \<longrightarrow> check_type G mxs mxr (OK (phi ! pc)))
  \<longrightarrow> check_types G mxs mxr (map OK phi)"
apply (induct phi)
apply (simp add: check_types_def)
apply (simp add: check_types_def)
apply clarify
apply (frule_tac x=0 in spec)
apply (simp add: check_type_def)
apply auto
done

lemma wt_method_altern_wt_method [rule_format]:
  "wt_method_altern G C pTs rT mxs mxl ins et phi \<longrightarrow> wt_method G C pTs rT mxs mxl ins et phi"
apply (simp add: wt_method_def wt_method_altern_def)
apply (intro strip)
apply clarify
apply (rule conjI)
  (* show check_types *)
apply (rule check_type_check_types)
apply (simp add: wt_instr_altern_def)

  (* show wt_instr *)
apply (intro strip)
apply (drule spec, drule mp, assumption)
apply (simp add: wt_instr_def wt_instr_altern_def)
done

end


           (*-------------------------------------------*
            |    Example 1 [Roscoe_Dathi_1987 P.10]     |
            |             WITH computation              |
            |  Self-timed version of a systolic array   |
            |                   June 2005               |
            |               December 2005  (modified)   |
            |                                           |
            |   on DFP on CSP-Prover ver.3.0            |
            |              September 2006  (modified)   |
            |                                           |
            |   on DFP on CSP-Prover ver.4.0            |
            |                  April 2007  (modified)   |
            |                   June 2008  (modified)   |
            |                                           |
            |   on DFP on CSP-Prover ver.5.0            |
            |                    May 2016  (modified)   |
            |                                           |
            |        Yoshinao Isobe (AIST JAPAN)        |
            *-------------------------------------------*)

theory SA_definition
imports DFP_Main HOL.Rings
begin

(*********************************************************
                         event
 *********************************************************)

datatype 'r Event = vert "nat * nat" 'r | hori "nat * nat" 'r

(*********************************************************
                  element process
 *********************************************************)

type_synonym index_type = "nat * nat"

datatype 'r ProcName = pe "index_type" 'r | pe' "index_type" 'r 'r 'r

fun
  SAfun  :: "('r::ring) ProcName => ('r ProcName, 'r Event) proc"

where
  "SAfun (pe (i,j) r) = (vert (i,j) ? x -> hori (i,j) ? y -> $(pe' (i,j) r x y)) [+]
                        (hori (i,j) ? y -> vert (i,j) ? x -> $(pe' (i,j) r x y))"

 | "SAfun (pe' (i,j) r x y) = ((vert (i+1,j) ! x -> SKIP) |||
                                 (hori (i,j+1) ! y -> SKIP)) ;;
                                 $(pe (i,j) (r + x * y))"
(*
defs (overloaded)
 set_SAfun_Pnfun_def [simp]: "PNfun == SAfun"
*)

overloading Set_SAfun ==
  "PNfun :: (('r::ring) ProcName, 'r Event) pnfun"
begin
  definition "PNfun :: (('r::ring) ProcName, 'r Event) pnfun == SAfun"
end

declare Set_SAfun_def [simp]

(*
defs
 set_FPmode_def [simp]: "FPmode == CPOmode"
*)

overloading FPmode ==
  "FPmode :: fpmode"
begin
  definition "FPmode == CPOmode"
end
declare FPmode_def [simp]

(*** fixed point ***)

lemma pe_FIX:
  "$(pe ij r) =F (FIX SAfun) (pe ij r)"
apply (rule cspF_rw_left)
apply (rule cspF_FIX)
apply (simp)+
done

(*** network ***)

fun
  Alpha_pe :: "index_type => ('r::ring) Event set"

where
  "Alpha_pe (i,j) = {a. EX x. a = vert (i  ,j) x | a = hori (i,j  ) x |
                              a = vert (i+1,j) x | a = hori (i,j+1) x }"

declare Alpha_pe.simps [simp del]

definition
  Array_Index :: "nat => index_type set"
  where
  Array_Index_def : "Array_Index N == {(i,j)|i j. i < N & j < N}"

definition
  Systolic_Array :: "nat => (index_type,('r::ring) ProcName,'r Event) Network"
  where
  Systolic_Array_def:
  "Systolic_Array N ==
   { ($(pe (i,j) 0), Alpha_pe (i,j)) | (i,j) : (Array_Index N)}net"

(*---------------------------------*
 | Failures sets of Systolic_Array |
 *---------------------------------*)

(*** out term ***)

definition
  Faiures_out_hori :: "('r::ring) => index_type
                         => 'r Event failure set => 'r Event failure set"
  where
  Faiures_out_hori_def :
  "Faiures_out_hori y ==
   (%(i,j). (%F.
      {(<>, {Ev a |a. EX z. (a = vert (i,j) z | a = hori (i,j) z | a = vert (i+1,j) z |
                              (a = hori (i,j+1) z & z ~= y))})} Un
      {(<Ev (hori (i,j+1) y)> ^^^ s, Y) |s Y. (s, Y) : F}))"

definition
  Faiures_out_vert :: "('r::ring) => index_type
                         => 'r Event failure set => 'r Event failure set"
  where
  Faiures_out_vert_def :
  "Faiures_out_vert x ==
   (%(i,j). (%F.
      {(<>, {Ev a |a. EX z. (a = hori (i,j) z | a = vert (i,j) z | a = hori (i,j+1) z |
                              (a = vert (i+1,j) z & z ~= x))})} Un
      {(<Ev (vert (i+1,j) x)> ^^^ s, Y) |s Y. (s, Y) : F}))"

definition
  Faiures_out:: "('r::ring) => 'r => index_type
                         => 'r Event failure set => 'r Event failure set"
  where
  Faiures_out_def :
  "Faiures_out x y ==
   (%(i,j). (%F.
      {(<>, {Ev a |a. EX z. (a = hori (i,j) z | a = vert (i,j) z |
                              (a = hori (i,j+1) z & z ~= y) |
                              (a = vert (i+1,j) z & z ~= x))})} Un
      {(<Ev (vert (i+1,j) x)> ^^^ s, Y) |s Y. (s, Y) : Faiures_out_hori y (i,j) F} Un
      {(<Ev (hori (i,j+1) y)> ^^^ s, Y) |s Y. (s, Y) : Faiures_out_vert x (i,j) F}))"

(*** in term ***)

definition
  Faiures_in_hori :: "('r::ring) => index_type
                       => 'r Event failure set => 'r Event failure set"
  where
  Faiures_in_hori_def :
  "Faiures_in_hori x ==
   (%(i,j) F.
      {(<>, {Ev a |a. EX x. (a = vert (i,j) x | a = hori (i,j+1) x |
                              a = vert (i+1,j) x)})} Un
      {(<Ev (hori (i,j) y)> ^^^ s, Y) |y s Y. (s, Y) : Faiures_out x y (i,j) F})"

definition
  Faiures_in_vert :: "('r::ring) => index_type
                       => 'r Event failure set => 'r Event failure set"
  where
  Faiures_in_vert_def :
  "Faiures_in_vert y ==
   (%(i,j) F.
      {(<>, {Ev a |a. EX x. (a = hori (i,j) x | a = vert (i+1,j) x |
                              a = hori (i,j+1) x)})} Un
      {(<Ev (vert (i,j) x)> ^^^ s, Y) |x s Y. (s, Y) : Faiures_out x y (i,j) F})"

definition
  Faiures_in      :: "index_type => ('r::ring) Event failure set => 'r Event failure set"
  where
  Faiures_in_def :
  "Faiures_in ==
   (%(i,j) F.
      {(<>, {Ev a |a. EX x. (a = vert (i+1,j) x | a = hori (i,j+1) x)})} Un
      {(<Ev (vert (i,j) x)> ^^^ s, Y) |x s Y. (s, Y) : Faiures_in_hori x (i,j) F} Un
      {(<Ev (hori (i,j) y)> ^^^ s, Y) |y s Y. (s, Y) : Faiures_in_vert y (i,j) F})"

(*** induction ***)

primrec
  peF_rec :: "nat => index_type => ('r::ring) Event failure set"
where
  "peF_rec 0       = (%ij. {})"
 |"peF_rec (Suc n) = (%ij. Faiures_in ij (peF_rec n ij))"

definition
  peF     :: "index_type => ('r::ring) Event failure set"
  where
   peF_def : "peF ij == Union {peF_rec n ij |n. True}"

(*** NetworkF ***)

definition
  Systolic_ArrayF :: "nat => (index_type, ('r::ring) Event) NetworkF"
  where
  Systolic_ArrayF_def:
  "Systolic_ArrayF ==
   (%N. { (peF ij, Alpha_pe ij) | ij : (Array_Index N)}Fnet)"

(******************************************************************
                        small lemmas
 ******************************************************************)

(* index *)

lemma Example1_index_mem:
  "ij : Array_Index N = (EX i j. ij = (i,j) & i < N & j < N)"
apply (simp add: Array_Index_def)
by (auto)

(****************** to add it again ******************)

end


(*  Title:      Nominal2_Eqvt
    Author:     Brian Huffman,
    Author:     Christian Urban

    Test cases for perm_simp
*)
theory Eqvt
imports Nominal2_Base
begin

declare [[trace_eqvt = false]]
(* declare [[trace_eqvt = true]] *)

lemma
  fixes B::"'a::pt"
  shows "p \<bullet> (B = C)"
apply(perm_simp)
oops

lemma
  fixes B::"bool"
  shows "p \<bullet> (B = C)"
apply(perm_simp)
oops

lemma
  fixes B::"bool"
  shows "p \<bullet> (A \<longrightarrow> B = C)"
apply (perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>(x::'a::pt). A \<longrightarrow> (B::'a \<Rightarrow> bool) x = C) = foo"
apply(perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>B::bool. A \<longrightarrow> (B = C)) = foo"
apply (perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>x y. \<exists>z. x = z \<and> x = y \<longrightarrow> z \<noteq> x) = foo"
apply (perm_simp)
oops

lemma
  shows "p \<bullet> (\<lambda>f x. f (g (f x))) = foo"
apply (perm_simp)
oops

lemma
  fixes p q::"perm"
  and   x::"'a::pt"
  shows "p \<bullet> (q \<bullet> x) = foo"
apply(perm_simp)
oops

lemma
  fixes p q r::"perm"
  and   x::"'a::pt"
  shows "p \<bullet> (q \<bullet> r \<bullet> x) = foo"
apply(perm_simp)
oops

lemma
  fixes p r::"perm"
  shows "p \<bullet> (\<lambda>q::perm. q \<bullet> (r \<bullet> x)) = foo"
apply (perm_simp)
oops

lemma
  fixes C D::"bool"
  shows "B (p \<bullet> (C = D))"
apply(perm_simp)
oops

declare [[trace_eqvt = false]]

text {* there is no raw eqvt-rule for The *}
lemma "p \<bullet> (THE x. P x) = foo"
apply(perm_strict_simp exclude: The)
apply(perm_simp exclude: The)
oops

lemma
  fixes P :: "(('b \<Rightarrow> bool) \<Rightarrow> ('b::pt)) \<Rightarrow> ('a::pt)"
  shows "p \<bullet> (P The) = foo"
apply(perm_simp exclude: The)
oops

lemma
  fixes  P :: "('a::pt) \<Rightarrow> ('b::pt) \<Rightarrow> bool"
  shows "p \<bullet> (\<lambda>(a, b). P a b) = (\<lambda>(a, b). (p \<bullet> P) a b)"
apply(perm_simp)
oops

thm eqvts
thm eqvts_raw

ML {* Nominal_ThmDecls.is_eqvt @{context} @{term "supp"} *}

end


(*  Title:      Containers/RBT_Mapping2.thy
    Author:     Andreas Lochbihler, KIT *)

theory RBT_Mapping2
imports
  Collection_Order
  RBT_ext
  Deriving.RBT_Comparator_Impl
begin

section \<open>Mappings implemented by red-black trees\<close>

lemma distinct_map_filterI: "distinct (map f xs) \<Longrightarrow> distinct (map f (filter P xs))"
by(induct xs) auto

lemma map_of_filter_apply:
  "distinct (map fst xs)
  \<Longrightarrow> map_of (filter P xs) k =
  (case map_of xs k of None \<Rightarrow> None | Some v \<Rightarrow> if P (k, v) then Some v else None)"
by(induct xs)(auto simp add: map_of_eq_None_iff split: option.split)

subsection \<open>Type definition\<close>

typedef (overloaded) ('a, 'b) mapping_rbt
  = "{t :: ('a :: ccompare, 'b) RBT_Impl.rbt. ord.is_rbt cless t \<or> ID CCOMPARE('a) = None}"
  morphisms impl_of Mapping_RBT'
proof
  show "RBT_Impl.Empty \<in> ?mapping_rbt" by(simp add: ord.Empty_is_rbt)
qed

definition Mapping_RBT :: "('a :: ccompare, 'b) rbt \<Rightarrow> ('a, 'b) mapping_rbt"
where
  "Mapping_RBT t = Mapping_RBT'
  (if ord.is_rbt cless t \<or> ID CCOMPARE('a) = None then t
   else RBT_Impl.fold (ord.rbt_insert cless) t rbt.Empty)"

lemma Mapping_RBT_inverse:
  fixes y :: "('a :: ccompare, 'b) rbt"
  assumes "y \<in> {t. ord.is_rbt cless t \<or> ID CCOMPARE('a) = None}"
  shows "impl_of (Mapping_RBT y) = y"
using assms by(auto simp add: Mapping_RBT_def Mapping_RBT'_inverse)

lemma impl_of_inverse: "Mapping_RBT (impl_of t) = t"
by(cases t)(auto simp add: Mapping_RBT'_inverse Mapping_RBT_def)

lemma type_definition_mapping_rbt':
  "type_definition impl_of Mapping_RBT
    {t :: ('a, 'b) rbt. ord.is_rbt cless t \<or> ID CCOMPARE('a :: ccompare) = None}"
by unfold_locales(rule mapping_rbt.impl_of impl_of_inverse Mapping_RBT_inverse)+

lemmas Mapping_RBT_cases[cases type: mapping_rbt] =
  type_definition.Abs_cases[OF type_definition_mapping_rbt']
  and Mapping_RBT_induct[induct type: mapping_rbt] =
  type_definition.Abs_induct[OF type_definition_mapping_rbt'] and
  Mapping_RBT_inject = type_definition.Abs_inject[OF type_definition_mapping_rbt']

lemma rbt_eq_iff:
  "t1 = t2 \<longleftrightarrow> impl_of t1 = impl_of t2"
  by (simp add: impl_of_inject)

lemma rbt_eqI:
  "impl_of t1 = impl_of t2 \<Longrightarrow> t1 = t2"
  by (simp add: rbt_eq_iff)

lemma Mapping_RBT_impl_of [simp]:
  "Mapping_RBT (impl_of t) = t"
  by (simp add: impl_of_inverse)

subsection \<open>Operations\<close>

setup_lifting type_definition_mapping_rbt'

context fixes dummy :: "'a :: ccompare" begin

lift_definition lookup :: "('a, 'b) mapping_rbt \<Rightarrow> 'a \<rightharpoonup> 'b" is "rbt_comp_lookup ccomp" .

lift_definition empty :: "('a, 'b) mapping_rbt" is "RBT_Impl.Empty"
by(simp add: ord.Empty_is_rbt)

lift_definition insert :: "'a \<Rightarrow> 'b \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "rbt_comp_insert ccomp"
by(auto 4 3 intro: linorder.rbt_insert_is_rbt ID_ccompare simp: rbt_comp_insert[OF ID_ccompare'])

lift_definition delete :: "'a \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "rbt_comp_delete ccomp"
by(auto 4 3 intro: linorder.rbt_delete_is_rbt ID_ccompare simp: rbt_comp_delete[OF ID_ccompare'])

lift_definition bulkload :: "('a \<times> 'b) list \<Rightarrow> ('a, 'b) mapping_rbt" is
  "rbt_comp_bulkload ccomp"
by(auto 4 3 intro: linorder.rbt_bulkload_is_rbt ID_ccompare simp: rbt_comp_bulkload[OF ID_ccompare'])

lift_definition map_entry :: "'a \<Rightarrow> ('b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "rbt_comp_map_entry ccomp"
by(auto simp: ord.rbt_map_entry_is_rbt rbt_comp_map_entry[OF ID_ccompare'])

lift_definition map :: "('a \<Rightarrow> 'b \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'c) mapping_rbt" is "RBT_Impl.map"
by(simp add: ord.map_is_rbt)

lift_definition entries :: "('a, 'b) mapping_rbt \<Rightarrow> ('a \<times> 'b) list" is "RBT_Impl.entries" .

lift_definition keys :: "('a, 'b) mapping_rbt \<Rightarrow> 'a set" is "set \<circ> RBT_Impl.keys" .

lift_definition fold :: "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'c) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> 'c \<Rightarrow> 'c" is "RBT_Impl.fold" .

lift_definition is_empty :: "('a, 'b) mapping_rbt \<Rightarrow> bool" is "case_rbt True (\<lambda>_ _ _ _ _. False)" .

lift_definition filter :: "('a \<times> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt" is
  "\<lambda>P t. rbtreeify (List.filter P (RBT_Impl.entries t))"
by(auto intro!: linorder.is_rbt_rbtreeify ID_ccompare linorder.sorted_filter linorder.rbt_sorted_entries ord.is_rbt_rbt_sorted linorder.distinct_entries distinct_map_filterI simp add: filter_map[symmetric])

lift_definition join ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt"
is "rbt_comp_union_with_key ccomp"
by(auto 4 3 intro: linorder.is_rbt_rbt_unionwk ID_ccompare simp: rbt_comp_union_with_key[OF ID_ccompare'])

lift_definition meet ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'b \<Rightarrow> 'b) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b) mapping_rbt"
is "rbt_comp_inter_with_key ccomp"
by(auto 4 3 intro: linorder.rbt_interwk_is_rbt ID_ccompare ord.is_rbt_rbt_sorted simp: rbt_comp_inter_with_key[OF ID_ccompare'])

lift_definition all :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> bool"
is "RBT_Impl_rbt_all" .

lift_definition ex :: "('a \<Rightarrow> 'b \<Rightarrow> bool) \<Rightarrow> ('a, 'b) mapping_rbt \<Rightarrow> bool"
is "RBT_Impl_rbt_ex" .

lift_definition product ::
  "('a \<Rightarrow> 'b \<Rightarrow> 'c \<Rightarrow> 'd \<Rightarrow> 'e) \<Rightarrow> ('a, 'b) mapping_rbt
  \<Rightarrow> ('c :: ccompare, 'd) mapping_rbt \<Rightarrow> ('a \<times> 'c, 'e) mapping_rbt"
is "rbt_product"
  by (fastforce intro: is_rbt_rbt_product ID_ccompare simp add: lt_of_comp_less_prod ccompare_prod_def ID_Some ID_None split: option.split_asm)

lift_definition diag ::
  "('a, 'b) mapping_rbt \<Rightarrow> ('a \<times> 'a, 'b) mapping_rbt"
is "RBT_Impl_diag"
by(auto simp add: lt_of_comp_less_prod ccompare_prod_def ID_Some ID_None is_rbt_RBT_Impl_diag split: option.split_asm)

lift_definition init :: "('a, 'b) mapping_rbt \<Rightarrow> ('a, 'b, 'c) rbt_generator_state"
is "rbt_init" .

end

subsection \<open>Properties\<close>

lemma unfoldr_rbt_entries_generator:
  "list.unfoldr rbt_entries_generator (init t) = entries t"
  by transfer(simp add: unfoldr_rbt_entries_generator)

lemma lookup_RBT:
  "ord.is_rbt cless t \<Longrightarrow>
  lookup (Mapping_RBT t) = rbt_comp_lookup ccomp t"
by(simp add: lookup_def Mapping_RBT_inverse)

lemma lookup_impl_of:
  "rbt_comp_lookup ccomp (impl_of t) = lookup t"
by(transfer) simp

lemma entries_impl_of:
  "RBT_Impl.entries (impl_of t) = entries t"
by transfer simp

lemma keys_impl_of:
  "set (RBT_Impl.keys (impl_of t)) = keys t"
  by (simp add: keys_def)

lemma lookup_empty [simp]:
  "lookup empty = Map.empty"
by transfer (simp add: fun_eq_iff ord.rbt_lookup.simps)

lemma fold_conv_fold:
  "fold f t = List.fold (case_prod f) (entries t)"
by transfer(simp add: RBT_Impl.fold_def)

lemma is_empty_empty [simp]:
  "is_empty t \<longleftrightarrow> t = empty"
by transfer (simp split: rbt.split)

context assumes ID_ccompare_neq_None: "ID CCOMPARE('a :: ccompare) \<noteq> None"
begin

lemma mapping_linorder: "class.linorder (cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool) cless"
using ID_ccompare_neq_None by(clarsimp)(rule ID_ccompare)

lemma mapping_comparator: "comparator (ccomp :: 'a comparator)"
using ID_ccompare_neq_None by(clarsimp)(rule ID_ccompare')

lemmas rbt_comp[simp] = rbt_comp_simps[OF mapping_comparator]

lemma lookup_insert [simp]:
  "lookup (insert (k :: 'a) v t) = (lookup t)(k \<mapsto> v)"
by transfer (simp add: ID_ccompare_neq_None
  linorder.rbt_lookup_rbt_insert[OF mapping_linorder])

lemma lookup_delete [simp]:
  "lookup (delete (k :: 'a) t) = (lookup t)(k := None)"
by transfer(simp add: ID_ccompare_neq_None linorder.rbt_lookup_rbt_delete[OF mapping_linorder] restrict_complement_singleton_eq)

lemma map_of_entries [simp]:
  "map_of (entries (t :: ('a, 'b) mapping_rbt)) = lookup t"
by transfer(simp add: ID_ccompare_neq_None linorder.map_of_entries[OF mapping_linorder] ord.is_rbt_rbt_sorted)

lemma entries_lookup:
  "entries (t1 :: ('a, 'b) mapping_rbt) = entries t2 \<longleftrightarrow> lookup t1 = lookup t2"
by transfer(simp add: ID_ccompare_neq_None linorder.entries_rbt_lookup[OF mapping_linorder] ord.is_rbt_rbt_sorted)

lemma lookup_bulkload [simp]:
  "lookup (bulkload xs) = map_of (xs :: ('a \<times> 'b) list)"
by transfer(simp add: linorder.rbt_lookup_rbt_bulkload[OF mapping_linorder])

lemma lookup_map_entry [simp]:
  "lookup (map_entry (k :: 'a) f t) = (lookup t)(k := map_option f (lookup t k))"
by transfer(simp add: ID_ccompare_neq_None linorder.rbt_lookup_rbt_map_entry[OF mapping_linorder])

lemma lookup_map [simp]:
  "lookup (map f t) (k :: 'a) = map_option (f k) (lookup t k)"
by transfer(simp add: linorder.rbt_lookup_map[OF mapping_linorder])

lemma RBT_lookup_empty [simp]:
  "ord.rbt_lookup cless (t :: ('a, 'b) RBT_Impl.rbt) = Map.empty \<longleftrightarrow> t = RBT_Impl.Empty"
proof -
  interpret linorder "cless_eq :: 'a \<Rightarrow> 'a \<Rightarrow> bool" cless by(rule mapping_linorder)
  show ?thesis by(cases t)(auto simp add: fun_eq_iff)
qed

lemma lookup_empty_empty [simp]:
  "lookup t = Map.empty \<longleftrightarrow> (t :: ('a, 'b) mapping_rbt) = empty"
by transfer simp

lemma finite_dom_lookup [simp]: "finite (dom (lookup (t :: ('a, 'b) mapping_rbt)))"
by transfer(auto simp add: linorder.finite_dom_rbt_lookup[OF mapping_linorder])

lemma card_com_lookup [unfolded length_map, simp]:
  "card (dom (lookup (t :: ('a, 'b) mapping_rbt))) = length (List.map fst (entries t))"
by transfer(auto simp add: linorder.rbt_lookup_keys[OF mapping_linorder] linorder.distinct_entries[OF mapping_linorder] RBT_Impl.keys_def ord.is_rbt_rbt_sorted ID_ccompare_neq_None List.card_set simp del: set_map length_map)

lemma lookup_join:
  "lookup (join f (t1 :: ('a, 'b) mapping_rbt) t2) =
  (\<lambda>k. case lookup t1 k of None \<Rightarrow> lookup t2 k | Some v1 \<Rightarrow> Some (case lookup t2 k of None \<Rightarrow> v1 | Some v2 \<Rightarrow> f k v1 v2))"
by transfer(auto simp add: fun_eq_iff linorder.rbt_lookup_rbt_unionwk[OF mapping_linorder] ord.is_rbt_rbt_sorted ID_ccompare_neq_None split: option.splits)

lemma lookup_meet:
  "lookup (meet f (t1 :: ('a, 'b) mapping_rbt) t2) =
  (\<lambda>k. case lookup t1 k of None \<Rightarrow> None | Some v1 \<Rightarrow> case lookup t2 k of None \<Rightarrow> None | Some v2 \<Rightarrow> Some (f k v1 v2))"
by transfer(auto simp add: fun_eq_iff linorder.rbt_lookup_rbt_interwk[OF mapping_linorder] ord.is_rbt_rbt_sorted ID_ccompare_neq_None split: option.splits)

lemma lookup_filter [simp]:
  "lookup (filter P (t :: ('a, 'b) mapping_rbt)) k =
  (case lookup t k of None \<Rightarrow> None | Some v \<Rightarrow> if P (k, v) then Some v else None)"
by transfer(simp split: option.split add: ID_ccompare_neq_None linorder.rbt_lookup_rbtreeify[OF mapping_linorder] linorder.sorted_filter[OF mapping_linorder] ord.is_rbt_rbt_sorted linorder.rbt_sorted_entries[OF mapping_linorder] distinct_map_filterI linorder.distinct_entries[OF mapping_linorder] map_of_filter_apply linorder.map_of_entries[OF mapping_linorder])

lemma all_conv_all_lookup:
  "all P t \<longleftrightarrow> (\<forall>(k :: 'a) v. lookup t k = Some v \<longrightarrow> P k v)"
by transfer(auto simp add: ID_ccompare_neq_None linorder.rbt_lookup_keys[OF mapping_linorder] ord.is_rbt_rbt_sorted RBT_Impl.keys_def RBT_Impl_rbt_all_def linorder.map_of_entries[OF mapping_linorder, symmetric] linorder.distinct_entries[OF mapping_linorder] dest: map_of_SomeD intro: map_of_is_SomeI)

lemma ex_conv_ex_lookup:
  "ex P t \<longleftrightarrow> (\<exists>(k :: 'a) v. lookup t k = Some v \<and> P k v)"
by transfer(auto simp add: ID_ccompare_neq_None linorder.rbt_lookup_keys[OF mapping_linorder] ord.is_rbt_rbt_sorted RBT_Impl.keys_def RBT_Impl_rbt_ex_def linorder.map_of_entries[OF mapping_linorder, symmetric] linorder.distinct_entries[OF mapping_linorder] intro: map_of_is_SomeI)

lemma diag_lookup:
  "lookup (diag t) = (\<lambda>(k :: 'a, k'). if k = k' then lookup t k else None)"
using linorder.rbt_lookup_RBT_Impl_diag[where ?'b='b, OF mapping_linorder]
apply transfer
apply (clarsimp simp add: ID_ccompare_neq_None ccompare_prod_def lt_of_comp_less_prod[symmetric]
  rbt_comp_lookup[OF comparator_prod[OF mapping_comparator mapping_comparator], symmetric]
  ID_Some split: option.split)
apply (unfold rbt_comp_lookup[OF mapping_comparator], simp)
done

context assumes ID_ccompare_neq_None': "ID CCOMPARE('b :: ccompare) \<noteq> None"
begin

lemma mapping_linorder': "class.linorder (cless_eq :: 'b \<Rightarrow> 'b \<Rightarrow> bool) cless"
using ID_ccompare_neq_None' by(clarsimp)(rule ID_ccompare)

lemma mapping_comparator': "comparator (ccomp :: 'b comparator)"
using ID_ccompare_neq_None' by(clarsimp)(rule ID_ccompare')

lemmas rbt_comp'[simp] = rbt_comp_simps[OF mapping_comparator']

lemma ccomp_comparator_prod:
  "ccomp = (comparator_prod ccomp ccomp :: ('a \<times> 'b)comparator)"
  by(simp add: ccompare_prod_def lt_of_comp_less_prod ID_ccompare_neq_None ID_ccompare_neq_None' ID_Some split: option.splits)

lemma lookup_product:
  "lookup (product f rbt1 rbt2) (a :: 'a, b :: 'b) =
  (case lookup rbt1 a of None \<Rightarrow> None
   | Some c \<Rightarrow> map_option (f a c b) (lookup rbt2 b))"
using mapping_linorder mapping_linorder'
apply transfer
apply (unfold ccomp_comparator_prod rbt_comp_lookup[OF comparator_prod[OF mapping_comparator mapping_comparator']]
  rbt_comp rbt_comp' lt_of_comp_less_prod)
apply (simp add: ID_ccompare_neq_None ID_ccompare_neq_None' rbt_lookup_rbt_product)
done
end

end

hide_const (open) impl_of lookup empty insert delete
  entries keys bulkload map_entry map fold join meet filter all ex product diag init

end


theory It_to_It
imports
  Proper_Iterator
begin

  lemma proper_it_fold:
    "proper_it it it' \<Longrightarrow> foldli (it (\<lambda>_. True) (\<lambda>x l. l@[x]) []) = it'"
    unfolding proper_it_def by auto
  lemma proper_it_unfold:
    "proper_it it it' \<Longrightarrow> it' = foldli (it (\<lambda>_. True) (\<lambda>x l. l@[x]) [])"
    unfolding proper_it_def by auto

  text \<open>The following constant converts an iterator over list-state
    to an iterator over arbitrary state\<close>
  definition it_to_it :: "('x,'x list) set_iterator \<Rightarrow> ('x,'\<sigma>) set_iterator"
    where [code del]: "it_to_it it
    \<equiv> (foldli (it (\<lambda>_. True) (\<lambda>x l. l@[x]) []))"

  lemma pi_it_to_it[icf_proper_iteratorI]: "proper_it (it_to_it I) (it_to_it I)"
    unfolding it_to_it_def by (rule pi_foldli)
  text \<open>In case of a proper iterator, it is equivalent to direct iteration\<close>
  lemma it_to_it_fold: "proper_it it (it'::('x,'\<sigma>) set_iterator)
    \<Longrightarrow> it_to_it it = it'"
    unfolding it_to_it_def
    by (simp add: proper_it_fold)

  lemma it_to_it_map_fold:
    assumes P: "proper_it it it'"
    shows "it_to_it (\<lambda>c f. it c (f \<circ> f')) = (\<lambda>c f. it' c (f o f'))"
    apply (rule proper_itE[OF P])
    unfolding it_to_it_def
    apply (intro ext)
    apply (simp add: foldli_foldl map_by_foldl foldli_map)
    done

  lemma it_to_it_fold': "proper_it' it (it'::'s \<Rightarrow> ('x,'\<sigma>) set_iterator)
    \<Longrightarrow> it_to_it (it s) = (it' s)"
    by (drule proper_it'D) (rule it_to_it_fold)

  lemma it_to_it_map_fold':
    assumes P: "proper_it' it it'"
    shows "it_to_it (\<lambda>c f. it s c (f \<circ> f')) = (\<lambda>c f. it' s c (f o f'))"
    using P[THEN proper_it'D] by (rule it_to_it_map_fold)

  text \<open>This locale wraps up the setup of a proper iterator for use
    with \<open>it_to_it\<close>.\<close>
  locale proper_it_loc =
    fixes it :: "'s \<Rightarrow> ('x,'x list) set_iterator"
    and it' :: "'s \<Rightarrow> ('x,'\<sigma>) set_iterator"
    assumes proper': "proper_it' it it'"
  begin
    lemma proper: "proper_it (it s) (it' s)"
      using proper' by (rule proper_it'D)

    lemmas it_to_it_code_unfold[code_unfold] = it_to_it_fold[OF proper]
  end

  subsubsection \<open>Correctness\<close>
  text \<open>The polymorphic iterator is a valid iterator again.\<close>
  lemma it_to_it_genord_correct:
    assumes "set_iterator_genord (it::('x,'x list) set_iterator) S R"
    shows "set_iterator_genord ((it_to_it it)::('x,'\<sigma>) set_iterator) S R"
  proof -
    interpret set_iterator_genord it S R by fact

    show ?thesis
      apply (unfold_locales)
      unfolding it_to_it_def
      using foldli_transform
      by auto
  qed

  lemma it_to_it_linord_correct:
    assumes "set_iterator_linord (it::('x::linorder,'x list) set_iterator) S"
    shows "set_iterator_linord ((it_to_it it)::('x,'\<sigma>) set_iterator) S"
    using assms
    unfolding set_iterator_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_rev_linord_correct:
    assumes "set_iterator_rev_linord (it::('x::linorder,'x list) set_iterator) S"
    shows "set_iterator_rev_linord ((it_to_it it)::('x,'\<sigma>) set_iterator) S"
    using assms
    unfolding set_iterator_rev_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_map_genord_correct:
    assumes "map_iterator_genord (it::('u,'v,('u\<times>'v) list) map_iterator) S R"
    shows "map_iterator_genord ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S R"
    using assms by (rule it_to_it_genord_correct)

  lemma it_to_it_map_linord_correct:
    assumes "map_iterator_linord (it::('u::linorder,'v,('u\<times>'v) list) map_iterator) S"
    shows "map_iterator_linord ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S"
    using assms unfolding set_iterator_map_linord_def by (rule it_to_it_genord_correct)

  lemma it_to_it_map_rev_linord_correct:
    assumes
      "map_iterator_rev_linord (it::('u::linorder,'v,('u\<times>'v) list) map_iterator) S"
    shows "map_iterator_rev_linord ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S"
    using assms unfolding set_iterator_map_rev_linord_def
    by (rule it_to_it_genord_correct)

  lemma it_to_it_map_correct:
    assumes "map_iterator (it::('u,'v,('u\<times>'v) list) map_iterator) S"
    shows "map_iterator ((it_to_it it)::('u,'v,'\<sigma>) map_iterator) S"
    using assms by (rule it_to_it_correct)

end


theory Recursion_Combinators
  imports Refine_Imperative_HOL.IICF
begin

context
begin

private definition for_comb where
  "for_comb f a0 n = nfoldli [0..<n + 1] (\<lambda> x. True) (\<lambda> k a. (f a k)) a0"

fun for_rec :: "('a \<Rightarrow> nat \<Rightarrow> 'a nres) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> 'a nres" where
  "for_rec f a 0 = f a 0" |
  "for_rec f a (Suc n) = for_rec f a n \<bind> (\<lambda> x. f x (Suc n))"

private lemma for_comb_for_rec: "for_comb f a n = for_rec f a n"
unfolding for_comb_def
proof (induction f a n rule: for_rec.induct)
  case 1 then show ?case by (auto simp: pw_eq_iff refine_pw_simps)
next
  case IH: (2 a n)
  then show ?case by (fastforce simp: nfoldli_append pw_eq_iff refine_pw_simps)
qed

private definition for_rec2' where
  "for_rec2' f a n i j =
    (if i = 0 then RETURN a else for_rec (\<lambda>a i. for_rec (\<lambda> a. f a i) a n) a (i - 1))
    \<bind> (\<lambda> a. for_rec (\<lambda> a. f a i) a j)"

fun for_rec2 :: "('a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nres) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nres" where
  "for_rec2 f a n 0 0 = f a 0 0" |
  "for_rec2 f a n (Suc i) 0 = for_rec2 f a n i n \<bind> (\<lambda> a. f a (Suc i) 0)" |
  "for_rec2 f a n i (Suc j) = for_rec2 f a n i j \<bind> (\<lambda> a. f a i (Suc j))"

private lemma for_rec2_for_rec2':
  "for_rec2 f a n i j = for_rec2' f a n i j"
unfolding for_rec2'_def
 apply (induction f a n i j rule: for_rec2.induct)
 apply simp_all
 subgoal for f a n i
  apply (cases i)
 by auto
done

fun for_rec3 :: "('a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nres) \<Rightarrow> 'a \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> nat \<Rightarrow> 'a nres"
where
  "for_rec3 f m n 0       0       0        = f m 0 0 0" |
  "for_rec3 f m n (Suc k) 0       0        = for_rec3 f m n k n n \<bind> (\<lambda> a. f a (Suc k) 0 0)" |
  "for_rec3 f m n k       (Suc i) 0        = for_rec3 f m n k i n \<bind> (\<lambda> a. f a k (Suc i) 0)" |
  "for_rec3 f m n k       i       (Suc j)  = for_rec3 f m n k i j \<bind> (\<lambda> a. f a k i (Suc j))"

private definition for_rec3' where
  "for_rec3' f a n k i j =
    (if k = 0 then RETURN a else for_rec (\<lambda>a k. for_rec2' (\<lambda> a. f a k) a n n n) a (k - 1))
    \<bind> (\<lambda> a. for_rec2' (\<lambda> a. f a k) a n i j)"

private lemma for_rec3_for_rec3':
  "for_rec3 f a n k i j = for_rec3' f a n k i j"
unfolding for_rec3'_def
 apply (induction f a n k i j rule: for_rec3.induct)
 apply (simp_all add: for_rec2_for_rec2'[symmetric])
 subgoal for f a n k
  apply (cases k)
 by auto
done

private lemma for_rec2'_for_rec:
  "for_rec2' f a n n n =
    for_rec (\<lambda>a i. for_rec (\<lambda> a. f a i) a n) a n"
unfolding for_rec2'_def by (cases n) auto

private lemma for_rec3'_for_rec:
  "for_rec3' f a n n n n =
    for_rec (\<lambda> a k. for_rec (\<lambda>a i. for_rec (\<lambda> a. f a k i) a n) a n) a n"
unfolding for_rec3'_def for_rec2'_for_rec by (cases n) auto

theorem for_rec_eq:
  "for_rec f a n = nfoldli [0..<n + 1] (\<lambda>x. True) (\<lambda>k a. f a k) a"
using for_comb_for_rec[unfolded for_comb_def, symmetric] .

theorem for_rec2_eq:
  "for_rec2 f a n n n =
     nfoldli [0..<n + 1] (\<lambda>x. True)
           (\<lambda>i. nfoldli [0..<n + 1] (\<lambda>x. True) (\<lambda>j a. f a i j)) a"
using
  for_rec2'_for_rec[
    unfolded for_rec2_for_rec2'[symmetric], unfolded for_comb_for_rec[symmetric] for_comb_def
  ] .

theorem for_rec3_eq:
  "for_rec3 f a n n n n =
    nfoldli [0..<n + 1] (\<lambda>x. True)
     (\<lambda>k. nfoldli [0..<n + 1] (\<lambda>x. True)
           (\<lambda>i. nfoldli [0..<n + 1] (\<lambda>x. True) (\<lambda>j a. f a k i j)))
     a"
using
  for_rec3'_for_rec[
    unfolded for_rec3_for_rec3'[symmetric], unfolded for_comb_for_rec[symmetric] for_comb_def
  ] .

end

lemmas [intf_of_assn] = intf_of_assnI[where R= "is_mtx n" and 'a= "'b i_mtx" for n]

declare param_upt[sepref_import_param]

end


(*<*)
section \<open>Miscellaneous Tests\<close>
theory Sepref_Minitests
imports
  "../IICF/IICF"
  Sepref_Graph
  "HOL-Library.Code_Target_Numeral"
begin

  (* (* Pattern to analyze why preparing with a rule fails *)
  apply (tactic \<open> let
      val ctxt = @{context}
      val i = 0
      val thm = @{thm sepref_fr_rules(30)}
      open Sepref_Translate Refine_Util
    in
      CONVERSION (Refine_Util.HOL_concl_conv (monitor_conv' "" (prepare_refine_conv (i,thm))) ctxt) 1
    end
      \<close>)
  *)

  definition [simp]: "mop_plus = RETURN oo (+)"
  definition [simp]: "mop_plusi = return oo (+)"
  lemma [sepref_fr_rules]: "(uncurry mop_plusi,uncurry mop_plus) \<in> nat_assn\<^sup>k*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
    by (sep_auto intro!: hfrefI hn_refineI simp: pure_def)
  sepref_register mop_plus

  sepref_definition copy_test is "(\<lambda>x. do {
    let y = x+ x;
    mop_plus y y
    })" :: "((nat_assn)\<^sup>k \<rightarrow>\<^sub>a UNSPEC)"
    by sepref

  definition "bar s \<equiv> do {
    x\<leftarrow>RETURN (insert (1::nat) s);
    y\<leftarrow>RETURN (insert (1::nat) x);
    ASSERT (y\<noteq>{});
    if 1\<in>y then
      RETURN (y)
    else RETURN (insert (1::nat) y)
  }"

definition "bar2 s \<equiv> do {
    if (1::nat)\<in>s then
      RETURN True
    else RETURN False
  }"

definition "bar' \<equiv> do {
    y \<leftarrow> RETURN {1,1::nat};
    if 1\<in>y then
      RETURN (y)
    else RETURN (insert 1 y)
  }"

definition "foo \<equiv> do {
  s \<leftarrow> RETURN [1,1,1::nat];
  y \<leftarrow> RETURN ({}::nat set);
  RECT (\<lambda>D l.
    case l of
      [] \<Rightarrow> RETURN (case [0,1] of [] \<Rightarrow> {} | x#xs \<Rightarrow> {x})
    | x#l \<Rightarrow> do {
        \<^cancel>\<open>r \<leftarrow> RETURN (y\<union>y);\<close>
        r \<leftarrow> D l;
        \<^cancel>\<open>RETURN (insert (x+1) r)\<close>
        RETURN (if x<1 then insert x r else insert (x+1) r)
    }) s
  }
"

definition "simple_rec \<equiv> do {
  RECT (\<lambda>D l. case l of
    [] \<Rightarrow> RETURN 0
  | x#xs \<Rightarrow> do {
      a\<leftarrow>D xs;
      RETURN (a+x)
    }
  ) [1,0::nat]
}"

definition "simple_while \<equiv> do {
  WHILEIT (\<lambda>(i,m). i \<notin> dom m) (\<lambda>(i,m). i\<ge>1) (\<lambda>(i,m). do {
    let i=i+1;
    RETURN (i,m)
  }) (10::nat, Map.empty::nat \<rightharpoonup> nat)
}"

definition "lst_mem_to_sets \<equiv> do {
  l\<leftarrow>RETURN [0,1,0::nat];
  RECT (\<lambda>D l.
    case l of
      [] \<Rightarrow> RETURN []
    | x#l \<Rightarrow> do {
        r \<leftarrow> D l;
        RETURN ({x}#r)
    }) l
  }
"

definition "lst_mem_to_sets_nonlin \<equiv> do {
  l\<leftarrow>RETURN [0,1,0::nat];
  RECT (\<lambda>D l.
    case l of
      [] \<Rightarrow> RETURN []
    | x#l \<Rightarrow> do {
        r \<leftarrow> D l;
        RETURN ({x,x}#r)
    }) l
  }
"

definition "lst_mem_to_sets_nonlin2 \<equiv> do {
  l\<leftarrow>RETURN [0,1,0::nat];
  RECT (\<lambda>D l.
    case l of
      [] \<Rightarrow> RETURN []
    | x#l \<Rightarrow> do {
        r \<leftarrow> D l;
        RETURN ({x}#r@r)
    }) l
  }
"

definition "lst_nonlin \<equiv> do {
  l\<leftarrow>RETURN [0::nat];
  RETURN (case l of [] \<Rightarrow> l | x#xs \<Rightarrow> x#l)
}"

definition "lst_nonlin2 \<equiv> do {
  l\<leftarrow>RETURN [0::nat];
  RETURN (case l of [] \<Rightarrow> [] | x#xs \<Rightarrow> x#(x#xs))
}"

definition "lst_nonlin3 \<equiv> do {
  l\<leftarrow>RETURN [{0::nat}];
  RETURN (case l of [] \<Rightarrow> [] | x#xs \<Rightarrow> x#(x#xs))
}"

definition "lst_nonlin4 \<equiv> do {
  l\<leftarrow>RETURN [{0::nat}];
  RETURN (l@l)
}"

definition "dup_arg == do {
  x <- RETURN [1::nat];
  RETURN (x@x)
}"

definition "big_list == RETURN [1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1::nat]"
definition "big_list2 == do {
  x1 <- RETURN ({}::nat set);
  x2 <- RETURN {};
  x3 <- RETURN {};
  x4 <- RETURN {};
  x5 <- RETURN {};
  x6 <- RETURN {};
  x7 <- RETURN {};
  x8 <- RETURN {};
\<^cancel>\<open>  x9 <- RETURN {};
  x10 <- RETURN {};
  x11 <- RETURN {};
  x12 <- RETURN {};
  x13 <- RETURN {};
  x14 <- RETURN {};
  x15 <- RETURN {};
  x16 <- RETURN {};\<close>
  RETURN [x1,x2,x3,x4,x5,x6,x7,x8\<^cancel>\<open>,x9,x10,x11,x12,x13,x14,x14,x15,x16]\<close>]
}"

term Set.insert

definition "foo1 \<equiv>
  case [] of
    [] \<Rightarrow> RETURN {}
  | x#l \<Rightarrow> do {
      r \<leftarrow> RETURN ({}::nat set);
      RETURN (if x<1 then insert x r else insert x r)
  }
"

definition "basic_foreach \<equiv> do {
  FOREACH\<^sub>C {0,1::nat} (\<lambda>s. s>1) (\<lambda>x s. RETURN (x+s)) 0
}"

definition "basic_foreach2 \<equiv> do {
  FOREACH\<^sub>C {0,1::nat} (\<lambda>_. True) (\<lambda>x s. RETURN (insert x s)) {}
}"

definition "basic_option \<equiv> do {
  let a={};
  let b=Some a;
  let c=Some (0::nat);
  let d=Some (1::nat);
  RETURN (b,c=d)
}"

definition dfs :: "(('a\<times>'a) set) \<Rightarrow> 'a \<Rightarrow> 'a \<Rightarrow> ('a set \<times> bool) nres"
  where
  "\<And>E vd v0. dfs E vd v0 \<equiv> REC\<^sub>T (\<lambda>D (V,v).
    if v=vd then RETURN (V,True)
    else if v\<in>V then RETURN (V,False)
    else do {
      let V=insert v V;
      FOREACH\<^sub>C (E``{v}) (\<lambda>(_,b). b=False) (\<lambda>v' (V,_). D (V,v')) (V,False) }
  ) ({},v0)"

lemma ID_unfold_vars: "ID x y T \<Longrightarrow> x\<equiv>y" by simp

schematic_goal testsuite_basic_param:
  fixes s
  notes [id_rules] =
    itypeI[Pure.of s "TYPE(nat set)"]
  shows
    "hn_refine (emp * hn_ctxt (hs.assn id_assn) s s') (?c1::?'c1 Heap) ?\<Gamma>1' ?R1 (bar s)"
    "hn_refine (emp * hn_ctxt (hs.assn id_assn) s s') (?c2::?'c2 Heap) ?\<Gamma>2' ?R2 (bar2 s)"
  unfolding bar_def bar2_def
  using [[id_debug]]
  by sepref+

term case_list
thm id_rules

lemmas [id_rules] =
  itypeI[Pure.of RECT "TYPE ((('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b)"]
  itypeI[Pure.of case_list "TYPE('a \<Rightarrow> ('b \<Rightarrow> 'b list \<Rightarrow> 'a) \<Rightarrow> 'b list \<Rightarrow> 'a)"]

ML \<open>
  fun is_eta_norm t = t aconv (Envir.eta_contract t)

  fun find_not_eta_norm (a$b) = (find_not_eta_norm a @ find_not_eta_norm b)
    | find_not_eta_norm (t as Abs (_,_,t'$Bound 0)) = t :: find_not_eta_norm t'
    | find_not_eta_norm (Abs (_,_,t)) = find_not_eta_norm t
    | find_not_eta_norm _ = []

  fun is_eta_norm_tac st = if is_eta_norm (Thm.prop_of st) then Seq.single st
    else (raise TERM ("\<not>eta-norm",find_not_eta_norm (Thm.prop_of st)))

\<close>

definition "xfoo \<equiv> do {
  s \<leftarrow> RETURN [1::nat];
  y \<leftarrow> RETURN ({}::nat set);
  RECT (\<lambda>D l.
    case l of
      [] \<Rightarrow> RETURN ({0})
    | x#l \<Rightarrow> do {
        r \<leftarrow> D l;
        RETURN (insert x r)
    }) s
  }
"

schematic_goal testsuite_basic1:
  notes [sepref_fr_rules] = HOL_list_empty_hnr hs.hnr_op_empty[of nat_assn] (* TODO: handle open relations *)
  shows "hn_refine emp (?c1::?'c1 Heap) ?\<Gamma>1' ?R1 bar'"
  and "hn_refine emp (?c2::?'c2 Heap) ?\<Gamma>2' ?R2 foo"
  and "hn_refine emp (?c3::?'c3 Heap) ?\<Gamma>3' ?R3 simple_rec"
  and "hn_refine emp (?c4::?'c4 Heap) ?\<Gamma>4' ?R4 lst_mem_to_sets"
  and "hn_refine emp (?c5::?'c5 Heap) ?\<Gamma>5' ?R5 lst_mem_to_sets_nonlin"
  (*and "hn_refine emp (?c6::?'c6 Heap) ?\<Gamma>6' ?R6 lst_mem_to_sets_nonlin2"*)
  and "hn_refine emp (?c7::?'c7 Heap) ?\<Gamma>7' ?R7 lst_nonlin"
  and "hn_refine emp (?c8::?'c8 Heap) ?\<Gamma>8' ?R8 lst_nonlin2"
  (*and "hn_refine emp (?c9::?'c9 Heap) ?\<Gamma>9' ?R9 lst_nonlin3"*)
  (*and "hn_refine emp (?ca::?'ca Heap) ?\<Gamma>a' ?Ra lst_nonlin4"*)
  unfolding bar'_def foo_def simple_rec_def lst_mem_to_sets_def
    lst_mem_to_sets_nonlin_def lst_mem_to_sets_nonlin2_def
    lst_nonlin_def lst_nonlin2_def lst_nonlin3_def lst_nonlin4_def
  using [[goals_limit = 1]]
  apply sepref+
  done

schematic_goal testsuite_basic2:
  notes [sepref_fr_rules] = HOL_list_empty_hnr hs.hnr_op_empty hm.empty_hnr
  shows "hn_refine emp (?c1::?'c1 Heap) ?\<Gamma>1' ?R1 dup_arg"
  and "hn_refine emp (?c2::?'c2 Heap) ?\<Gamma>2' ?R2 big_list"
  and "hn_refine emp (?c3::?'c3 Heap) ?\<Gamma>3' ?R3 big_list2"
  and "hn_refine emp (?c4::?'c4 Heap) ?\<Gamma>4' ?R4 foo1"
  and "hn_refine emp (?c5::?'c5 Heap) ?\<Gamma>5' ?R5 basic_foreach"
  and "hn_refine emp (?c6::?'c6 Heap) ?\<Gamma>6' ?R6 basic_foreach2"
  and "hn_refine emp (?c7::?'c7 Heap) ?\<Gamma>7' ?R7 basic_option"
  and "hn_refine emp (?c8::?'c8 Heap) ?\<Gamma>8' ?R8 simple_while"
  unfolding dup_arg_def big_list_def big_list2_def foo1_def
    basic_foreach_def basic_foreach2_def simple_while_def
    basic_option_def
  using [[goals_limit = 1, id_debug]]
  apply sepref+
  done

sepref_definition imp_dfs is "uncurry2 dfs" :: "((adjg_assn nat_assn)\<^sup>k *\<^sub>a nat_assn\<^sup>k *\<^sub>a nat_assn\<^sup>k \<rightarrow>\<^sub>a prod_assn (hs.assn nat_assn) bool_assn)"
  unfolding dfs_def[abs_def]
  apply (rewrite in "FOREACHc \<hole>" op_graph_succ_def[symmetric])
  apply (rewrite in "(\<hole>,_)" hs.fold_custom_empty)
  using [[goals_limit = 1]]
  by sepref

export_code imp_dfs checking SML_imp

definition "simple_algo a c m x = do {
  let s = {m};
  RECT (\<lambda>D (x,s,l).
    if x\<in>s then RETURN l
    else D ((a*x+c) mod m,insert x s,l+1)
  ) (x::nat,s,0::nat)
}"

schematic_goal sa_impl:
  notes [autoref_tyrel] = ty_REL[where 'a = "nat set"
    and R="\<langle>nat_rel\<rangle>iam_set_rel"]
  assumes [autoref_rules]: "(a,a)\<in>nat_rel"
  assumes [autoref_rules]: "(c,c)\<in>nat_rel"
  assumes [autoref_rules]: "(m,m)\<in>nat_rel"
  assumes [autoref_rules]: "(x,x)\<in>nat_rel"
  shows "(?c::?'c,simple_algo a c m x)\<in>?R"
  unfolding simple_algo_def[abs_def]
  using [[autoref_trace_failed_id]]
  apply autoref_monadic
  done

concrete_definition sa_impl uses sa_impl
prepare_code_thms sa_impl_def
export_code sa_impl checking SML

sepref_definition sai_impl is
    "(uncurry2 (uncurry simple_algo))"
  :: "(nat_assn\<^sup>k*\<^sub>anat_assn\<^sup>k*\<^sub>anat_assn\<^sup>k*\<^sub>anat_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn)"
  unfolding simple_algo_def[abs_def]
  unfolding ias.fold_custom_empty
  using [[goals_limit = 1]]
  using [[id_debug]]
  by sepref
export_code sai_impl checking SML

term Array.upd

definition "sad_impl a c m x \<equiv> do {
  s\<leftarrow>Array.new m False;
  heap.fixp_fun (\<lambda>D (x,s,l). do {
    brk\<leftarrow>Array.nth s x;
    if brk then return l
    else do {
      _\<leftarrow>Array.len s;
      _\<leftarrow>if x<l then return True else return False;
      s\<leftarrow>Array.upd x True s;
      D ((a*x+c) mod m,s,l+1)
    }
  }) (x,s,0::nat)
}"

definition "sad_impl2 a c m x \<equiv> do {
  s\<leftarrow>Array.new m False;
  heap.fixp_fun (\<lambda>D (x,l). do {
    brk\<leftarrow>Array.nth s x;
    if brk then return l
    else do {
      Array.upd x True s;
      D ((a*x+c) mod m,l+1)
    }
  }) (x,0::nat)
}"

prepare_code_thms sad_impl_def
prepare_code_thms sad_impl2_def

code_thms sai_impl

lemma
 "ias_ins k a = do {
    l\<leftarrow>Array.len a;
    if k<l then
      Array.upd k True a
    else do {
      let newsz = max (k+1) (2 * l + 3);
      a\<leftarrow>Array_Blit.array_grow a newsz False;
      Array.upd k True a
    }
  }"
  unfolding ias_ins_def
  apply (fo_rule cong[OF arg_cong])
  apply (auto)
  done

export_code sa_impl sad_impl sad_impl2 sai_impl
  checking SML_imp

schematic_goal
  shows "hn_refine emp (?c1::?'c1 Heap) ?\<Gamma>1' ?R1
  (do {
    let x=(1::nat);
    RETURN {x,x}
  })"
  apply (rewrite in "RETURN \<hole>" hs.fold_custom_empty)
  apply sepref
  done

term hn_invalid

definition "remdup l \<equiv>
  RECT (\<lambda>remdup. \<lambda>(
    [],s) \<Rightarrow> RETURN op_HOL_list_empty
  | (x#xs,s) \<Rightarrow> if x\<in>s then
      remdup (xs,s )
    else do {
      l \<leftarrow> remdup (xs, insert x s);
      RETURN (x#l)
    }
  ) (l,op_hs_empty)
"

schematic_goal
  fixes l :: "nat list"
  notes [id_rules] = itypeI[Pure.of l "TYPE(nat list)"]
  shows "hn_refine ( (hn_ctxt (list_assn (pure Id))) l li) (?c::?'c Heap) ?\<Gamma> ?R (remdup l)"
  unfolding remdup_def
  using [[id_debug]]
  by sepref

  text \<open>Test structural frame-inference and merging (on product type)\<close>

  definition "smart_match_test1 \<equiv> \<lambda>(p1,p2). RETURN (p1+p2)"

  sepref_definition smart_match_test1_impl is "smart_match_test1" :: "((prod_assn nat_assn nat_assn)\<^sup>k \<rightarrow>\<^sub>a nat_assn)"
    unfolding smart_match_test1_def
    by sepref
  sepref_register smart_match_test1
  lemmas [sepref_fr_rules] = smart_match_test1_impl.refine

  definition "smart_match_test2 \<equiv> do {
    let p = (2::nat,2::nat);

    f \<leftarrow> if True then
      case p of (a,b) \<Rightarrow> RETURN (Some b)
    else
      case p of (a,b) \<Rightarrow> RETURN (Some a);

    smart_match_test1 p
  }"

  sepref_thm smart_match_test2_impl is "uncurry0 smart_match_test2" :: "unit_assn\<^sup>k \<rightarrow>\<^sub>a nat_assn"
    unfolding smart_match_test2_def
    by sepref

  (* Regression from incomplete monadify, that could not not handle nested
    plain operations that get converted to monadic operations. *)
  sepref_thm regr_incomplete_monadify is "RETURN o (\<lambda>l. fold (\<lambda>x. (#) (case x of (x, xa) \<Rightarrow> x + xa)) l [])" :: "(list_assn (prod_assn nat_assn nat_assn))\<^sup>k \<rightarrow>\<^sub>a list_assn nat_assn"
    unfolding test_def[abs_def] "HOL_list.fold_custom_empty"
    by sepref

end
(*>*)


section \<open>Array with Potential Zero Size\<close>
theory LLVM_DS_NArray
imports "LLVM_DS_Array"
begin

  term array_assn

  type_synonym 'a narray = "'a ptr"

  definition "narray_assn \<equiv> mk_assn (\<lambda>xs p. case xs of [] \<Rightarrow> \<up>(p=null) | _ \<Rightarrow> \<upharpoonleft>array_assn xs p)"

  term array_new

  definition [llvm_inline]:
    "narray_new TYPE('a::llvm_rep) n \<equiv> if n=signed_nat 0 then return null else array_new TYPE('a) n"

  thm array_new_rule_snat[no_vars]

  lemma narray_new_rule_snat[vcg_rules]:
    "llvm_htriple (\<upharpoonleft>snat.assn n ni) (narray_new TYPE(_) ni) (\<upharpoonleft>narray_assn (replicate n init))"
    unfolding narray_assn_def narray_new_def
    supply [split] = list.split
    apply vcg_monadify
    apply vcg
    done

  (* TODO: From an abstract point of view,
    it's a bad idea to split init by the simplifier!
    Remove that from default setup!
  *)
  lemma narray_assn_init_pure: "\<box> \<turnstile> \<upharpoonleft>narray_assn [] null"
    unfolding narray_assn_def
    by (auto simp: sep_algebra_simps)

  thm array_nth_rule_snat[no_vars]

  lemma narray_nth_rule[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>narray_assn xs p \<and>* \<upharpoonleft>snat.assn i ii \<and>* \<up>\<^sub>d(i < length xs))
    (array_nth p ii)
    (\<lambda>r. \<up>(r = xs ! i) \<and>* \<upharpoonleft>narray_assn xs p)"
    unfolding narray_assn_def
    apply (clarsimp split: list.split)
    apply vcg
    done

  thm array_upd_rule_snat[no_vars]

  lemma narray_upd_rule_snat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>narray_assn xs p \<and>* \<upharpoonleft>snat.assn i ii \<and>* \<up>\<^sub>d(i < length xs))
    (array_upd p ii x)
    (\<lambda>r. \<up>(r = p) \<and>* \<upharpoonleft>narray_assn (xs[i := x]) p)"
    unfolding narray_assn_def
    apply (clarsimp split: list.splits nat.splits; intro allI impI conjI)
    apply vcg
    done

  definition [llvm_code]: "narray_free p \<equiv> if p=null then return () else array_free p"

  thm array_free_rule[no_vars]

  lemma narray_free_rule[vcg_rules]:
    "llvm_htriple (\<upharpoonleft>narray_assn xs p) (narray_free p) (\<lambda>_. \<box>)"
    unfolding narray_assn_def narray_free_def
    apply (cases xs; clarsimp)
    apply vcg
    done

  lemma narrayset_rule_snat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>narray_assn dst dsti ** \<upharpoonleft>snat.assn n ni ** \<up>\<^sub>d(n\<le>length dst))
    (arrayset dsti c ni)
    (\<lambda>_. \<upharpoonleft>narray_assn (replicate n c @ drop n dst) dsti)"
    unfolding narray_assn_def
    apply (cases dst; clarsimp split: list.splits)
    supply [vcg_rules] = arrayset_zerosize_rule
    by vcg

  definition [llvm_code]: "narray_new_init n (c::'a::llvm_rep) \<equiv> doM {
    r \<leftarrow> narray_new TYPE('a) n;
    arrayset r c n;
    return r
  }"

  lemma narray_new_init_rule[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>snat.assn n ni)
    (narray_new_init ni c)
    (\<lambda>r. \<upharpoonleft>narray_assn (replicate n c) r)"
    unfolding narray_new_init_def
    by vcg

  lemma arraycpy_0_rl:
    "llvm_htriple (\<upharpoonleft>snat.assn 0 ni) (arraycpy dsti srci ni) (\<lambda>_. \<box>)"
    unfolding arraycpy_def
    apply (subst llc_while_unfold)
    apply vcg_monadify
    apply vcg'
    done

  lemma narraycpy_rule_snat[vcg_rules]:
    "llvm_htriple
      (\<upharpoonleft>narray_assn dst dsti ** \<upharpoonleft>narray_assn src srci ** \<upharpoonleft>snat.assn n ni ** \<up>\<^sub>d(n\<le>length src \<and> n\<le>length dst))
      (arraycpy dsti srci ni)
      (\<lambda>_. \<upharpoonleft>narray_assn (take n src @ drop n dst) dsti ** \<upharpoonleft>narray_assn src srci)"
    unfolding narray_assn_def
    apply (cases dst; cases src; simp)
    supply [vcg_rules] = arraycpy_0_rl
    apply vcg
    apply (clarsimp split: list.splits)
    apply vcg
    done

  definition [llvm_code]: "array_grow newsz oldsz src \<equiv> doM {
    dst \<leftarrow> narray_new TYPE(_) newsz;
    arraycpy dst src oldsz;
    narray_free src;
    return dst
  }"

  lemma narray_grow_rule_snat[vcg_rules]: "llvm_htriple
    (\<upharpoonleft>narray_assn src srci ** \<upharpoonleft>snat.assn newsz newszi ** \<upharpoonleft>snat.assn oldsz oldszi ** \<up>(oldsz \<le> length src \<and> oldsz \<le> newsz))
    (array_grow newszi oldszi srci)
    (\<lambda>dsti. \<upharpoonleft>narray_assn (take oldsz src@replicate (newsz - oldsz) init) dsti)"
    unfolding array_grow_def
    by vcg

  definition [llvm_code]: "example1 (n::64 word) \<equiv> doM {
    a \<leftarrow> narray_new TYPE(8 word) n;
    array_upd a (1::64 word) 42;
    narray_free a
  }"

  export_llvm (debug) example1 (* is "example1" file "exampel1.ll"*)

end


(*  Title:      Uint64.thy
    Author:     Andreas Lochbihler, ETH Zurich
*)

chapter {* Unsigned words of 64 bits *}

theory Uint64 imports
  Word_Misc
  Bits_Integer
begin

text \<open>
  PolyML (in version 5.7) provides a Word64 structure only when run in 64-bit mode.
  Therefore, we by default provide an implementation of 64-bit words using \verb$IntInf.int$ and
  masking. The code target \texttt{SML\_word} replaces this implementation and maps the operations
  directly to the \verb$Word64$ structure provided by the Standard ML implementations.

  The \verb$Eval$ target used by @{command value} and @{method eval} dynamically tests at
  runtime for the version of PolyML and uses PolyML's Word64 structure if it detects a 64-bit
  version which does not suffer from a division bug found in PolyML 5.6.
\<close>

declare prod.Quotient[transfer_rule]

section {* Type definition and primitive operations *}

typedef uint64 = "UNIV :: 64 word set" ..

setup_lifting type_definition_uint64

text {* Use an abstract type for code generation to disable pattern matching on @{term Abs_uint64}. *}
declare Rep_uint64_inverse[code abstype]

declare Quotient_uint64[transfer_rule]

instantiation uint64 :: "{neg_numeral, modulo, comm_monoid_mult, comm_ring}" begin
lift_definition zero_uint64 :: uint64 is "0 :: 64 word" .
lift_definition one_uint64 :: uint64 is "1" .
lift_definition plus_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "op + :: 64 word \<Rightarrow> _" .
lift_definition minus_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "op -" .
lift_definition uminus_uint64 :: "uint64 \<Rightarrow> uint64" is uminus .
lift_definition times_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "op *" .
lift_definition divide_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "op div" .
lift_definition modulo_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is "op mod" .
instance by standard (transfer, simp add: algebra_simps)+
end

instantiation uint64 :: linorder begin
lift_definition less_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> bool" is "op <" .
lift_definition less_eq_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> bool" is "op \<le>" .
instance by standard (transfer, simp add: less_le_not_le linear)+
end

lemmas [code] = less_uint64.rep_eq less_eq_uint64.rep_eq

instantiation uint64 :: bitss begin
lift_definition bitNOT_uint64 :: "uint64 \<Rightarrow> uint64" is bitNOT .
lift_definition bitAND_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is bitAND .
lift_definition bitOR_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is bitOR .
lift_definition bitXOR_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64" is bitXOR .
lift_definition test_bit_uint64 :: "uint64 \<Rightarrow> nat \<Rightarrow> bool" is test_bit .
lift_definition set_bit_uint64 :: "uint64 \<Rightarrow> nat \<Rightarrow> bool \<Rightarrow> uint64" is set_bit .
lift_definition set_bits_uint64 :: "(nat \<Rightarrow> bool) \<Rightarrow> uint64" is "set_bits" .
lift_definition lsb_uint64 :: "uint64 \<Rightarrow> bool" is lsb .
lift_definition shiftl_uint64 :: "uint64 \<Rightarrow> nat \<Rightarrow> uint64" is shiftl .
lift_definition shiftr_uint64 :: "uint64 \<Rightarrow> nat \<Rightarrow> uint64" is shiftr .
lift_definition msb_uint64 :: "uint64 \<Rightarrow> bool" is msb .
instance ..
end

lemmas [code] = test_bit_uint64.rep_eq lsb_uint64.rep_eq msb_uint64.rep_eq

instantiation uint64 :: equal begin
lift_definition equal_uint64 :: "uint64 \<Rightarrow> uint64 \<Rightarrow> bool" is "equal_class.equal" .
instance by standard (transfer, simp add: equal_eq)
end

lemmas [code] = equal_uint64.rep_eq

instantiation uint64 :: size begin
lift_definition size_uint64 :: "uint64 \<Rightarrow> nat" is "size" .
instance ..
end

lemmas [code] = size_uint64.rep_eq

lift_definition sshiftr_uint64 :: "uint64 \<Rightarrow> nat \<Rightarrow> uint64" (infixl ">>>" 55) is sshiftr .

lift_definition uint64_of_int :: "int \<Rightarrow> uint64" is "word_of_int" .

definition uint64_of_nat :: "nat \<Rightarrow> uint64"
where "uint64_of_nat = uint64_of_int \<circ> int"

lift_definition int_of_uint64 :: "uint64 \<Rightarrow> int" is "uint" .
lift_definition nat_of_uint64 :: "uint64 \<Rightarrow> nat" is "unat" .

definition integer_of_uint64 :: "uint64 \<Rightarrow> integer"
where "integer_of_uint64 = integer_of_int o int_of_uint64"

lemma bitval_integer_transfer [transfer_rule]:
  "(rel_fun op = pcr_integer) of_bool of_bool"
by(auto simp add: of_bool_def integer.pcr_cr_eq cr_integer_def split: bit.split)

text {* Use pretty numerals from integer for pretty printing *}

context includes integer.lifting begin

lift_definition Uint64 :: "integer \<Rightarrow> uint64" is "word_of_int" .

lemma Rep_uint64_numeral [simp]: "Rep_uint64 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint64_def Abs_uint64_inverse numeral.simps plus_uint64_def)

lemma numeral_uint64_transfer [transfer_rule]:
  "(rel_fun op = cr_uint64) numeral numeral"
by(auto simp add: cr_uint64_def)

lemma numeral_uint64 [code_unfold]: "numeral n = Uint64 (numeral n)"
by transfer simp

lemma Rep_uint64_neg_numeral [simp]: "Rep_uint64 (- numeral n) = - numeral n"
by(simp only: uminus_uint64_def)(simp add: Abs_uint64_inverse)

lemma neg_numeral_uint64 [code_unfold]: "- numeral n = Uint64 (- numeral n)"
by transfer(simp add: cr_uint64_def)

end

lemma Abs_uint64_numeral [code_post]: "Abs_uint64 (numeral n) = numeral n"
by(induction n)(simp_all add: one_uint64_def numeral.simps plus_uint64_def Abs_uint64_inverse)

lemma Abs_uint64_0 [code_post]: "Abs_uint64 0 = 0"
by(simp add: zero_uint64_def)

lemma Abs_uint64_1 [code_post]: "Abs_uint64 1 = 1"
by(simp add: one_uint64_def)

section {* Code setup *}

text \<open> For SML, we generate an implementation of unsigned 64-bit words using \verb$IntInf.int$.
  If @{ML "LargeWord.wordSize > 63"} of the Isabelle/ML runtime environment holds, then we assume
  that there is also a @{text Word64} structure available and accordingly replace the implementation
  for the target \verb$Eval$.
\<close>
code_printing code_module "Uint64" \<rightharpoonup> (SML) \<open>(* Test that words can handle numbers between 0 and 63 *)
val _ = if 6 <= Word.wordSize then () else raise (Fail ("wordSize less than 6"));

structure Uint64 : sig
  eqtype uint64;
  val zero : uint64;
  val one : uint64;
  val fromInt : IntInf.int -> uint64;
  val toInt : uint64 -> IntInf.int;
  val toLarge : uint64 -> LargeWord.word;
  val fromLarge : LargeWord.word -> uint64
  val plus : uint64 -> uint64 -> uint64;
  val minus : uint64 -> uint64 -> uint64;
  val times : uint64 -> uint64 -> uint64;
  val divide : uint64 -> uint64 -> uint64;
  val modulus : uint64 -> uint64 -> uint64;
  val negate : uint64 -> uint64;
  val less_eq : uint64 -> uint64 -> bool;
  val less : uint64 -> uint64 -> bool;
  val notb : uint64 -> uint64;
  val andb : uint64 -> uint64 -> uint64;
  val orb : uint64 -> uint64 -> uint64;
  val xorb : uint64 -> uint64 -> uint64;
  val shiftl : uint64 -> IntInf.int -> uint64;
  val shiftr : uint64 -> IntInf.int -> uint64;
  val shiftr_signed : uint64 -> IntInf.int -> uint64;
  val set_bit : uint64 -> IntInf.int -> bool -> uint64;
  val test_bit : uint64 -> IntInf.int -> bool;
end = struct

type uint64 = IntInf.int;

val mask = 0xFFFFFFFFFFFFFFFF : IntInf.int;

val zero = 0 : IntInf.int;

val one = 1 : IntInf.int;

fun fromInt x = IntInf.andb(x, mask);

fun toInt x = x

fun toLarge x = LargeWord.fromLargeInt (IntInf.toLarge x);

fun fromLarge x = IntInf.fromLarge (LargeWord.toLargeInt x);

fun plus x y = IntInf.andb(IntInf.+(x, y), mask);

fun minus x y = IntInf.andb(IntInf.-(x, y), mask);

fun negate x = IntInf.andb(IntInf.~(x), mask);

fun times x y = IntInf.andb(IntInf.*(x, y), mask);

fun divide x y = IntInf.div(x, y);

fun modulus x y = IntInf.mod(x, y);

fun less_eq x y = IntInf.<=(x, y);

fun less x y = IntInf.<(x, y);

fun notb x = IntInf.andb(IntInf.notb(x), mask);

fun orb x y = IntInf.orb(x, y);

fun andb x y = IntInf.andb(x, y);

fun xorb x y = IntInf.xorb(x, y);

val maxWord = IntInf.pow (2, Word.wordSize);

fun shiftl x n =
  if n < maxWord then IntInf.andb(IntInf.<< (x, Word.fromLargeInt (IntInf.toLarge n)), mask)
  else 0;

fun shiftr x n =
  if n < maxWord then IntInf.~>> (x, Word.fromLargeInt (IntInf.toLarge n))
  else 0;

val msb_mask = 0x8000000000000000 : IntInf.int;

fun shiftr_signed x i =
  if IntInf.andb(x, msb_mask) = 0 then shiftr x i
  else if i >= 64 then 0xFFFFFFFFFFFFFFFF
  else let
    val x' = shiftr x i
    val m' = IntInf.andb(IntInf.<<(mask, Word.max(0w64 - Word.fromLargeInt (IntInf.toLarge i), 0w0)), mask)
  in IntInf.orb(x', m') end;

fun test_bit x n =
  if n < maxWord then IntInf.andb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))) <> 0
  else false;

fun set_bit x n b =
  if n < 64 then
    if b then IntInf.orb (x, IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n)))
    else IntInf.andb (x, IntInf.notb (IntInf.<< (1, Word.fromLargeInt (IntInf.toLarge n))))
  else x;

end
\<close>
code_reserved SML Uint64

setup \<open>
let
  val polyml64 = LargeWord.wordSize > 63;
  (* PolyML 5.6 has bugs in its Word64 implementation. We test for one such bug and refrain
     from using Word64 in that case. Testing is done with dynamic code evaluation such that
     the compiler does not choke on the Word64 structure, which need not be present in a 32bit
     environment. *)
  val error_msg = "Buggy Word64 structure";
  val test_code =
   "val _ = if Word64.div (0w18446744073709551611 : Word64.word, 0w3) = 0w6148914691236517203 then ()\n" ^
   "else raise (Fail \"" ^ error_msg ^ "\");";
  val f = Exn.interruptible_capture (fn () => ML_Compiler.eval ML_Compiler.flags Position.none (ML_Lex.tokenize test_code))
  val use_Word64 = polyml64 andalso
    (case f () of
       Exn.Res _ => true
     | Exn.Exn (e as ERROR m) => if String.isSuffix error_msg m then false else Exn.reraise e
     | Exn.Exn e => Exn.reraise e)
    ;

  val newline = "\n";
  val content =
    "structure Uint64 : sig" ^ newline ^
    "  eqtype uint64;" ^ newline ^
    "  val zero : uint64;" ^ newline ^
    "  val one : uint64;" ^ newline ^
    "  val fromInt : IntInf.int -> uint64;" ^ newline ^
    "  val toInt : uint64 -> IntInf.int;" ^ newline ^
    "  val toLarge : uint64 -> LargeWord.word;" ^ newline ^
    "  val fromLarge : LargeWord.word -> uint64" ^ newline ^
    "  val plus : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val minus : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val times : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val divide : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val modulus : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val negate : uint64 -> uint64;" ^ newline ^
    "  val less_eq : uint64 -> uint64 -> bool;" ^ newline ^
    "  val less : uint64 -> uint64 -> bool;" ^ newline ^
    "  val notb : uint64 -> uint64;" ^ newline ^
    "  val andb : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val orb : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val xorb : uint64 -> uint64 -> uint64;" ^ newline ^
    "  val shiftl : uint64 -> IntInf.int -> uint64;" ^ newline ^
    "  val shiftr : uint64 -> IntInf.int -> uint64;" ^ newline ^
    "  val shiftr_signed : uint64 -> IntInf.int -> uint64;" ^ newline ^
    "  val set_bit : uint64 -> IntInf.int -> bool -> uint64;" ^ newline ^
    "  val test_bit : uint64 -> IntInf.int -> bool;" ^ newline ^
    "end = struct" ^ newline ^
    "" ^ newline ^
    "type uint64 = Word64.word;" ^ newline ^
    "" ^ newline ^
    "val zero = (0wx0 : uint64);" ^ newline ^
    "" ^ newline ^
    "val one = (0wx1 : uint64);" ^ newline ^
    "" ^ newline ^
    "fun fromInt x = Word64.fromLargeInt (IntInf.toLarge x);" ^ newline ^
    "" ^ newline ^
    "fun toInt x = IntInf.fromLarge (Word64.toLargeInt x);"  ^ newline ^
    "" ^ newline ^
    "fun fromLarge x = Word64.fromLarge x;" ^ newline ^
    "" ^ newline ^
    "fun toLarge x = Word64.toLarge x;"  ^ newline ^
    "" ^ newline ^
    "fun plus x y = Word64.+(x, y);" ^ newline ^
    "" ^ newline ^
    "fun minus x y = Word64.-(x, y);" ^ newline ^
    "" ^ newline ^
    "fun negate x = Word64.~(x);" ^ newline ^
    "" ^ newline ^
    "fun times x y = Word64.*(x, y);" ^ newline ^
    "" ^ newline ^
    "fun divide x y = Word64.div(x, y);" ^ newline ^
    "" ^ newline ^
    "fun modulus x y = Word64.mod(x, y);" ^ newline ^
    "" ^ newline ^
    "fun less_eq x y = Word64.<=(x, y);" ^ newline ^
    "" ^ newline ^
    "fun less x y = Word64.<(x, y);" ^ newline ^
    "" ^ newline ^
    "fun set_bit x n b =" ^ newline ^
    "  let val mask = Word64.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "  in if b then Word64.orb (x, mask)" ^ newline ^
    "     else Word64.andb (x, Word64.notb mask)" ^ newline ^
    "  end" ^ newline ^
    "" ^ newline ^
    "fun shiftl x n =" ^ newline ^
    "  Word64.<< (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "" ^ newline ^
    "fun shiftr x n =" ^ newline ^
    "  Word64.>> (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "" ^ newline ^
    "fun shiftr_signed x n =" ^ newline ^
    "  Word64.~>> (x, Word.fromLargeInt (IntInf.toLarge n))" ^ newline ^
    "" ^ newline ^
    "fun test_bit x n =" ^ newline ^
    "  Word64.andb (x, Word64.<< (0wx1, Word.fromLargeInt (IntInf.toLarge n))) <> Word64.fromInt 0" ^ newline ^
    "" ^ newline ^
    "val notb = Word64.notb" ^ newline ^
    "" ^ newline ^
    "fun andb x y = Word64.andb(x, y);" ^ newline ^
    "" ^ newline ^
    "fun orb x y = Word64.orb(x, y);" ^ newline ^
    "" ^ newline ^
    "fun xorb x y = Word64.xorb(x, y);" ^ newline ^
    "" ^ newline ^
    "end (*struct Uint64*)"
  val target_SML64 = "SML_word";
in
  (if use_Word64 then Code_Target.set_printings (Code_Symbol.Module ("Uint64", [(Code_Runtime.target, SOME (content, []))])) else I)
  #> Code_Target.set_printings (Code_Symbol.Module ("Uint64", [(target_SML64, SOME (content, []))]))
end
\<close>

code_printing code_module Uint64 \<rightharpoonup> (Haskell)
{*import qualified Data.Word;
import qualified Data.Int;

type Int64 = Data.Int.Int64;

type Word64 = Data.Word.Word64;*}
code_reserved Haskell Uint64

text {*
  OCaml and Scala provide only signed 64bit numbers, so we use these and
  implement sign-sensitive operations like comparisons manually.
*}
code_printing code_module "Uint64" \<rightharpoonup> (OCaml)
{*module Uint64 : sig
  val less : int64 -> int64 -> bool
  val less_eq : int64 -> int64 -> bool
  val set_bit : int64 -> Big_int.big_int -> bool -> int64
  val shiftl : int64 -> Big_int.big_int -> int64
  val shiftr : int64 -> Big_int.big_int -> int64
  val shiftr_signed : int64 -> Big_int.big_int -> int64
  val test_bit : int64 -> Big_int.big_int -> bool
end = struct

(* negative numbers have their highest bit set,
   so they are greater than positive ones *)
let less x y =
  if Int64.compare x Int64.zero < 0 then
    Int64.compare y Int64.zero < 0 && Int64.compare x y < 0
  else Int64.compare y Int64.zero < 0 || Int64.compare x y < 0;;

let less_eq x y =
  if Int64.compare x Int64.zero < 0 then
    Int64.compare y Int64.zero < 0 && Int64.compare x y <= 0
  else Int64.compare y Int64.zero < 0 || Int64.compare x y <= 0;;

let set_bit x n b =
  let mask = Int64.shift_left Int64.one (Big_int.int_of_big_int n)
  in if b then Int64.logor x mask
     else Int64.logand x (Int64.lognot mask);;

let shiftl x n = Int64.shift_left x (Big_int.int_of_big_int n);;

let shiftr x n = Int64.shift_right_logical x (Big_int.int_of_big_int n);;

let shiftr_signed x n = Int64.shift_right x (Big_int.int_of_big_int n);;

let test_bit x n =
  Int64.compare
    (Int64.logand x (Int64.shift_left Int64.one (Big_int.int_of_big_int n)))
    Int64.zero
  <> 0;;

end;; (*struct Uint64*)*}
code_reserved OCaml Uint64

code_printing code_module Uint64 \<rightharpoonup> (Scala)
{*object Uint64 {

def less(x: Long, y: Long) : Boolean =
  if (x < 0) y < 0 && x < y
  else y < 0 || x < y

def less_eq(x: Long, y: Long) : Boolean =
  if (x < 0) y < 0 && x <= y
  else y < 0 || x <= y

def set_bit(x: Long, n: BigInt, b: Boolean) : Long =
  if (b)
    x | (1L << n.intValue)
  else
    x & (1L << n.intValue).unary_~

def shiftl(x: Long, n: BigInt) : Long = x << n.intValue

def shiftr(x: Long, n: BigInt) : Long = x >>> n.intValue

def shiftr_signed(x: Long, n: BigInt) : Long = x >> n.intValue

def test_bit(x: Long, n: BigInt) : Boolean =
  (x & (1L << n.intValue)) != 0

} /* object Uint64 */*}
code_reserved Scala Uint64

text {*
  OCaml's conversion from Big\_int to int64 demands that the value fits int a signed 64-bit integer.
  The following justifies the implementation.
*}

definition Uint64_signed :: "integer \<Rightarrow> uint64"
where "Uint64_signed i = (if i < -(0x8000000000000000) \<or> i \<ge> 0x8000000000000000 then undefined Uint64 i else Uint64 i)"

lemma Uint64_code [code]:
  "Uint64 i =
  (let i' = i AND 0xFFFFFFFFFFFFFFFF
   in if i' !! 63 then Uint64_signed (i' - 0x10000000000000000) else Uint64_signed i')"
including undefined_transfer integer.lifting unfolding Uint64_signed_def
by transfer(rule word_of_int_via_signed, simp_all add: bin_mask_numeral)

lemma Uint64_signed_code [code abstract]:
  "Rep_uint64 (Uint64_signed i) =
  (if i < -(0x8000000000000000) \<or> i \<ge> 0x8000000000000000 then Rep_uint64 (undefined Uint64 i) else word_of_int (int_of_integer_symbolic i))"
unfolding Uint64_signed_def Uint64_def int_of_integer_symbolic_def word_of_integer_def
by(simp add: Abs_uint64_inverse)

text {*
  Avoid @{term Abs_uint64} in generated code, use @{term Rep_uint64'} instead.
  The symbolic implementations for code\_simp use @{term Rep_uint64}.

  The new destructor @{term Rep_uint64'} is executable.
  As the simplifier is given the [code abstract] equations literally,
  we cannot implement @{term Rep_uint64} directly, because that makes code\_simp loop.

  If code generation raises Match, some equation probably contains @{term Rep_uint64}
  ([code abstract] equations for @{typ uint64} may use @{term Rep_uint64} because
  these instances will be folded away.)

  To convert @{typ "64 word"} values into @{typ uint64}, use @{term "Abs_uint64'"}.
*}

definition Rep_uint64' where [simp]: "Rep_uint64' = Rep_uint64"

lemma Rep_uint64'_transfer [transfer_rule]:
  "rel_fun cr_uint64 op = (\<lambda>x. x) Rep_uint64'"
unfolding Rep_uint64'_def by(rule uint64.rep_transfer)

lemma Rep_uint64'_code [code]: "Rep_uint64' x = (BITS n. x !! n)"
by transfer simp

lift_definition Abs_uint64' :: "64 word \<Rightarrow> uint64" is "\<lambda>x :: 64 word. x" .

lemma Abs_uint64'_code [code]:
  "Abs_uint64' x = Uint64 (integer_of_int (uint x))"
including integer.lifting by transfer simp

declare [[code drop: "term_of_class.term_of :: uint64 \<Rightarrow> _"]]

lemma term_of_uint64_code [code]:
  defines "TR \<equiv> typerep.Typerep" and "bit0 \<equiv> STR ''Numeral_Type.bit0''"
  shows
  "term_of_class.term_of x =
   Code_Evaluation.App (Code_Evaluation.Const (STR ''Uint64.uint64.Abs_uint64'') (TR (STR ''fun'') [TR (STR ''Word.word'') [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR bit0 [TR (STR ''Numeral_Type.num1'') []]]]]]]], TR (STR ''Uint64.uint64'') []]))
       (term_of_class.term_of (Rep_uint64' x))"
by(simp add: term_of_anything)

code_printing
  type_constructor uint64 \<rightharpoonup>
  (SML) "Uint64.uint64" and
  (Haskell) "Uint64.Word64" and
  (OCaml) "int64" and
  (Scala) "Long"
| constant Uint64 \<rightharpoonup>
  (SML) "Uint64.fromInt" and
  (Haskell) "(Prelude.fromInteger _ :: Uint64.Word64)" and
  (Haskell_Quickcheck) "(Prelude.fromInteger (Prelude.toInteger _) :: Uint64.Word64)" and
  (Scala) "_.longValue"
| constant Uint64_signed \<rightharpoonup>
  (OCaml) "Big'_int.int64'_of'_big'_int"
| constant "0 :: uint64" \<rightharpoonup>
  (SML) "Uint64.zero" and
  (Haskell) "(0 :: Uint64.Word64)" and
  (OCaml) "Int64.zero" and
  (Scala) "0"
| constant "1 :: uint64" \<rightharpoonup>
  (SML) "Uint64.one" and
  (Haskell) "(1 :: Uint64.Word64)" and
  (OCaml) "Int64.one" and
  (Scala) "1"
| constant "plus :: uint64 \<Rightarrow> _ " \<rightharpoonup>
  (SML) "Uint64.plus" and
  (Haskell) infixl 6 "+" and
  (OCaml) "Int64.add" and
  (Scala) infixl 7 "+"
| constant "uminus :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.negate" and
  (Haskell) "negate" and
  (OCaml) "Int64.neg" and
  (Scala) "!(- _)"
| constant "minus :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.minus" and
  (Haskell) infixl 6 "-" and
  (OCaml) "Int64.sub" and
  (Scala) infixl 7 "-"
| constant "times :: uint64 \<Rightarrow> _ \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.times" and
  (Haskell) infixl 7 "*" and
  (OCaml) "Int64.mul" and
  (Scala) infixl 8 "*"
| constant "HOL.equal :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "!((_ : Uint64.uint64) = _)" and
  (Haskell) infix 4 "==" and
  (OCaml) "(Int64.compare _ _ = 0)" and
  (Scala) infixl 5 "=="
| class_instance uint64 :: equal \<rightharpoonup>
  (Haskell) -
| constant "less_eq :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Uint64.less'_eq" and
  (Haskell) infix 4 "<=" and
  (OCaml) "Uint64.less'_eq" and
  (Scala) "Uint64.less'_eq"
| constant "less :: uint64 \<Rightarrow> _ \<Rightarrow> bool" \<rightharpoonup>
  (SML) "Uint64.less" and
  (Haskell) infix 4 "<" and
  (OCaml) "Uint64.less" and
  (Scala) "Uint64.less"
| constant "bitNOT :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.notb" and
  (Haskell) "Data'_Bits.complement" and
  (OCaml) "Int64.lognot" and
  (Scala) "_.unary'_~"
| constant "bitAND :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.andb" and
  (Haskell) infixl 7 "Data_Bits..&." and
  (OCaml) "Int64.logand" and
  (Scala) infixl 3 "&"
| constant "bitOR :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.orb" and
  (Haskell) infixl 5 "Data_Bits..|." and
  (OCaml) "Int64.logor" and
  (Scala) infixl 1 "|"
| constant "bitXOR :: uint64 \<Rightarrow> _" \<rightharpoonup>
  (SML) "Uint64.xorb" and
  (Haskell) "Data'_Bits.xor" and
  (OCaml) "Int64.logxor" and
  (Scala) infixl 2 "^"

definition uint64_divmod :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64 \<times> uint64" where
  "uint64_divmod x y =
  (if y = 0 then (undefined (op div :: uint64 \<Rightarrow> _) x (0 :: uint64), undefined (op mod :: uint64 \<Rightarrow> _) x (0 :: uint64))
  else (x div y, x mod y))"

definition uint64_div :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
where "uint64_div x y = fst (uint64_divmod x y)"

definition uint64_mod :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
where "uint64_mod x y = snd (uint64_divmod x y)"

lemma div_uint64_code [code]: "x div y = (if y = 0 then 0 else uint64_div x y)"
including undefined_transfer unfolding uint64_divmod_def uint64_div_def
by transfer (simp add: word_div_def)

lemma mod_uint64_code [code]: "x mod y = (if y = 0 then x else uint64_mod x y)"
including undefined_transfer unfolding uint64_mod_def uint64_divmod_def
by transfer (simp add: word_mod_def)

definition uint64_sdiv :: "uint64 \<Rightarrow> uint64 \<Rightarrow> uint64"
where [code del]:
  "uint64_sdiv x y =
   (if y = 0 then undefined (op div :: uint64 \<Rightarrow> _) x (0 :: uint64)
    else Abs_uint64 (Rep_uint64 x sdiv Rep_uint64 y))"

definition div0_uint64 :: "uint64 \<Rightarrow> uint64"
where [code del]: "div0_uint64 x = undefined (op div :: uint64 \<Rightarrow> _) x (0 :: uint64)"
declare [[code abort: div0_uint64]]

definition mod0_uint64 :: "uint64 \<Rightarrow> uint64"
where [code del]: "mod0_uint64 x = undefined (op mod :: uint64 \<Rightarrow> _) x (0 :: uint64)"
declare [[code abort: mod0_uint64]]

lemma uint64_divmod_code [code]:
  "uint64_divmod x y =
  (if 0x8000000000000000 \<le> y then if x < y then (0, x) else (1, x - y)
   else if y = 0 then (div0_uint64 x, mod0_uint64 x)
   else let q = (uint64_sdiv (x >> 1) y) << 1;
            r = x - q * y
        in if r \<ge> y then (q + 1, r - y) else (q, r))"
including undefined_transfer unfolding uint64_divmod_def uint64_sdiv_def div0_uint64_def mod0_uint64_def
by transfer(simp add: divmod_via_sdivmod)

lemma uint64_sdiv_code [code abstract]:
  "Rep_uint64 (uint64_sdiv x y) =
   (if y = 0 then Rep_uint64 (undefined (op div :: uint64 \<Rightarrow> _) x (0 :: uint64))
    else Rep_uint64 x sdiv Rep_uint64 y)"
unfolding uint64_sdiv_def by(simp add: Abs_uint64_inverse)

text {*
  Note that we only need a translation for signed division, but not for the remainder
  because @{thm uint64_divmod_code} computes both with division only.
*}

code_printing
  constant uint64_div \<rightharpoonup>
  (SML) "Uint64.divide" and
  (Haskell) "Prelude.div"
| constant uint64_mod \<rightharpoonup>
  (SML) "Uint64.modulus" and
  (Haskell) "Prelude.mod"
| constant uint64_divmod \<rightharpoonup>
  (Haskell) "divmod"
| constant uint64_sdiv \<rightharpoonup>
  (OCaml) "Int64.div" and
  (Scala) "_ '/ _"

definition uint64_test_bit :: "uint64 \<Rightarrow> integer \<Rightarrow> bool"
where [code del]:
  "uint64_test_bit x n =
  (if n < 0 \<or> 63 < n then undefined (test_bit :: uint64 \<Rightarrow> _) x n
   else x !! (nat_of_integer n))"

lemma test_bit_uint64_code [code]:
  "test_bit x n \<longleftrightarrow> n < 64 \<and> uint64_test_bit x (integer_of_nat n)"
including undefined_transfer integer.lifting unfolding uint64_test_bit_def
by transfer(auto cong: conj_cong dest: test_bit_size simp add: word_size)

lemma uint64_test_bit_code [code]:
  "uint64_test_bit w n =
  (if n < 0 \<or> 63 < n then undefined (test_bit :: uint64 \<Rightarrow> _) w n else Rep_uint64 w !! nat_of_integer n)"
unfolding uint64_test_bit_def
by(simp add: test_bit_uint64.rep_eq)

code_printing constant uint64_test_bit \<rightharpoonup>
  (SML) "Uint64.test'_bit" and
  (Haskell) "Data'_Bits.testBitBounded" and
  (OCaml) "Uint64.test'_bit" and
  (Scala) "Uint64.test'_bit"

definition uint64_set_bit :: "uint64 \<Rightarrow> integer \<Rightarrow> bool \<Rightarrow> uint64"
where [code del]:
  "uint64_set_bit x n b =
  (if n < 0 \<or> 63 < n then undefined (set_bit :: uint64 \<Rightarrow> _) x n b
   else set_bit x (nat_of_integer n) b)"

lemma set_bit_uint64_code [code]:
  "set_bit x n b = (if n < 64 then uint64_set_bit x (integer_of_nat n) b else x)"
including undefined_transfer integer.lifting unfolding uint64_set_bit_def
by(transfer)(auto cong: conj_cong simp add: not_less set_bit_beyond word_size)

lemma uint64_set_bit_code [code abstract]:
  "Rep_uint64 (uint64_set_bit w n b) =
  (if n < 0 \<or> 63 < n then Rep_uint64 (undefined (set_bit :: uint64 \<Rightarrow> _) w n b)
   else set_bit (Rep_uint64 w) (nat_of_integer n) b)"
including undefined_transfer unfolding uint64_set_bit_def by transfer simp

code_printing constant uint64_set_bit \<rightharpoonup>
  (SML) "Uint64.set'_bit" and
  (Haskell) "Data'_Bits.setBitBounded" and
  (OCaml) "Uint64.set'_bit" and
  (Scala) "Uint64.set'_bit"

lift_definition uint64_set_bits :: "(nat \<Rightarrow> bool) \<Rightarrow> uint64 \<Rightarrow> nat \<Rightarrow> uint64" is set_bits_aux .

lemma uint64_set_bits_code [code]:
  "uint64_set_bits f w n =
  (if n = 0 then w
   else let n' = n - 1 in uint64_set_bits f ((w << 1) OR (if f n' then 1 else 0)) n')"
by(transfer fixing: n)(cases n, simp_all)

lemma set_bits_uint64 [code]:
  "(BITS n. f n) = uint64_set_bits f 0 64"
by transfer(simp add: set_bits_conv_set_bits_aux)

lemma lsb_code [code]: fixes x :: uint64 shows "lsb x = x !! 0"
by transfer(simp add: word_lsb_def word_test_bit_def)

definition uint64_shiftl :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
where [code del]:
  "uint64_shiftl x n = (if n < 0 \<or> 64 \<le> n then undefined (shiftl :: uint64 \<Rightarrow> _) x n else x << (nat_of_integer n))"

lemma shiftl_uint64_code [code]: "x << n = (if n < 64 then uint64_shiftl x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint64_shiftl_def
by transfer(simp add: not_less shiftl_zero_size word_size)

lemma uint64_shiftl_code [code abstract]:
  "Rep_uint64 (uint64_shiftl w n) =
  (if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined (shiftl :: uint64 \<Rightarrow> _) w n) else Rep_uint64 w << (nat_of_integer n))"
including undefined_transfer unfolding uint64_shiftl_def by transfer simp

code_printing constant uint64_shiftl \<rightharpoonup>
  (SML) "Uint64.shiftl" and
  (Haskell) "Data'_Bits.shiftlBounded" and
  (OCaml) "Uint64.shiftl" and
  (Scala) "Uint64.shiftl"

definition uint64_shiftr :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
where [code del]:
  "uint64_shiftr x n = (if n < 0 \<or> 64 \<le> n then undefined (shiftr :: uint64 \<Rightarrow> _) x n else x >> (nat_of_integer n))"

lemma shiftr_uint64_code [code]: "x >> n = (if n < 64 then uint64_shiftr x (integer_of_nat n) else 0)"
including undefined_transfer integer.lifting unfolding uint64_shiftr_def
by transfer(simp add: not_less shiftr_zero_size word_size)

lemma uint64_shiftr_code [code abstract]:
  "Rep_uint64 (uint64_shiftr w n) =
  (if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined (shiftr :: uint64 \<Rightarrow> _) w n) else Rep_uint64 w >> nat_of_integer n)"
including undefined_transfer unfolding uint64_shiftr_def by transfer simp

code_printing constant uint64_shiftr \<rightharpoonup>
  (SML) "Uint64.shiftr" and
  (Haskell) "Data'_Bits.shiftrBounded" and
  (OCaml) "Uint64.shiftr" and
  (Scala) "Uint64.shiftr"

definition uint64_sshiftr :: "uint64 \<Rightarrow> integer \<Rightarrow> uint64"
where [code del]:
  "uint64_sshiftr x n =
  (if n < 0 \<or> 64 \<le> n then undefined sshiftr_uint64 x n else sshiftr_uint64 x (nat_of_integer n))"

lemma sshiftr_beyond: fixes x :: "'a :: len word" shows
  "size x \<le> n \<Longrightarrow> x >>> n = (if x !! (size x - 1) then -1 else 0)"
by(rule word_eqI)(simp add: nth_sshiftr word_size)

lemma sshiftr_uint64_code [code]:
  "x >>> n =
  (if n < 64 then uint64_sshiftr x (integer_of_nat n) else if x !! 63 then -1 else 0)"
including undefined_transfer integer.lifting unfolding uint64_sshiftr_def
by transfer(simp add: not_less sshiftr_beyond word_size)

lemma uint64_sshiftr_code [code abstract]:
  "Rep_uint64 (uint64_sshiftr w n) =
  (if n < 0 \<or> 64 \<le> n then Rep_uint64 (undefined sshiftr_uint64 w n) else Rep_uint64 w >>> (nat_of_integer n))"
including undefined_transfer unfolding uint64_sshiftr_def by transfer simp

code_printing constant uint64_sshiftr \<rightharpoonup>
  (SML) "Uint64.shiftr'_signed" and
  (Haskell)
    "(Prelude.fromInteger (Prelude.toInteger (Data'_Bits.shiftrBounded (Prelude.fromInteger (Prelude.toInteger _) :: Uint64.Int64) _)) :: Uint64.Word64)" and
  (OCaml) "Uint64.shiftr'_signed" and
  (Scala) "Uint64.shiftr'_signed"

lemma uint64_msb_test_bit: "msb x \<longleftrightarrow> (x :: uint64) !! 63"
by transfer(simp add: msb_nth)

lemma msb_uint64_code [code]: "msb x \<longleftrightarrow> uint64_test_bit x 63"
by(simp add: uint64_test_bit_def uint64_msb_test_bit)

lemma uint64_of_int_code [code]: "uint64_of_int i = Uint64 (integer_of_int i)"
including integer.lifting by transfer simp

lemma int_of_uint64_code [code]:
  "int_of_uint64 x = int_of_integer (integer_of_uint64 x)"
by(simp add: integer_of_uint64_def)

lemma nat_of_uint64_code [code]:
  "nat_of_uint64 x = nat_of_integer (integer_of_uint64 x)"
unfolding integer_of_uint64_def including integer.lifting by transfer (simp add: unat_def)

definition integer_of_uint64_signed :: "uint64 \<Rightarrow> integer"
where
  "integer_of_uint64_signed n = (if n !! 63 then undefined integer_of_uint64 n else integer_of_uint64 n)"

lemma integer_of_uint64_signed_code [code]:
  "integer_of_uint64_signed n =
  (if n !! 63 then undefined integer_of_uint64 n else integer_of_int (uint (Rep_uint64' n)))"
unfolding integer_of_uint64_signed_def integer_of_uint64_def
including undefined_transfer by transfer simp

lemma integer_of_uint64_code [code]:
  "integer_of_uint64 n =
  (if n !! 63 then integer_of_uint64_signed (n AND 0x7FFFFFFFFFFFFFFF) OR 0x8000000000000000 else integer_of_uint64_signed n)"
unfolding integer_of_uint64_def integer_of_uint64_signed_def o_def
including undefined_transfer integer.lifting
by transfer(auto simp add: word_ao_nth uint_and_mask_or_full mask_numeral mask_Suc_0 intro!: uint_and_mask_or_full[symmetric])

code_printing
  constant "integer_of_uint64" \<rightharpoonup>
  (SML) "Uint64.toInt" and
  (Haskell) "Prelude.toInteger"
| constant "integer_of_uint64_signed" \<rightharpoonup>
  (OCaml) "Big'_int.big'_int'_of'_int64" and
  (Scala) "BigInt"

section {* Quickcheck setup *}

definition uint64_of_natural :: "natural \<Rightarrow> uint64"
where "uint64_of_natural x \<equiv> Uint64 (integer_of_natural x)"

instantiation uint64 :: "{random, exhaustive, full_exhaustive}" begin
definition "random_uint64 \<equiv> qc_random_cnv uint64_of_natural"
definition "exhaustive_uint64 \<equiv> qc_exhaustive_cnv uint64_of_natural"
definition "full_exhaustive_uint64 \<equiv> qc_full_exhaustive_cnv uint64_of_natural"
instance ..
end

instantiation uint64 :: narrowing begin

interpretation quickcheck_narrowing_samples
  "\<lambda>i. let x = Uint64 i in (x, 0xFFFFFFFFFFFFFFFF - x)" "0"
  "Typerep.Typerep (STR ''Uint64.uint64'') []" .

definition "narrowing_uint64 d = qc_narrowing_drawn_from (narrowing_samples d) d"
declare [[code drop: "partial_term_of :: uint64 itself \<Rightarrow> _"]]
lemmas partial_term_of_uint64 [code] = partial_term_of_code

instance ..
end

no_notation sshiftr_uint64 (infixl ">>>" 55)

end