theory LiveDemo13
  imports 
    Main
    "HOL-Library.Code_Target_Numeral"
begin

section \<open>More Types\<close>

codatatype 'a hlist = HNil | HCons 'a "'a hlist" 

text \<open>The infinite list starting from a given value\<close>
primcorec "from" :: "nat \<Rightarrow> nat hlist" where
  "from x = HCons x (from (Suc x))" 

export_code "from" in Haskell module_name From

record person =  
  name :: string
  age :: nat

record student = person +
  matrikel :: nat

definition "sue = \<lparr> name = ''Sue'', age = 27 \<rparr>" 
definition "bob = sue \<lparr> name := ''Bob'' \<rparr>" 
definition "john = \<lparr> name = ''John'', age = 32, matrikel = 4711 \<rparr>" 
definition "johns_name = name john" 
definition "bobs_name = name bob" 




section \<open>Syntax\<close>

definition infix_apply :: "('a \<Rightarrow> 'b) \<Rightarrow> 'a \<Rightarrow> 'b" (infixr "$" 51) where
  "f $ x = f x" 

text \<open>Precedence 51 is one above 50, which is the precedence of \<^term>\<open>(=)\<close>,
  but below 65, which is the precedence of \<^term>\<open>(+)\<close>}\<close>

lemma "f $ g $ x = f (g (x))" 
  unfolding infix_apply_def by auto

lemma "f $ x + y = f (x + y)" 
  unfolding infix_apply_def by auto

text \<open>Do you know the internal representation of numerals?\<close>

term \<open>100\<close>
ML \<open>@{term 100}\<close>
term "numeral (num.Bit0 (num.Bit1 num.One))" 

text \<open>Do you know the internal representation of chars and strings?\<close>

typ char
text \<open>there is a complex setup for syntax of chars and strings, 
  cf. @{file "~~/src/HOL/Tools/string_syntax.ML"}}\<close>

term \<open>CHR ''a''\<close>
ML \<open>@{term "CHR ''a''"}\<close>
term "char.Char True False False False False True True False" 

ML \<open>@{term "''abc''"}\<close>

ML \<open>@{term "STR ''abc''"}\<close>

text \<open>Quantifiers, Sums, ...\<close>

text \<open>Click on sum, to see several syntax translations.\<close>
term sum

term "\<forall> x \<in> A. p x" 
term "\<forall> x. x \<in> A \<longrightarrow> p x" 
term "Ball A p"
term "Ball A (\<lambda> x. p x)"

term "\<Sum> i \<in> A. f i" 
term "sum f A" 
term "\<Sum> i \<in> A. i + 5" 
term "sum ((+) 5) A" 
term "sum (\<lambda> x. x) A" 
term "sum (\<lambda> x. x + 5) A" 
term "sum (\<lambda> x. 5 + x) A"
 

text \<open>For further information consult Chapter 8 (Inner Syntax) of @{doc "isar-ref"}.\<close>



section \<open>Isabelle/ML\<close>

ML \<open>
  val num = 5
  val t = HOLogic.mk_Trueprop (HOLogic.mk_eq (@{term "x :: nat"}, 
    HOLogic.mk_number @{typ nat} 5))
  val ct = Thm.cterm_of @{context} t
  val prop = Thm.prop_of @{lemma "(5 + x :: 'a :: {numeral,comm_ring}) = x + 5" by auto}
\<close>

ML \<open>@{method auto}\<close>
ML \<open>Clasimp.auto_tac\<close>
text \<open>have a look at \<open>mk_auto_tac\<close> in @{file \<open>~~/src/Provers/clasimp.ML\<close>}\<close>

text \<open>@{command fun}\<close>


subsection \<open>Example: Integer Implementation of Characters\<close>

text \<open>Observe non-efficient implementation of characters\<close>

definition "test x = (''abc'', CHR ''a'', ''abc'' = x, String.explode (STR ''abc''))" 

export_code test in Haskell module_name Test_Before



typedef char_int = "{x :: int . 0 \<le> x \<and> x < 256}" by auto

setup_lifting type_definition_char_int

