Theory Autoref_Bindings_HOL

theory Autoref_Bindings_HOL
imports Autoref_Tool
header {* \isaheader{Standard HOL Bindings} *}
theory Autoref_Bindings_HOL
imports "Tool/Autoref_Tool"
begin


  subsection "Structural Expansion"
  text {*
    In some situations, autoref imitates the operations on typeclasses and
    the typeclass hierarchy. This may result in structural mismatches, e.g.,
    a hashcode side-condition may look like:
      @{text [display] "is_hashcode (prod_eq op= op=) hashcode"}

    This cannot be discharged by the rule
      @{text [display] "is_hashcode op= hashcode"}
    
    In order to handle such cases, we introduce a set of simplification lemmas
    that expand the structure of an operator as far as possible.
    These lemmas are integrated into a tagged solver, that can prove equality
    between operators modulo structural expansion.
    *}

definition [simp]: "STRUCT_EQ_tag x y ≡ x = y"
lemma STRUCT_EQ_tagI: "x=y ==> STRUCT_EQ_tag x y" by simp

ML {*
  structure Autoref_Struct_Expand = struct
    structure autoref_struct_expand = Named_Thms (
      val name = @{binding autoref_struct_expand}
      val description = "Autoref: Structural expansion lemmas"
    )

    fun expand_tac ctxt = let
      val ss = put_simpset HOL_basic_ss ctxt addsimps autoref_struct_expand.get ctxt
    in
      SOLVED' (asm_simp_tac ss)
    end


    val setup = autoref_struct_expand.setup
    val decl_setup = fn phi =>
      Tagged_Solver.declare_solver @{thms STRUCT_EQ_tagI} @{binding STRUCT_EQ} 
        "Autoref: Equality modulo structural expansion" 
        (expand_tac) phi

  end
*}

setup Autoref_Struct_Expand.setup
declaration Autoref_Struct_Expand.decl_setup


text {* Sometimes, also relators must be expanded. Usually to check them to be the identity relator *}
definition [simp]: "REL_IS_ID R ≡ R=Id"
definition [simp]: "REL_FORCE_ID R ≡ R=Id"
lemma REL_IS_ID_trigger: "R=Id ==> REL_IS_ID R" by simp
lemma REL_FORCE_ID_trigger: "R=Id ==> REL_FORCE_ID R" by simp

declaration {* Tagged_Solver.add_triggers 
  "Relators.relator_props_solver" @{thms REL_IS_ID_trigger} *}

declaration {* Tagged_Solver.add_triggers 
  "Relators.force_relator_props_solver" @{thms REL_FORCE_ID_trigger} *}

abbreviation "PREFER_id R ≡ PREFER REL_IS_ID R"



  
  (* TODO: Most of these are parametricity theorems! *)

  lemmas [autoref_rel_intf] = REL_INTFI[of fun_rel i_fun]

  subsection "Booleans"
  consts
    i_bool :: interface

  lemmas [autoref_rel_intf] = REL_INTFI[of bool_rel i_bool]

  lemma [autoref_itype]:
    "True ::i i_bool"
    "False ::i i_bool"
    "conj ::i i_bool ->i i_bool ->i i_bool"
    "op <-> ::i i_bool ->i i_bool ->i i_bool"
    "op --> ::i i_bool ->i i_bool ->i i_bool"
    "disj ::i i_bool ->i i_bool ->i i_bool"
    "Not ::i i_bool ->i i_bool"
    "case_bool ::i I ->i I ->i i_bool ->i I"
    "old.rec_bool ::i I ->i I ->i i_bool ->i I"
    by auto

  lemma autoref_bool[autoref_rules]:
    "(x,x)∈bool_rel"
    "(conj,conj)∈bool_rel->bool_rel->bool_rel"
    "(disj,disj)∈bool_rel->bool_rel->bool_rel"
    "(Not,Not)∈bool_rel->bool_rel"
    "(case_bool,case_bool)∈R->R->bool_rel->R"
    "(old.rec_bool,old.rec_bool)∈R->R->bool_rel->R"
    "(op <->, op <->)∈bool_rel->bool_rel->bool_rel"
    "(op -->, op -->)∈bool_rel->bool_rel->bool_rel"
    by (auto split: bool.split simp: rec_bool_is_case)


  subsection "Standard Type Classes"