lift_definition char_of_ci :: "char_int \<Rightarrow> char" is char_of_int .
lift_definition int_of_ci :: "char_int \<Rightarrow> int" is "\<lambda> x. x" .

lift_definition char_int_of_int :: "int \<Rightarrow> char_int" 
  is "\<lambda> x. if 0 \<le> x \<and> x < 256 then x 
  else Code.abort (STR ''char_int_of_int argument must be in range 0 .. 255'') (\<lambda> _. int_of_char (char_of x))" 
  using unique_euclidean_semiring_numeral_class.pos_mod_bound[of "256 :: int"]
    unique_euclidean_semiring_numeral_class.pos_mod_sign[of "256 :: int"]
  by (auto simp: int_of_char_def)

lemma int_of_char_of_nat: "int_of_char c = int_of_nat (of_char c :: nat)" 
proof -
  define ds where "ds = [digit0 c, digit1 c, digit2 c, digit3 c, digit4 c, digit5 c, digit6 c, digit7 c]" 
  show ?thesis unfolding int_of_char_def unfolding of_char_def ds_def[symmetric]
    by (induct ds, auto simp: int_of_nat_def)
qed

code_datatype char_of_ci

declare [[code drop: 
      int_of_char 
      char_of_int
      char_of_integer
      String.asciis_of_literal 
      ]]

lemma int_of_char_code[code]: "int_of_char (char_of_ci x) = int_of_ci x" 
  by (transfer, auto simp: int_of_char_def char_of_int_def unique_euclidean_semiring_numeral_class.mod_less)

lemma char_of_int_code[code]: "char_of_int x = char_of_ci (char_int_of_int x)"
  by (transfer, auto simp: char_of_int_def int_of_char_def)

lemma char_of_integer_code[code]: "char_of_integer x = char_of_int (int_of_integer x)" 
  unfolding char_of_int_def char_of_integer_def 
  by (simp add: bit_integer.rep_eq char_of_def)


lemma equal_char_code[code]: "equal_class.equal c d = (int_of_char c = int_of_char d)" 
  unfolding equal_char_def int_of_char_of_nat int_of_nat_def by simp

(* finally we provide a separate implementation for all 256 characters *)

(* we first define all 256 characters (x = 0 .. 255) following the following schema:

     lift_definition char_x :: char_int is x by simp
*)
local_setup \<open>
  let fun create_char x = Lifting_Def.lift_def 
    Lifting_Def.default_config 
    (Binding.name ("char_" ^ string_of_int x),Mixfix.NoSyn) 
    @{typ char_int} 
    (HOLogic.mk_number @{typ int} x)
    (fn ctxt => unfold_tac ctxt @{thms eq_onp_def} THEN simp_tac ctxt 1)
    []
    #> #2
  in fold create_char (0 upto 255) end
\<close>
print_theorems

term char_65

(* and then prove code-unfold lemmas of the following shape
 
lemma char_256_unfold[code_unfold]: "CHR 0x00 = char_of_ci char_0" ... "CHR 0xFF = char_of_ci char_255"

to replace all concrete characters by their number, so that constructor Char vanishes.
*)

ML \<open>@{term "CHR 0x00"}\<close>


local_setup \<open>
  fn lthy => let
    val name_prefix = "LiveDemo13.char_"
    fun create_eq x = let
      val eq = HOLogic.mk_Trueprop (HOLogic.mk_eq (HOLogic.mk_char x, 
        Const (@{const_name char_of_ci}, @{typ "char_int \<Rightarrow> char"}) $ 
          Const (name_prefix ^ string_of_int x, @{typ char_int})));
      in Goal.prove_future lthy [] [] eq (fn {context = ctxt, ...} => 
            Transfer.transfer_tac true ctxt 1 
            THEN unfold_tac ctxt @{thms char_of_int_def char_of_def} 
            THEN simp_tac ctxt 1) end
    val thms = map create_eq (0 upto 255)
    in Local_Theory.note ((Binding.name "char_256_unfold", @{attributes [code_unfold]}), thms) lthy |> #2 end
\<close>

thm char_256_unfold

export_code test in Haskell module_name Test_After

end