context begin interpretation autoref_syn .
  text {*
    We allow these operators for all interfaces.
    *}
  lemma [autoref_itype]:
    "op < ::i I ->i I ->i i_bool"
    "op ≤ ::i I ->i I ->i i_bool"
    "op = ::i I ->i I ->i i_bool"
    "op + ::i I ->i I ->i I"
    "op - ::i I ->i I ->i I"
    "op div ::i I ->i I ->i I"
    "op mod ::i I ->i I ->i I"
    "op * ::i I ->i I ->i I"
    "0 ::i I"
    "1 ::i I"
    "numeral x ::i I"
    "uminus ::i I ->i I"
    by auto

  lemma pat_num_generic[autoref_op_pat]:
    "0 ≡ OP 0 :::i I"
    "1 ≡ OP 1 :::i I"
    "numeral x ≡ (OP (numeral x) :::i I)"
    by simp_all

  lemma [autoref_rules]: 
    assumes "PRIO_TAG_GEN_ALGO"
    shows "(op <, op <) ∈ Id->Id->bool_rel"
    and "(op ≤, op ≤) ∈ Id->Id->bool_rel"
    and "(op =, op =) ∈ Id->Id->bool_rel"
    and "(numeral x,OP (numeral x) ::: Id) ∈ Id"
    and "(uminus,uminus) ∈ Id -> Id"
    and "(0,0) ∈ Id"
    and "(1,1) ∈ Id"
    by auto

  subsection "Functional Combinators"
  lemma [autoref_itype]: "id ::i I ->i I" by simp
  lemma autoref_id[autoref_rules]: "(id,id)∈R->R" by auto

  term "op o"
  lemma [autoref_itype]: "op o ::i (Ia->iIb) ->i (Ic ->i Ia) ->i Ic ->i Ib" 
    by simp
  lemma autoref_comp[autoref_rules]: 
    "(op o, op o) ∈ (Ra -> Rb) -> (Rc -> Ra) -> Rc -> Rb"
    by (auto dest: fun_relD)

  lemma [autoref_itype]: "If ::i i_bool ->i I ->i I ->i I" by simp
  lemma autoref_If[autoref_rules]: "(If,If)∈Id->R->R->R" by auto
  lemma autoref_If_cong[autoref_rules]:
    assumes "(c',c)∈Id"
    assumes "REMOVE_INTERNAL c ==> (t',t)∈R"
    assumes "¬ REMOVE_INTERNAL c ==> (e',e)∈R"
    shows "(If c' t' e',(OP If ::: Id->R->R->R)$c$t$e)∈R"
    using assms by (auto)

  lemma [autoref_itype]: "Let ::i Ix ->i (Ix->iIy) ->i Iy" by auto
  lemma autoref_Let[autoref_rules]: 
    "(Let,Let)∈Ra -> (Ra->Rr) -> Rr"
    by (auto dest: fun_relD)

end

  subsection "Unit"
  consts i_unit :: interface
  lemmas [autoref_rel_intf] = REL_INTFI[of unit_rel i_unit]

  (*lemma [autoref_itype]: "(a::unit) ::i i_unit" by simp*)
  lemma [autoref_rules]: "((),())∈unit_rel" by simp

  subsection "Nat"
    consts i_nat :: interface
    lemmas [autoref_rel_intf] = REL_INTFI[of nat_rel i_nat]

context begin interpretation autoref_syn .
    lemma pat_num_nat[autoref_op_pat]:
      "0::nat ≡ OP 0 :::i i_nat"
      "1::nat ≡ OP 1 :::i i_nat"
      "(numeral x)::nat ≡ (OP (numeral x) :::i i_nat)"
      by simp_all
   
    lemma autoref_nat[autoref_rules]:
      "(0, 0::nat) ∈ nat_rel"
      "(Suc, Suc) ∈ nat_rel -> nat_rel"
      "(1, 1::nat) ∈ nat_rel"
      "(numeral n::nat,numeral n::nat) ∈ nat_rel"
      "(op <, op <::nat => _) ∈ nat_rel -> nat_rel -> bool_rel"
      "(op ≤, op ≤::nat => _) ∈ nat_rel -> nat_rel -> bool_rel"
      "(op =, op =::nat => _) ∈ nat_rel -> nat_rel -> bool_rel"
      "(op +::nat=>_,op +)∈nat_rel->nat_rel->nat_rel"
      "(op -::nat=>_,op -)∈nat_rel->nat_rel->nat_rel"
      "(op div::nat=>_,op div)∈nat_rel->nat_rel->nat_rel"
      "(op *, op *)∈nat_rel->nat_rel->nat_rel"
      "(op mod, op mod)∈nat_rel->nat_rel->nat_rel"
      by auto
    
    lemma autoref_case_nat[autoref_rules]: 
      "(case_nat,case_nat)∈Ra -> (Id -> Ra) -> Id -> Ra"
      apply (intro fun_relI)
      apply (auto split: nat.split dest: fun_relD)
      done

    lemma autoref_rec_nat: "(rec_nat,rec_nat) ∈ R -> (Id -> R -> R) -> Id -> R"
      apply (intro fun_relI)
    proof -
      case (goal1 s s' f f' n n') thus ?case
        apply (induct n' arbitrary: n s s')
        apply (fastforce simp: fun_rel_def)+
        done
    qed
end

  subsection "Int"
    consts i_int :: interface
    lemmas [autoref_rel_intf] = REL_INTFI[of int_rel i_int]

context begin interpretation autoref_syn .
    lemma pat_num_int[autoref_op_pat]:
      "0::int ≡ OP 0 :::i i_int"
      "1::int ≡ OP 1 :::i i_int"
      "(numeral x)::int ≡ (OP (numeral x) :::i i_int)"
      "(neg_numeral x)::int ≡ (OP (neg_numeral x) :::i i_int)"
      by simp_all

    (*lemma [autoref_itype]:
      "(op < :: int => _) ::i i_int ->i i_int ->i i_bool"
      "(op ≤ :: int => _) ::i i_int ->i i_int ->i i_bool"
      "(op = :: int => _) ::i i_int ->i i_int ->i i_bool"
      "(op + :: int => _) ::i i_int ->i i_int ->i i_int"
      "(op - :: int => _) ::i i_int ->i i_int ->i i_int"
      "(op div :: int => _) ::i i_int ->i i_int ->i i_int"
      "(uminus :: int => _) ::i i_int ->i i_int"
      by auto*)

    lemma autoref_int[autoref_rules (overloaded)]:
      "(0, 0::int) ∈ int_rel"
      "(1, 1::int) ∈ int_rel"
      "(numeral n::int,numeral n::int) ∈ int_rel"
      "(op <, op <::int => _) ∈ int_rel -> int_rel -> bool_rel"
      "(op ≤, op ≤::int => _) ∈ int_rel -> int_rel -> bool_rel"
      "(op =, op =::int => _) ∈ int_rel -> int_rel -> bool_rel"
      "(op +::int=>_,op +)∈int_rel->int_rel->int_rel"
      "(op -::int=>_,op -)∈int_rel->int_rel->int_rel"
      "(op div::int=>_,op div)∈int_rel->int_rel->int_rel"
      "(uminus,uminus)∈int_rel->int_rel"
      "(op *, op *)∈int_rel->int_rel->int_rel"
      "(op mod, op mod)∈int_rel->int_rel->int_rel"
      by auto
end
  
  subsection "Product"
    consts i_prod :: "interface => interface => interface"
    lemmas [autoref_rel_intf] = REL_INTFI[of prod_rel i_prod]

context begin interpretation autoref_syn .
    (*
    lemma [autoref_itype]:
      "Pair ::i Ia ->i Ib ->i ⟨Ia,Ib⟩ii_prod"
      "case_prod ::i (Ia ->i Ib ->i I) ->i ⟨Ia,Ib⟩ii_prod ->i I"
      "old.rec_prod ::i (Ia ->i Ib ->i I) ->i ⟨Ia,Ib⟩ii_prod ->i I"
      "fst ::i ⟨Ia,Ib⟩ii_prod ->i Ia"
      "snd ::i ⟨Ia,Ib⟩ii_prod ->i Ib"
      "(op = :: _×_ => _) ::i ⟨Ia,Ib⟩ii_prod ->i ⟨Ia,Ib⟩ii_prod ->i i_bool"
      by auto
      *)

    lemma prod_refine[autoref_rules]:
      "(Pair,Pair)∈Ra -> Rb -> ⟨Ra,Rb⟩prod_rel"
      "(case_prod,case_prod) ∈ (Ra -> Rb -> Rr) -> ⟨Ra,Rb⟩prod_rel -> Rr"
      "(old.rec_prod,old.rec_prod) ∈ (Ra -> Rb -> Rr) -> ⟨Ra,Rb⟩prod_rel -> Rr"
      "(fst,fst)∈⟨Ra,Rb⟩prod_rel -> Ra"
      "(snd,snd)∈⟨Ra,Rb⟩prod_rel -> Rb"
      by (auto dest: fun_relD split: prod.split 
        simp: prod_rel_def rec_prod_is_case)

    definition "prod_eq eqa eqb x1 x2 ≡ 
      case x1 of (a1,b1) => case x2 of (a2,b2) => eqa a1 a2 ∧ eqb b1 b2"

    lemma prod_eq_autoref[autoref_rules (overloaded)]:
      "[|GEN_OP eqa op = (Ra->Ra->Id); GEN_OP eqb op = (Rb->Rb->Id)|] 
      ==> (prod_eq eqa eqb,op =) ∈ ⟨Ra,Rb⟩prod_rel -> ⟨Ra,Rb⟩prod_rel -> Id"
      unfolding prod_eq_def[abs_def]
      by (fastforce dest: fun_relD)

    lemma prod_eq_expand[autoref_struct_expand]: "op = = prod_eq op= op="
      unfolding prod_eq_def[abs_def]
      by (auto intro!: ext)
end

  subsection "Option"
    consts i_option :: "interface => interface"
    lemmas [autoref_rel_intf] = REL_INTFI[of option_rel i_option]

context begin interpretation autoref_syn .
    (*
    lemma [autoref_itype]:
      "None ::i ⟨I⟩ii_option"
      "Some ::i I ->i ⟨I⟩ii_option"
      "the ::i ⟨I⟩ii_option ->i I"
      "case_option ::i I ->i (Iv->iI) ->i ⟨Iv⟩ii_option ->i I"
      "rec_option ::i I ->i (Iv->iI) ->i ⟨Iv⟩ii_option ->i I"
      "(op = :: _ option => _) ::i ⟨I⟩ii_option ->i ⟨I⟩ii_option ->i i_bool"
      by auto
      *)

    lemma autoref_opt[autoref_rules]:
      "(None,None)∈⟨R⟩option_rel"
      "(Some,Some)∈R -> ⟨R⟩option_rel"
      "(case_option,case_option)∈Rr->(R -> Rr)->⟨R⟩option_rel -> Rr"
      "(rec_option,rec_option)∈Rr->(R -> Rr)->⟨R⟩option_rel -> Rr"
      by (auto split: option.split 
        simp: option_rel_def case_option_def[symmetric]
        dest: fun_relD)

    lemma autoref_the[autoref_rules]:
      assumes "SIDE_PRECOND (x≠None)"
      assumes "(x',x)∈⟨R⟩option_rel"
      shows "(the x', (OP the ::: ⟨R⟩option_rel -> R)$x) ∈ R"
      using assms
      by (auto simp: option_rel_def)

    lemma autoref_the_default[autoref_rules]:
      "(the_default, the_default) ∈ R -> ⟨R⟩option_rel -> R"
      by parametricity

    definition [simp]: "is_None a ≡ case a of None => True | _ => False"
    lemma pat_isNone[autoref_op_pat]:
      "a=None ≡ (OP is_None :::i ⟨I⟩ii_option ->i i_bool)$a"
      "None=a ≡ (OP is_None :::i ⟨I⟩ii_option ->i i_bool)$a"
      by (auto intro!: eq_reflection split: option.splits)
    lemma autoref_is_None[autoref_rules]: 
      "(is_None,is_None)∈⟨R⟩option_rel -> Id"
      by (auto split: option.splits)

    definition "option_eq eq v1 v2 ≡ 
      case (v1,v2) of 
        (None,None) => True
      | (Some x1, Some x2) => eq x1 x2
      | _ => False"

    lemma option_eq_autoref[autoref_rules (overloaded)]:
      "[|GEN_OP eq op = (R->R->Id)|] 
      ==> (option_eq eq,op =) ∈ ⟨R⟩option_rel -> ⟨R⟩option_rel -> Id"
      unfolding option_eq_def[abs_def]
      by (auto dest: fun_relD split: option.splits elim!: option_relE)

    lemma option_eq_expand[autoref_struct_expand]: 
      "op = = option_eq op="
      by (auto intro!: ext simp: option_eq_def split: option.splits)
end

  subsection "Sum-Types"
  consts i_sum :: "interface => interface => interface"
  lemmas [autoref_rel_intf] = REL_INTFI[of sum_rel i_sum]

context begin interpretation autoref_syn .
  (*lemma [autoref_itype]:
    "(op = :: _+_ => _) ::i ⟨Il,Ir⟩ii_sum ->i ⟨Il,Ir⟩ii_sum ->i i_bool"
    "Inl ::i Il ->i ⟨Il,Ir⟩ii_sum"
    "Inr ::i Ir ->i ⟨Il,Ir⟩ii_sum"
    "case_sum ::i (Il->iI) ->i (Ir ->i I) ->i ⟨Il,Ir⟩ii_sum ->i I"
    "old.rec_sum ::i (Il->iI) ->i (Ir ->i I) ->i ⟨Il,Ir⟩ii_sum ->i I"
    by auto*)

  lemma autoref_sum[autoref_rules]:
    "(Inl,Inl) ∈ Rl -> ⟨Rl,Rr⟩sum_rel"
    "(Inr,Inr) ∈ Rr -> ⟨Rl,Rr⟩sum_rel"
    "(case_sum,case_sum) ∈ (Rl -> R) -> (Rr -> R) -> ⟨Rl,Rr⟩sum_rel -> R"
    "(old.rec_sum,old.rec_sum) ∈ (Rl -> R) -> (Rr -> R) -> ⟨Rl,Rr⟩sum_rel -> R"
    by (fastforce split: sum.split dest: fun_relD 
      simp: rec_sum_is_case)+

  definition "sum_eq eql eqr s1 s2 ≡ 
    case (s1,s2) of 
      (Inl x1, Inl x2) => eql x1 x2
    | (Inr x1, Inr x2) => eqr x1 x2
    | _ => False"

  lemma sum_eq_autoref[autoref_rules (overloaded)]:
    "[|GEN_OP eql op = (Rl->Rl->Id); GEN_OP eqr op = (Rr->Rr->Id)|] 
    ==> (sum_eq eql eqr,op =) ∈ ⟨Rl,Rr⟩sum_rel -> ⟨Rl,Rr⟩sum_rel -> Id"
    unfolding sum_eq_def[abs_def]
    by (fastforce dest: fun_relD elim!: sum_relE)

  lemma sum_eq_expand[autoref_struct_expand]: "op = = sum_eq op= op="
    by (auto intro!: ext simp: sum_eq_def split: sum.splits)

  lemmas [autoref_rules] = is_Inl_param is_Inr_param

  lemma autoref_sum_Projl[autoref_rules]: 
    "[|SIDE_PRECOND (is_Inl s); (s',s)∈⟨Ra,Rb⟩sum_rel|] 
    ==> (Sum_Type.sum.projl s', (OP Sum_Type.sum.projl ::: ⟨Ra,Rb⟩sum_rel -> Ra)$s)∈Ra"
    by simp parametricity

  lemma autoref_sum_Projr[autoref_rules]: 
    "[|SIDE_PRECOND (is_Inr s); (s',s)∈⟨Ra,Rb⟩sum_rel|] 
    ==> (Sum_Type.sum.projr s', (OP Sum_Type.sum.projr ::: ⟨Ra,Rb⟩sum_rel -> Rb)$s)∈Rb"
    by simp parametricity

end

subsection "List"
  consts i_list :: "interface => interface"
  lemmas [autoref_rel_intf] = REL_INTFI[of list_rel i_list]

context begin interpretation autoref_syn .
  (*
  term nth
  lemma [autoref_itype]:
    "(op = :: _ list => _) ::i ⟨I⟩ii_list ->i ⟨I⟩ii_list ->i i_bool"
    "[] ::i ⟨I⟩ii_list"
    "op # ::i I ->i ⟨I⟩ii_list ->i ⟨I⟩ii_list"
    "op @ ::i ⟨I⟩ii_list ->i ⟨I⟩ii_list ->i ⟨I⟩ii_list"
    "case_list ::i Ir ->i (I->i⟨I⟩ii_list->iIr) ->i ⟨I⟩ii_list ->i Ir"
    "rec_list ::i Ir ->i (I->i⟨I⟩ii_list->iIr->iIr) ->i ⟨I⟩ii_list ->i Ir"
    "map ::i (I1->iI2) ->i ⟨I1⟩ii_list ->i ⟨I2⟩ii_list"
    "foldl ::i (Ia->iIb->iIa) ->i Ia ->i ⟨Ib⟩ii_list ->i Ia"
    "foldr ::i (Ia->iIb->iIb) ->i ⟨Ia⟩ii_list ->i Ib ->i Ib"
    "fold ::i (Ia->iIb->iIb) ->i ⟨Ia⟩ii_list ->i Ib ->i Ib"
    "take ::i i_nat ->i ⟨I⟩ii_list ->i ⟨I⟩ii_list"
    "drop ::i i_nat ->i ⟨I⟩ii_list ->i ⟨I⟩ii_list"
    "length ::i ⟨I⟩ii_list ->i i_nat"
    "nth ::i ⟨I⟩ii_list ->i i_nat ->i I"
    "hd ::i ⟨I⟩ii_list ->i I"
    "tl ::i ⟨I⟩ii_list ->i ⟨I⟩ii_list"
    "last ::i ⟨I⟩ii_list ->i I"
    "butlast ::i ⟨I⟩ii_list ->i ⟨I⟩ii_list"
    by auto
    *)

  lemma autoref_append[autoref_rules]: 
    "(append, append)∈⟨R⟩list_rel -> ⟨R⟩list_rel -> ⟨R⟩list_rel"
    by (auto simp: list_rel_def list_all2_appendI)

  lemma refine_list[autoref_rules]:
    "(Nil,Nil)∈⟨R⟩list_rel"
    "(Cons,Cons)∈R -> ⟨R⟩list_rel -> ⟨R⟩list_rel"
    "(case_list,case_list)∈Rr->(R->⟨R⟩list_rel->Rr)->⟨R⟩list_rel->Rr"
    apply (force dest: fun_relD split: list.split)+
    done

  lemma autoref_rec_list[autoref_rules]: "(rec_list,rec_list) 
    ∈ Ra -> (Rb -> ⟨Rb⟩list_rel -> Ra -> Ra) -> ⟨Rb⟩list_rel -> Ra"
  proof (intro fun_relI)
    case (goal1 a a' f f' l l')
    from goal1(3) show ?case
      using goal1(1,2)
      apply (induct arbitrary: a a')
      apply simp
      apply (fastforce dest: fun_relD)
      done
  qed

  lemma refine_map[autoref_rules]: 
    "(map,map)∈(R1->R2) -> ⟨R1⟩list_rel -> ⟨R2⟩list_rel"
    using [[autoref_sbias = -1]]
    unfolding map_rec[abs_def]
    by autoref

  lemma refine_fold[autoref_rules]: 
    "(fold,fold)∈(Re->Rs->Rs) -> ⟨Re⟩list_rel -> Rs -> Rs"
    "(foldl,foldl)∈(Rs->Re->Rs) -> Rs -> ⟨Re⟩list_rel -> Rs"
    "(foldr,foldr)∈(Re->Rs->Rs) -> ⟨Re⟩list_rel -> Rs -> Rs"
    unfolding List.fold_def List.foldr_def List.foldl_def
    by (autoref)+

  schematic_lemma autoref_take[autoref_rules]: "(take,take)∈(?R::(_×_) set)"
    unfolding take_def by autoref
  schematic_lemma autoref_drop[autoref_rules]: "(drop,drop)∈(?R::(_×_) set)"
    unfolding drop_def by autoref
  schematic_lemma autoref_length[autoref_rules]: 
    "(length,length)∈(?R::(_×_) set)"
    unfolding size_list_overloaded_def size_list_def 
    by (autoref)

  lemma autoref_nth[autoref_rules]: 
    assumes "(l,l')∈⟨R⟩list_rel"
    assumes "(i,i')∈Id"
    assumes "SIDE_PRECOND (i' < length l')"
    shows "(nth l i,(OP nth ::: ⟨R⟩list_rel -> Id -> R)$l'$i')∈R"
    unfolding ANNOT_def
    using assms
    apply (induct arbitrary: i i')
    apply simp
    apply (case_tac i')
    apply auto
    done

  fun list_eq :: "('a => 'a => bool) => 'a list => 'a list => bool" where
    "list_eq eq [] [] <-> True"
  | "list_eq eq (a#l) (a'#l') 
       <-> (if eq a a' then list_eq eq l l' else False)"
  | "list_eq _ _ _ <-> False"

  lemma autoref_list_eq_aux: "
    (list_eq,list_eq) ∈ 
      (R -> R -> Id) -> ⟨R⟩list_rel -> ⟨R⟩list_rel -> Id"
  proof (intro fun_relI)
    case (goal1 eq eq' l1 l1' l2 l2')
    thus ?case
      apply -
      apply (induct eq' l1' l2' arbitrary: l1 l2 rule: list_eq.induct)
      apply simp
      apply (case_tac l1)
      apply simp
      apply (case_tac l2)
      apply (simp)
      apply (auto dest: fun_relD) []
      apply (case_tac l1)
      apply simp
      apply simp
      apply (case_tac l2)
      apply simp
      apply simp
      done
  qed

  lemma list_eq_expand[autoref_struct_expand]: "(op =) = (list_eq op =)"
  proof (intro ext)
    fix l1 l2 :: "'a list"
    show "(l1 = l2) <-> list_eq op = l1 l2"
      apply (induct "op = :: 'a => _" l1 l2 rule: list_eq.induct)
      apply simp_all
      done
  qed

  lemma autoref_list_eq[autoref_rules (overloaded)]:
    "GEN_OP eq op = (R->R->Id) ==> (list_eq eq, op =) 
    ∈ ⟨R⟩list_rel -> ⟨R⟩list_rel -> Id"
    unfolding autoref_tag_defs
    apply (subst list_eq_expand)
    apply (parametricity add: autoref_list_eq_aux)
    done

  lemma autoref_hd[autoref_rules]:
    "[| SIDE_PRECOND (l'≠[]); (l,l') ∈ ⟨R⟩list_rel |] ==>
      (hd l,(OP hd ::: ⟨R⟩list_rel -> R)$l') ∈ R"
    apply (simp add: ANNOT_def)
    apply (cases l')
    apply simp
    apply (cases l)
    apply auto
    done

  lemma autoref_tl[autoref_rules]:
    "(tl,tl) ∈ ⟨R⟩list_rel -> ⟨R⟩list_rel"
    unfolding tl_def[abs_def]
    by autoref

  definition [simp]: "is_Nil a ≡ case a of [] => True | _ => False"

  lemma is_Nil_pat[autoref_op_pat]:
    "a=[] ≡ (OP is_Nil :::i ⟨I⟩ii_list ->i i_bool)$a"
    "[]=a ≡ (OP is_Nil :::i ⟨I⟩ii_list ->i i_bool)$a"
    by (auto intro!: eq_reflection split: list.splits)

  lemma autoref_is_Nil[param,autoref_rules]: 
    "(is_Nil,is_Nil)∈⟨R⟩list_rel -> bool_rel"
    by (auto split: list.splits)

  lemma conv_to_is_Nil: 
    "l=[] <-> is_Nil l"
    "[]=l <-> is_Nil l"
    unfolding is_Nil_def by (auto split: list.split)

  lemma autoref_butlast[param, autoref_rules]: 
    "(butlast,butlast) ∈ ⟨R⟩list_rel -> ⟨R⟩list_rel"
    unfolding butlast_def conv_to_is_Nil
    by parametricity

  definition [simp]: "op_list_singleton x ≡ [x]"
  lemma op_list_singleton_pat[autoref_op_pat]:
    "[x] ≡ (OP op_list_singleton :::i I ->i ⟨I⟩ii_list)$x" by simp
  lemma autoref_list_singleton[autoref_rules]: 
    "(λa. [a],op_list_singleton) ∈ R -> ⟨R⟩list_rel"
    by auto

  definition [simp]: "op_list_append_elem s x ≡ s@[x]"

  lemma pat_list_append_elem[autoref_op_pat]: 
    "s@[x] ≡ (OP op_list_append_elem :::i ⟨I⟩ii_list ->i I ->i ⟨I⟩ii_list)$s$x" 
    by (simp add: relAPP_def)

  lemma autoref_list_append_elem[autoref_rules]: 
    "(λs x. s@[x], op_list_append_elem) ∈ ⟨R⟩list_rel -> R -> ⟨R⟩list_rel"
    unfolding op_list_append_elem_def[abs_def] by parametricity


  declare param_rev[autoref_rules]

  declare param_all_interval_nat[autoref_rules]
  lemma [autoref_op_pat]: 
    "(∀i<u. P i) ≡ OP List.all_interval_nat P 0 u"
    "(∀i≤u. P i) ≡ OP List.all_interval_nat P 0 (Suc u)"
    "(∀i<u. l≤i --> P i) ≡ OP List.all_interval_nat P l u"
    "(∀i≤u. l≤i --> P i) ≡ OP List.all_interval_nat P l (Suc u)"
    by (auto intro!: eq_reflection simp: List.all_interval_nat_def)

end

subsection "Examples"

text {* Be careful to make the concrete type a schematic type variable.
  The default behaviour of @{text "schematic_lemma"} makes it a fixed variable,
  that will not unify with the infered term! *}
schematic_lemma 
  "(?f::?'c,[1,2,3]@[4::nat])∈?R"
  by autoref

schematic_lemma 
  "(?f::?'c,[1::nat,
    2,3,4,5,6,7,8,9,0,1,43,5,5,435,5,1,5,6,5,6,5,63,56
  ]
  )∈?R"
  apply (autoref)
  done

schematic_lemma 
  "(?f::?'c,[1,2,3] = [])∈?R"
  by autoref

text {*
  When specifying custom refinement rules on the fly, be careful with
  the type-inference between @{text "notes"} and @{text "shows"}. It's
  too easy to ,,decouple'' the type @{text "'a"} in the autoref-rule and
  the actual goal, as shown below!
*}

schematic_lemma 
  notes [autoref_rules] = IdI[where 'a="'a"]
  notes [autoref_itype] = itypeI[where 't="'a::numeral" and I=i_std]
  shows "(?f::?'c, hd [a,b,c::'a::numeral])∈?R"
  txt {* The autoref-rule is bound with type @{text "'a::typ"}, while
    the goal statement has @{text "'a::numeral"}! *}
  apply (autoref (keep_goal))
  txt {* We get an unsolved goal, as it finds no rule to translate 
    @{text "a"} *}
  oops

text {* Here comes the correct version. Note the duplicate sort annotation
  of type @{text "'a"}: *}
schematic_lemma 
  notes [autoref_rules_raw] = IdI[where 'a="'a::numeral"]
  notes [autoref_itype] = itypeI[where 't="'a::numeral" and I=i_std]
  shows "(?f::?'c, hd [a,b,c::'a::numeral])∈?R"
  by (autoref)

text {* Special cases of equality: Note that we do not require equality
  on the element type! *}
schematic_lemma 
  (*notes [autoref_itype] = itypeI[of a "⟨I⟩ii_option"]*)
  assumes [autoref_rules]: "(ai,a)∈⟨R⟩option_rel"
  shows "(?f::?'c, a = None)∈?R"
  apply (autoref (keep_goal))
  done


schematic_lemma 
  (*notes [autoref_itype] = itypeI[of a "⟨I⟩ii_list"]*)
  assumes [autoref_rules]: "(ai,a)∈⟨R⟩list_rel"  
  shows "(?f::?'c, [] = a)∈?R"
  apply (autoref (keep_goal))
  done

schematic_lemma 
  shows "(?f::?'c, [1,2] = [2,3::nat])∈?R"
  apply (autoref (keep_goal))
  done


end