(* ========================================================================= *)
(* Some miscellaneous OCaml system hacking before we get started.            *)
(*                                                                           *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

Gc.set { (Gc.get()) with Gc.stack_limit = 16777216 };;

(* ------------------------------------------------------------------------- *)
(* Make sure user interrupts generate an exception, not kill the process.    *)
(* ------------------------------------------------------------------------- *)

Sys.catch_break true;;

(* ------------------------------------------------------------------------- *)
(* Set up a quotation expander for the `...` quotes.                         *)
(* ------------------------------------------------------------------------- *)

(* ------------------------------------------------------------------------- *)
(* Modify the lexical analysis of uppercase identifiers.                     *)
(* ------------------------------------------------------------------------- *)

fun set_jrh_lexer -> set_jrh_lexer;;

(* ------------------------------------------------------------------------- *)
(* Load in the bignum library and set up printing in the toplevel.           *)
(* ------------------------------------------------------------------------- *)

open Num;;

let print_num n =
  Format.open_hbox();
  Format.print_string(string_of_num n);
  Format.close_box();;

(* ========================================================================= *)
(* Convenient library functions.                                             *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let fail() = failwith "";;

(* ------------------------------------------------------------------------- *)
(* Combinators.                                                              *)
(* ------------------------------------------------------------------------- *)

let curry f x y = f(x,y);;

let uncurry f(x,y) = f x y;;

let I x = x;;

let K x y = x;;

let C f x y = f y x;;

let W f x = f x x;;

let (o) = fun f g x -> f(g x);;

let (F_F) = fun f g (x,y) -> (f x,g y);;

(* ------------------------------------------------------------------------- *)
(* List basics.                                                              *)
(* ------------------------------------------------------------------------- *)

let hd l =
  match l with
   h::t -> h
  | _ -> failwith "hd";;

let tl l =
  match l with
   h::t -> t
  | _ -> failwith "tl";;

let map f =
  let rec mapf l =
    match l with
      [] -> []
    | (x::t) -> let y = f x in y::(mapf t) in
  mapf;;

let rec last l =
  match l with
    [x] -> x
  | (h::t) -> last t
  | [] -> failwith "last";;

let rec butlast l =
  match l with
    [_] -> []
  | (h::t) -> h::(butlast t)
  | [] -> failwith "butlast";;

let rec el n l =
  if n = 0 then hd l else el (n - 1) (tl l);;

let rev =
  let rec rev_append acc l =
    match l with
      [] -> acc
    | h::t -> rev_append (h::acc) t in
  fun l -> rev_append [] l;;

let rec map2 f l1 l2 =
  match (l1,l2) with
    [],[] -> []
  | (h1::t1),(h2::t2) -> let h = f h1 h2 in h::(map2 f t1 t2)
  | _ -> failwith "map2: length mismatch";;

(* ------------------------------------------------------------------------- *)
(* Attempting function or predicate applications.                            *)
(* ------------------------------------------------------------------------- *)

let can f x = try (f x; true) with Failure _ -> false;;

let check p x = if p x then x else failwith "check";;

(* ------------------------------------------------------------------------- *)
(* Repetition of a function.                                                 *)
(* ------------------------------------------------------------------------- *)

let rec funpow n f x =
  if n < 1 then x else funpow (n-1) f (f x);;

let rec repeat f x =
  try let y = f x in repeat f y with Failure _ -> x;;

(* ------------------------------------------------------------------------- *)
(* To avoid consing in various situations, we propagate this exception.      *)
(* I should probably eliminate this and use pointer EQ tests instead.        *)
(* ------------------------------------------------------------------------- *)

exception Unchanged;;

(* ------------------------------------------------------------------------- *)
(* Various versions of list iteration.                                       *)
(* ------------------------------------------------------------------------- *)

let rec itlist f l b =
  match l with
    [] -> b
  | (h::t) -> f h (itlist f t b);;

let rec rev_itlist f l b =
  match l with
    [] -> b
  | (h::t) -> rev_itlist f t (f h b);;

let rec end_itlist f l =
  match l with
        []     -> failwith "end_itlist"
      | [x]    -> x
      | (h::t) -> f h (end_itlist f t);;

let rec itlist2 f l1 l2 b =
  match (l1,l2) with
    ([],[]) -> b
  | (h1::t1,h2::t2) -> f h1 h2 (itlist2 f t1 t2 b)
  | _ -> failwith "itlist2";;

let rec rev_itlist2 f l1 l2 b =
   match (l1,l2) with
     ([],[]) -> b
   | (h1::t1,h2::t2) -> rev_itlist2 f t1 t2 (f h1 h2 b)
      | _ -> failwith "rev_itlist2";;

(* ------------------------------------------------------------------------- *)
(* Iterative splitting (list) and stripping (tree) via destructor.           *)
(* ------------------------------------------------------------------------- *)

let rec splitlist dest x =
  try let l,r = dest x in
      let ls,res = splitlist dest r in
      (l::ls,res)
  with Failure _ -> ([],x);;

let rev_splitlist dest =
  let rec rsplist ls x =
    try let l,r = dest x in
        rsplist (r::ls) l
    with Failure _ -> (x,ls) in
  fun x -> rsplist [] x;;

let striplist dest =
  let rec strip x acc =
    try let l,r = dest x in
        strip l (strip r acc)
    with Failure _ -> x::acc in
  fun x -> strip x [];;

(* ------------------------------------------------------------------------- *)
(* Apply a destructor as many times as elements in list.                     *)
(* ------------------------------------------------------------------------- *)

let rec nsplit dest clist x =
  if clist = [] then [],x else
  let l,r = dest x in
  let ll,y = nsplit dest (tl clist) r in
  l::ll,y;;

(* ------------------------------------------------------------------------- *)
(* Replication and sequences.                                                *)
(* ------------------------------------------------------------------------- *)

let rec replicate x n =
    if n < 1 then []
    else x::(replicate x (n - 1));;

let rec (--) = fun m n -> if m > n then [] else m::((m + 1) -- n);;

(* ------------------------------------------------------------------------- *)
(* Various useful list operations.                                           *)
(* ------------------------------------------------------------------------- *)

let rec forall p l =
  match l with
    [] -> true
  | h::t -> p(h) & forall p t;;

let rec forall2 p l1 l2 =
  match (l1,l2) with
    [],[] -> true
  | (h1::t1,h2::t2) -> p h1 h2 & forall2 p t1 t2
  | _ -> false;;

let rec exists p l =
  match l with
    [] -> false
  | h::t -> p(h) or exists p t;;

let length =
  let rec len k l =
    if l = [] then k else len (k + 1) (tl l) in
  fun l -> len 0 l;;

let rec filter p l =
  match l with
    [] -> l
  | h::t -> let t' = filter p t in
            if p(h) then if t'==t then l else h::t'
            else t';;

let rec partition p l =
  match l with
    [] -> [],l
  | h::t -> let yes,no = partition p t in
            if p(h) then (if yes == t then l,[] else h::yes,no)
            else (if no == t then [],l else yes,h::no);;

let rec mapfilter f l =
  match l with
    [] -> []
  | (h::t) -> let rest = mapfilter f t in
              try (f h)::rest with Failure _ -> rest;;

let rec find p l =
  match l with
      [] -> failwith "find"
    | (h::t) -> if p(h) then h else find p t;;

let rec tryfind f l =
  match l with
      [] -> failwith "tryfind"
    | (h::t) -> try f h with Failure _ -> tryfind f t;;

let flat l = itlist (@) l [];;

let rec remove p l =
  match l with
    [] -> failwith "remove"
  | (h::t) -> if p(h) then h,t else
              let y,n = remove p t in y,h::n;;

let rec chop_list n l =
  if n = 0 then [],l else
  try let m,l' = chop_list (n-1) (tl l) in (hd l)::m,l'
  with Failure _ -> failwith "chop_list";;

let index x =
  let rec ind n l =
    match l with
      [] -> failwith "index"
    | (h::t) -> if Pervasives.compare x h = 0 then n else ind (n + 1) t in
  ind 0;;

(* ------------------------------------------------------------------------- *)
(* "Set" operations on lists.                                                *)
(* ------------------------------------------------------------------------- *)

let rec mem x lis =
  match lis with
    [] -> false
  | (h::t) -> Pervasives.compare x h = 0 or mem x t;;

let insert x l =
  if mem x l then l else x::l;;

let union l1 l2 = itlist insert l1 l2;;

let unions l = itlist union l [];;

let intersect l1 l2 = filter (fun x -> mem x l2) l1;;

let subtract l1 l2 = filter (fun x -> not (mem x l2)) l1;;

let subset l1 l2 = forall (fun t -> mem t l2) l1;;

let set_eq l1 l2 = subset l1 l2 & subset l2 l1;;

(* ------------------------------------------------------------------------- *)
(* Association lists.                                                        *)
(* ------------------------------------------------------------------------- *)

let rec assoc a l =
  match l with
    (x,y)::t -> if Pervasives.compare x a = 0 then y else assoc a t
  | [] -> failwith "find";;

let rec rev_assoc a l =
  match l with
    (x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assoc a t
  | [] -> failwith "find";;

(* ------------------------------------------------------------------------- *)
(* Zipping, unzipping etc.                                                   *)
(* ------------------------------------------------------------------------- *)

let rec zip l1 l2 =
  match (l1,l2) with
        ([],[]) -> []
      | (h1::t1,h2::t2) -> (h1,h2)::(zip t1 t2)
      | _ -> failwith "zip";;

let rec unzip =
  function [] -> [],[]
         | ((a,b)::rest) -> let alist,blist = unzip rest in
                            (a::alist,b::blist);;

(* ------------------------------------------------------------------------- *)
(* Sharing out a list according to pattern in list-of-lists.                 *)
(* ------------------------------------------------------------------------- *)

let rec shareout pat all =
  if pat = [] then [] else
  let l,r = chop_list (length (hd pat)) all in
  l::(shareout (tl pat) r);;

(* ------------------------------------------------------------------------- *)
(* Iterating functions over lists.                                           *)
(* ------------------------------------------------------------------------- *)

let rec do_list f l =
  match l with
    [] -> ()
  | (h::t) -> (f h; do_list f t);;

(* ------------------------------------------------------------------------- *)
(* Sorting.                                                                  *)
(* ------------------------------------------------------------------------- *)

let rec sort cmp lis =
  match lis with
    [] -> []
  | piv::rest ->
      let r,l = partition (cmp piv) rest in
      (sort cmp l) @ (piv::(sort cmp r));;

(* ------------------------------------------------------------------------- *)
(* Removing adjacent (NB!) equal elements from list.                         *)
(* ------------------------------------------------------------------------- *)

let rec uniq l =
  match l with
    x::(y::_ as t) -> let t' = uniq t in
                      if Pervasives.compare x y = 0 then t' else
                      if t'==t then l else x::t'
 | _ -> l;;

(* ------------------------------------------------------------------------- *)
(* Convert list into set by eliminating duplicates.                          *)
(* ------------------------------------------------------------------------- *)

let setify s = uniq (sort (fun x y -> Pervasives.compare x y <= 0) s);;

(* ------------------------------------------------------------------------- *)
(* String operations (surely there is a better way...)                       *)
(* ------------------------------------------------------------------------- *)

let implode l = itlist (^) l "";;

let explode s =
  let rec exap n l =
      if n < 0 then l else
      exap (n - 1) ((String.sub s n 1)::l) in
  exap (String.length s - 1) [];;

(* ------------------------------------------------------------------------- *)
(* Greatest common divisor.                                                  *)
(* ------------------------------------------------------------------------- *)

let gcd =
  let rec gxd x y =
    if y = 0 then x else gxd y (x mod y) in
  fun x y -> let x' = abs x and y' = abs y in
              if x' < y' then gxd y' x' else gxd x' y';;

(* ------------------------------------------------------------------------- *)
(* Some useful functions on "num" type.                                      *)
(* ------------------------------------------------------------------------- *)

let num_0 = Int 0
and num_1 = Int 1
and num_2 = Int 2
and num_10 = Int 10;;

let pow2 n = power_num num_2 (Int n);;
let pow10 n = power_num num_10 (Int n);;

let numdom r =
  let r' = Ratio.normalize_ratio (ratio_of_num r) in
  num_of_big_int(Ratio.numerator_ratio r'),
  num_of_big_int(Ratio.denominator_ratio r');;

let numerator = fst o numdom
and denominator = snd o numdom;;

let gcd_num n1 n2 =
  num_of_big_int(Big_int.gcd_big_int (big_int_of_num n1) (big_int_of_num n2));;

let lcm_num x y =
  if x =/ num_0 & y =/ num_0 then num_0
  else abs_num((x */ y) // gcd_num x y);;

(* ------------------------------------------------------------------------- *)
(* All pairs arising from applying a function over two lists.                *)
(* ------------------------------------------------------------------------- *)

let rec allpairs f l1 l2 =
  match l1 with
   h1::t1 ->  itlist (fun x a -> f h1 x :: a) l2 (allpairs f t1 l2)
  | [] -> [];;

(* ------------------------------------------------------------------------- *)
(* Issue a report with a newline.                                            *)
(* ------------------------------------------------------------------------- *)

let report s =
  Format.print_string s; Format.print_newline();;

(* ------------------------------------------------------------------------- *)
(* Convenient function for issuing a warning.                                *)
(* ------------------------------------------------------------------------- *)

let warn cond s =
  if cond then report ("Warning: "^s) else ();;

(* ------------------------------------------------------------------------- *)
(* Flags to switch on verbose mode.                                          *)
(* ------------------------------------------------------------------------- *)

let verbose = ref true;;
let report_timing = ref true;;

(* ------------------------------------------------------------------------- *)
(* Switchable version of "report".                                           *)
(* ------------------------------------------------------------------------- *)

let remark s =
  if !verbose then report s else ();;

(* ------------------------------------------------------------------------- *)
(* Time a function.                                                          *)
(* ------------------------------------------------------------------------- *)

let time f x =
  if not (!report_timing) then f x else
  let start_time = Sys.time() in
  try let result = f x in
      let finish_time = Sys.time() in
      report("CPU time (user): "^(string_of_float(finish_time -. start_time)));
      result
  with e ->
      let finish_time = Sys.time() in
      Format.print_string("Failed after (user) CPU time of "^
                          (string_of_float(finish_time -. start_time))^": ");
      raise e;;

(* ------------------------------------------------------------------------- *)
(* Versions of assoc and rev_assoc with default rather than failure.         *)
(* ------------------------------------------------------------------------- *)

let rec assocd a l d =
  match l with
    [] -> d
  | (x,y)::t -> if Pervasives.compare x a = 0 then y else assocd a t d;;

let rec rev_assocd a l d =
  match l with
    [] -> d
  | (x,y)::t -> if Pervasives.compare y a = 0 then x else rev_assocd a t d;;

(* ------------------------------------------------------------------------- *)
(* Version of map that avoids rebuilding unchanged subterms.                 *)
(* ------------------------------------------------------------------------- *)

let rec qmap f l =
  match l with
    h::t -> let h' = f h and t' = qmap f t in
            if h' == h & t' == t then l else h'::t'
  | _ -> l;;

(* ------------------------------------------------------------------------- *)
(* Merging and bottom-up mergesort.                                          *)
(* ------------------------------------------------------------------------- *)

let rec merge ord l1 l2 =
  match l1 with
    [] -> l2
  | h1::t1 -> match l2 with
                [] -> l1
              | h2::t2 -> if ord h1 h2 then h1::(merge ord t1 l2)
                          else h2::(merge ord l1 t2);;

let mergesort ord =
  let rec mergepairs l1 l2 =
    match (l1,l2) with
        ([s],[]) -> s
      | (l,[]) -> mergepairs [] l
      | (l,[s1]) -> mergepairs (s1::l) []
      | (l,(s1::s2::ss)) -> mergepairs ((merge ord s1 s2)::l) ss in
  fun l -> if l = [] then [] else mergepairs [] (map (fun x -> [x]) l);;

(* ------------------------------------------------------------------------- *)
(* Common measure predicates to use with "sort".                             *)
(* ------------------------------------------------------------------------- *)

let increasing f x y = Pervasives.compare (f x) (f y) < 0;;

let decreasing f x y = Pervasives.compare (f x) (f y) > 0;;

(* ------------------------------------------------------------------------- *)
(* Polymorphic finite partial functions via Patricia trees.                  *)
(*                                                                           *)
(* The point of this strange representation is that it is canonical (equal   *)
(* functions have the same encoding) yet reasonably efficient on average.    *)
(*                                                                           *)
(* Idea due to Diego Olivier Fernandez Pons (OCaml list, 2003/11/10).        *)
(* ------------------------------------------------------------------------- *)

type ('a,'b)func =
   Empty
 | Leaf of int * ('a*'b)list
 | Branch of int * int * ('a,'b)func * ('a,'b)func;;

(* ------------------------------------------------------------------------- *)
(* Undefined function.                                                       *)
(* ------------------------------------------------------------------------- *)

let undefined = Empty;;

(* ------------------------------------------------------------------------- *)
(* In case of equality comparison worries, better use this.                  *)
(* ------------------------------------------------------------------------- *)

let is_undefined f =
  match f with
    Empty -> true
  | _ -> false;;

(* ------------------------------------------------------------------------- *)
(* Operation analagous to "map" for lists.                                   *)
(* ------------------------------------------------------------------------- *)

let mapf =
  let rec map_list f l =
    match l with
      [] -> []
    | (x,y)::t -> (x,f(y))::(map_list f t) in
  let rec mapf f t =
    match t with
      Empty -> Empty
    | Leaf(h,l) -> Leaf(h,map_list f l)
    | Branch(p,b,l,r) -> Branch(p,b,mapf f l,mapf f r) in
  mapf;;

(* ------------------------------------------------------------------------- *)
(* Operations analogous to "fold" for lists.                                 *)
(* ------------------------------------------------------------------------- *)

let foldl =
  let rec foldl_list f a l =
    match l with
      [] -> a
    | (x,y)::t -> foldl_list f (f a x y) t in
  let rec foldl f a t =
    match t with
      Empty -> a
    | Leaf(h,l) -> foldl_list f a l
    | Branch(p,b,l,r) -> foldl f (foldl f a l) r in
  foldl;;

let foldr =
  let rec foldr_list f l a =
    match l with
      [] -> a
    | (x,y)::t -> f x y (foldr_list f t a) in
  let rec foldr f t a =
    match t with
      Empty -> a
    | Leaf(h,l) -> foldr_list f l a
    | Branch(p,b,l,r) -> foldr f l (foldr f r a) in
  foldr;;

(* ------------------------------------------------------------------------- *)
(* Mapping to sorted-list representation of the graph, domain and range.     *)
(* ------------------------------------------------------------------------- *)

let graph f = setify (foldl (fun a x y -> (x,y)::a) [] f);;

let dom f = setify(foldl (fun a x y -> x::a) [] f);;

let ran f = setify(foldl (fun a x y -> y::a) [] f);;

(* ------------------------------------------------------------------------- *)
(* Application.                                                              *)
(* ------------------------------------------------------------------------- *)

let applyd =
  let rec apply_listd l d x =
    match l with
      (a,b)::t -> let c = Pervasives.compare x a in
                  if c = 0 then b else if c > 0 then apply_listd t d x else d x
    | [] -> d x in
  fun f d x ->
    let k = Hashtbl.hash x in
    let rec look t =
      match t with
        Leaf(h,l) when h = k -> apply_listd l d x
      | Branch(p,b,l,r) when (k lxor p) land (b - 1) = 0
                -> look (if k land b = 0 then l else r)
      | _ -> d x in
    look f;;

let apply f = applyd f (fun x -> failwith "apply");;

let tryapplyd f a d = applyd f (fun x -> d) a;;

let defined f x = try apply f x; true with Failure _ -> false;;

(* ------------------------------------------------------------------------- *)
(* Undefinition.                                                             *)
(* ------------------------------------------------------------------------- *)

let undefine =
  let rec undefine_list x l =
    match l with
      (a,b as ab)::t ->
          let c = Pervasives.compare x a in
          if c = 0 then t
          else if c < 0 then l else
          let t' = undefine_list x t in
          if t' == t then l else ab::t'
    | [] -> [] in
  fun x ->
    let k = Hashtbl.hash x in
    let rec und t =
      match t with
        Leaf(h,l) when h = k ->
          let l' = undefine_list x l in
          if l' == l then t
          else if l' = [] then Empty
          else Leaf(h,l')
      | Branch(p,b,l,r) when k land (b - 1) = p ->
          if k land b = 0 then
            let l' = und l in
            if l' == l then t
            else (match l' with Empty -> r | _ -> Branch(p,b,l',r))
          else
            let r' = und r in
            if r' == r then t
            else (match r' with Empty -> l | _ -> Branch(p,b,l,r'))
      | _ -> t in
    und;;

(* ------------------------------------------------------------------------- *)
(* Redefinition and combination.                                             *)
(* ------------------------------------------------------------------------- *)

let (|->),combine =
  let newbranch p1 t1 p2 t2 =
    let zp = p1 lxor p2 in
    let b = zp land (-zp) in
    let p = p1 land (b - 1) in
    if p1 land b = 0 then Branch(p,b,t1,t2)
    else Branch(p,b,t2,t1) in
  let rec define_list (x,y as xy) l =
    match l with
      (a,b as ab)::t ->
          let c = Pervasives.compare x a in
          if c = 0 then xy::t
          else if c < 0 then xy::l
          else ab::(define_list xy t)
    | [] -> [xy]
  and combine_list op z l1 l2 =
    match (l1,l2) with
      [],_ -> l2
    | _,[] -> l1
    | ((x1,y1 as xy1)::t1,(x2,y2 as xy2)::t2) ->
          let c = Pervasives.compare x1 x2 in
          if c < 0 then xy1::(combine_list op z t1 l2)
          else if c > 0 then xy2::(combine_list op z l1 t2) else
          let y = op y1 y2 and l = combine_list op z t1 t2 in
          if z(y) then l else (x1,y)::l in
  let (|->) x y =
    let k = Hashtbl.hash x in
    let rec upd t =
      match t with
        Empty -> Leaf (k,[x,y])
      | Leaf(h,l) ->
           if h = k then Leaf(h,define_list (x,y) l)
           else newbranch h t k (Leaf(k,[x,y]))
      | Branch(p,b,l,r) ->
          if k land (b - 1) <> p then newbranch p t k (Leaf(k,[x,y]))
          else if k land b = 0 then Branch(p,b,upd l,r)
          else Branch(p,b,l,upd r) in
    upd in
  let rec combine op z t1 t2 =
    match (t1,t2) with
      Empty,_ -> t2
    | _,Empty -> t1
    | Leaf(h1,l1),Leaf(h2,l2) ->
          if h1 = h2 then
            let l = combine_list op z l1 l2 in
            if l = [] then Empty else Leaf(h1,l)
          else newbranch h1 t1 h2 t2
    | (Leaf(k,lis) as lf),(Branch(p,b,l,r) as br) ->
          if k land (b - 1) = p then
            if k land b = 0 then
              (match combine op z lf l with
                 Empty -> r | l' -> Branch(p,b,l',r))
            else
              (match combine op z lf r with
                 Empty -> l | r' -> Branch(p,b,l,r'))
          else
            newbranch k lf p br
    | (Branch(p,b,l,r) as br),(Leaf(k,lis) as lf) ->
          if k land (b - 1) = p then
            if k land b = 0 then
              (match combine op z l lf with
                Empty -> r | l' -> Branch(p,b,l',r))
            else
              (match combine op z r lf with
                 Empty -> l | r' -> Branch(p,b,l,r'))
          else
            newbranch p br k lf
    | Branch(p1,b1,l1,r1),Branch(p2,b2,l2,r2) ->
          if b1 < b2 then
            if p2 land (b1 - 1) <> p1 then newbranch p1 t1 p2 t2
            else if p2 land b1 = 0 then
              (match combine op z l1 t2 with
                 Empty -> r1 | l -> Branch(p1,b1,l,r1))
            else
              (match combine op z r1 t2 with
                 Empty -> l1 | r -> Branch(p1,b1,l1,r))
          else if b2 < b1 then
            if p1 land (b2 - 1) <> p2 then newbranch p1 t1 p2 t2
            else if p1 land b2 = 0 then
              (match combine op z t1 l2 with
                 Empty -> r2 | l -> Branch(p2,b2,l,r2))
            else
              (match combine op z t1 r2 with
                 Empty -> l2 | r -> Branch(p2,b2,l2,r))
          else if p1 = p2 then
           (match (combine op z l1 l2,combine op z r1 r2) with
              (Empty,r) -> r | (l,Empty) -> l | (l,r) -> Branch(p1,b1,l,r))
          else
            newbranch p1 t1 p2 t2 in
  (|->),combine;;

(* ------------------------------------------------------------------------- *)
(* Special case of point function.                                           *)
(* ------------------------------------------------------------------------- *)

let (|=>) = fun x y -> (x |-> y) undefined;;

(* ------------------------------------------------------------------------- *)
(* Grab an arbitrary element.                                                *)
(* ------------------------------------------------------------------------- *)

let rec choose t =
  match t with
    Empty -> failwith "choose: completely undefined function"
  | Leaf(h,l) -> hd l
  | Branch(b,p,t1,t2) -> choose t1;;

(* ------------------------------------------------------------------------- *)
(* Install a trivial printer for the general polymorphic case.               *)
(* ------------------------------------------------------------------------- *)

let print_fpf (f:('a,'b)func) = Format.print_string "<func>";;


(* ------------------------------------------------------------------------- *)
(* Set operations parametrized by equality (from Steven Obua).               *)
(* ------------------------------------------------------------------------- *)

let rec mem' eq =
  let rec mem x lis =
    match lis with
      [] -> false
    | (h::t) -> eq x h or mem x t
  in mem;;

let insert' eq x l =
  if mem' eq x l then l else x::l;;

let union' eq l1 l2 = itlist (insert' eq) l1 l2;;

let unions' eq l = itlist (union' eq) l [];;

let subtract' eq l1 l2 = filter (fun x -> not (mem' eq x l2)) l1;;

(* ------------------------------------------------------------------------- *)
(* Accepts decimal, hex or binary numeral, using C notation 0x... for hex    *)
(* and analogous 0b... for binary.                                           *)
(* ------------------------------------------------------------------------- *)

let num_of_string =
  let values =
   ["0",0; "1",1; "2",2; "3",3; "4",4;
    "5",5; "6",6; "7",7; "8",8; "9",9;
    "a",10; "A",10; "b",11; "B",11;
    "c",12; "C",12; "d",13; "D",13;
    "e",14; "E",14; "f",15; "F",15] in
  let valof b s =
    let v = Int(assoc s values) in
    if v </ b then v else failwith "num_of_string: invalid digit for base"
  and two = num_2 and ten = num_10 and sixteen = Int 16 in
  let rec num_of_stringlist b l =
    match l with
      [] -> failwith "num_of_string: no digits after base indicator"
    | [h] -> valof b h
    | h::t -> valof b h +/ b */ num_of_stringlist b t in
  fun s ->
    match explode(s) with
        [] -> failwith "num_of_string: no digits"
      | "0"::"x"::hexdigits -> num_of_stringlist sixteen (rev hexdigits)
      | "0"::"b"::bindigits -> num_of_stringlist two (rev bindigits)
      | decdigits -> num_of_stringlist ten (rev decdigits);;

(* ------------------------------------------------------------------------- *)
(* Convenient conversion between files and (lists of) strings.               *)
(* ------------------------------------------------------------------------- *)

let strings_of_file filename =
  let fd = try Pervasives.open_in filename
           with Sys_error _ ->
             failwith("strings_of_file: can't open "^filename) in
  let rec suck_lines acc =
    try let l = Pervasives.input_line fd in
        suck_lines (l::acc)
    with End_of_file -> rev acc in
  let data = suck_lines [] in
  (Pervasives.close_in fd; data);;

let string_of_file filename =
  end_itlist (fun s t -> s^"\n"^t) (strings_of_file filename);;

let file_of_string filename s =
  let fd = Pervasives.open_out filename in
  output_string fd s; close_out fd;;
(* ========================================================================= *)
(* Complete HOL kernel of types, terms and theorems.                         *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

module type Hol_kernel =
  sig
      type hol_type = private
        Tyvar of string
      | Tyapp of string *  hol_type list

      type term = private
        Var of string * hol_type
      | Const of string * hol_type
      | Comb of term * term
      | Abs of term * term

      type thm

      val types: unit -> (string * int)list
      val get_type_arity : string -> int
      val new_type : (string * int) -> unit
      val mk_type: (string * hol_type list) -> hol_type
      val mk_vartype : string -> hol_type
      val dest_type : hol_type -> (string * hol_type list)
      val dest_vartype : hol_type -> string
      val is_type : hol_type -> bool
      val is_vartype : hol_type -> bool
      val tyvars : hol_type -> hol_type list
      val type_subst : (hol_type * hol_type)list -> hol_type -> hol_type
      val bool_ty : hol_type
      val aty : hol_type

      val constants : unit -> (string * hol_type) list
      val get_const_type : string -> hol_type
      val new_constant : string * hol_type -> unit
      val type_of : term -> hol_type
      val alphaorder : term -> term -> int
      val is_var : term -> bool
      val is_const : term -> bool
      val is_abs : term -> bool
      val is_comb : term -> bool
      val mk_var : string * hol_type -> term
      val mk_const : string * (hol_type * hol_type) list -> term
      val mk_abs : term * term -> term
      val mk_comb : term * term -> term
      val dest_var : term -> string * hol_type
      val dest_const : term -> string * hol_type
      val dest_comb : term -> term * term
      val dest_abs : term -> term * term
      val frees : term -> term list
      val freesl : term list -> term list
      val freesin : term list -> term -> bool
      val vfree_in : term -> term -> bool
      val type_vars_in_term : term -> hol_type list
      val variant : term list -> term -> term
      val vsubst : (term * term) list -> term -> term
      val inst : (hol_type * hol_type) list -> term -> term
      val rand: term -> term
      val rator: term -> term
      val dest_eq: term -> term * term

      val dest_thm : thm -> term list * term
      val hyp : thm -> term list
      val concl : thm -> term
      val REFL : term -> thm
      val TRANS : thm -> thm -> thm
      val MK_COMB : thm * thm -> thm
      val ABS : term -> thm -> thm
      val BETA : term -> thm
      val ASSUME : term -> thm
      val EQ_MP : thm -> thm -> thm
      val DEDUCT_ANTISYM_RULE : thm -> thm -> thm
      val INST_TYPE : (hol_type * hol_type) list -> thm -> thm
      val INST : (term * term) list -> thm -> thm
      val axioms : unit -> thm list
      val new_axiom : term -> thm
      val definitions : unit -> thm list
      val new_basic_definition : term -> thm
      val new_basic_type_definition :
              string -> string * string -> thm -> thm * thm
end;;

(* ------------------------------------------------------------------------- *)
(* This is the implementation of those primitives.                           *)
(* ------------------------------------------------------------------------- *)

module Hol : Hol_kernel = struct

  type hol_type = Tyvar of string
                | Tyapp of string *  hol_type list

  type term = Var of string * hol_type
            | Const of string * hol_type
            | Comb of term * term
            | Abs of term * term

  type thm = Sequent of (term list * term)

(* ------------------------------------------------------------------------- *)
(* List of current type constants with their arities.                        *)
(*                                                                           *)
(* Initially we just have the boolean type and the function space            *)
(* constructor. Later on we add as primitive the type of individuals.        *)
(* All other new types result from definitional extension.                   *)
(* ------------------------------------------------------------------------- *)

  let the_type_constants = ref ["bool",0; "fun",2]

(* ------------------------------------------------------------------------- *)
(* Return all the defined types.                                             *)
(* ------------------------------------------------------------------------- *)

  let types() = !the_type_constants

(* ------------------------------------------------------------------------- *)
(* Lookup function for type constants. Returns arity if it succeeds.         *)
(* ------------------------------------------------------------------------- *)

  let get_type_arity s = assoc s (!the_type_constants)

(* ------------------------------------------------------------------------- *)
(* Declare a new type.                                                       *)
(* ------------------------------------------------------------------------- *)

  let new_type(name,arity) =
    if can get_type_arity name then
      failwith ("new_type: type "^name^" has already been declared")
    else the_type_constants := (name,arity)::(!the_type_constants)

(* ------------------------------------------------------------------------- *)
(* Basic type constructors.                                                  *)
(* ------------------------------------------------------------------------- *)

  let mk_type(tyop,args) =
    let arity = try get_type_arity tyop with Failure _ ->
      failwith ("mk_type: type "^tyop^" has not been defined") in
    if arity = length args then
      Tyapp(tyop,args)
    else failwith ("mk_type: wrong number of arguments to "^tyop)

  let mk_vartype v = Tyvar(v)

(* ------------------------------------------------------------------------- *)
(* Basic type destructors.                                                   *)
(* ------------------------------------------------------------------------- *)

  let dest_type =
    function
        (Tyapp (s,ty)) -> s,ty
      | (Tyvar _) -> failwith "dest_type: type variable not a constructor"

  let dest_vartype =
    function
        (Tyapp(_,_)) -> failwith "dest_vartype: type constructor not a variable"
      | (Tyvar s) -> s

(* ------------------------------------------------------------------------- *)
(* Basic type discriminators.                                                *)
(* ------------------------------------------------------------------------- *)

  let is_type = can dest_type

  let is_vartype = can dest_vartype

(* ------------------------------------------------------------------------- *)
(* Return the type variables in a type and in a list of types.               *)
(* ------------------------------------------------------------------------- *)

  let rec tyvars =
      function
          (Tyapp(_,args)) -> itlist (union o tyvars) args []
        | (Tyvar v as tv) -> [tv]

(* ------------------------------------------------------------------------- *)
(* Substitute types for type variables.                                      *)
(*                                                                           *)
(* NB: non-variables in subst list are just ignored (a check would be        *)
(* repeated many times), as are repetitions (first possibility is taken).    *)
(* ------------------------------------------------------------------------- *)

  let rec type_subst i ty =
    match ty with
      Tyapp(tycon,args) ->
          let args' = qmap (type_subst i) args in
          if args' == args then ty else Tyapp(tycon,args')
      | _ -> rev_assocd ty i ty

  let bool_ty = Tyapp("bool",[])

  let aty = Tyvar "A"

(* ------------------------------------------------------------------------- *)
(* List of term constants and their types.                                   *)
(*                                                                           *)
(* We begin with just equality (over all types). Later, the Hilbert choice   *)
(* operator is added. All other new constants are defined.                   *)
(* ------------------------------------------------------------------------- *)

  let the_term_constants =
     ref ["=",Tyapp("fun",[aty;Tyapp("fun",[aty;bool_ty])])]

(* ------------------------------------------------------------------------- *)
(* Return all the defined constants with generic types.                      *)
(* ------------------------------------------------------------------------- *)

  let constants() = !the_term_constants

(* ------------------------------------------------------------------------- *)
(* Gets type of constant if it succeeds.                                     *)
(* ------------------------------------------------------------------------- *)

  let get_const_type s = assoc s (!the_term_constants)

(* ------------------------------------------------------------------------- *)
(* Declare a new constant.                                                   *)
(* ------------------------------------------------------------------------- *)

  let new_constant(name,ty) =
    if can get_const_type name then
      failwith ("new_constant: constant "^name^" has already been declared")
    else the_term_constants := (name,ty)::(!the_term_constants)

(* ------------------------------------------------------------------------- *)
(* Finds the type of a term (assumes it is well-typed).                      *)
(* ------------------------------------------------------------------------- *)

  let rec type_of tm =
    match tm with
      Var(_,ty) -> ty
    | Const(_,ty) -> ty
    | Comb(s,_) -> hd(tl(snd(dest_type(type_of s))))
    | Abs(Var(_,ty),t) -> Tyapp("fun",[ty;type_of t])

(* ------------------------------------------------------------------------- *)
(* Primitive discriminators.                                                 *)
(* ------------------------------------------------------------------------- *)

  let is_var = function (Var(_,_)) -> true | _ -> false

  let is_const = function (Const(_,_)) -> true | _ -> false

  let is_abs = function (Abs(_,_)) -> true | _ -> false

  let is_comb = function (Comb(_,_)) -> true | _ -> false

(* ------------------------------------------------------------------------- *)
(* Primitive constructors.                                                   *)
(* ------------------------------------------------------------------------- *)

  let mk_var(v,ty) = Var(v,ty)

  let mk_const(name,theta) =
    let uty = try get_const_type name with Failure _ ->
      failwith "mk_const: not a constant name" in
    Const(name,type_subst theta uty)

  let mk_abs(bvar,bod) =
    match bvar with
      Var(_,_) -> Abs(bvar,bod)
    | _ -> failwith "mk_abs: not a variable"

  let mk_comb(f,a) =
    match type_of f with
      Tyapp("fun",[ty;_]) when Pervasives.compare ty (type_of a) = 0
        -> Comb(f,a)
    | _ -> failwith "mk_comb: types do not agree"

(* ------------------------------------------------------------------------- *)
(* Primitive destructors.                                                    *)
(* ------------------------------------------------------------------------- *)

  let dest_var =
    function (Var(s,ty)) -> s,ty | _ -> failwith "dest_var: not a variable"

  let dest_const =
    function (Const(s,ty)) -> s,ty | _ -> failwith "dest_const: not a constant"

  let dest_comb =
    function (Comb(f,x)) -> f,x | _ -> failwith "dest_comb: not a combination"

  let dest_abs =
    function (Abs(v,b)) -> v,b | _ -> failwith "dest_abs: not an abstraction"

(* ------------------------------------------------------------------------- *)
(* Finds the variables free in a term (list of terms).                       *)
(* ------------------------------------------------------------------------- *)

  let rec frees tm =
    match tm with
      Var(_,_) -> [tm]
    | Const(_,_) -> []
    | Abs(bv,bod) -> subtract (frees bod) [bv]
    | Comb(s,t) -> union (frees s) (frees t)

  let freesl tml = itlist (union o frees) tml []

(* ------------------------------------------------------------------------- *)
(* Whether all free variables in a term appear in a list.                    *)
(* ------------------------------------------------------------------------- *)

  let rec freesin acc tm =
    match tm with
      Var(_,_) -> mem tm acc
    | Const(_,_) -> true
    | Abs(bv,bod) -> freesin (bv::acc) bod
    | Comb(s,t) -> freesin acc s & freesin acc t

(* ------------------------------------------------------------------------- *)
(* Whether a variable (or constant in fact) is free in a term.               *)
(* ------------------------------------------------------------------------- *)

  let rec vfree_in v tm =
    match tm with
      Abs(bv,bod) -> v <> bv & vfree_in v bod
    | Comb(s,t) -> vfree_in v s or vfree_in v t
    | _ -> Pervasives.compare tm v = 0

(* ------------------------------------------------------------------------- *)
(* Finds the type variables (free) in a term.                                *)
(* ------------------------------------------------------------------------- *)

  let rec type_vars_in_term tm =
    match tm with
      Var(_,ty)        -> tyvars ty
    | Const(_,ty)      -> tyvars ty
    | Comb(s,t)        -> union (type_vars_in_term s) (type_vars_in_term t)
    | Abs(Var(_,ty),t) -> union (tyvars ty) (type_vars_in_term t)

(* ------------------------------------------------------------------------- *)
(* For name-carrying syntax, we need this early.                             *)
(* ------------------------------------------------------------------------- *)

  let rec variant avoid v =
    if not(exists (vfree_in v) avoid) then v else
    match v with
      Var(s,ty) -> variant avoid (Var(s^"'",ty))
    | _ -> failwith "variant: not a variable"

(* ------------------------------------------------------------------------- *)
(* Substitution primitive (substitution for variables only!)                 *)
(* ------------------------------------------------------------------------- *)

  let vsubst =
    let rec vsubst ilist tm =
      match tm with
        Var(_,_) -> rev_assocd tm ilist tm
      | Const(_,_) -> tm
      | Comb(s,t) -> let s' = vsubst ilist s and t' = vsubst ilist t in
                     if s' == s & t' == t then tm else Comb(s',t')
      | Abs(v,s) -> let ilist' = filter (fun (t,x) -> x <> v) ilist in
                    if ilist' = [] then tm else
                    let s' = vsubst ilist' s in
                    if s' == s then tm else
                    if exists (fun (t,x) -> vfree_in v t & vfree_in x s) ilist'
                    then let v' = variant [s'] v in
                         Abs(v',vsubst ((v',v)::ilist') s)
                    else Abs(v,s') in
    fun theta ->
      if theta = [] then (fun tm -> tm) else
      if forall (fun (t,x) -> type_of t = snd(dest_var x)) theta
      then vsubst theta else failwith "vsubst: Bad substitution list"

(* ------------------------------------------------------------------------- *)
(* Type instantiation primitive.                                             *)
(* ------------------------------------------------------------------------- *)

  exception Clash of term

  let inst =
    let rec inst env tyin tm =
      match tm with
        Var(n,ty)   -> let ty' = type_subst tyin ty in
                       let tm' = if ty' == ty then tm else Var(n,ty') in
                       if Pervasives.compare (rev_assocd tm' env tm) tm = 0
                       then tm'
                       else raise (Clash tm')
      | Const(c,ty) -> let ty' = type_subst tyin ty in
                       if ty' == ty then tm else Const(c,ty')
      | Comb(f,x)   -> let f' = inst env tyin f and x' = inst env tyin x in
                       if f' == f & x' == x then tm else Comb(f',x')
      | Abs(y,t)    -> let y' = inst [] tyin y in
                       let env' = (y,y')::env in
                       try let t' = inst env' tyin t in
                           if y' == y & t' == t then tm else Abs(y',t')
                       with (Clash(w') as ex) ->
                       if w' <> y' then raise ex else
                       let ifrees = map (inst [] tyin) (frees t) in
                       let y'' = variant ifrees y' in
                       let z = Var(fst(dest_var y''),snd(dest_var y)) in
                       inst env tyin (Abs(z,vsubst[z,y] t)) in
    fun tyin -> if tyin = [] then fun tm -> tm else inst [] tyin

(* ------------------------------------------------------------------------- *)
(* A few bits of general derived syntax.                                     *)
(* ------------------------------------------------------------------------- *)

  let rator tm =
    match tm with
      Comb(l,r) -> l
    | _ -> failwith "rator: Not a combination"

  let rand tm =
    match tm with
      Comb(l,r) -> r
    | _ -> failwith "rand: Not a combination"

(* ------------------------------------------------------------------------- *)
(* Syntax operations for equations.                                          *)
(* ------------------------------------------------------------------------- *)

  let safe_mk_eq l r =
    let ty = type_of l in
    Comb(Comb(Const("=",Tyapp("fun",[ty;Tyapp("fun",[ty;bool_ty])])),l),r)

  let dest_eq tm =
    match tm with
      Comb(Comb(Const("=",_),l),r) -> l,r
    | _ -> failwith "dest_eq"

(* ------------------------------------------------------------------------- *)
(* Useful to have term union modulo alpha-conversion for assumption lists.   *)
(* ------------------------------------------------------------------------- *)

  let rec ordav env x1 x2 =
    match env with
      [] -> Pervasives.compare x1 x2
    | (t1,t2 as tp)::oenv -> if Pervasives.compare x1 t1 = 0
                             then if Pervasives.compare x2 t2 = 0
                                  then 0 else -1
                             else if Pervasives.compare x2 t2 = 0 then 1
                             else ordav oenv x1 x2

  let rec orda env tm1 tm2 =
    if tm1 == tm2 & env = [] then 0 else
    match (tm1,tm2) with
      Var(x1,ty1),Var(x2,ty2) -> ordav env tm1 tm2
    | Const(x1,ty1),Const(x2,ty2) -> Pervasives.compare tm1 tm2
    | Comb(s1,t1),Comb(s2,t2) ->
          let c = orda env s1 s2 in if c <> 0 then c else orda env t1 t2
    | Abs(Var(_,ty1) as x1,t1),Abs(Var(_,ty2) as x2,t2) ->
          let c = Pervasives.compare ty1 ty2 in
          if c <> 0 then c else orda ((x1,x2)::env) t1 t2
    | Const(_,_),_ -> -1
    | _,Const(_,_) -> 1
    | Var(_,_),_ -> -1
    | _,Var(_,_) -> 1
    | Comb(_,_),_ -> -1
    | _,Comb(_,_) -> 1

  let alphaorder = orda []

  let rec term_union l1 l2 =
    match (l1,l2) with
      ([],l2) -> l2
    | (l1,[]) -> l1
    | (h1::t1,h2::t2) -> let c = alphaorder h1 h2 in
                         if c = 0 then h1::(term_union t1 t2)
                         else if c < 0 then h1::(term_union t1 l2)
                         else h2::(term_union l1 t2)

  let rec term_remove t l =
    match l with
      s::ss -> let c = alphaorder t s in
               if c > 0 then
                 let ss' = term_remove t ss in
                 if ss' == ss then l else s::ss'
               else if c = 0 then ss else l
    | [] -> l

  let rec term_image f l =
    match l with
      h::t -> let h' = f h and t' = term_image f t in
              if h' == h & t' == t then l else term_union [h'] t'
    | [] -> l

(* ------------------------------------------------------------------------- *)
(* Basic theorem destructors.                                                *)
(* ------------------------------------------------------------------------- *)

  let dest_thm (Sequent(asl,c)) = (asl,c)

  let hyp (Sequent(asl,c)) = asl

  let concl (Sequent(asl,c)) = c

(* ------------------------------------------------------------------------- *)
(* Basic equality properties; TRANS is derivable but included for efficiency *)
(* ------------------------------------------------------------------------- *)

  let REFL tm =
    Sequent([],safe_mk_eq tm tm)

  let TRANS (Sequent(asl1,c1)) (Sequent(asl2,c2)) =
    match (c1,c2) with
      Comb((Comb(Const("=",_),l) as eql),m1),Comb(Comb(Const("=",_),m2),r)
        when alphaorder m1 m2 = 0 -> Sequent(term_union asl1 asl2,Comb(eql,r))
    | _ -> failwith "TRANS"

(* ------------------------------------------------------------------------- *)
(* Congruence properties of equality.                                        *)
(* ------------------------------------------------------------------------- *)

  let MK_COMB(Sequent(asl1,c1),Sequent(asl2,c2)) =
     match (c1,c2) with
       Comb(Comb(Const("=",_),l1),r1),Comb(Comb(Const("=",_),l2),r2) ->
        (match type_of l1 with
           Tyapp("fun",[ty;_]) when Pervasives.compare ty (type_of l2) = 0
             -> Sequent(term_union asl1 asl2,
                        safe_mk_eq (Comb(l1,l2)) (Comb(r1,r2)))
         | _ -> failwith "MK_COMB: types do not agree")
     | _ -> failwith "MK_COMB: not both equations"

  let ABS v (Sequent(asl,c)) =
    match (v,c) with
      Var(_,_),Comb(Comb(Const("=",_),l),r) when not(exists (vfree_in v) asl)
         -> Sequent(asl,safe_mk_eq (Abs(v,l)) (Abs(v,r)))
    | _ -> failwith "ABS";;

(* ------------------------------------------------------------------------- *)
(* Trivial case of lambda calculus beta-conversion.                          *)
(* ------------------------------------------------------------------------- *)

  let BETA tm =
    match tm with
      Comb(Abs(v,bod),arg) when Pervasives.compare arg v = 0
        -> Sequent([],safe_mk_eq tm bod)
    | _ -> failwith "BETA: not a trivial beta-redex"

(* ------------------------------------------------------------------------- *)
(* Rules connected with deduction.                                           *)
(* ------------------------------------------------------------------------- *)

  let ASSUME tm =
    if Pervasives.compare (type_of tm) bool_ty = 0 then Sequent([tm],tm)
    else failwith "ASSUME: not a proposition"

  let EQ_MP (Sequent(asl1,eq)) (Sequent(asl2,c)) =
    match eq with
      Comb(Comb(Const("=",_),l),r) when alphaorder l c = 0
        -> Sequent(term_union asl1 asl2,r)
    | _ -> failwith "EQ_MP"

  let DEDUCT_ANTISYM_RULE (Sequent(asl1,c1)) (Sequent(asl2,c2)) =
    let asl1' = term_remove c2 asl1 and asl2' = term_remove c1 asl2 in
    Sequent(term_union asl1' asl2',safe_mk_eq c1 c2)

(* ------------------------------------------------------------------------- *)
(* Type and term instantiation.                                              *)
(* ------------------------------------------------------------------------- *)

  let INST_TYPE theta (Sequent(asl,c)) =
    let inst_fn = inst theta in
    Sequent(term_image inst_fn asl,inst_fn c)

  let INST theta (Sequent(asl,c)) =
    let inst_fun = vsubst theta in
    Sequent(term_image inst_fun asl,inst_fun c)

(* ------------------------------------------------------------------------- *)
(* Handling of axioms.                                                       *)
(* ------------------------------------------------------------------------- *)

  let the_axioms = ref ([]:thm list)

  let axioms() = !the_axioms

  let new_axiom tm =
    if Pervasives.compare (type_of tm) bool_ty = 0 then
      let th = Sequent([],tm) in
       (the_axioms := th::(!the_axioms); th)
    else failwith "new_axiom: Not a proposition"

(* ------------------------------------------------------------------------- *)
(* Handling of (term) definitions.                                           *)
(* ------------------------------------------------------------------------- *)

  let the_definitions = ref ([]:thm list)

  let definitions() = !the_definitions

  let new_basic_definition tm =
    match tm with
      Comb(Comb(Const("=",_),(Var(cname,ty) as l)),r) ->
        if not(freesin [] r) then failwith "new_definition: term not closed"
        else if not (subset (type_vars_in_term r) (tyvars ty))
        then failwith "new_definition: Type variables not reflected in constant"
        else let c = new_constant(cname,ty); Const(cname,ty) in
             let dth = Sequent([],safe_mk_eq c r) in
             the_definitions := dth::(!the_definitions); dth
    | _ -> failwith "new_basic_definition"

(* ------------------------------------------------------------------------- *)
(* Handling of type definitions.                                             *)
(*                                                                           *)
(* This function now involves no logical constants beyond equality.          *)
(*                                                                           *)
(*             |- P t                                                        *)
(*    ---------------------------                                            *)
(*        |- abs(rep a) = a                                                  *)
(*     |- P r = (rep(abs r) = r)                                             *)
(*                                                                           *)
(* Where "abs" and "rep" are new constants with the nominated names.         *)
(* ------------------------------------------------------------------------- *)

  let new_basic_type_definition tyname (absname,repname) (Sequent(asl,c)) =
    if exists (can get_const_type) [absname; repname] then
      failwith "new_basic_type_definition: Constant(s) already in use" else
    if not (asl = []) then
      failwith "new_basic_type_definition: Assumptions in theorem" else
    let P,x = try dest_comb c
              with Failure _ ->
                failwith "new_basic_type_definition: Not a combination" in
    if not(freesin [] P) then
      failwith "new_basic_type_definition: Predicate is not closed" else
    let tyvars = sort (<=) (type_vars_in_term P) in
    let _ = try new_type(tyname,length tyvars)
            with Failure _ ->
                failwith "new_basic_type_definition: Type already defined" in
    let aty = Tyapp(tyname,tyvars)
    and rty = type_of x in
    let absty = Tyapp("fun",[rty;aty]) and repty = Tyapp("fun",[aty;rty]) in
    let abs = (new_constant(absname,absty); Const(absname,absty))
    and rep = (new_constant(repname,repty); Const(repname,repty)) in
    let a = Var("a",aty) and r = Var("r",rty) in
    Sequent([],safe_mk_eq (Comb(abs,mk_comb(rep,a))) a),
    Sequent([],safe_mk_eq (Comb(P,r))
                          (safe_mk_eq (mk_comb(rep,mk_comb(abs,r))) r))

end;;

include Hol;;

(* ------------------------------------------------------------------------- *)
(* Stuff that didn't seem worth putting in.                                  *)
(* ------------------------------------------------------------------------- *)

let mk_fun_ty ty1 ty2 = mk_type("fun",[ty1; ty2]);;
let bty = mk_vartype "B";;

let is_eq tm =
  match tm with
    Comb(Comb(Const("=",_),_),_) -> true
  | _ -> false;;

let mk_eq =
  let eq = mk_const("=",[]) in
  fun (l,r) ->
    try let ty = type_of l in
        let eq_tm = inst [ty,aty] eq in
        mk_comb(mk_comb(eq_tm,l),r)
    with Failure _ -> failwith "mk_eq";;

(* ------------------------------------------------------------------------- *)
(* Tests for alpha-convertibility (equality ignoring names in abstractions). *)
(* ------------------------------------------------------------------------- *)

let aconv s t = alphaorder s t = 0;;

(* ------------------------------------------------------------------------- *)
(* Comparison function on theorems. Currently the same as equality, but      *)
(* it's useful to separate because in the proof-recording version it isn't.  *)
(* ------------------------------------------------------------------------- *)

let equals_thm th th' = dest_thm th = dest_thm th';;
(* ========================================================================= *)
(* More syntax constructors, and prelogical utilities like matching.         *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let genvar =
  let gcounter = ref 0 in
  fun ty -> let count = !gcounter in
             (gcounter := count + 1;
              mk_var("_"^(string_of_int count),ty));;

(* ------------------------------------------------------------------------- *)
(* Convenient functions for manipulating types.                              *)
(* ------------------------------------------------------------------------- *)

let dest_fun_ty ty =
  match ty with
    Tyapp("fun",[ty1;ty2]) -> (ty1,ty2)
  | _ -> failwith "dest_fun_ty";;

let rec occurs_in ty bigty =
  bigty = ty or
  is_type bigty & exists (occurs_in ty) (snd(dest_type bigty));;

let rec tysubst alist ty =
  try rev_assoc ty alist with Failure _ ->
  if is_vartype ty then ty else
  let tycon,tyvars = dest_type ty in
  mk_type(tycon,map (tysubst alist) tyvars);;

(* ------------------------------------------------------------------------- *)
(* A bit more syntax.                                                        *)
(* ------------------------------------------------------------------------- *)

let bndvar tm =
  try fst(dest_abs tm)
  with Failure _ -> failwith "bndvar: Not an abstraction";;

let body tm =
  try snd(dest_abs tm)
  with Failure _ -> failwith "body: Not an abstraction";;

let list_mk_comb(h,t) = rev_itlist (C (curry mk_comb)) t h;;

let list_mk_abs(vs,bod) = itlist (curry mk_abs) vs bod;;

let strip_comb = rev_splitlist dest_comb;;

let strip_abs = splitlist dest_abs;;

(* ------------------------------------------------------------------------- *)
(* Generic syntax to deal with some binary operators.                        *)
(*                                                                           *)
(* Note that "mk_binary" only works for monomorphic functions.               *)
(* ------------------------------------------------------------------------- *)

let is_binary s tm =
  match tm with
    Comb(Comb(Const(s',_),_),_) -> s' = s
  | _ -> false;;

let dest_binary s tm =
  match tm with
    Comb(Comb(Const(s',_),l),r) when s' = s -> (l,r)
  | _ -> failwith "dest_binary";;

let mk_binary s =
  let c = mk_const(s,[]) in
  fun (l,r) -> try mk_comb(mk_comb(c,l),r)
               with Failure _ -> failwith "mk_binary";;

(* ------------------------------------------------------------------------- *)
(* Produces a sequence of variants, considering previous inventions.         *)
(* ------------------------------------------------------------------------- *)

let rec variants av vs =
  if vs = [] then [] else
  let vh = variant av (hd vs) in vh::(variants (vh::av) (tl vs));;

(* ------------------------------------------------------------------------- *)
(* Gets all variables (free and/or bound) in a term.                         *)
(* ------------------------------------------------------------------------- *)

let variables =
  let rec vars(acc,tm) =
    if is_var tm then insert tm acc
    else if is_const tm then acc
    else if is_abs tm then
      let v,bod = dest_abs tm in
      vars(insert v acc,bod)
    else
      let l,r = dest_comb tm in
      vars(vars(acc,l),r) in
  fun tm -> vars([],tm);;

(* ------------------------------------------------------------------------- *)
(* General substitution (for any free expression).                           *)
(* ------------------------------------------------------------------------- *)

let subst =
  let rec ssubst ilist tm =
    if ilist = [] then tm else
    try fst (find ((aconv tm) o snd) ilist) with Failure _ ->
    match tm with
      Comb(f,x) -> let f' = ssubst ilist f and x' = ssubst ilist x in
                   if f' == f & x' == x then tm else mk_comb(f',x')
    | Abs(v,bod) ->
          let ilist' = filter (not o (vfree_in v) o snd) ilist in
          mk_abs(v,ssubst ilist' bod)
    | _ -> tm in
  fun ilist ->
    let ts,xs = unzip ilist in
    fun tm ->
      let gs = variants (variables tm) (map (genvar o type_of) xs) in
      let tm' = ssubst (zip gs xs) tm in
      if tm' == tm then tm else vsubst (zip ts gs) tm';;

(* ------------------------------------------------------------------------- *)
(* Alpha conversion term operation.                                          *)
(* ------------------------------------------------------------------------- *)

let alpha v tm =
  let v0,bod = try dest_abs tm
               with Failure _ -> failwith "alpha: Not an abstraction"in
  if v = v0 then tm else
  if type_of v = type_of v0 & not (vfree_in v bod) then
    mk_abs(v,vsubst[v,v0]bod)
  else failwith "alpha: Invalid new variable";;

(* ------------------------------------------------------------------------- *)
(* Type matching.                                                            *)
(* ------------------------------------------------------------------------- *)

let rec type_match vty cty sofar =
  if is_vartype vty then
     try if rev_assoc vty sofar = cty then sofar else failwith "type_match"
     with Failure "find" -> (cty,vty)::sofar
  else
     let vop,vargs = dest_type vty and cop,cargs = dest_type cty in
     if vop = cop then itlist2 type_match vargs cargs sofar
     else failwith "type_match";;

(* ------------------------------------------------------------------------- *)
(* Conventional matching version of mk_const (but with a sanity test).       *)
(* ------------------------------------------------------------------------- *)

let mk_mconst(c,ty) =
  try let uty = get_const_type c in
      let mat = type_match uty ty [] in
      let con = mk_const(c,mat) in
      if type_of con = ty then con else fail()
  with Failure _ -> failwith "mk_const: generic type cannot be instantiated";;

(* ------------------------------------------------------------------------- *)
(* Like mk_comb, but instantiates type variables in rator if necessary.      *)
(* ------------------------------------------------------------------------- *)

let mk_icomb(tm1,tm2) =
  let "fun",[ty;_] = dest_type (type_of tm1) in
  let tyins = type_match ty (type_of tm2) [] in
  mk_comb(inst tyins tm1,tm2);;

(* ------------------------------------------------------------------------- *)
(* Instantiates types for constant c and iteratively makes combination.      *)
(* ------------------------------------------------------------------------- *)

let list_mk_icomb cname =
  let cnst = mk_const(cname,[]) in
  fun args -> rev_itlist (C (curry mk_icomb)) args cnst;;

(* ------------------------------------------------------------------------- *)
(* Free variables in assumption list and conclusion of a theorem.            *)
(* ------------------------------------------------------------------------- *)

let thm_frees th =
  let asl,c = dest_thm th in
  itlist (union o frees) asl (frees c);;

(* ------------------------------------------------------------------------- *)
(* Is one term free in another?                                              *)
(* ------------------------------------------------------------------------- *)

let rec free_in tm1 tm2 =
  if aconv tm1 tm2 then true
  else if is_comb tm2 then
    let l,r = dest_comb tm2 in free_in tm1 l or free_in tm1 r
  else if is_abs tm2 then
    let bv,bod = dest_abs tm2 in
    not (vfree_in bv tm1) & free_in tm1 bod
  else false;;

(* ------------------------------------------------------------------------- *)
(* Searching for terms.                                                      *)
(* ------------------------------------------------------------------------- *)

let rec find_term p tm =
  if p tm then tm else
  if is_abs tm then find_term p (body tm) else
  if is_comb tm then
    let l,r = dest_comb tm in
    try find_term p l with Failure _ -> find_term p r
  else failwith "find_term";;

let find_terms =
  let rec accum tl p tm =
    let tl' = if p tm then insert tm tl else tl in
    if is_abs tm then
       accum tl' p (body tm)
    else if is_comb tm then
       accum (accum tl' p (rator tm)) p (rand tm)
    else tl' in
  accum [];;

(* ------------------------------------------------------------------------- *)
(* General syntax for binders.                                               *)
(*                                                                           *)
(* NB! The "mk_binder" function expects polytype "A", which is the domain.   *)
(* ------------------------------------------------------------------------- *)

let is_binder s tm =
  match tm with
    Comb(Const(s',_),Abs(_,_)) -> s' = s
  | _ -> false;;

let dest_binder s tm =
  match tm with
    Comb(Const(s',_),Abs(x,t)) when s' = s -> (x,t)
  | _ -> failwith "dest_binder";;

let mk_binder op =
  let c = mk_const(op,[]) in
  fun (v,tm) -> mk_comb(inst [type_of v,aty] c,mk_abs(v,tm));;

(* ------------------------------------------------------------------------- *)
(* Syntax for binary operators.                                              *)
(* ------------------------------------------------------------------------- *)

let is_binop op tm =
  match tm with
    Comb(Comb(op',_),_) -> op' = op
  | _ -> false;;

let dest_binop op tm =
  match tm with
    Comb(Comb(op',l),r) when op' = op -> (l,r)
  | _ -> failwith "dest_binop";;

let mk_binop op tm1 =
  let f = mk_comb(op,tm1) in
  fun tm2 -> mk_comb(f,tm2);;

let list_mk_binop op = end_itlist (mk_binop op);;

let binops op = striplist (dest_binop op);;

(* ------------------------------------------------------------------------- *)
(* Some common special cases                                                 *)
(* ------------------------------------------------------------------------- *)

let is_conj = is_binary "/\\";;
let dest_conj = dest_binary "/\\";;
let conjuncts = striplist dest_conj;;

let is_imp = is_binary "==>";;
let dest_imp = dest_binary "==>";;

let is_forall = is_binder "!";;
let dest_forall = dest_binder "!";;
let strip_forall = splitlist dest_forall;;

let is_exists = is_binder "?";;
let dest_exists = dest_binder "?";;
let strip_exists = splitlist dest_exists;;

let is_disj = is_binary "\\/";;
let dest_disj = dest_binary "\\/";;
let disjuncts = striplist dest_disj;;

let is_neg tm =
  try fst(dest_const(rator tm)) = "~"
  with Failure _ -> false;;

let dest_neg tm =
  try let n,p = dest_comb tm in
      if fst(dest_const n) = "~" then p else fail()
  with Failure _ -> failwith "dest_neg";;

let is_uexists = is_binder "?!";;
let dest_uexists = dest_binder "?!";;

let dest_cons = dest_binary "CONS";;
let is_cons = is_binary "CONS";;
let dest_list tm =
  try let tms,nil = splitlist dest_cons tm in
      if fst(dest_const nil) = "NIL" then tms else fail()
  with Failure _ -> failwith "dest_list";;
let is_list = can dest_list;;

(* ------------------------------------------------------------------------- *)
(* Syntax for numerals.                                                      *)
(* ------------------------------------------------------------------------- *)

let dest_numeral =
  let rec dest_num tm =
    if try fst(dest_const tm) = "_0" with Failure _ -> false then num_0 else
    let l,r = dest_comb tm in
    let n = num_2 */ dest_num r in
    let cn = fst(dest_const l) in
    if cn = "BIT0" then n
    else if cn = "BIT1" then n +/ num_1
    else fail() in
  fun tm -> try let l,r = dest_comb tm in
                if fst(dest_const l) = "NUMERAL" then dest_num r else fail()
            with Failure _ -> failwith "dest_numeral";;

(* ------------------------------------------------------------------------- *)
(* Syntax for generalized abstractions.                                      *)
(*                                                                           *)
(* These are here because they are used by the preterm->term translator;     *)
(* preterms regard generalized abstractions as an atomic notion. This is     *)
(* slightly unclean --- for example we need locally some operations on       *)
(* universal quantifiers --- but probably simplest. It has to go somewhere!  *)
(* ------------------------------------------------------------------------- *)

let dest_gabs =
  let dest_geq = dest_binary "GEQ" in
  fun tm ->
    try if is_abs tm then dest_abs tm else
        let l,r = dest_comb tm in
        if not (fst(dest_const l) = "GABS") then fail() else
        let ltm,rtm = dest_geq(snd(strip_forall(body r))) in
        rand ltm,rtm
    with Failure _ -> failwith "dest_gabs: Not a generalized abstraction";;

let is_gabs = can dest_gabs;;

let mk_gabs =
  let mk_forall(v,t) =
    let cop = mk_const("!",[type_of v,aty]) in
    mk_comb(cop,mk_abs(v,t)) in
  let list_mk_forall(vars,bod) = itlist (curry mk_forall) vars bod in
  let mk_geq(t1,t2) =
    let p = mk_const("GEQ",[type_of t1,aty]) in
    mk_comb(mk_comb(p,t1),t2) in
  fun (tm1,tm2) ->
    if is_var tm1 then mk_abs(tm1,tm2) else
    let fvs = frees tm1 in
    let fty = mk_fun_ty (type_of tm1) (type_of tm2) in
    let f = variant (frees tm1 @ frees tm2) (mk_var("f",fty)) in
    let bod = mk_abs(f,list_mk_forall(fvs,mk_geq(mk_comb(f,tm1),tm2))) in
    mk_comb(mk_const("GABS",[fty,aty]),bod);;

let list_mk_gabs(vs,bod) = itlist (curry mk_gabs) vs bod;;

let strip_gabs = splitlist dest_gabs;;

(* ------------------------------------------------------------------------- *)
(* Syntax for let terms.                                                     *)
(* ------------------------------------------------------------------------- *)

let dest_let tm =
  try let l,aargs = strip_comb tm in
      if fst(dest_const l) <> "LET" then fail() else
      let vars,lebod = strip_gabs (hd aargs) in
      let eqs = zip vars (tl aargs) in
      let le,bod = dest_comb lebod in
      if fst(dest_const le) = "LET_END" then eqs,bod else fail()
  with Failure _ -> failwith "dest_let: not a let-term";;

let is_let = can dest_let;;

let mk_let(assigs,bod) =
  let lefts,rights = unzip assigs in
  let lend = mk_comb(mk_const("LET_END",[type_of bod,aty]),bod) in
  let lbod = list_mk_gabs(lefts,lend) in
  let ty1,ty2 = dest_fun_ty(type_of lbod) in
  let ltm = mk_const("LET",[ty1,aty; ty2,bty]) in
  list_mk_comb(ltm,lbod::rights);;

(* ------------------------------------------------------------------------- *)
(* Useful function to create stylized arguments using numbers.               *)
(* ------------------------------------------------------------------------- *)

let make_args =
  let rec margs n s avoid tys =
    if tys = [] then [] else
    let v = variant avoid (mk_var(s^(string_of_int n),hd tys)) in
    v::(margs (n + 1) s (v::avoid) (tl tys)) in
  fun s avoid tys ->
    if length tys = 1 then
      [variant avoid (mk_var(s,hd tys))]
    else
      margs 0 s avoid tys;;

(* ------------------------------------------------------------------------- *)
(* Director strings down a term.                                             *)
(* ------------------------------------------------------------------------- *)

let find_path =
  let rec find_path p tm =
    if p tm then [] else
    if is_abs tm then "b"::(find_path p (body tm)) else
    try "r"::(find_path p (rand tm))
    with Failure _ -> "l"::(find_path p (rator tm)) in
  fun p tm -> implode(find_path p tm);;

let follow_path =
  let rec follow_path s tm =
    match s with
      [] -> tm
    | "l"::t -> follow_path t (rator tm)
    | "r"::t -> follow_path t (rand tm)
    | _::t -> follow_path t (body tm) in
  fun s tm -> follow_path (explode s) tm;;
(* ========================================================================= *)
(* Term nets: reasonably fast lookup based on term matchability.             *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

type term_label = Vnet                          (* variable (instantiable)   *)
                 | Lcnet of (string * int)      (* local constant            *)
                 | Cnet of (string * int)       (* constant                  *)
                 | Lnet of int;;                (* lambda term (abstraction) *)

(* ------------------------------------------------------------------------- *)
(* Term nets are a finitely branching tree structure; at each level we       *)
(* have a set of branches and a set of "values". Linearization is            *)
(* performed from the left of a combination; even in iterated                *)
(* combinations we look at the head first. This is probably fastest, and     *)
(* anyway it's useful to allow our restricted second order matches: if       *)
(* the head is a variable then then whole term is treated as a variable.     *)
(* ------------------------------------------------------------------------- *)

type 'a net = Netnode of (term_label * 'a net) list * 'a list;;

(* ------------------------------------------------------------------------- *)
(* The empty net.                                                            *)
(* ------------------------------------------------------------------------- *)

let empty_net = Netnode([],[]);;

(* ------------------------------------------------------------------------- *)
(* Insert a new element into a net.                                          *)
(* ------------------------------------------------------------------------- *)

let enter =
  let label_to_store lconsts tm =
    let op,args = strip_comb tm in
    if is_const op then Cnet(fst(dest_const op),length args),args
    else if is_abs op then
      let bv,bod = dest_abs op in
      let bod' = if mem bv lconsts then vsubst [genvar(type_of bv),bv] bod
                 else bod in
      Lnet(length args),bod'::args
    else if mem op lconsts then Lcnet(fst(dest_var op),length args),args
    else Vnet,[] in
  let canon_eq x y =
    try Pervasives.compare x y = 0 with Invalid_argument _ -> false
  and canon_lt x y =
    try Pervasives.compare x y < 0 with Invalid_argument _ -> false in
  let rec sinsert x l =
    if l = [] then [x] else
    let h = hd l in
    if canon_eq h x then failwith "sinsert" else
    if canon_lt x h then x::l else
    h::(sinsert x (tl l)) in
  let set_insert x l = try sinsert x l with Failure "sinsert" -> l in
  let rec net_update lconsts (elem,tms,Netnode(edges,tips)) =
    match tms with
      [] -> Netnode(edges,set_insert elem tips)
    | (tm::rtms) ->
          let label,ntms = label_to_store lconsts tm in
          let child,others =
            try (snd F_F I) (remove (fun (x,y) -> x = label) edges)
            with Failure _ -> (empty_net,edges) in
          let new_child = net_update lconsts (elem,ntms@rtms,child) in
          Netnode ((label,new_child)::others,tips) in
  fun lconsts (tm,elem) net -> net_update lconsts (elem,[tm],net);;

(* ------------------------------------------------------------------------- *)
(* Look up a term in a net and return possible matches.                      *)
(* ------------------------------------------------------------------------- *)

let lookup =
  let label_for_lookup tm =
    let op,args = strip_comb tm in
    if is_const op then Cnet(fst(dest_const op),length args),args
    else if is_abs op then Lnet(length args),(body op)::args
    else Lcnet(fst(dest_var op),length args),args in
  let rec follow (tms,Netnode(edges,tips)) =
    match tms with
      [] -> tips
    | (tm::rtms) ->
          let label,ntms = label_for_lookup tm in
          let collection =
            try let child = assoc label edges in
                follow(ntms @ rtms, child)
            with Failure _ -> [] in
          if label = Vnet then collection else
          try collection @ follow(rtms,assoc Vnet edges)
          with Failure _ -> collection in
  fun tm net -> follow([tm],net);;

(* ------------------------------------------------------------------------- *)
(* Function to merge two nets (code from Don Syme's hol-lite).               *)
(* ------------------------------------------------------------------------- *)

let merge_nets =
  let canon_eq x y =
    try Pervasives.compare x y = 0 with Invalid_argument _ -> false
  and canon_lt x y =
    try Pervasives.compare x y < 0 with Invalid_argument _ -> false in
  let rec set_merge l1 l2 =
    if l1 = [] then l2
    else if l2 = [] then l1 else
    let h1 = hd l1 and t1 = tl l1
    and h2 = hd l2 and t2 = tl l2 in
    if canon_eq h1 h2 then h1::(set_merge t1 t2)
    else if canon_lt h1 h2 then h1::(set_merge t1 l2)
    else h2::(set_merge l1 t2) in
  let rec merge_nets (Netnode(l1,data1),Netnode(l2,data2)) =
    let add_node ((lab,net) as p) l =
      try let (lab',net'),rest = remove (fun (x,y) -> x = lab) l in
          (lab',merge_nets (net,net'))::rest
      with Failure _ -> p::l in
    Netnode(itlist add_node l2 (itlist add_node l1 []),
            set_merge data1 data2) in
  merge_nets;;
(* ========================================================================= *)
(* Preterms and pretypes; typechecking; translation to types and terms.      *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Character discrimination.                                                 *)
(* ------------------------------------------------------------------------- *)

let isspace,issep,isbra,issymb,isalpha,isnum,isalnum =
  let charcode s = Char.code(String.get s 0) in
  let spaces = " \t\n\r"
  and separators = ",;"
  and brackets = "()[]{}"
  and symbs = "\\!@#$%^&*-+|\\<=>/?~.:"
  and alphas = "'abcdefghijklmnopqrstuvwxyz_ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  and nums = "0123456789" in
  let allchars = spaces^separators^brackets^symbs^alphas^nums in
  let csetsize = itlist (max o charcode) (explode allchars) 256 in
  let ctable = Array.make csetsize 0 in
  do_list (fun c -> Array.set ctable (charcode c) 1) (explode spaces);
  do_list (fun c -> Array.set ctable (charcode c) 2) (explode separators);
  do_list (fun c -> Array.set ctable (charcode c) 4) (explode brackets);
  do_list (fun c -> Array.set ctable (charcode c) 8) (explode symbs);
  do_list (fun c -> Array.set ctable (charcode c) 16) (explode alphas);
  do_list (fun c -> Array.set ctable (charcode c) 32) (explode nums);
  let isspace c = Array.get ctable (charcode c) = 1
  and issep c  = Array.get ctable (charcode c) = 2
  and isbra c  = Array.get ctable (charcode c) = 4
  and issymb c = Array.get ctable (charcode c) = 8
  and isalpha c = Array.get ctable (charcode c) = 16
  and isnum c = Array.get ctable (charcode c) = 32
  and isalnum c = Array.get ctable (charcode c) >= 16 in
  isspace,issep,isbra,issymb,isalpha,isnum,isalnum;;

(* ------------------------------------------------------------------------- *)
(* Flag to say whether to treat varstruct "\const. bod" as variable.         *)
(* ------------------------------------------------------------------------- *)

let ignore_constant_varstruct = ref true;;

(* ------------------------------------------------------------------------- *)
(* Flag indicating that user should be warned if type variables invented.    *)
(* ------------------------------------------------------------------------- *)

let type_invention_warning = ref true;;

(* ------------------------------------------------------------------------- *)
(* Overloading and interface mapping.                                        *)
(* ------------------------------------------------------------------------- *)

let the_interface = ref ([] :(string * (string * hol_type)) list);;

let the_overload_skeletons = ref ([] : (string * hol_type) list);;

let make_overloadable s gty =
  if can (assoc s) (!the_overload_skeletons)
  then if assoc s (!the_overload_skeletons) = gty then ()
       else failwith "make_overloadable: differs from existing skeleton"
  else the_overload_skeletons := (s,gty)::(!the_overload_skeletons);;

let remove_interface sym =
  let interface = filter ((<>)sym o fst) (!the_interface) in
  the_interface := interface;;

let reduce_interface (sym,tm) =
  let namty = try dest_const tm with Failure _ -> dest_var tm in
  the_interface := filter ((<>) (sym,namty)) (!the_interface);;

let override_interface (sym,tm) =
  let namty = try dest_const tm with Failure _ -> dest_var tm in
  let interface = filter ((<>)sym o fst) (!the_interface) in
  the_interface := (sym,namty)::interface;;

let overload_interface (sym,tm) =
  let gty = try assoc sym (!the_overload_skeletons) with Failure _ ->
            failwith ("symbol \""^sym^"\" is not overloadable") in
  let (name,ty) as namty = try dest_const tm with Failure _ -> dest_var tm in
  if not (can (type_match gty ty) [])
  then failwith "Not an instance of type skeleton" else
  let interface = filter ((<>) (sym,namty)) (!the_interface) in
  the_interface := (sym,namty)::interface;;

let prioritize_overload ty =
  do_list
   (fun (s,gty) ->
      try let _,(n,t) = find
            (fun (s',(n,t)) -> s' = s & mem ty (map fst (type_match gty t [])))
            (!the_interface) in
          overload_interface(s,mk_var(n,t))
      with Failure _ -> ())
   (!the_overload_skeletons);;

(* ------------------------------------------------------------------------- *)
(* Type abbreviations.                                                       *)
(* ------------------------------------------------------------------------- *)

let new_type_abbrev,remove_type_abbrev,type_abbrevs =
  let the_type_abbreviations = ref ([]:(string*hol_type)list) in
  let remove_type_abbrev s =
    the_type_abbreviations :=
      filter (fun (s',_) -> s' <> s) (!the_type_abbreviations) in
  let new_type_abbrev(s,ty) =
    (remove_type_abbrev s;
     the_type_abbreviations := merge(<) [s,ty] (!the_type_abbreviations)) in
  let type_abbrevs() = !the_type_abbreviations in
  new_type_abbrev,remove_type_abbrev,type_abbrevs;;

(* ------------------------------------------------------------------------- *)
(* Handle constant hiding.                                                   *)
(* ------------------------------------------------------------------------- *)

let hide_constant,unhide_constant,is_hidden =
  let hcs = ref ([]:string list) in
  let hide_constant c = hcs := union [c] (!hcs)
  and unhide_constant c = hcs := subtract (!hcs) [c]
  and is_hidden c = mem c (!hcs) in
  hide_constant,unhide_constant,is_hidden;;

(* ------------------------------------------------------------------------- *)
(* The type of pretypes.                                                     *)
(* ------------------------------------------------------------------------- *)

type pretype = Utv of string                   (* User type variable         *)
             | Ptycon of string * pretype list (* Type constructor           *)
             | Stv of int;;                    (* System type variable       *)

(* ------------------------------------------------------------------------- *)
(* Dummy pretype for the parser to stick in before a proper typing pass.     *)
(* ------------------------------------------------------------------------- *)

let dpty = Ptycon("",[]);;

(* ------------------------------------------------------------------------- *)
(* Convert type to pretype.                                                  *)
(* ------------------------------------------------------------------------- *)

let rec pretype_of_type ty =
  try let con,args = dest_type ty in
      Ptycon(con,map pretype_of_type args)
  with Failure _ -> Utv(dest_vartype ty);;

(* ------------------------------------------------------------------------- *)
(* Preterm syntax.                                                           *)
(* ------------------------------------------------------------------------- *)

type preterm = Varp of string * pretype       (* Variable           - v      *)
             | Constp of string * pretype     (* Constant           - c      *)
             | Combp of preterm * preterm     (* Combination        - f x    *)
             | Absp of preterm * preterm      (* Lambda-abstraction - \x. t  *)
             | Typing of preterm * pretype;;  (* Type constraint    - t : ty *)

(* ------------------------------------------------------------------------- *)
(* Convert term to preterm.                                                  *)
(* ------------------------------------------------------------------------- *)

let rec preterm_of_term tm =
  try let n,ty = dest_var tm in
      Varp(n,pretype_of_type ty)
  with Failure _ -> try
      let n,ty = dest_const tm in
      Constp(n,pretype_of_type ty)
  with Failure _ -> try
      let v,bod = dest_abs tm in
      Absp(preterm_of_term v,preterm_of_term bod)
  with Failure _ ->
      let l,r = dest_comb tm in
      Combp(preterm_of_term l,preterm_of_term r);;

(* ------------------------------------------------------------------------- *)
(* Main pretype->type, preterm->term and retypechecking functions.           *)
(* ------------------------------------------------------------------------- *)

let type_of_pretype,term_of_preterm,retypecheck =
  let tyv_num = ref 0 in
  let new_type_var() = let n = !tyv_num in (tyv_num := n + 1; Stv(n)) in

  let pmk_cv(s,pty) =
    if can get_const_type s then Constp(s,pty)
    else Varp(s,pty) in

  let pmk_numeral =
    let num_pty = Ptycon("num",[]) in
    let NUMERAL = Constp("NUMERAL",Ptycon("fun",[num_pty; num_pty]))
    and BIT0 = Constp("BIT0",Ptycon("fun",[num_pty; num_pty]))
    and BIT1 = Constp("BIT1",Ptycon("fun",[num_pty; num_pty]))
    and t_0 = Constp("_0",num_pty) in
    let rec pmk_numeral(n) =
      if n =/ num_0 then t_0 else
      let m = quo_num n (num_2) and b = mod_num n (num_2) in
      let op = if b =/ num_0 then BIT0 else BIT1 in
      Combp(op,pmk_numeral(m)) in
    fun n -> Combp(NUMERAL,pmk_numeral n) in

  (* ----------------------------------------------------------------------- *)
  (* Pretype substitution for a pretype resulting from translation of type.  *)
  (* ----------------------------------------------------------------------- *)

  let rec pretype_subst th ty =
    match ty with
      Ptycon(tycon,args) -> Ptycon(tycon,map (pretype_subst th) args)
    | Utv v -> rev_assocd ty th ty
    | _ -> failwith "pretype_subst: Unexpected form of pretype" in

  (* ----------------------------------------------------------------------- *)
  (* Convert type to pretype with new Stvs for all type variables.           *)
  (* ----------------------------------------------------------------------- *)

  let pretype_instance ty =
    let gty = pretype_of_type ty
    and tyvs = map pretype_of_type (tyvars ty) in
    let subs = map (fun tv -> new_type_var(),tv) tyvs in
    pretype_subst subs gty in

  (* ----------------------------------------------------------------------- *)
  (* Get a new instance of a constant's generic type modulo interface.       *)
  (* ----------------------------------------------------------------------- *)

  let get_generic_type cname =
    match filter ((=) cname o fst) (!the_interface) with
      [_,(c,ty)] -> ty
    | _::_::_ -> assoc cname (!the_overload_skeletons)
    | [] -> get_const_type cname in

  (* ----------------------------------------------------------------------- *)
  (* Unification of types                                                    *)
  (* ----------------------------------------------------------------------- *)

  let rec istrivial env x t =
    match t with
      Stv y -> y = x or defined env y & istrivial env x (apply env y)
    | Ptycon(f,args) -> exists (istrivial env x) args & failwith "cyclic"
    | Utv _ -> false in

  let rec unify env eqs =
    match eqs with
      [] -> env
    | (ty1,ty2)::oth when ty1 = ty2 -> unify env oth
    | (Ptycon(f,fargs),Ptycon(g,gargs))::oth ->
          if f = g & length fargs = length gargs
          then unify env (zip fargs gargs @ oth)
          else failwith "unify: types cannot be unified"
    | (Stv x,t)::oth ->
          if defined env x then unify env ((apply env x,t)::oth)
          else unify (if istrivial env x t then env else (x|->t) env) oth
    | (t,Stv x)::oth -> unify env ((Stv x,t)::oth)
    | _ -> failwith "unify: types cannot be unified" in

  (* ----------------------------------------------------------------------- *)
  (* Attempt to attach a given type to a term, performing unifications.      *)
  (* ----------------------------------------------------------------------- *)

  let rec typify ty (ptm,venv,uenv) =
    match ptm with
      Varp(s,_) ->
       (if can (assoc s) venv then
          let ty' = assoc s venv in
          Varp(s,ty'),[],unify uenv [ty',ty]
        else if can num_of_string s then
          let t = pmk_numeral(num_of_string s) in
          t,[],unify uenv [Ptycon("num",[]),ty]
        else
         (warn (s <> "" & isnum s) "Non-numeral begins with a digit";
          if not(is_hidden s) & can get_generic_type s then
            let pty = pretype_instance(get_generic_type s) in
            Constp(s,pty),[],unify uenv [pty,ty]
          else
            let t = Varp(s,ty) in t,[s,ty],uenv))
    | Combp(f,x) -> let ty'' = new_type_var() in
                   let ty' = Ptycon("fun",[ty'';ty]) in
                   let f',venv1,uenv1 = typify ty' (f,venv,uenv) in
                   let x',venv2,uenv2 = typify ty'' (x,venv1@venv,uenv1) in
                   Combp(f',x'),(venv1@venv2),uenv2
    | Typing(tm,pty) -> typify ty (tm,venv,unify uenv [ty,pty])
    | Absp(v,bod) -> let ty',ty'' =
                       match ty with
                          Ptycon("fun",[ty';ty'']) -> ty',ty''
                       | _ -> new_type_var(),new_type_var() in
                     let uenv0 = unify uenv [Ptycon("fun",[ty';ty'']),ty] in
                     let v',venv1,uenv1 =
                       let v',venv1,uenv1 = typify ty' (v,[],uenv0) in
                       match v' with
                         Constp(s,_) when !ignore_constant_varstruct ->
                            let t = Varp(s,ty') in t,[s,ty'],uenv0
                       | _ -> v',venv1,uenv1 in
                     let bod',venv2,uenv2 = typify ty''
                      (bod,venv1@venv,uenv1) in
                     Absp(v',bod'),venv2,uenv2
    | _ -> failwith "typify: unexpected constant at this stage" in

  (* ----------------------------------------------------------------------- *)
  (* Further specialize type constraints by resolving overloadings.          *)
  (* ----------------------------------------------------------------------- *)

  let rec resolve_interface ptm cont env =
    match ptm with
      Combp(f,x) -> resolve_interface f (resolve_interface x cont) env
    | Absp(v,bod) -> resolve_interface v (resolve_interface bod cont) env
    | Varp(_,_) -> cont env
    | Constp(s,ty) ->
          let maps = filter (fun (s',_) -> s' = s) (!the_interface) in
          if maps = [] then cont env else
          tryfind (fun (_,(_,ty')) -> cont(unify env [pretype_instance ty',ty]))
                  maps in

  (* ----------------------------------------------------------------------- *)
  (* Finally unravel unifications and apply them to a type.                  *)
  (* ----------------------------------------------------------------------- *)

  let rec solve env pty =
    match pty with
      Ptycon(f,args) -> Ptycon(f,map (solve env) args)
    | Stv(i) -> if defined env i then solve env (apply env i) else pty
    | _ -> pty in

  (* ----------------------------------------------------------------------- *)
  (* Hence apply throughout a preterm.                                       *)
  (* ----------------------------------------------------------------------- *)

  let rec solve_preterm env ptm =
    match ptm with
      Varp(s,ty) -> Varp(s,solve env ty)
    | Combp(f,x) -> Combp(solve_preterm env f,solve_preterm env x)
    | Absp(v,bod) -> Absp(solve_preterm env v,solve_preterm env bod)
    | Constp(s,ty) -> let tys = solve env ty in
          try let _,(c',_) = find
                (fun (s',(c',ty')) ->
                   s = s' & can (unify env) [pretype_instance ty',ty])
                (!the_interface) in
              pmk_cv(c',tys)
          with Failure _ -> Constp(s,tys) in

  (* ----------------------------------------------------------------------- *)
  (* Flag to indicate that Stvs were translated to real type variables.      *)
  (* ----------------------------------------------------------------------- *)

  let stvs_translated = ref false in

  (* ----------------------------------------------------------------------- *)
  (* Pretype <-> type conversion; -> flags system type variable translation. *)
  (* ----------------------------------------------------------------------- *)

  let rec type_of_pretype ty =
    match ty with
      Stv n -> stvs_translated := true;
               let s = "?"^(string_of_int n) in
               mk_vartype(s)
    | Utv(v) -> mk_vartype(v)
    | Ptycon(con,args) -> mk_type(con,map type_of_pretype args) in

  (* ----------------------------------------------------------------------- *)
  (* Maps preterms to terms.                                                 *)
  (* ----------------------------------------------------------------------- *)

  let term_of_preterm =
    let rec term_of_preterm ptm =
      match ptm with
        Varp(s,pty) -> mk_var(s,type_of_pretype pty)
      | Constp(s,pty) -> mk_mconst(s,type_of_pretype pty)
      | Combp(l,r) -> mk_comb(term_of_preterm l,term_of_preterm r)
      | Absp(v,bod) -> mk_gabs(term_of_preterm v,term_of_preterm bod)
      | Typing(ptm,pty) -> term_of_preterm ptm in
    fun ptm -> stvs_translated := false;
               let tm = term_of_preterm ptm in
               warn (!stvs_translated & !type_invention_warning)
                    "inventing type variables"; tm in

  (* ----------------------------------------------------------------------- *)
  (* Overall typechecker: initial typecheck plus overload resolution pass.   *)
  (* ----------------------------------------------------------------------- *)

  let retypecheck venv ptm =
    let ty = new_type_var() in
    let ptm',_,env =
      try typify ty (ptm,venv,undefined)
      with Failure _ -> failwith
       "typechecking error (initial type assignment)" in
    let env' =
      try resolve_interface ptm' (fun e -> e) env
      with Failure _ -> failwith "typechecking error (overload resolution)" in
    let ptm'' = solve_preterm env' ptm' in
    ptm'' in

  type_of_pretype,term_of_preterm,retypecheck;;
(* ========================================================================= *)
(* Lexical analyzer, type and preterm parsers.                               *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Reserved words.                                                           *)
(* ------------------------------------------------------------------------- *)

let reserve_words,unreserve_words,is_reserved_word,reserved_words =
  let reswords = ref ["(";  ")"; "[";   "]";  "{";   "}";
                      ":";  ";";  ".";  "|";
                      "let"; "in"; "and"; "if"; "then"; "else";
                      "match"; "with"; "function"; "->"; "when"] in
  (fun ns  -> reswords := union (!reswords) ns),
  (fun ns  -> reswords := subtract (!reswords) ns),
  (fun n  -> mem n (!reswords)),
  (fun () -> !reswords);;

(* ------------------------------------------------------------------------- *)
(* Functions to access the global tables controlling special parse status.   *)
(*                                                                           *)
(*  o List of binders;                                                       *)
(*                                                                           *)
(*  o List of prefixes (right-associated unary functions like negation).     *)
(*                                                                           *)
(*  o List of infixes with their precedences and associations.               *)
(*                                                                           *)
(* Note that these tables are independent of constant/variable status or     *)
(* whether an identifier is symbolic.                                        *)
(* ------------------------------------------------------------------------- *)

let unparse_as_binder,parse_as_binder,parses_as_binder,binders =
  let binder_list = ref ([]:string list) in
  (fun n  -> binder_list := subtract (!binder_list) [n]),
  (fun n  -> binder_list := union (!binder_list) [n]),
  (fun n  -> mem n (!binder_list)),
  (fun () -> !binder_list);;

let unparse_as_prefix,parse_as_prefix,is_prefix,prefixes =
  let prefix_list = ref ([]:string list) in
  (fun n  -> prefix_list := subtract (!prefix_list) [n]),
  (fun n  -> prefix_list := union (!prefix_list) [n]),
  (fun n  -> mem n (!prefix_list)),
  (fun () -> !prefix_list);;

let unparse_as_infix,parse_as_infix,get_infix_status,infixes =
  let cmp (s,(x,a)) (t,(y,b)) =
     x < y or x = y & a > b or x = y & a = b & s < t in
  let infix_list = ref ([]:(string * (int * string)) list) in
  (fun n     -> infix_list := filter (((<>) n) o fst) (!infix_list)),
  (fun (n,d) -> infix_list := sort cmp
     ((n,d)::(filter (((<>) n) o fst) (!infix_list)))),
  (fun n     -> assoc n (!infix_list)),
  (fun ()    -> !infix_list);;

(* ------------------------------------------------------------------------- *)
(* Need to have this now for set enums, since "," isn't a reserved word.     *)
(* ------------------------------------------------------------------------- *)

parse_as_infix (",",(14,"right"));;

(* ------------------------------------------------------------------------- *)
(* Basic parser combinators.                                                 *)
(* ------------------------------------------------------------------------- *)

exception Noparse;;

let (||) parser1 parser2 input =
  try parser1 input
  with Noparse -> parser2 input;;

let (++) parser1 parser2 input =
  let result1,rest1 = parser1 input in
  let result2,rest2 = parser2 rest1 in
  (result1,result2),rest2;;

let rec many prs input =
  try let result,next = prs input in
      let results,rest = many prs next in
      (result::results),rest
  with Noparse -> [],input;;

let (>>) prs treatment input =
  let result,rest = prs input in
  treatment(result),rest;;

let fix err prs input =
  try prs input
  with Noparse -> failwith (err ^ " expected");;

let rec listof prs sep err =
  prs ++ many (sep ++ fix err prs >> snd) >> (fun (h,t) -> h::t);;

let nothing input = [],input;;

let elistof prs sep err =
  listof prs sep err || nothing;;

let leftbin prs sep cons err =
  prs ++ many (sep ++ fix err prs) >>
  (fun (x,opxs) -> let ops,xs = unzip opxs in
                   itlist2 (fun op y x -> cons op x y) (rev ops) (rev xs) x);;

let rightbin prs sep cons err =
  prs ++ many (sep ++ fix err prs) >>
  (fun (x,opxs) -> if opxs = [] then x else
                   let ops,xs = unzip opxs in
                   itlist2 cons ops (x::butlast xs) (last xs));;

let possibly prs input =
  try let x,rest = prs input in [x],rest
  with Noparse -> [],input;;

let some p =
  function
      [] -> raise Noparse
    | (h::t) -> if p h then (h,t) else raise Noparse;;

let a tok = some (fun item -> item = tok);;

let rec atleast n prs i =
  (if n <= 0 then many prs
   else prs ++ atleast (n - 1) prs >> (fun (h,t) -> h::t)) i;;

let finished input =
  if input = [] then 0,input else failwith "Unparsed input";;

(* ------------------------------------------------------------------------- *)
(* The basic lexical classes: identifiers, strings and reserved words.       *)
(* ------------------------------------------------------------------------- *)

type lexcode = Ident of string
             | Resword of string;;

(* ------------------------------------------------------------------------- *)
(* Lexical analyzer. Apart from some special bracket symbols, each           *)
(* identifier is made up of the longest string of alphanumerics or           *)
(* the longest string of symbolics.                                          *)
(* ------------------------------------------------------------------------- *)

reserve_words ["//"];;

let comment_token = ref (Resword "//");;

let lex =
  let collect (h,t) = end_itlist (^) (h::t) in
  let reserve =
    function
        (Ident n as tok) ->
            if is_reserved_word n then Resword(n) else tok
      | t -> t in
  let stringof p = atleast 1 p >> end_itlist (^) in
  let simple_ident = stringof(some isalnum) || stringof(some issymb) in
  let undertail = stringof (a "_") ++ possibly simple_ident >> collect in
  let ident = (undertail || simple_ident) ++ many undertail >> collect in
  let septok = stringof(some issep) in
  let escapecode i =
    match i with
      "\\"::rst -> "\\",rst
    | "\""::rst -> "\"",rst
    | "\'"::rst -> "\'",rst
    | "n"::rst -> "\n",rst
    | "r"::rst -> "\r",rst
    | "t"::rst -> "\t",rst
    | "b"::rst -> "\b",rst
    | " "::rst -> " ",rst
    | "x"::h::l::rst -> 
         String.make 1 (Char.chr(int_of_string("0x"^h^l))),rst
    | a::b::c::rst when forall isnum [a;b;c] ->
         String.make 1 (Char.chr(int_of_string(a^b^c))),rst
    | _ -> failwith "lex:unrecognized OCaml-style escape in string" in
  let stringchar =
      some (fun i -> i <> "\\" & i <> "\"")
  || (a "\\" ++ escapecode >> snd) in
  let string = a "\"" ++ many stringchar ++ a "\"" >>
        (fun ((_,s),_) -> "\""^implode s^"\"") in
  let rawtoken = (string || some isbra || septok || ident) >>
    (fun x -> Ident x) in
  let simptoken = many (some isspace) ++ rawtoken >> (reserve o snd) in
  let rec tokens i =
    try let (t,rst) = simptoken i in
        if t = !comment_token then
          (many (fun i -> if i <> [] & hd i <> "\n" then 1,tl i
                          else raise Noparse) ++ tokens >> snd) rst
        else
          let toks,rst1 = tokens rst in t::toks,rst1
    with Noparse -> [],i in
  fst o (tokens ++ many (some isspace) ++ finished >> (fst o fst));;

(* ------------------------------------------------------------------------- *)
(* Parser for pretypes. Concrete syntax:                                     *)
(*                                                                           *)
(* TYPE        :: SUMTYPE -> TYPE                                            *)
(*              | SUMTYPE                                                    *)
(*                                                                           *)
(* SUMTYPE     :: PRODTYPE + SUMTYPE                                         *)
(*              | PRODTYPE                                                   *)
(*                                                                           *)
(* PRODTYPE    :: POWTYPE # PRODTYPE                                         *)
(*              | POWTYPE                                                    *)
(*                                                                           *)
(* POWTYPE     :: APPTYPE ^ POWTYPE                                          *)
(*              | APPTYPE                                                    *)
(*                                                                           *)
(* APPTYPE     :: ATOMICTYPES type-constructor  [Provided arity matches]     *)
(*              | ATOMICTYPES                   [Provided only 1 ATOMICTYPE] *)
(*                                                                           *)
(* ATOMICTYPES :: type-constructor              [Provided arity zero]        *)
(*              | type-variable                                              *)
(*              | ( TYPE )                                                   *)
(*              | ( TYPE LIST )                                              *)
(*                                                                           *)
(* TYPELIST    :: TYPE , TYPELIST                                            *)
(*              | TYPE                                                       *)
(*                                                                           *)
(* Two features make this different from previous HOL type syntax:           *)
(*                                                                           *)
(*  o Any identifier not in use as a type constant will be parsed as a       *)
(*    type variable; a ' is not needed and a * is not allowed.               *)
(*                                                                           *)
(*  o Antiquotation is not supported.                                        *)
(* ------------------------------------------------------------------------- *)

let parse_pretype =
  let btyop n n' x y = Ptycon(n,[x;y])
  and mk_apptype =
    function
        ([s],[]) -> s
      | (tys,[c]) -> Ptycon(c,tys)
      | _ -> failwith "Bad type construction"
  and type_atom input =
    match input with
      (Ident s)::rest ->
          (try pretype_of_type(assoc s (type_abbrevs())) with Failure _ ->
           if try get_type_arity s = 0 with Failure _ -> false
           then Ptycon(s,[]) else Utv(s)),rest
    | _ -> raise Noparse
  and type_constructor input =
    match input with
      (Ident s)::rest -> if try get_type_arity s > 0 with Failure _ -> false
                         then s,rest else raise Noparse
    | _ -> raise Noparse in
  let rec pretype i = rightbin sumtype (a (Resword "->")) (btyop "fun") "type" i
  and sumtype i = rightbin prodtype (a (Ident "+")) (btyop "sum") "type" i
  and prodtype i = rightbin carttype (a (Ident "#")) (btyop "prod") "type" i
  and carttype i = leftbin apptype (a (Ident "^")) (btyop "cart") "type" i
  and apptype i = (atomictypes ++ (type_constructor >> (fun x -> [x])
                                || nothing) >> mk_apptype) i
  and atomictypes i =
        (((a (Resword "(")) ++ typelist ++ a (Resword ")") >> (snd o fst))
      || type_atom >> (fun x -> [x])) i
  and typelist i = listof pretype (a (Ident ",")) "type" i in
  pretype;;

(* ------------------------------------------------------------------------- *)
(* Hook to allow installation of user parsers.                               *)
(* ------------------------------------------------------------------------- *)

let install_parser,delete_parser,installed_parsers,try_user_parser =
  let rec try_parsers ps i =
    if ps = [] then raise Noparse else
    try snd(hd ps) i with Noparse -> try_parsers (tl ps) i in
  let parser_list =
    ref([]:(string*(lexcode list -> preterm * lexcode list))list) in
  (fun dat -> parser_list := dat::(!parser_list)),
  (fun key -> try parser_list := snd (remove (fun (key',_) -> key = key')
                                                 (!parser_list))
                  with Failure _ -> ()),
  (fun () -> !parser_list),
  (fun i -> try_parsers (!parser_list) i);;

(* ------------------------------------------------------------------------- *)
(* Initial preterm parsing. This uses binder and precedence/associativity/   *)
(* prefix status to guide parsing and preterm construction, but treats all   *)
(* identifiers as variables.                                                 *)
(*                                                                           *)
(* PRETERM            :: APPL_PRETERM binop APPL_PRETERM                     *)
(*                     | APPL_PRETERM                                        *)
(*                                                                           *)
(* APPL_PRETERM       :: APPL_PRETERM : type                                 *)
(*                     | APPL_PRETERM BINDER_PRETERM                         *)
(*                     | BINDER_PRETERM                                      *)
(*                                                                           *)
(* BINDER_PRETERM     :: binder VARSTRUCT_PRETERMS . PRETERM                 *)
(*                     | let PRETERM and ... and PRETERM in PRETERM          *)
(*                     | ATOMIC_PRETERM                                      *)
(*                                                                           *)
(* VARSTRUCT_PRETERMS :: TYPED_PRETERM VARSTRUCT_PRETERMS                    *)
(*                     | TYPED_PRETERM                                       *)
(*                                                                           *)
(* TYPED_PRETERM      :: TYPED_PRETERM : type                                *)
(*                     | ATOMIC_PRETERM                                      *)
(*                                                                           *)
(* ATOMIC_PRETERM     :: ( PRETERM )                                         *)
(*                     | if PRETERM then PRETERM else PRETERM                *)
(*                     | [ PRETERM; .. ; PRETERM ]                           *)
(*                     | { PRETERM, .. , PRETERM }                           *)
(*                     | { PRETERM | PRETERM }                               *)
(*                     | identifier                                          *)
(*                                                                           *)
(* Note that arbitrary preterms are allowed as varstructs. This allows       *)
(* more general forms of matching and considerably regularizes the syntax.   *)
(* ------------------------------------------------------------------------- *)

let parse_preterm =
  let rec pfrees ptm acc =
    match ptm with
      Varp(v,pty) ->
        if v = "" & pty = dpty then acc
        else if can get_const_type v or can num_of_string v
                or exists (fun (w,_) -> v = w) (!the_interface) then acc
        else insert ptm acc
    | Constp(_,_) -> acc
    | Combp(p1,p2) -> pfrees p1 (pfrees p2 acc)
    | Absp(p1,p2) -> subtract (pfrees p2 acc) (pfrees p1 [])
    | Typing(p,_) -> pfrees p acc in
  let pdest_eq (Combp(Combp(Varp(("="|"<=>"),_),l),r)) = l,r in
  let pmk_let (letbindings,body) =
    let vars,tms = unzip (map pdest_eq letbindings) in
    let lend = Combp(Varp("LET_END",dpty),body) in
    let abs = itlist (fun v t -> Absp(v,t)) vars lend in
    let labs = Combp(Varp("LET",dpty),abs) in
    rev_itlist (fun x f -> Combp(f,x)) tms labs in
  let pmk_vbinder(n,v,bod) =
    if n = "\\" then Absp(v,bod)
    else Combp(Varp(n,dpty),Absp(v,bod)) in
  let pmk_binder(n,vs,bod) =
    itlist (fun v b -> pmk_vbinder(n,v,b)) vs bod in
  let pmk_set_enum ptms =
    itlist (fun x t -> Combp(Combp(Varp("INSERT",dpty),x),t)) ptms
           (Varp("EMPTY",dpty)) in
  let pgenvar =
    let gcounter = ref 0 in
    fun () -> let count = !gcounter in
              (gcounter := count + 1;
               Varp("GEN%PVAR%"^(string_of_int count),dpty)) in
  let pmk_exists(v,ptm) = Combp(Varp("?",dpty),Absp(v,ptm)) in
  let pmk_list els =
    itlist (fun x y -> Combp(Combp(Varp("CONS",dpty),x),y))
           els (Varp("NIL",dpty)) in
  let pmk_bool =
    let tt = Varp("T",dpty) and ff = Varp("F",dpty) in
    fun b -> if b then tt else ff in
  let pmk_char c =
    let lis = map (fun i -> pmk_bool((c / (1 lsl i)) mod 2 = 1)) (0--7) in
    itlist (fun x y -> Combp(y,x)) lis (Varp("ASCII",dpty)) in
  let pmk_string s =
    let ns = map (fun i -> Char.code(String.get s i))
                 (0--(String.length s - 1)) in
    pmk_list(map pmk_char ns) in
  let pmk_setcompr (fabs,bvs,babs) =
    let v = pgenvar() in
    let bod = itlist (curry pmk_exists) bvs
                     (Combp(Combp(Combp(Varp("SETSPEC",dpty),v),babs),fabs)) in
    Combp(Varp("GSPEC",dpty),Absp(v,bod)) in
  let pmk_setabs (fabs,babs) =
    let evs =
      let fvs = pfrees fabs []
      and bvs = pfrees babs [] in
      if length fvs <= 1 or bvs = [] then fvs
      else intersect fvs bvs in
    pmk_setcompr (fabs,evs,babs) in
  let rec mk_precedence infxs prs inp =
    match infxs with
      (s,(p,at))::_ ->
          let topins,rest = partition (fun (s',pat') -> pat' = (p,at)) infxs in
          (if at = "right" then rightbin else leftbin)
          (mk_precedence rest prs)
          (end_itlist (||) (map (fun (s,_) -> a (Ident s)) topins))
          (fun (Ident op) x y -> Combp(Combp(Varp(op,dpty),x),y))
          ("term after binary operator")
          inp
    | _ -> prs inp in
  let pmk_geq s t = Combp(Combp(Varp("GEQ",dpty),s),t) in
  let pmk_pattern ((pat,guards),res) =
    let x = pgenvar() and y = pgenvar() in
    let vs = pfrees pat []
    and bod =
     if guards = [] then
       Combp(Combp(Varp("_UNGUARDED_PATTERN",dpty),pmk_geq pat x),
             pmk_geq res y)
     else
       Combp(Combp(Combp(Varp("_GUARDED_PATTERN",dpty),pmk_geq pat x),
                   hd guards),
             pmk_geq res y) in
    Absp(x,Absp(y,itlist (curry pmk_exists) vs bod)) in
  let pretype = parse_pretype
  and string inp =
    match inp with
      Ident s::rst when String.length s >= 2 &
                        String.sub s 0 1 = "\"" &
                        String.sub s (String.length s - 1) 1 = "\""
       -> String.sub s 1 (String.length s - 2),rst
    | _ -> raise Noparse
  and singleton1 x = [x]
  and lmk_ite (((((_,b),_),l),_),r) =
          Combp(Combp(Combp(Varp("COND",dpty),b),l),r)
  and lmk_typed =
    function (p,[]) -> p | (p,[ty]) -> Typing(p,ty) | _ -> fail()
  and lmk_let (((_,bnds),_),ptm) = pmk_let (bnds,ptm)
  and lmk_binder ((((s,h),t),_),p) = pmk_binder(s,h::t,p)
  and lmk_setenum(l,_) = pmk_set_enum l
  and lmk_setabs(((l,_),r),_) = pmk_setabs(l,r)
  and lmk_setcompr(((((f,_),vs),_),b),_) =
     pmk_setcompr(f,pfrees vs [],b)
  and lmk_decimal ((_,l0),ropt) =
    let l,r = if ropt = [] then l0,"1" else
              let r0 = hd ropt in
              let n_l = num_of_string l0
              and n_r = num_of_string r0 in
              let n_d = power_num (Int 10) (Int (String.length r0)) in
              let n_n = n_l */ n_d +/ n_r in
              string_of_num n_n,string_of_num n_d in
     Combp(Combp(Varp("DECIMAL",dpty),Varp(l,dpty)),Varp(r,dpty))
  and lmk_univ((_,pty),_) =
    Typing(Varp("UNIV",dpty),Ptycon("fun",[pty;Ptycon("bool",[])]))
  and any_identifier =
    function
        ((Ident s):: rest) -> s,rest
      | _ -> raise Noparse
  and identifier =
    function
       ((Ident s):: rest) ->
        if can get_infix_status s or is_prefix s or parses_as_binder s
        then raise Noparse else s,rest
      | _ -> raise Noparse
  and binder =
    function
        ((Ident s):: rest) ->
        if parses_as_binder s then s,rest else raise Noparse
      | _ -> raise Noparse
  and pre_fix =
    function
        ((Ident s):: rest) ->
        if is_prefix s then s,rest else raise Noparse
      | _ -> raise Noparse in
  let rec preterm i =
    mk_precedence (infixes()) typed_appl_preterm i
  and nocommapreterm i =
    let infs = filter (fun (s,_) -> s <> ",") (infixes()) in
    mk_precedence infs typed_appl_preterm i
  and typed_appl_preterm i =
    (appl_preterm ++
     possibly (a (Resword ":") ++ pretype >> snd)
    >> lmk_typed) i
  and appl_preterm i =
    (pre_fix ++ appl_preterm
    >> (fun (x,y) -> Combp(Varp(x,dpty),y))
  || binder_preterm ++ many binder_preterm >>
        (fun (h,t) -> itlist (fun x y -> Combp(y,x)) (rev t) h)) i
  and binder_preterm i =
    (a (Resword "let") ++
     leftbin (preterm >> singleton1) (a (Resword "and")) (K (@)) "binding" ++
     a (Resword "in") ++
     preterm
    >> lmk_let
  || binder ++
     typed_apreterm ++
     many typed_apreterm ++
     a (Resword ".") ++
     preterm
    >> lmk_binder
  || atomic_preterm) i
  and typed_apreterm i =
    (atomic_preterm ++
     possibly (a (Resword ":") ++ pretype >> snd)
    >> lmk_typed) i
  and atomic_preterm i =
    (try_user_parser
  || (a (Resword "(") ++ a (Resword ":")) ++ pretype ++ a (Resword ")")
    >> lmk_univ
  || string
     >> pmk_string
  || a (Resword "(") ++
     (any_identifier >> (fun s -> Varp(s,dpty))) ++
     a (Resword ")")
    >> (snd o fst)
  || a (Resword "(") ++
     preterm ++
     a (Resword ")")
    >> (snd o fst)
  || a (Resword "if") ++
     preterm ++
     a (Resword "then") ++
     preterm ++
     a (Resword "else") ++
     preterm
     >> lmk_ite
  || a (Resword "[") ++
     elistof preterm (a (Resword ";")) "term" ++
     a (Resword "]")
    >> (pmk_list o snd o fst)
  || a (Resword "{") ++
     (elistof nocommapreterm (a (Ident ",")) "term" ++  a (Resword "}")
            >> lmk_setenum
      || preterm ++ a (Resword "|") ++ preterm ++ a (Resword "}")
            >> lmk_setabs
      || preterm ++ a (Resword "|") ++ preterm ++
         a (Resword "|") ++ preterm ++ a (Resword "}")
            >> lmk_setcompr)
    >> snd
  || a (Resword "match") ++ preterm ++ a (Resword "with") ++ clauses
     >> (fun (((_,e),_),c) -> Combp(Combp(Varp("_MATCH",dpty),e),c))
  || a (Resword "function") ++ clauses
     >> (fun (_,c) -> Combp(Varp("_FUNCTION",dpty),c))
  || a (Ident "#") ++ identifier ++
     possibly (a (Resword ".") ++ identifier >> snd)
    >> lmk_decimal
  || identifier
    >> (fun s -> Varp(s,dpty))) i
  and pattern i =
    (preterm ++ possibly (a (Resword "when") ++ preterm >> snd)) i
  and clause i =
   ((pattern ++ (a (Resword "->") ++ preterm >> snd)) >> pmk_pattern) i
  and clauses i =
   ((possibly (a (Resword "|")) ++
     listof clause (a (Resword "|")) "pattern-match clause" >> snd)
    >> end_itlist (fun s t -> Combp(Combp(Varp("_SEQPATTERN",dpty),s),t))) i in
  preterm;;

(* ------------------------------------------------------------------------- *)
(* Type and term parsers.                                                    *)
(* ------------------------------------------------------------------------- *)

let parse_type s =
  let pty,l = (parse_pretype o lex o explode) s in
  if l = [] then type_of_pretype pty
  else failwith "Unparsed input following type";;

let parse_term s =
  let ptm,l = (parse_preterm o lex o explode) s in
  if l = [] then
   (term_of_preterm o (retypecheck [])) ptm
  else failwith "Unparsed input following term";;
(* ========================================================================= *)
(* Simplistic HOL Light prettyprinter, using the OCaml "Format" library.     *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

include Format;;

set_max_boxes 100;;

(* ------------------------------------------------------------------------- *)
(* Flag determining whether interface/overloading is reversed on printing.   *)
(* ------------------------------------------------------------------------- *)

let reverse_interface_mapping = ref true;;

(* ------------------------------------------------------------------------- *)
(* Determine binary operators that print without surrounding spaces.         *)
(* ------------------------------------------------------------------------- *)

let unspaced_binops = ref [","; ".."; "$"];;

(* ------------------------------------------------------------------------- *)
(* Binary operators to print at start of line when breaking.                 *)
(* ------------------------------------------------------------------------- *)

let prebroken_binops = ref ["==>"];;

(* ------------------------------------------------------------------------- *)
(* Force explicit indications of bound variables in set abstractions.        *)
(* ------------------------------------------------------------------------- *)

let print_unambiguous_comprehensions = ref false;;

(* ------------------------------------------------------------------------- *)
(* Print the universal set UNIV:A->bool as "(:A)".                           *)
(* ------------------------------------------------------------------------- *)

let typify_universal_set = ref true;;

(* ------------------------------------------------------------------------- *)
(* Flag controlling whether hypotheses print.                                *)
(* ------------------------------------------------------------------------- *)

let print_all_thm = ref true;;

(* ------------------------------------------------------------------------- *)
(* Get the name of a constant or variable.                                   *)
(* ------------------------------------------------------------------------- *)

let name_of tm =
  match tm with
    Var(x,ty) | Const(x,ty) -> x
  | _ -> "";;

(* ------------------------------------------------------------------------- *)
(* Printer for types.                                                        *)
(* ------------------------------------------------------------------------- *)

let pp_print_type,pp_print_qtype =
  let soc sep flag ss =
    if ss = [] then "" else
    let s = end_itlist (fun s1 s2 -> s1^sep^s2) ss in
    if flag then "("^s^")" else s in
  let rec sot pr ty =
    try dest_vartype ty with Failure _ ->
    match dest_type ty with
      con,[] -> con
    | "fun",[ty1;ty2] -> soc "->" (pr > 0) [sot 1 ty1; sot 0 ty2]
    | "sum",[ty1;ty2] -> soc "+" (pr > 2) [sot 3 ty1; sot 2 ty2]
    | "prod",[ty1;ty2] -> soc "#" (pr > 4) [sot 5 ty1; sot 4 ty2]
    | "cart",[ty1;ty2] -> soc "^" (pr > 6) [sot 6 ty1; sot 7 ty2]
    | con,args -> (soc "," true (map (sot 0) args))^con in
  (fun fmt ty -> pp_print_string fmt (sot 0 ty)),
  (fun fmt ty -> pp_print_string fmt ("`:" ^ sot 0 ty ^ "`"));;

(* ------------------------------------------------------------------------- *)
(* Allow the installation of user printers. Must fail quickly if N/A.        *)
(* ------------------------------------------------------------------------- *)

let install_user_printer,delete_user_printer,try_user_printer =
  let user_printers = ref ([]:(string*(term->unit))list) in
  (fun pr -> user_printers := pr::(!user_printers)),
  (fun s -> user_printers := snd(remove (fun (s',_) -> s = s')
                                        (!user_printers))),
  (fun tm -> tryfind (fun (_,pr) -> pr tm) (!user_printers));;

(* ------------------------------------------------------------------------- *)
(* Printer for terms.                                                        *)
(* ------------------------------------------------------------------------- *)

let pp_print_term =
  let reverse_interface (s0,ty0) =
    if not(!reverse_interface_mapping) then s0 else
    try fst(find (fun (s,(s',ty)) -> s' = s0 & can (type_match ty ty0) [])
                 (!the_interface))
    with Failure _ -> s0 in
  let DEST_BINARY c tm =
    try let il,r = dest_comb tm in
        let i,l = dest_comb il in
        if i = c or
           (is_const i & is_const c &
            reverse_interface(dest_const i) = reverse_interface(dest_const c))
        then l,r else fail()
    with Failure _ -> failwith "DEST_BINARY"
  and ARIGHT s =
    match snd(get_infix_status s) with
    "right" -> true | _ -> false in
  let rec powerof10 n =
    if abs_num n </ Int 1 then false
    else if n =/ Int 1 then true
    else powerof10 (n // Int 10) in
  let bool_of_term t =
    match t with
      Const("T",_) -> true
    | Const("F",_) -> false
    | _ -> failwith "bool_of_term" in
  let code_of_term t =
    let f,tms = strip_comb t in
    if not(is_const f & fst(dest_const f) = "ASCII")
       or not(length tms = 8) then failwith "code_of_term"
    else
       itlist (fun b f -> if b then 1 + 2 * f else 2 * f)
              (map bool_of_term (rev tms)) 0 in
  let rec dest_clause tm =
    let pbod = snd(strip_exists(body(body tm))) in
    let s,args = strip_comb pbod in
    if name_of s = "_UNGUARDED_PATTERN" & length args = 2 then
      [rand(rator(hd args));rand(rator(hd(tl args)))]
    else if name_of s = "_GUARDED_PATTERN" & length args = 3 then
      [rand(rator(hd args)); hd(tl args); rand(rator(hd(tl(tl args))))]
    else failwith "dest_clause" in
  let rec dest_clauses tm =
    let s,args = strip_comb tm in
    if name_of s = "_SEQPATTERN" & length args = 2 then
      dest_clause (hd args)::dest_clauses(hd(tl args))
    else [dest_clause tm] in
  fun fmt ->
    let rec print_term prec tm =
      try try_user_printer tm with Failure _ ->
      try pp_print_string fmt (string_of_num(dest_numeral tm)) with Failure _ ->
      try (let tms = dest_list tm in
           try if fst(dest_type(hd(snd(dest_type(type_of tm))))) <> "char"
               then fail() else
               let ccs = map (String.make 1 o Char.chr o code_of_term) tms in
               let s = "\"" ^ String.escaped (implode ccs) ^ "\"" in
               pp_print_string fmt s
           with Failure _ ->
               pp_print_string fmt "[";
               print_term_sequence "; " 0 tms;
               pp_print_string fmt "]")
      with Failure _ ->
      if is_gabs tm then print_binder prec tm else
      let hop,args = strip_comb tm in
      let s0 = name_of hop
      and ty0 = type_of hop in
      let s = reverse_interface (s0,ty0) in
      try if s = "EMPTY" & is_const tm & args = [] then
          pp_print_string fmt "{}" else fail()
      with Failure _ ->
      try if s = "UNIV" & !typify_universal_set & is_const tm & args = [] then
            let ty = fst(dest_fun_ty(type_of tm)) in
            (pp_print_string fmt "(:";
             pp_print_type fmt ty;
             pp_print_string fmt ")")
          else fail()
      with Failure _ ->
      try if s <> "INSERT" then fail() else
          let mems,oth = splitlist (dest_binary "INSERT") tm in
          if is_const oth & fst(dest_const oth) = "EMPTY" then
            (pp_print_string fmt "{";
             print_term_sequence ", " 14 mems;
             pp_print_string fmt "}")
          else fail()
      with Failure _ ->
      try if not (s = "GSPEC") then fail() else
          let evs,bod = strip_exists(body(rand tm)) in
          let bod1,fabs = dest_comb bod in
          let bod2,babs = dest_comb bod1 in
          let c = rator bod2 in
          if fst(dest_const c) <> "SETSPEC" then fail() else
          pp_print_string fmt "{";
          print_term 0 fabs;
          pp_print_string fmt " | ";
          (let fvs = frees fabs and bvs = frees babs in
           if not(!print_unambiguous_comprehensions) &
              set_eq evs
               (if (length fvs <= 1 or bvs = []) then fvs
                else intersect fvs bvs)
           then ()
           else (print_term_sequence "," 14 evs;
                 pp_print_string fmt " | "));
          print_term 0 babs;
          pp_print_string fmt "}"
      with Failure _ ->
      try let eqs,bod = dest_let tm in
          (if prec = 0 then pp_open_hvbox fmt 0
           else (pp_open_hvbox fmt 1; pp_print_string fmt "(");
           pp_print_string fmt "let ";
           print_term 0 (mk_eq(hd eqs));
           do_list (fun (v,t) -> pp_print_break fmt 1 0;
                                 pp_print_string fmt "and ";
                                 print_term 0 (mk_eq(v,t)))
                   (tl eqs);
           pp_print_string fmt " in";
           pp_print_break fmt 1 0;
           print_term 0 bod;
           if prec = 0 then () else pp_print_string fmt ")";
           pp_close_box fmt ())
      with Failure _ -> try
        if s <> "DECIMAL" then fail() else
        let n_num = dest_numeral (hd args)
        and n_den = dest_numeral (hd(tl args)) in
        if not(powerof10 n_den) then fail() else
        let s_num = string_of_num(quo_num n_num n_den) in
        let s_den = implode(tl(explode(string_of_num
                        (n_den +/ (mod_num n_num n_den))))) in
        pp_print_string fmt("#"^s_num^(if n_den = Int 1 then "" else ".")^s_den)
      with Failure _ -> try
        if s <> "_MATCH" or length args <> 2 then failwith "" else
        let cls = dest_clauses(hd(tl args)) in
        (if prec = 0 then () else pp_print_string fmt "(";
         pp_open_hvbox fmt 0;
         pp_print_string fmt "match ";
         print_term 0 (hd args);
         pp_print_string fmt " with";
         pp_print_break fmt 1 2;
         print_clauses cls;
         pp_close_box fmt ();
         if prec = 0 then () else pp_print_string fmt ")")
      with Failure _ -> try
        if s <> "_FUNCTION" or length args <> 1 then failwith "" else
        let cls = dest_clauses(hd args) in
        (if prec = 0 then () else pp_print_string fmt "(";
         pp_open_hvbox fmt 0;
         pp_print_string fmt "function";
         pp_print_break fmt 1 2;
         print_clauses cls;
         pp_close_box fmt ();
         if prec = 0 then () else pp_print_string fmt ")")
      with Failure _ ->
      if s = "COND" & length args = 3 then
        (if prec = 0 then () else pp_print_string fmt "(";
         pp_open_hvbox fmt (-1);
         pp_print_string fmt "if ";
         print_term 0 (hd args);
         pp_print_break fmt 0 0;
         pp_print_string fmt " then ";
         print_term 0 (hd(tl args));
         pp_print_break fmt 0 0;
         pp_print_string fmt " else ";
         print_term 0 (hd(tl(tl args)));
         pp_close_box fmt ();
         if prec = 0 then () else pp_print_string fmt ")")
      else if is_prefix s & length args = 1 then
        (if prec = 1000 then pp_print_string fmt "(" else ();
         pp_print_string fmt s;
         (if isalnum s or
           s = "--" &
           length args = 1 &
           (try let l,r = dest_comb(hd args) in
                let s0 = name_of l and ty0 = type_of l in
                reverse_interface (s0,ty0) = "--" or
                mem (fst(dest_const l)) ["real_of_num"; "int_of_num"]
            with Failure _ -> false) or
           s = "~" & length args = 1 & is_neg(hd args)
          then pp_print_string fmt " " else ());
         print_term 999 (hd args);
         if prec = 1000 then pp_print_string fmt ")" else ())
      else if parses_as_binder s & length args = 1 & is_gabs (hd args) then
        print_binder prec tm
      else if can get_infix_status s & length args = 2 then
        let bargs =
          if ARIGHT s then
            let tms,tmt = splitlist (DEST_BINARY hop) tm in tms@[tmt]
          else
            let tmt,tms = rev_splitlist (DEST_BINARY hop) tm in tmt::tms in
        let newprec = fst(get_infix_status s) in
        (if newprec <= prec then
          (pp_open_hvbox fmt 1; pp_print_string fmt "(")
         else pp_open_hvbox fmt 0;
         print_term newprec (hd bargs);
         do_list (fun x -> if mem s (!unspaced_binops) then ()
                           else if mem s (!prebroken_binops)
                           then pp_print_break fmt 1 0
                           else pp_print_string fmt " ";
                           pp_print_string fmt s;
                           if mem s (!unspaced_binops)
                           then pp_print_break fmt 0 0
                           else if mem s (!prebroken_binops)
                           then pp_print_string fmt " "
                           else pp_print_break fmt 1 0;
                           print_term newprec x) (tl bargs);
         if newprec <= prec then pp_print_string fmt ")" else ();
         pp_close_box fmt ())
      else if (is_const hop or is_var hop) & args = [] then
        let s' = if parses_as_binder s or can get_infix_status s or is_prefix s
                 then "("^s^")" else s in
        pp_print_string fmt s'
      else
        let l,r = dest_comb tm in
        (pp_open_hvbox fmt 0;
         if prec = 1000 then pp_print_string fmt "(" else ();
         print_term 999 l;
         (if try mem (fst(dest_const l)) ["real_of_num"; "int_of_num"]
             with Failure _ -> false
          then () else pp_print_space fmt ());
         print_term 1000 r;
         if prec = 1000 then pp_print_string fmt ")" else ();
         pp_close_box fmt ())

    and print_term_sequence sep prec tms =
      if tms = [] then () else
      (print_term prec (hd tms);
       let ttms = tl tms in
       if ttms = [] then ()
       else (pp_print_string fmt sep; print_term_sequence sep prec ttms))

    and print_binder prec tm =
      let absf = is_gabs tm in
      let s = if absf then "\\" else name_of(rator tm) in
      let rec collectvs tm =
        if absf then
          if is_abs tm then
            let v,t = dest_abs tm in
            let vs,bod = collectvs t in (false,v)::vs,bod
          else if is_gabs tm then
            let v,t = dest_gabs tm in
            let vs,bod = collectvs t in (true,v)::vs,bod
          else [],tm
        else if is_comb tm & name_of(rator tm) = s then
          if is_abs(rand tm) then
            let v,t = dest_abs(rand tm) in
            let vs,bod = collectvs t in (false,v)::vs,bod
          else if is_gabs(rand tm) then
            let v,t = dest_gabs(rand tm) in
            let vs,bod = collectvs t in (true,v)::vs,bod
          else [],tm
        else [],tm in
      let vs,bod = collectvs tm in
      ((if prec = 0 then pp_open_hvbox fmt 4
        else (pp_open_hvbox fmt 5; pp_print_string fmt "("));
       pp_print_string fmt s;
       (if isalnum s then pp_print_string fmt " " else ());
       do_list (fun (b,x) ->
         (if b then pp_print_string fmt "(" else ());
         print_term 0 x;
         (if b then pp_print_string fmt ")" else ());
         pp_print_string fmt " ") (butlast vs);
       (if fst(last vs) then pp_print_string fmt "(" else ());
       print_term 0 (snd(last vs));
       (if fst(last vs) then pp_print_string fmt ")" else ());
       pp_print_string fmt ".";
       (if length vs = 1 then pp_print_string fmt " "
        else pp_print_space fmt ());
       print_term 0 bod;
       (if prec = 0 then () else pp_print_string fmt ")");
       pp_close_box fmt ())
  and print_clauses cls =
    match cls with
      [c] -> print_clause c
    | c::cs -> (print_clause c;
                pp_print_break fmt 1 0;
                pp_print_string fmt "| ";
                print_clauses cs)
  and print_clause cl =
    match cl with
     [p;g;r] -> (print_term 1 p;
                 pp_print_string fmt " when ";
                 print_term 1 g;
                 pp_print_string fmt " -> ";
                 print_term 1 r)
   | [p;r] -> (print_term 1 p;
               pp_print_string fmt " -> ";
               print_term 1 r)
  in print_term 0;;

(* ------------------------------------------------------------------------- *)
(* Print term with quotes.                                                   *)
(* ------------------------------------------------------------------------- *)

let pp_print_qterm fmt tm =
  pp_print_string fmt "`";
  pp_print_term fmt tm;
  pp_print_string fmt "`";;

(* ------------------------------------------------------------------------- *)
(* Printer for theorems.                                                     *)
(* ------------------------------------------------------------------------- *)

let pp_print_thm fmt th =
  let asl,tm = dest_thm th in
  (if not (asl = []) then
    (if !print_all_thm then
      (pp_print_term fmt (hd asl);
       do_list (fun x -> pp_print_string fmt ",";
                         pp_print_space fmt ();
                         pp_print_term fmt x)
               (tl asl))
     else pp_print_string fmt "...";
     pp_print_space fmt ())
   else ();
   pp_open_hbox fmt();
   pp_print_string fmt "|- ";
   pp_print_term fmt tm;
   pp_close_box fmt ());;

(* ------------------------------------------------------------------------- *)
(* Print on standard output.                                                 *)
(* ------------------------------------------------------------------------- *)

let print_type = pp_print_type std_formatter;;
let print_qtype = pp_print_qtype std_formatter;;
let print_term = pp_print_term std_formatter;;
let print_qterm = pp_print_qterm std_formatter;;
let print_thm = pp_print_thm std_formatter;;

(* ------------------------------------------------------------------------- *)
(* Install all the printers.                                                 *)
(* ------------------------------------------------------------------------- *)

(* ------------------------------------------------------------------------- *)
(* Conversions to string.                                                    *)
(* ------------------------------------------------------------------------- *)

let print_to_string printer =
  let sbuff = ref "" in
  let output s m n = sbuff := (!sbuff)^(String.sub s m n) and flush() = () in
  let fmt = make_formatter output flush in
  ignore(pp_set_max_boxes fmt 100);
  fun i -> ignore(printer fmt i);
           ignore(pp_print_flush fmt ());
           let s = !sbuff in sbuff := ""; s;;

let string_of_type = print_to_string pp_print_type;;
let string_of_term = print_to_string pp_print_term;;
let string_of_thm = print_to_string pp_print_thm;;
(* ========================================================================= *)
(* Basic equality reasoning including conversionals.                         *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

type conv = term->thm;;

(* ------------------------------------------------------------------------- *)
(* A bit more syntax.                                                        *)
(* ------------------------------------------------------------------------- *)

let lhand = rand o rator;;

let lhs = fst o dest_eq;;

let rhs = snd o dest_eq;;

(* ------------------------------------------------------------------------- *)
(* Similar to variant, but even avoids constants, and ignores types.         *)
(* ------------------------------------------------------------------------- *)

let mk_primed_var =
  let rec svariant avoid s =
    if mem s avoid or (can get_const_type s & not(is_hidden s)) then
      svariant avoid (s^"'")
    else s in
  fun avoid v ->
    let s,ty = dest_var v in
    let s' = svariant (mapfilter (fst o dest_var) avoid) s in
    mk_var(s',ty);;

(* ------------------------------------------------------------------------- *)
(* General case of beta-conversion.                                          *)
(* ------------------------------------------------------------------------- *)

let BETA_CONV tm =
  try BETA tm with Failure _ ->
  try let f,arg = dest_comb tm in
      let v = bndvar f in
      INST [arg,v] (BETA (mk_comb(f,v)))
  with Failure _ -> failwith "BETA_CONV: Not a beta-redex";;

(* ------------------------------------------------------------------------- *)
(* A few very basic derived equality rules.                                  *)
(* ------------------------------------------------------------------------- *)

let AP_TERM tm th =
  try MK_COMB(REFL tm,th)
  with Failure _ -> failwith "AP_TERM";;

let AP_THM th tm =
  try MK_COMB(th,REFL tm)
  with Failure _ -> failwith "AP_THM";;

let SYM th =
  let tm = concl th in
  let l,r = dest_eq tm in
  let lth = REFL l in
  EQ_MP (MK_COMB(AP_TERM (rator (rator tm)) th,lth)) lth;;

let ALPHA tm1 tm2 =
  try TRANS (REFL tm1) (REFL tm2)
  with Failure _ -> failwith "ALPHA";;

let ALPHA_CONV v tm =
  let res = alpha v tm in
  ALPHA tm res;;

let GEN_ALPHA_CONV v tm =
  if is_abs tm then ALPHA_CONV v tm else
  let b,abs = dest_comb tm in
  AP_TERM b (ALPHA_CONV v abs);;

let MK_BINOP op (lth,rth) =
  MK_COMB(AP_TERM op lth,rth);;

(* ------------------------------------------------------------------------- *)
(* Terminal conversion combinators.                                          *)
(* ------------------------------------------------------------------------- *)

let (NO_CONV:conv) = fun tm -> failwith "NO_CONV";;

let (ALL_CONV:conv) = REFL;;

(* ------------------------------------------------------------------------- *)
(* Combinators for sequencing, trying, repeating etc. conversions.           *)
(* ------------------------------------------------------------------------- *)

let ((THENC):conv -> conv -> conv) =
  fun conv1 conv2 t ->
    let th1 = conv1 t in
    let th2 = conv2 (rand(concl th1)) in
    TRANS th1 th2;;

let ((ORELSEC):conv -> conv -> conv) =
  fun conv1 conv2 t ->
    try conv1 t with Failure _ -> conv2 t;;

let (FIRST_CONV:conv list -> conv) = end_itlist (fun c1 c2 -> c1 ORELSEC c2);;

let (EVERY_CONV:conv list -> conv) =
  fun l -> itlist (fun c1 c2 -> c1 THENC c2) l ALL_CONV;;

let REPEATC =
  let rec REPEATC conv t =
    ((conv THENC (REPEATC conv)) ORELSEC ALL_CONV) t in
  (REPEATC:conv->conv);;

let (CHANGED_CONV:conv->conv) =
  fun conv tm ->
    let th = conv tm in
    let l,r = dest_eq (concl th) in
    if aconv l r then failwith "CHANGED_CONV" else th;;

let TRY_CONV conv = conv ORELSEC ALL_CONV;;

(* ------------------------------------------------------------------------- *)
(* Subterm conversions.                                                      *)
(* ------------------------------------------------------------------------- *)

let (RATOR_CONV:conv->conv) =
  fun conv tm ->
    let l,r = dest_comb tm in AP_THM (conv l) r;;

let (RAND_CONV:conv->conv) =
  fun conv tm ->
    let l,r = dest_comb tm in AP_TERM l (conv r);;

let LAND_CONV = RATOR_CONV o RAND_CONV;;

let (COMB2_CONV: conv->conv->conv) =
  fun lconv rconv tm -> let l,r = dest_comb tm in MK_COMB(lconv l,rconv r);;

let COMB_CONV = W COMB2_CONV;;

let (ABS_CONV:conv->conv) =
  fun conv tm ->
    let v,bod = dest_abs tm in
    let th = conv bod in
    try ABS v th with Failure _ ->
    let gv = genvar(type_of v) in
    let gbod = vsubst[gv,v] bod in
    let gth = ABS gv (conv gbod) in
    let gtm = concl gth in
    let l,r = dest_eq gtm in
    let v' = variant (frees gtm) v in
    let l' = alpha v' l and r' = alpha v' r in
    EQ_MP (ALPHA gtm (mk_eq(l',r'))) gth;;

let BINDER_CONV conv tm =
  if is_abs tm then ABS_CONV conv tm
  else RAND_CONV(ABS_CONV conv) tm;;

let SUB_CONV conv tm =
  match tm with
    Comb(_,_) -> COMB_CONV conv tm
  | Abs(_,_) -> ABS_CONV conv tm
  | _ -> REFL tm;;

let BINOP_CONV conv tm =
  let lop,r = dest_comb tm in
  let op,l = dest_comb lop in
  MK_COMB(AP_TERM op (conv l),conv r);;

(* ------------------------------------------------------------------------- *)
(* Depth conversions; internal use of a failure-propagating `Boultonized'    *)
(* version to avoid a great deal of reuilding of terms.                      *)
(* ------------------------------------------------------------------------- *)

let (ONCE_DEPTH_CONV: conv->conv),
    (DEPTH_CONV: conv->conv),
    (REDEPTH_CONV: conv->conv),
    (TOP_DEPTH_CONV: conv->conv),
    (TOP_SWEEP_CONV: conv->conv) =
  let THENQC conv1 conv2 tm =
    try let th1 = conv1 tm in
        try let th2 = conv2(rand(concl th1)) in TRANS th1 th2
        with Failure _ -> th1
    with Failure _ -> conv2 tm
  and THENCQC conv1 conv2 tm =
    let th1 = conv1 tm in
    try let th2 = conv2(rand(concl th1)) in TRANS th1 th2
    with Failure _ -> th1
  and COMB_QCONV conv tm =
    let l,r = dest_comb tm in
    try let th1 = conv l in
        try let th2 = conv r in MK_COMB(th1,th2)
        with Failure _ -> AP_THM th1 r
    with Failure _ -> AP_TERM l (conv r) in
  let rec REPEATQC conv tm = THENCQC conv (REPEATQC conv) tm in
  let SUB_QCONV conv tm =
    if is_abs tm then ABS_CONV conv tm
    else COMB_QCONV conv tm in
  let rec ONCE_DEPTH_QCONV conv tm =
      (conv ORELSEC (SUB_QCONV (ONCE_DEPTH_QCONV conv))) tm
  and DEPTH_QCONV conv tm =
    THENQC (SUB_QCONV (DEPTH_QCONV conv))
           (REPEATQC conv) tm
  and REDEPTH_QCONV conv tm =
    THENQC (SUB_QCONV (REDEPTH_QCONV conv))
           (THENCQC conv (REDEPTH_QCONV conv)) tm
  and TOP_DEPTH_QCONV conv tm =
    THENQC (REPEATQC conv)
           (THENCQC (SUB_QCONV (TOP_DEPTH_QCONV conv))
                    (THENCQC conv (TOP_DEPTH_QCONV conv))) tm
  and TOP_SWEEP_QCONV conv tm =
    THENQC (REPEATQC conv)
           (SUB_QCONV (TOP_SWEEP_QCONV conv)) tm in
  (fun c -> TRY_CONV (ONCE_DEPTH_QCONV c)),
  (fun c -> TRY_CONV (DEPTH_QCONV c)),
  (fun c -> TRY_CONV (REDEPTH_QCONV c)),
  (fun c -> TRY_CONV (TOP_DEPTH_QCONV c)),
  (fun c -> TRY_CONV (TOP_SWEEP_QCONV c));;

(* ------------------------------------------------------------------------- *)
(* Apply at leaves of op-tree; NB any failures at leaves cause failure.      *)
(* ------------------------------------------------------------------------- *)

let rec DEPTH_BINOP_CONV op conv tm =
  match tm with
    Comb(Comb(op',l),r) when op' = op ->
      let l,r = dest_binop op tm in
      let lth = DEPTH_BINOP_CONV op conv l
      and rth = DEPTH_BINOP_CONV op conv r in
      MK_COMB(AP_TERM op' lth,rth)
  | _ -> conv tm;;

(* ------------------------------------------------------------------------- *)
(* Follow a path.                                                            *)
(* ------------------------------------------------------------------------- *)

let PATH_CONV =
  let rec path_conv s cnv =
    match s with
      [] -> cnv
    | "l"::t -> RATOR_CONV (path_conv t cnv)
    | "r"::t -> RAND_CONV (path_conv t cnv)
    | _::t -> ABS_CONV (path_conv t cnv) in
  fun s cnv -> path_conv (explode s) cnv;;

(* ------------------------------------------------------------------------- *)
(* Follow a pattern                                                          *)
(* ------------------------------------------------------------------------- *)

let PAT_CONV =
  let rec PCONV xs pat conv =
    if mem pat xs then conv
    else if not(exists (fun x -> free_in x pat) xs) then ALL_CONV
    else if is_comb pat then
      COMB2_CONV (PCONV xs (rator pat) conv) (PCONV xs (rand pat) conv)
    else
      ABS_CONV (PCONV xs (body pat) conv) in
  fun pat -> let xs,pbod = strip_abs pat in PCONV xs pbod;;

(* ------------------------------------------------------------------------- *)
(* Symmetry conversion.                                                      *)
(* ------------------------------------------------------------------------- *)

let SYM_CONV tm =
  try let th1 = SYM(ASSUME tm) in
      let tm' = concl th1 in
      let th2 = SYM(ASSUME tm') in
      DEDUCT_ANTISYM_RULE th2 th1
  with Failure _ -> failwith "SYM_CONV";;

(* ------------------------------------------------------------------------- *)
(* Conversion to a rule.                                                     *)
(* ------------------------------------------------------------------------- *)

let CONV_RULE (conv:conv) th =
  EQ_MP (conv(concl th)) th;;

(* ------------------------------------------------------------------------- *)
(* Substitution conversion.                                                  *)
(* ------------------------------------------------------------------------- *)

let SUBS_CONV ths tm =
  try if ths = [] then REFL tm else
      let lefts = map (lhand o concl) ths in
      let gvs = map (genvar o type_of) lefts in
      let pat = subst (zip gvs lefts) tm in
      let abs = list_mk_abs(gvs,pat) in
      let th = rev_itlist
        (fun y x -> CONV_RULE (RAND_CONV BETA_CONV THENC LAND_CONV BETA_CONV)
                              (MK_COMB(x,y))) ths (REFL abs) in
      if rand(concl th) = tm then REFL tm else th
  with Failure _ -> failwith "SUBS_CONV";;

(* ------------------------------------------------------------------------- *)
(* Get a few rules.                                                          *)
(* ------------------------------------------------------------------------- *)

let BETA_RULE = CONV_RULE(REDEPTH_CONV BETA_CONV);;

let GSYM = CONV_RULE(ONCE_DEPTH_CONV SYM_CONV);;

let SUBS ths = CONV_RULE (SUBS_CONV ths);;

(* ------------------------------------------------------------------------- *)
(* A cacher for conversions.                                                 *)
(* ------------------------------------------------------------------------- *)

let CACHE_CONV =
  let ALPHA_HACK th =
    let tm' = lhand(concl th) in
    fun tm -> if tm' = tm then th else TRANS (ALPHA tm tm') th in
  fun conv ->
    let net = ref empty_net in
    fun tm -> try tryfind (fun f -> f tm) (lookup tm (!net))
              with Failure _ ->
                  let th = conv tm in
                  (net := enter [] (tm,ALPHA_HACK th) (!net); th);;
(* ========================================================================= *)
(* Boolean theory including (intuitionistic) defs of logical connectives.    *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Set up parse status of basic and derived logical constants.               *)
(* ------------------------------------------------------------------------- *)

parse_as_prefix "~";;

map parse_as_binder ["\\"; "!"; "?"; "?!"];;

map parse_as_infix ["==>",(4,"right"); "\\/",(6,"right"); "/\\",(8,"right")];;

(* ------------------------------------------------------------------------- *)
(* Set up more orthodox notation for equations and equivalence.              *)
(* ------------------------------------------------------------------------- *)

parse_as_infix("<=>",(2,"right"));;
override_interface ("<=>",`(=):bool->bool->bool`);;
parse_as_infix("=",(12,"right"));;

(* ------------------------------------------------------------------------- *)
(* Special syntax for Boolean equations (IFF).                               *)
(* ------------------------------------------------------------------------- *)

let is_iff tm =
  match tm with
    Comb(Comb(Const("=",Tyapp("fun",[Tyapp("bool",[]);_])),l),r) -> true
  | _ -> false;;

let dest_iff tm =
  match tm with
    Comb(Comb(Const("=",Tyapp("fun",[Tyapp("bool",[]);_])),l),r) -> (l,r)
  | _ -> failwith "dest_iff";;

let mk_iff =
  let eq_tm = `(<=>)` in
  fun (l,r) -> mk_comb(mk_comb(eq_tm,l),r);;

(* ------------------------------------------------------------------------- *)
(* Rule allowing easy instantiation of polymorphic proformas.                *)
(* ------------------------------------------------------------------------- *)

let PINST tyin tmin =
  let iterm_fn = INST (map (I F_F (inst tyin)) tmin)
  and itype_fn = INST_TYPE tyin in
  fun th -> try iterm_fn (itype_fn th)
            with Failure _ -> failwith "PINST";;

(* ------------------------------------------------------------------------- *)
(* Useful derived deductive rule.                                            *)
(* ------------------------------------------------------------------------- *)

let PROVE_HYP ath bth =
  if exists (aconv (concl ath)) (hyp bth)
  then EQ_MP (DEDUCT_ANTISYM_RULE ath bth) ath
  else bth;;

(* ------------------------------------------------------------------------- *)
(* Rules for T                                                               *)
(* ------------------------------------------------------------------------- *)

let T_DEF = new_basic_definition
 `T = ((\p:bool. p) = (\p:bool. p))`;;

let TRUTH = EQ_MP (SYM T_DEF) (REFL `\p:bool. p`);;

let EQT_ELIM th =
  try EQ_MP (SYM th) TRUTH
  with Failure _ -> failwith "EQT_ELIM";;

let EQT_INTRO =
  let t = `t:bool` in
  let pth =
    let th1 = DEDUCT_ANTISYM_RULE (ASSUME t) TRUTH in
    let th2 = EQT_ELIM(ASSUME(concl th1)) in
    DEDUCT_ANTISYM_RULE th2 th1 in
  fun th -> EQ_MP (INST[concl th,t] pth) th;;

(* ------------------------------------------------------------------------- *)
(* Rules for /\                                                              *)
(* ------------------------------------------------------------------------- *)

let AND_DEF = new_basic_definition
 `(/\) = \p q. (\f:bool->bool->bool. f p q) = (\f. f T T)`;;

let mk_conj = mk_binary "/\\";;
let list_mk_conj = end_itlist (curry mk_conj);;

let CONJ =
  let f = `f:bool->bool->bool`
  and p = `p:bool`
  and q = `q:bool` in
  let pth =
    let pth = ASSUME p
    and qth = ASSUME q in
    let th1 = MK_COMB(AP_TERM f (EQT_INTRO pth),EQT_INTRO qth) in
    let th2 = ABS f th1 in
    let th3 = BETA_RULE (AP_THM (AP_THM AND_DEF p) q) in
    EQ_MP (SYM th3) th2 in
  fun th1 th2 ->
    let th = INST [concl th1,p; concl th2,q] pth in
    PROVE_HYP th2 (PROVE_HYP th1 th);;

let CONJUNCT1 =
  let P = `P:bool` and Q = `Q:bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM AND_DEF `P:bool`) in
    let th2 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM th1 `Q:bool`) in
    let th3 = EQ_MP th2 (ASSUME `P /\ Q`) in
    EQT_ELIM(BETA_RULE (AP_THM th3 `\(p:bool) (q:bool). p`)) in
  fun th ->
    try let l,r = dest_conj(concl th) in
        PROVE_HYP th (INST [l,P; r,Q] pth)
    with Failure _ -> failwith "CONJUNCT1";;

let CONJUNCT2 =
  let P = `P:bool` and Q = `Q:bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM AND_DEF `P:bool`) in
    let th2 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM th1 `Q:bool`) in
    let th3 = EQ_MP th2 (ASSUME `P /\ Q`) in
    EQT_ELIM(BETA_RULE (AP_THM th3 `\(p:bool) (q:bool). q`)) in
  fun th ->
    try let l,r = dest_conj(concl th) in
        PROVE_HYP th (INST [l,P; r,Q] pth)
    with Failure _ -> failwith "CONJUNCT2";;

let CONJ_PAIR th =
  try CONJUNCT1 th,CONJUNCT2 th
  with Failure _ -> failwith "CONJ_PAIR: Not a conjunction";;

let CONJUNCTS = striplist CONJ_PAIR;;

(* ------------------------------------------------------------------------- *)
(* Rules for ==>                                                             *)
(* ------------------------------------------------------------------------- *)

let IMP_DEF = new_basic_definition
  `(==>) = \p q. p /\ q <=> p`;;

let mk_imp = mk_binary "==>";;

let MP =
  let p = `p:bool`
  and q = `q:bool` in
  let pth =
    let th1 = BETA_RULE (AP_THM (AP_THM IMP_DEF p) q) in
    let th2 = EQ_MP th1 (ASSUME `p ==> q`) in
    CONJUNCT2 (EQ_MP (SYM th2) (ASSUME `p:bool`)) in
  fun ith th ->
    let ant,con = dest_imp (concl ith) in
    if aconv ant (concl th) then
      PROVE_HYP th (PROVE_HYP ith (INST [ant,p; con,q] pth))
    else failwith "MP: theorems do not agree";;

let DISCH =
  let p = `p:bool`
  and q = `q:bool` in
  let pth = SYM(BETA_RULE (AP_THM (AP_THM IMP_DEF p) q)) in
  fun a th ->
    let th1 = CONJ (ASSUME a) th in
    let th2 = CONJUNCT1 (ASSUME (concl th1)) in
    let th3 = DEDUCT_ANTISYM_RULE th1 th2 in
    let th4 = INST [a,p; concl th,q] pth in
    EQ_MP th4 th3;;

let rec DISCH_ALL th =
  try DISCH_ALL (DISCH (hd (hyp th)) th)
  with Failure _ -> th;;

let UNDISCH th =
  try MP th (ASSUME(rand(rator(concl th))))
  with Failure _ -> failwith "UNDISCH";;

let rec UNDISCH_ALL th =
  if is_imp (concl th) then UNDISCH_ALL (UNDISCH th)
  else th;;

let IMP_ANTISYM_RULE th1 th2 =
  DEDUCT_ANTISYM_RULE (UNDISCH th2) (UNDISCH th1);;

let ADD_ASSUM tm th = MP (DISCH tm th) (ASSUME tm);;

let EQ_IMP_RULE =
  let peq = `p <=> q` in
  let p,q = dest_iff peq in
  let pth1 = DISCH peq (DISCH p (EQ_MP (ASSUME peq) (ASSUME p)))
  and pth2 = DISCH peq (DISCH q (EQ_MP (SYM(ASSUME peq)) (ASSUME q))) in
  fun th -> let l,r = dest_iff(concl th) in
            MP (INST [l,p; r,q] pth1) th,MP (INST [l,p; r,q] pth2) th;;

let IMP_TRANS =
  let pq = `p ==> q`
  and qr = `q ==> r` in
  let p,q = dest_imp pq and r = rand qr in
  let pth = 
    itlist DISCH [pq; qr; p] (MP (ASSUME qr) (MP (ASSUME pq) (ASSUME p))) in
  fun th1 th2 ->
        let x,y = dest_imp(concl th1)
        and y',z = dest_imp(concl th2) in
        if y <> y' then failwith "IMP_TRANS" else
        MP (MP (INST [x,p; y,q; z,r] pth) th1) th2;;

(* ------------------------------------------------------------------------- *)
(* Rules for !                                                               *)
(* ------------------------------------------------------------------------- *)

let FORALL_DEF = new_basic_definition
 `(!) = \P:A->bool. P = \x. T`;;

let mk_forall = mk_binder "!";;
let list_mk_forall(vs,bod) = itlist (curry mk_forall) vs bod;;

let SPEC =
  let P = `P:A->bool`
  and x = `x:A` in
  let pth =
    let th1 = EQ_MP(AP_THM FORALL_DEF `P:A->bool`) (ASSUME `(!)(P:A->bool)`) in
    let th2 = AP_THM (CONV_RULE BETA_CONV th1) `x:A` in
    let th3 = CONV_RULE (RAND_CONV BETA_CONV) th2 in
    DISCH_ALL (EQT_ELIM th3) in
  fun tm th ->
    try let abs = rand(concl th) in
        CONV_RULE BETA_CONV
         (MP (PINST [snd(dest_var(bndvar abs)),aty] [abs,P; tm,x] pth) th)
    with Failure _ -> failwith "SPEC";;

let SPECL tms th =
  try rev_itlist SPEC tms th
  with Failure _ -> failwith "SPECL";;

let SPEC_VAR th =
  let bv = variant (thm_frees th) (bndvar(rand(concl th))) in
  bv,SPEC bv th;;

let rec SPEC_ALL th =
  if is_forall(concl th) then SPEC_ALL(snd(SPEC_VAR th)) else th;;

let ISPEC t th =
  let x,_ = try dest_forall(concl th) with Failure _ ->
    failwith "ISPEC: input theorem not universally quantified" in
  let tyins = try type_match (snd(dest_var x)) (type_of t) [] with Failure _ ->
    failwith "ISPEC can't type-instantiate input theorem" in
  try SPEC t (INST_TYPE tyins th)
  with Failure _ -> failwith "ISPEC: type variable(s) free in assumptions";;

let ISPECL tms th =
  try if tms = [] then th else
      let avs = fst (chop_list (length tms) (fst(strip_forall(concl th)))) in
      let tyins = itlist2 type_match (map (snd o dest_var) avs)
                          (map type_of tms) [] in
      SPECL tms (INST_TYPE tyins th)
  with Failure _ -> failwith "ISPECL";;

let GEN =
  let P = `P:A->bool`
  and pth =
    let th1 = ASSUME `P = \x:A. T` in
    let th2 = AP_THM FORALL_DEF `P:A->bool` in
    EQ_MP (SYM(CONV_RULE(RAND_CONV BETA_CONV) th2)) th1 in
  fun x th ->
   PROVE_HYP (ABS x (EQT_INTRO th))
             (PINST [snd(dest_var x),aty] [mk_abs(x,concl th),P] pth);;

let GENL = itlist GEN;;

let GEN_ALL th =
  let asl,c = dest_thm th in
  let vars = subtract (frees c) (freesl asl) in
  GENL vars th;;

(* ------------------------------------------------------------------------- *)
(* Rules for ?                                                               *)
(* ------------------------------------------------------------------------- *)

let EXISTS_DEF = new_basic_definition
 `(?) = \P:A->bool. !q. (!x. P x ==> q) ==> q`;;

let mk_exists =  mk_binder "?";;
let list_mk_exists(vs,bod) =  itlist (curry mk_exists) vs bod;;

let EXISTS =
  let P = `P:A->bool` and x = `x:A` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM EXISTS_DEF P) in
    let th2 = SPEC `x:A` (ASSUME `!x:A. P x ==> Q`) in
    let th3 = DISCH `!x:A. P x ==> Q` (MP th2 (ASSUME `(P:A->bool) x`)) in
    EQ_MP (SYM th1) (GEN `Q:bool` th3) in
  fun (etm,stm) th ->
    try let qf,abs = dest_comb etm in
        let bth = BETA_CONV(mk_comb(abs,stm)) in
        let cth = PINST [type_of stm,aty] [abs,P; stm,x] pth in
        PROVE_HYP (EQ_MP (SYM bth) th) cth
    with Failure _ -> failwith "EXISTS";;

let SIMPLE_EXISTS v th =
  EXISTS (mk_exists(v,concl th),v) th;;

let CHOOSE =
  let P = `P:A->bool` and Q = `Q:bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM EXISTS_DEF P) in
    let th2 = SPEC `Q:bool` (UNDISCH(fst(EQ_IMP_RULE th1))) in
    DISCH_ALL (DISCH `(?) (P:A->bool)` (UNDISCH th2)) in
  fun (v,th1) th2 ->
    try let abs = rand(concl th1) in
        let bv,bod = dest_abs abs in
        let cmb = mk_comb(abs,v) in
        let pat = vsubst[v,bv] bod in
        let th3 = CONV_RULE BETA_CONV (ASSUME cmb) in
        let th4 = GEN v (DISCH cmb (MP (DISCH pat th2) th3)) in
        let th5 = PINST [snd(dest_var v),aty] [abs,P; concl th2,Q] pth in
        MP (MP th5 th4) th1
    with Failure _ -> failwith "CHOOSE";;

let SIMPLE_CHOOSE v th =
  CHOOSE(v,ASSUME (mk_exists(v,hd(hyp th)))) th;;

(* ------------------------------------------------------------------------- *)
(* Rules for \/                                                              *)
(* ------------------------------------------------------------------------- *)

let OR_DEF = new_basic_definition
 `(\/) = \p q. !r. (p ==> r) ==> (q ==> r) ==> r`;;

let mk_disj = mk_binary "\\/";;
let list_mk_disj = end_itlist (curry mk_disj);;

let DISJ1 =
  let P = `P:bool` and Q = `Q:bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM OR_DEF `P:bool`) in
    let th2 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM th1 `Q:bool`) in
    let th3 = MP (ASSUME `P ==> t`) (ASSUME `P:bool`) in
    let th4 = GEN `t:bool` (DISCH `P ==> t` (DISCH `Q ==> t` th3)) in
    EQ_MP (SYM th2) th4 in
  fun th tm ->
    try PROVE_HYP th (INST [concl th,P; tm,Q] pth)
    with Failure _ -> failwith "DISJ1";;

let DISJ2 =
  let P = `P:bool` and Q = `Q:bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM OR_DEF `P:bool`) in
    let th2 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM th1 `Q:bool`) in
    let th3 = MP (ASSUME `Q ==> t`) (ASSUME `Q:bool`) in
    let th4 = GEN `t:bool` (DISCH `P ==> t` (DISCH `Q ==> t` th3)) in
    EQ_MP (SYM th2) th4 in
  fun tm th ->
    try PROVE_HYP th (INST [tm,P; concl th,Q] pth)
    with Failure _ -> failwith "DISJ2";;

let DISJ_CASES =
  let P = `P:bool` and Q = `Q:bool` and R = `R:bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM OR_DEF `P:bool`) in
    let th2 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM th1 `Q:bool`) in
    let th3 = SPEC `R:bool` (EQ_MP th2 (ASSUME `P \/ Q`)) in
    UNDISCH (UNDISCH th3) in
  fun th0 th1 th2 ->
    try let c1 = concl th1 and c2 = concl th2 in
        if not (aconv c1 c2) then failwith "DISJ_CASES" else
        let l,r = dest_disj (concl th0) in
        let th = INST [l,P; r,Q; c1,R] pth in
        PROVE_HYP (DISCH r th2) (PROVE_HYP (DISCH l th1) (PROVE_HYP th0 th))
    with Failure _ -> failwith "DISJ_CASES";;

let SIMPLE_DISJ_CASES th1 th2 =
  DISJ_CASES (ASSUME(mk_disj(hd(hyp th1),hd(hyp th2)))) th1 th2;;

(* ------------------------------------------------------------------------- *)
(* Rules for negation and falsity.                                           *)
(* ------------------------------------------------------------------------- *)

let F_DEF = new_basic_definition
 `F = !p:bool. p`;;

let NOT_DEF = new_basic_definition
 `(~) = \p. p ==> F`;;

let mk_neg =
  let neg_tm = `(~)` in
  fun tm -> try mk_comb(neg_tm,tm)
            with Failure _ -> failwith "mk_neg";;

let NOT_ELIM =
  let P = `P:bool` in
  let pth = CONV_RULE(RAND_CONV BETA_CONV) (AP_THM NOT_DEF P) in
  fun th ->
    try EQ_MP (INST [rand(concl th),P] pth) th
    with Failure _ -> failwith "NOT_ELIM";;

let NOT_INTRO =
  let P = `P:bool` in
  let pth = SYM(CONV_RULE(RAND_CONV BETA_CONV) (AP_THM NOT_DEF P)) in
  fun th ->
    try EQ_MP (INST [rand(rator(concl th)),P] pth) th
    with Failure _ -> failwith "NOT_INTRO";;

let EQF_INTRO =
  let P = `P:bool` in
  let pth =
    let th1 = NOT_ELIM (ASSUME `~ P`)
    and th2 = DISCH `F` (SPEC P (EQ_MP F_DEF (ASSUME `F`))) in
    DISCH_ALL (IMP_ANTISYM_RULE th1 th2) in
  fun th ->
    try MP (INST [rand(concl th),P] pth) th
    with Failure _ -> failwith "EQF_INTRO";;

let EQF_ELIM =
  let P = `P:bool` in
  let pth =
    let th1 = EQ_MP (ASSUME `P = F`) (ASSUME `P:bool`) in
    let th2 = DISCH P (SPEC `F` (EQ_MP F_DEF th1)) in
    DISCH_ALL (NOT_INTRO th2) in
  fun th ->
    try MP (INST [rand(rator(concl th)),P] pth) th
    with Failure _ -> failwith "EQF_ELIM";;

let CONTR =
  let P = `P:bool` and f_tm = `F` in
  let pth = SPEC P (EQ_MP F_DEF (ASSUME `F`)) in
  fun tm th ->
    if concl th <> f_tm then failwith "CONTR"
    else PROVE_HYP th (INST [tm,P] pth);;

(* ------------------------------------------------------------------------- *)
(* Rules for unique existence.                                               *)
(* ------------------------------------------------------------------------- *)

let EXISTS_UNIQUE_DEF = new_basic_definition
 `(?!) = \P:A->bool. ((?) P) /\ (!x y. P x /\ P y ==> x = y)`;;

let mk_uexists = mk_binder "?!";;

let EXISTENCE =
  let P = `P:A->bool` in
  let pth =
    let th1 = CONV_RULE (RAND_CONV BETA_CONV) (AP_THM EXISTS_UNIQUE_DEF P) in
    let th2 = UNDISCH (fst(EQ_IMP_RULE th1)) in
    DISCH_ALL (CONJUNCT1 th2) in
  fun th ->
    try let abs = rand(concl th) in
        let ty = snd(dest_var(bndvar abs)) in
        MP (PINST [ty,aty] [abs,P] pth) th
    with Failure _ -> failwith "EXISTENCE";;
(* ========================================================================= *)
(* More sophisticated derived rules including definitions and rewriting.     *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

type instantiation =
  (int * term) list * (term * term) list * (hol_type * hol_type) list;;

(* ------------------------------------------------------------------------- *)
(* The last recourse when all else fails!                                    *)
(* ------------------------------------------------------------------------- *)

let mk_thm(asl,c) =
  let ax = new_axiom(itlist (curry mk_imp) (rev asl) c) in
  rev_itlist (fun t th -> MP th (ASSUME t)) (rev asl) ax;;

(* ------------------------------------------------------------------------- *)
(* Derived congruence rules; very useful things!                             *)
(* ------------------------------------------------------------------------- *)

let MK_CONJ =
  let andtm = `(/\)` in
  fun eq1 eq2 -> MK_COMB(AP_TERM andtm eq1,eq2);;

let MK_DISJ =
  let ortm = `(\/)` in
  fun eq1 eq2 -> MK_COMB(AP_TERM ortm eq1,eq2);;

let MK_FORALL =
  let atm = mk_const("!",[]) in
  fun v th -> AP_TERM (inst [type_of v,aty] atm) (ABS v th);;

let MK_EXISTS =
  let atm = mk_const("?",[]) in
  fun v th -> AP_TERM (inst [type_of v,aty] atm) (ABS v th);;

(* ------------------------------------------------------------------------- *)
(* Eliminate the antecedent of a theorem using a conversion/proof rule.      *)
(* ------------------------------------------------------------------------- *)

let MP_CONV (cnv:conv) th =
  let l,r = dest_imp(concl th) in
  let ath = cnv l in
  try MP th (EQT_ELIM ath) with Failure _ -> MP th ath;;

(* ------------------------------------------------------------------------- *)
(* Multiple beta-reduction (we use a slight variant below).                  *)
(* ------------------------------------------------------------------------- *)

let rec BETAS_CONV tm =
  match tm with
    Comb(Abs(_,_),_) -> BETA_CONV tm
  | Comb(Comb(_,_),_) -> (RATOR_CONV BETAS_CONV THENC BETA_CONV) tm
  | _ -> failwith "BETAS_CONV";;

(* ------------------------------------------------------------------------- *)
(* Instantiators.                                                            *)
(* ------------------------------------------------------------------------- *)

let (instantiate :instantiation->term->term) =
  let betas n tm =
    let args,lam = funpow n (fun (l,t) -> (rand t)::l,rator t) ([],tm) in
    rev_itlist (fun a l -> let v,b = dest_abs l in vsubst[a,v] b) args lam in
  let rec ho_betas bcs pat tm =
    if is_var pat or is_const pat then fail() else
    try let bv,bod = dest_abs tm in
        mk_abs(bv,ho_betas bcs (body pat) bod)
    with Failure _ ->
        let hop,args = strip_comb pat in
        try let n = rev_assoc hop bcs in
            if length args = n then betas n tm else fail()
        with Failure _ ->
            let lpat,rpat = dest_comb pat in
            let ltm,rtm = dest_comb tm in
            try let lth = ho_betas bcs lpat ltm in
                try let rth = ho_betas bcs rpat rtm in
                    mk_comb(lth,rth)
                with Failure _ ->
                    mk_comb(lth,rtm)
            with Failure _ ->
                let rth = ho_betas bcs rpat rtm in
                mk_comb(ltm,rth) in
  fun (bcs,tmin,tyin) tm ->
    let itm = if tyin = [] then tm else inst tyin tm in
    if tmin = [] then itm else
    let ttm = vsubst tmin itm in
    if bcs = [] then ttm else
    try ho_betas bcs itm ttm with Failure _ -> ttm;;

let (INSTANTIATE : instantiation->thm->thm) =
  let rec BETAS_CONV n tm =
    if n = 1 then TRY_CONV BETA_CONV tm else
    (RATOR_CONV (BETAS_CONV (n-1)) THENC
     TRY_CONV BETA_CONV) tm in
  let rec HO_BETAS bcs pat tm =
    if is_var pat or is_const pat then fail() else
    try let bv,bod = dest_abs tm in
        ABS bv (HO_BETAS bcs (body pat) bod)
    with Failure _ ->
        let hop,args = strip_comb pat in
        try let n = rev_assoc hop bcs in
            if length args = n then BETAS_CONV n tm else fail()
        with Failure _ ->
            let lpat,rpat = dest_comb pat in
            let ltm,rtm = dest_comb tm in
            try let lth = HO_BETAS bcs lpat ltm in
                try let rth = HO_BETAS bcs rpat rtm in
                    MK_COMB(lth,rth)
                with Failure _ ->
                    AP_THM lth rtm
            with Failure _ ->
                let rth = HO_BETAS bcs rpat rtm in
                AP_TERM ltm rth in
  fun (bcs,tmin,tyin) th ->
    let ith = if tyin = [] then th else INST_TYPE tyin th in
    if tmin = [] then ith else
    let tth = INST tmin ith in
    if hyp tth = hyp th then
      if bcs = [] then tth else
      try let eth = HO_BETAS bcs (concl ith) (concl tth) in
          EQ_MP eth tth
      with Failure _ -> tth
    else failwith "INSTANTIATE: term or type var free in assumptions";;

let (INSTANTIATE_ALL : instantiation->thm->thm) =
  fun ((_,tmin,tyin) as i) th ->
    if tmin = [] & tyin = [] then th else
    let hyps = hyp th in
    if hyps = [] then INSTANTIATE i th else
    let tyrel,tyiirel =
      if tyin = [] then [],hyps else
      let tvs = itlist (union o tyvars o snd) tyin [] in
      partition (fun tm -> let tvs' = type_vars_in_term tm in
                           not(intersect tvs tvs' = [])) hyps in
    let tmrel,tmirrel =
      if tmin = [] then [],tyiirel else
      let vs = itlist (union o frees o snd) tmin [] in
      partition (fun tm -> let vs' = frees tm in
                           not (intersect vs vs' = [])) tyiirel in
    let rhyps = union tyrel tmrel in
    let th1 = rev_itlist DISCH rhyps th in
    let th2 = INSTANTIATE i th1 in
    funpow (length rhyps) UNDISCH th2;;

(* ------------------------------------------------------------------------- *)
(* Higher order matching of terms.                                           *)
(*                                                                           *)
(* Note: in the event of spillover patterns, this may return false results;  *)
(* but there's usually an implicit check outside that the match worked       *)
(* anyway. A test could be put in (see if any "env" variables are left in    *)
(* the term after abstracting out the pattern instances) but it'd be slower. *)
(* ------------------------------------------------------------------------- *)

let (term_match:term list -> term -> term -> instantiation) =
  let safe_inserta ((y,x) as n) l =
    try let z = rev_assoc x l in
        if aconv y z then l else failwith "safe_inserta"
    with Failure "find" -> n::l in

  let safe_insert ((y,x) as n) l =
    try let z = rev_assoc x l in
        if Pervasives.compare y z = 0 then l else failwith "safe_insert"
    with Failure "find" -> n::l in

  let mk_dummy =
    let name = fst(dest_var(genvar aty)) in
    fun ty -> mk_var(name,ty) in

  let rec term_pmatch lconsts env vtm ctm ((insts,homs) as sofar) =
    match (vtm,ctm) with
      Var(_,_),_ ->
       (try let ctm' = rev_assoc vtm env in
            if Pervasives.compare ctm' ctm = 0 then sofar 
            else failwith "term_pmatch"
        with Failure "find" ->
            if mem vtm lconsts then
              if Pervasives.compare ctm vtm = 0 then sofar
              else failwith "term_pmatch: can't instantiate local constant"
            else safe_inserta (ctm,vtm) insts,homs)
    | Const(vname,vty),Const(cname,cty) ->
        if Pervasives.compare vname cname = 0 then
          if Pervasives.compare vty cty = 0 then sofar
          else safe_insert (mk_dummy cty,mk_dummy vty) insts,homs
        else failwith "term_pmatch"
    | Abs(vv,vbod),Abs(cv,cbod) ->
        let sofar' = safe_insert
          (mk_dummy(snd(dest_var cv)),mk_dummy(snd(dest_var vv))) insts,homs in
        term_pmatch lconsts ((cv,vv)::env) vbod cbod sofar'
    | _ ->
      let vhop = repeat rator vtm in
      if is_var vhop & not (mem vhop lconsts) &
                       not (can (rev_assoc vhop) env) then
        let vty = type_of vtm and cty = type_of ctm in
        let insts' =
          if Pervasives.compare vty cty = 0 then insts
          else safe_insert (mk_dummy cty,mk_dummy vty) insts in
        (insts',(env,ctm,vtm)::homs)
      else
        let lv,rv = dest_comb vtm
        and lc,rc = dest_comb ctm in
        let sofar' = term_pmatch lconsts env lv lc sofar in
        term_pmatch lconsts env rv rc sofar' in

  let get_type_insts insts =
    itlist (fun (t,x) -> type_match (snd(dest_var x)) (type_of t)) insts in

  let separate_insts insts =
      let realinsts,patterns = partition (is_var o snd) insts in
      let betacounts =
        if patterns = [] then [] else
        itlist
          (fun (_,p) sof ->
            let hop,args = strip_comb p in
            try safe_insert (length args,hop) sof with Failure _ ->
            (warn true "Inconsistent patterning in higher order match"; sof))
          patterns [] in
      let tyins = get_type_insts realinsts [] in
      betacounts,
      mapfilter (fun (t,x) ->
        let x' = let xn,xty = dest_var x in
                 mk_var(xn,type_subst tyins xty) in
        if Pervasives.compare t x' = 0 then fail() else (t,x')) realinsts,
      tyins in

  let rec term_homatch lconsts tyins (insts,homs) =
    if homs = [] then insts else
    let (env,ctm,vtm) = hd homs in
    if is_var vtm then
      if Pervasives.compare ctm vtm = 0 
       then term_homatch lconsts tyins (insts,tl homs) else
      let newtyins = safe_insert (type_of ctm,snd(dest_var vtm)) tyins
      and newinsts = (ctm,vtm)::insts in
      term_homatch lconsts newtyins (newinsts,tl homs) else
    let vhop,vargs = strip_comb vtm in
    let afvs = freesl vargs in
    let inst_fn = inst tyins in
    try let tmins = map
          (fun a -> (try rev_assoc a env with Failure _ -> try
                         rev_assoc a insts with Failure _ ->
                         if mem a lconsts then a else fail()),
                    inst_fn a) afvs in
        let pats0 = map inst_fn vargs in
        let pats = map (vsubst tmins) pats0 in
        let vhop' = inst_fn vhop in
        let ni =
          let chop,cargs = strip_comb ctm in
          if Pervasives.compare cargs pats = 0 then
            if Pervasives.compare chop vhop = 0 
            then insts else safe_inserta (chop,vhop) insts else
          let ginsts = map
            (fun p -> (if is_var p then p else genvar(type_of p)),p) pats in
          let ctm' = subst ginsts ctm
          and gvs = map fst ginsts in
          let abstm = list_mk_abs(gvs,ctm') in
          let vinsts = safe_inserta (abstm,vhop) insts in
          let icpair = ctm',list_mk_comb(vhop',gvs) in
          icpair::vinsts in
        term_homatch lconsts tyins (ni,tl homs)
    with Failure _ ->
        let lc,rc = dest_comb ctm
        and lv,rv = dest_comb vtm in
        let pinsts_homs' =
          term_pmatch lconsts env rv rc (insts,(env,lc,lv)::(tl homs)) in
        let tyins' = get_type_insts (fst pinsts_homs') [] in
        term_homatch lconsts tyins' pinsts_homs' in

  fun lconsts vtm ctm ->
    let pinsts_homs = term_pmatch lconsts [] vtm ctm ([],[]) in
    let tyins = get_type_insts (fst pinsts_homs) [] in
    let insts = term_homatch lconsts tyins pinsts_homs in
    separate_insts insts;;

(* ------------------------------------------------------------------------- *)
(* First order unification (no type instantiation -- yet).                   *)
(* ------------------------------------------------------------------------- *)

let (term_unify:term list -> term -> term -> instantiation) =
  let augment1 sofar (s,x) =
    let s' = subst sofar s in
    if vfree_in x s & not (s = x) then failwith "augment_insts"
    else (s',x) in
  let raw_augment_insts p insts =
    p::(map (augment1 [p]) insts) in
  let augment_insts(t,v) insts =
    let t' = vsubst insts t in
    if t' = v then insts
    else if vfree_in v t' then failwith "augment_insts"
    else raw_augment_insts (t',v) insts in
  let rec unify vars tm1 tm2 sofar =
    if tm1 = tm2 then sofar
    else if is_var tm1 & mem tm1 vars then
      try let tm1' = rev_assoc tm1 sofar in
          unify vars tm1' tm2 sofar
      with Failure "find" ->
          augment_insts (tm2,tm1) sofar
    else if is_var tm2 & mem tm2 vars then
       try let tm2' = rev_assoc tm2 sofar in
          unify vars tm1 tm2' sofar
      with Failure "find" ->
          augment_insts (tm1,tm2) sofar
    else if is_abs tm1 then
      let tm1' = body tm1
      and tm2' = subst [bndvar tm1,bndvar tm2] (body tm2) in
      unify vars tm1' tm2' sofar
    else
      let l1,r1 = dest_comb tm1
      and l2,r2 = dest_comb tm2 in
      unify vars l1 l2 (unify vars r1 r2 sofar) in
  fun vars tm1 tm2 -> [],unify vars tm1 tm2 [],[];;

(* ------------------------------------------------------------------------- *)
(* Modify bound variable names at depth. (Not very efficient...)             *)
(* ------------------------------------------------------------------------- *)

let deep_alpha =
  let tryalpha v tm =
    try alpha v tm
    with Failure _ -> try
        let v' = variant (frees tm) v in
        alpha v' tm
    with Failure _ -> tm in
  let rec deep_alpha env tm =
    if env = [] then tm else
    try let v,bod = dest_abs tm in
        let vn,vty = dest_var v in
        try let (vn',_),newenv = remove (fun (_,x) -> x = vn) env in
            let v' = mk_var(vn',vty) in
            let tm' = tryalpha v' tm in
            let iv,ib = dest_abs tm' in
            mk_abs(iv,deep_alpha newenv ib)
        with Failure _ -> mk_abs(v,deep_alpha env bod)
    with Failure _ -> try
        let l,r = dest_comb tm in
        mk_comb(deep_alpha env l,deep_alpha env r)
    with Failure _ -> tm in
  deep_alpha;;

(* ------------------------------------------------------------------------- *)
(* Instantiate theorem by matching part of it to a term.                     *)
(* The GEN_PART_MATCH version renames free vars to avoid clashes.            *)
(* ------------------------------------------------------------------------- *)

let PART_MATCH,GEN_PART_MATCH =
  let rec match_bvs t1 t2 acc =
    try let v1,b1 = dest_abs t1
        and v2,b2 = dest_abs t2 in
        let n1 = fst(dest_var v1) and n2 = fst(dest_var v2) in
        let newacc = if n1 = n2 then acc else insert (n1,n2) acc in
        match_bvs b1 b2 newacc
    with Failure _ -> try
        let l1,r1 = dest_comb t1
        and l2,r2 = dest_comb t2 in
        match_bvs l1 l2 (match_bvs r1 r2 acc)
    with Failure _ -> acc in
  let PART_MATCH partfn th =
    let sth = SPEC_ALL th in
    let bod = concl sth in
    let pbod = partfn bod in
    let lconsts = intersect (frees (concl th)) (freesl(hyp th)) in
    fun tm ->
      let bvms = match_bvs tm pbod [] in
      let abod = deep_alpha bvms bod in
      let ath = EQ_MP (ALPHA bod abod) sth in
      let insts = term_match lconsts (partfn abod) tm in
      let fth = INSTANTIATE insts ath in
      if hyp fth <> hyp ath then failwith "PART_MATCH: instantiated hyps" else
      let tm' = partfn (concl fth) in
      if Pervasives.compare tm' tm = 0 then fth else
      try SUBS[ALPHA tm' tm] fth
      with Failure _ -> failwith "PART_MATCH: Sanity check failure"
  and GEN_PART_MATCH partfn th =
    let sth = SPEC_ALL th in
    let bod = concl sth in
    let pbod = partfn bod in
    let lconsts = intersect (frees (concl th)) (freesl(hyp th)) in
    let fvs = subtract (subtract (frees bod) (frees pbod)) lconsts in
    fun tm ->
      let bvms = match_bvs tm pbod [] in
      let abod = deep_alpha bvms bod in
      let ath = EQ_MP (ALPHA bod abod) sth in
      let insts = term_match lconsts (partfn abod) tm in
      let eth = INSTANTIATE insts (GENL fvs ath) in
      let fth = itlist (fun v th -> snd(SPEC_VAR th)) fvs eth in
      if hyp fth <> hyp ath then failwith "PART_MATCH: instantiated hyps" else
      let tm' = partfn (concl fth) in
      if Pervasives.compare tm' tm = 0 then fth else
      try SUBS[ALPHA tm' tm] fth
      with Failure _ -> failwith "PART_MATCH: Sanity check failure" in
  PART_MATCH,GEN_PART_MATCH;;

(* ------------------------------------------------------------------------- *)
(* Matching modus ponens.                                                    *)
(* ------------------------------------------------------------------------- *)

let MATCH_MP ith =
  let sth =
    try let tm = concl ith in
        let avs,bod = strip_forall tm in
        let ant,con = dest_imp bod in
        let svs,pvs = partition (C vfree_in ant) avs in
        if pvs = [] then ith else
        let th1 = SPECL avs (ASSUME tm) in
        let th2 = GENL svs (DISCH ant (GENL pvs (UNDISCH th1))) in
        MP (DISCH tm th2) ith
    with Failure _ -> failwith "MATCH_MP: Not an implication" in
  let match_fun = PART_MATCH (fst o dest_imp) sth in
  fun th -> try MP (match_fun (concl th)) th
            with Failure _ -> failwith "MATCH_MP: No match";;

(* ------------------------------------------------------------------------- *)
(* Useful instance of more general higher order matching.                    *)
(* ------------------------------------------------------------------------- *)

let HIGHER_REWRITE_CONV =
  let BETA_VAR =
    let rec BETA_CONVS n =
      if n = 1 then TRY_CONV BETA_CONV else
      RATOR_CONV (BETA_CONVS (n - 1)) THENC TRY_CONV BETA_CONV in
    let rec free_beta v tm =
      if is_abs tm then
        let bv,bod = dest_abs tm in
        if v = bv then failwith "unchanged" else
        ABS_CONV(free_beta v bod) else
      let op,args = strip_comb tm in
      if args = [] then failwith "unchanged" else
      if op = v then BETA_CONVS (length args) else
      let l,r = dest_comb tm in
      try let lconv = free_beta v l in
          (try let rconv = free_beta v r in
               COMB2_CONV lconv rconv
           with Failure _ -> RATOR_CONV lconv)
      with Failure _ -> RAND_CONV (free_beta v r) in
    free_beta in
  let GINST th =
    let fvs = subtract (frees(concl th)) (freesl (hyp th)) in
    let gvs = map (genvar o type_of) fvs in
    INST (zip gvs fvs) th in
  fun ths ->
    let thl = map (GINST o SPEC_ALL) ths in
    let concs = map concl thl in
    let lefts = map lhs concs in
    let preds,pats = unzip(map dest_comb lefts) in
    let beta_fns = map2 BETA_VAR preds concs in
    let ass_list = zip pats (zip preds (zip thl beta_fns)) in
    let mnet = itlist (fun p n -> enter [] (p,p) n) pats empty_net in
    let look_fn t =
      mapfilter (fun p -> if can (term_match [] p) t then p else fail())
                (lookup t mnet) in
    fun top tm ->
      let pred t = not (look_fn t = []) & free_in t tm in
      let stm = if top then find_term pred tm
                else hd(sort free_in (find_terms pred tm)) in
      let pat = hd(look_fn stm) in
      let _,tmin,tyin = term_match [] pat stm in
      let pred,(th,beta_fn) = assoc pat ass_list in
      let gv = genvar(type_of stm) in
      let abs = mk_abs(gv,subst[gv,stm] tm) in
      let _,tmin0,tyin0 = term_match [] pred abs in
      CONV_RULE beta_fn (INST tmin (INST tmin0 (INST_TYPE tyin0 th)));;

(* ------------------------------------------------------------------------- *)
(* Derived principle of definition justifying |- c x1 .. xn = t[x1,..,xn]    *)
(* ------------------------------------------------------------------------- *)

let new_definition tm =
  let avs,bod = strip_forall tm in
  let l,r = try dest_eq bod
    with Failure _ -> failwith "new_definition: Not an equation" in
  let lv,largs = strip_comb l in
  let rtm = try list_mk_abs(largs,r)
    with Failure _ -> failwith "new_definition: Non-variable in LHS pattern" in
  let def = mk_eq(lv,rtm) in
  let th1 = new_basic_definition def in
  let th2 = rev_itlist
    (fun tm th -> let ith = AP_THM th tm in
                  TRANS ith (BETA_CONV(rand(concl ith)))) largs th1 in
  let rvs = filter (not o C mem avs) largs in
  itlist GEN rvs (itlist GEN avs th2);;
(* ========================================================================= *)
(* System of tactics (slightly different from any traditional LCF method).   *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let null_inst = ([],[],[] :instantiation);;

let null_meta = (([]:term list),null_inst);;

(* ------------------------------------------------------------------------- *)
(* A goal has labelled assumptions, and the hyps are now thms.               *)
(* ------------------------------------------------------------------------- *)

type goal = (string * thm) list * term;;

let equals_goal ((a,w):goal) ((a',w'):goal) =
  forall2 (fun (s,th) (s',th') -> s = s' & equals_thm th th') a a' & w = w';;

(* ------------------------------------------------------------------------- *)
(* A justification function for a goalstate [A1 ?- g1; ...; An ?- gn],       *)
(* starting from an initial goal A ?- g, is a function f such that for any   *)
(* instantiation @:                                                          *)
(*                                                                           *)
(*   f(@) [A1@ |- g1@; ...; An@ |- gn@] = A@ |- g@                           *)
(* ------------------------------------------------------------------------- *)

type justification = instantiation -> thm list -> thm;;

(* ------------------------------------------------------------------------- *)
(* The goalstate stores the subgoals, justification, current instantiation,  *)
(* and a list of metavariables.                                              *)
(* ------------------------------------------------------------------------- *)

type goalstate = (term list * instantiation) * goal list * justification;;

(* ------------------------------------------------------------------------- *)
(* A goalstack is just a list of goalstates. Could go for more...            *)
(* ------------------------------------------------------------------------- *)

type goalstack = goalstate list;;

(* ------------------------------------------------------------------------- *)
(* A refinement, applied to a goalstate [A1 ?- g1; ...; An ?- gn]            *)
(* yields a new goalstate with updated justification function, to            *)
(* give a possibly-more-instantiated version of the initial goal.            *)
(* ------------------------------------------------------------------------- *)

type refinement = goalstate -> goalstate;;

(* ------------------------------------------------------------------------- *)
(* A tactic, applied to a goal A ?- g, returns:                              *)
(*                                                                           *)
(*  o A list of new metavariables introduced                                 *)
(*  o An instantiation (%)                                                   *)
(*  o A list of subgoals                                                     *)
(*  o A justification f such that for any instantiation @ we have            *)
(*    f(@) [A1@  |- g1@; ...; An@ |- gn@] = A(%;@) |- g(%;@)                 *)
(* ------------------------------------------------------------------------- *)

type tactic = goal -> goalstate;;

type thm_tactic = thm -> tactic;;

type thm_tactical = thm_tactic -> thm_tactic;;

(* ------------------------------------------------------------------------- *)
(* Apply instantiation to a goal.                                            *)
(* ------------------------------------------------------------------------- *)

let (inst_goal:instantiation->goal->goal) =
  fun p (thms,w) ->
    map (I F_F INSTANTIATE_ALL p) thms,instantiate p w;;

(* ------------------------------------------------------------------------- *)
(* Perform a sequential composition (left first) of instantiations.          *)
(* ------------------------------------------------------------------------- *)

let (compose_insts :instantiation->instantiation->instantiation) =
  fun (pats1,tmin1,tyin1) ((pats2,tmin2,tyin2) as i2) ->
    let tmin = map (instantiate i2 F_F inst tyin2) tmin1
    and tyin = map (type_subst tyin2 F_F I) tyin1 in
    let tmin' = filter (fun (_,x) -> not (can (rev_assoc x) tmin)) tmin2
    and tyin' = filter (fun (_,a) -> not (can (rev_assoc a) tyin)) tyin2 in
    pats1@pats2,tmin@tmin',tyin@tyin';;

(* ------------------------------------------------------------------------- *)
(* Construct A,_FALSITY_ |- p; contortion so falsity is the last element.    *)
(* ------------------------------------------------------------------------- *)

let _FALSITY_ = new_definition `_FALSITY_ = F`;;

let mk_fthm =
  let pth = UNDISCH(fst(EQ_IMP_RULE _FALSITY_))
  and qth = ASSUME `_FALSITY_` in
  fun (asl,c) -> PROVE_HYP qth (itlist ADD_ASSUM (rev asl) (CONTR c pth));;

(* ------------------------------------------------------------------------- *)
(* Validity checking of tactics. This cannot be 100% accurate without making *)
(* arbitrary theorems, but "mk_fthm" brings us quite close.                  *)
(* ------------------------------------------------------------------------- *)

let (VALID:tactic->tactic) =
  let fake_thm (asl,w) =
    let asms = itlist (union o hyp o snd) asl [] in
    mk_fthm(asms,w)
  and false_tm = `_FALSITY_` in
  fun tac (asl,w) ->
    let ((mvs,i),gls,just as res) = tac (asl,w) in
    let ths = map fake_thm gls in
    let asl',w' = dest_thm(just null_inst ths) in
    let asl'',w'' = inst_goal i (asl,w) in
    let maxasms =
      itlist (fun (_,th) -> union (insert (concl th) (hyp th))) asl'' [] in
    if aconv w' w'' &
       forall (fun t -> exists (aconv t) maxasms) (subtract asl' [false_tm])
    then res else failwith "VALID: Invalid tactic";;

(* ------------------------------------------------------------------------- *)
(* Various simple combinators for tactics, identity tactic etc.              *)
(* ------------------------------------------------------------------------- *)

let (THEN),(THENL) =
  let propagate_empty i [] = []
  and propagate_thm th i [] = INSTANTIATE_ALL i th in
  let compose_justs n just1 just2 i ths =
    let ths1,ths2 = chop_list n ths in
    (just1 i ths1)::(just2 i ths2) in
  let rec seqapply l1 l2 = match (l1,l2) with
     ([],[]) -> null_meta,[],propagate_empty
   | ((tac:tactic)::tacs),((goal:goal)::goals) ->
            let ((mvs1,insts1),gls1,just1) = tac goal in
            let goals' = map (inst_goal insts1) goals in
            let ((mvs2,insts2),gls2,just2) = seqapply tacs goals' in
            ((union mvs1 mvs2,compose_insts insts1 insts2),
             gls1@gls2,compose_justs (length gls1) just1 just2)
   | _,_ -> failwith "seqapply: Length mismatch" in
  let justsequence just1 just2 insts2 i ths =
    just1 (compose_insts insts2 i) (just2 i ths) in
  let tacsequence ((mvs1,insts1),gls1,just1) tacl =
    let ((mvs2,insts2),gls2,just2) = seqapply tacl gls1 in
    let jst = justsequence just1 just2 insts2 in
    let just = if gls2 = [] then propagate_thm (jst null_inst []) else jst in
    ((union mvs1 mvs2,compose_insts insts1 insts2),gls2,just) in
  let (then_: tactic -> tactic -> tactic) =
    fun tac1 tac2 g ->
      let _,gls,_ as gstate = tac1 g in
      tacsequence gstate (replicate tac2 (length gls))
  and (thenl_: tactic -> tactic list -> tactic) =
    fun tac1 tac2l g ->
      let _,gls,_ as gstate = tac1 g in
      if gls = [] then tacsequence gstate []
      else tacsequence gstate tac2l in
  then_,thenl_;;

let ((ORELSE): tactic -> tactic -> tactic) =
  fun tac1 tac2 g ->
    try tac1 g with Failure _ -> tac2 g;;

let (FAIL_TAC: string -> tactic) =
  fun tok g -> failwith tok;;

let (NO_TAC: tactic) =
  FAIL_TAC "NO_TAC";;

let (ALL_TAC:tactic) =
  fun g -> null_meta,[g],fun _ [th] -> th;;

let TRY tac =
  tac ORELSE ALL_TAC;;

let rec REPEAT tac g =
  ((tac THEN REPEAT tac) ORELSE ALL_TAC) g;;

let EVERY tacl =
  itlist (fun t1 t2 -> t1 THEN t2) tacl ALL_TAC;;

let (FIRST: tactic list -> tactic) =
  fun tacl g -> end_itlist (fun t1 t2 -> t1 ORELSE t2) tacl g;;

let MAP_EVERY tacf lst =
  EVERY (map tacf lst);;

let MAP_FIRST tacf lst =
  FIRST (map tacf lst);;

let (CHANGED_TAC: tactic -> tactic) =
  fun tac g ->
    let (meta,gl,_ as gstate) = tac g in
    if meta = null_meta & length gl = 1 & equals_goal (hd gl) g
    then failwith "CHANGED_TAC" else gstate;;

let rec REPLICATE_TAC n tac =
  if n <= 0 then ALL_TAC else tac THEN (REPLICATE_TAC (n - 1) tac);;

(* ------------------------------------------------------------------------- *)
(* Combinators for theorem continuations / "theorem tacticals".              *)
(* ------------------------------------------------------------------------- *)

let ((THEN_TCL): thm_tactical -> thm_tactical -> thm_tactical) =
  fun ttcl1 ttcl2 ttac -> ttcl1 (ttcl2 ttac);;

let ((ORELSE_TCL): thm_tactical -> thm_tactical -> thm_tactical) =
  fun ttcl1 ttcl2 ttac th ->
    try ttcl1 ttac th with Failure _ -> ttcl2 ttac th;;

let rec REPEAT_TCL ttcl ttac th =
  ((ttcl THEN_TCL (REPEAT_TCL ttcl)) ORELSE_TCL I) ttac th;;

let (REPEAT_GTCL: thm_tactical -> thm_tactical) =
  let rec REPEAT_GTCL ttcl ttac th g =
    try ttcl (REPEAT_GTCL ttcl ttac) th g with Failure _ -> ttac th g in
  REPEAT_GTCL;;

let (ALL_THEN: thm_tactical) =
  I;;

let (NO_THEN: thm_tactical) =
  fun ttac th -> failwith "NO_THEN";;

let EVERY_TCL ttcll =
  itlist (fun t1 t2 -> t1 THEN_TCL t2) ttcll ALL_THEN;;

let FIRST_TCL ttcll =
  end_itlist (fun t1 t2 -> t1 ORELSE_TCL t2) ttcll;;

(* ------------------------------------------------------------------------- *)
(* Tactics to augment assumption list. Note that to allow "ASSUME p" for     *)
(* any assumption "p", these add a PROVE_HYP in the justification function,  *)
(* just in case.                                                             *)
(* ------------------------------------------------------------------------- *)

let (LABEL_TAC: string -> thm_tactic) =
  fun s thm (asl,w) ->
    null_meta,[(s,thm)::asl,w],
    fun i [th] -> PROVE_HYP (INSTANTIATE_ALL i thm) th;;

let ASSUME_TAC = LABEL_TAC "";;

(* ------------------------------------------------------------------------- *)
(* Manipulation of assumption list.                                          *)
(* ------------------------------------------------------------------------- *)

let (FIND_ASSUM: thm_tactic -> term -> tactic) =
  fun ttac t ((asl,w) as g) ->
    ttac(snd(find (fun (_,th) -> concl th = t) asl)) g;;

let (POP_ASSUM: thm_tactic -> tactic) =
  fun ttac ->
   function (((_,th)::asl),w) -> ttac th (asl,w)
    | _ -> failwith "POP_ASSUM: No assumption to pop";;

let (ASSUM_LIST: (thm list -> tactic) -> tactic) =
    fun aslfun (asl,w) -> aslfun (map snd asl) (asl,w);;

let (POP_ASSUM_LIST: (thm list -> tactic) -> tactic) =
  fun asltac (asl,w) -> asltac (map snd asl) ([],w);;

let (EVERY_ASSUM: thm_tactic -> tactic) =
  fun ttac -> ASSUM_LIST (MAP_EVERY ttac);;

let (FIRST_ASSUM: thm_tactic -> tactic) =
  fun ttac (asl,w as g) -> tryfind (fun (_,th) -> ttac th g) asl;;

let (RULE_ASSUM_TAC :(thm->thm)->tactic) =
  fun rule (asl,w) -> (POP_ASSUM_LIST(K ALL_TAC) THEN
                       MAP_EVERY (fun (s,th) -> LABEL_TAC s (rule th))
                                 (rev asl)) (asl,w);;

(* ------------------------------------------------------------------------- *)
(* Operate on assumption identified by a label.                              *)
(* ------------------------------------------------------------------------- *)

let (USE_THEN:string->thm_tactic->tactic) =
  fun s ttac (asl,w as gl) ->
    let th = try assoc s asl with Failure _ ->
             failwith("USE_TAC: didn't find assumption "^s) in
    ttac th gl;;

let (REMOVE_THEN:string->thm_tactic->tactic) =
  fun s ttac (asl,w) ->
    let th = try assoc s asl with Failure _ ->
             failwith("USE_TAC: didn't find assumption "^s) in
    let asl1,asl2 = chop_list(index s (map fst asl)) asl in
    let asl' = asl1 @ tl asl2 in
    ttac th (asl',w);;

(* ------------------------------------------------------------------------- *)
(* General tool to augment a required set of theorems with assumptions.      *)
(* ------------------------------------------------------------------------- *)

let (ASM :(thm list -> tactic)->(thm list -> tactic)) =
  fun tltac ths (asl,w as g) -> tltac (map snd asl @ ths) g;;

(* ------------------------------------------------------------------------- *)
(* Basic tactic to use a theorem equal to the goal. Does *no* matching.      *)
(* ------------------------------------------------------------------------- *)

let (ACCEPT_TAC: thm_tactic) =
  let propagate_thm th i [] = INSTANTIATE_ALL i th in
  fun th (asl,w) ->
    if aconv (concl th) w then
      null_meta,[],propagate_thm th
    else failwith "ACCEPT_TAC";;

(* ------------------------------------------------------------------------- *)
(* Create tactic from a conversion. This allows the conversion to return     *)
(* |- p rather than |- p = T on a term "p". It also eliminates any goals of  *)
(* the form "T" automatically.                                               *)
(* ------------------------------------------------------------------------- *)

let (CONV_TAC: conv -> tactic) =
  let t_tm = `T` in
  fun conv ((asl,w) as g) ->
    let th = conv w in
    let tm = concl th in
    if aconv tm w then ACCEPT_TAC th g else
    let l,r = dest_eq tm in
    if not(aconv l w) then failwith "CONV_TAC: bad equation" else
    if r = t_tm then ACCEPT_TAC(EQT_ELIM th) g else
    let th' = SYM th in
    null_meta,[asl,r],fun i [th] -> EQ_MP (INSTANTIATE_ALL i th') th;;

(* ------------------------------------------------------------------------- *)
(* Tactics for equality reasoning.                                           *)
(* ------------------------------------------------------------------------- *)

let (REFL_TAC: tactic) =
  fun ((asl,w) as g) ->
    try ACCEPT_TAC(REFL(rand w)) g
    with Failure _ -> failwith "REFL_TAC";;

let (ABS_TAC: tactic) =
  fun (asl,w) ->
    try let l,r = dest_eq w in
        let lv,lb = dest_abs l
        and rv,rb = dest_abs r in
        let avoids = itlist (union o thm_frees o snd) asl (frees w) in
        let v = mk_primed_var avoids lv in
        null_meta,[asl,mk_eq(vsubst[v,lv] lb,vsubst[v,rv] rb)],
        fun i [th] -> let ath = ABS v th in
                      EQ_MP (ALPHA (concl ath) (instantiate i w)) ath
    with Failure _ -> failwith "ABS_TAC";;

let (MK_COMB_TAC: tactic) =
  fun (asl,gl) ->
    try let l,r = dest_eq gl in
        let f,x = dest_comb l
        and g,y = dest_comb r in
        null_meta,[asl,mk_eq(f,g); asl,mk_eq(x,y)],
        fun _ [th1;th2] -> MK_COMB(th1,th2)
    with Failure _ -> failwith "MK_COMB_TAC";;

let (AP_TERM_TAC: tactic) =
  let tac = MK_COMB_TAC THENL [REFL_TAC; ALL_TAC] in
  fun gl -> try tac gl with Failure _ -> failwith "AP_TERM_TAC";;

let (AP_THM_TAC: tactic) =
  let tac = MK_COMB_TAC THENL [ALL_TAC; REFL_TAC] in
  fun gl -> try tac gl with Failure _ -> failwith "AP_THM_TAC";;

let (BINOP_TAC: tactic) =
  let tac = MK_COMB_TAC THENL [AP_TERM_TAC; ALL_TAC] in
  fun gl -> try tac gl with Failure _ -> failwith "AP_THM_TAC";;

let (SUBST1_TAC: thm_tactic) =
  fun th -> CONV_TAC(SUBS_CONV [th]);;

let SUBST_ALL_TAC rth =
  SUBST1_TAC rth THEN RULE_ASSUM_TAC (SUBS [rth]);;

let BETA_TAC = CONV_TAC(REDEPTH_CONV BETA_CONV);;

(* ------------------------------------------------------------------------- *)
(* Just use an equation to substitute if possible and uninstantiable.        *)
(* ------------------------------------------------------------------------- *)

let SUBST_VAR_TAC th =
  try let asm,eq = dest_thm th in
      let l,r = dest_eq eq in
      if aconv l r then ALL_TAC
      else if not (subset (frees eq) (freesl asm)) then fail()
      else if (is_const l or is_var l) & not(free_in l r)
           then SUBST_ALL_TAC th
      else if (is_const r or is_var r) & not(free_in r l)
           then SUBST_ALL_TAC(SYM th)
      else fail()
  with Failure _ -> failwith "SUBST_VAR_TAC";;

(* ------------------------------------------------------------------------- *)
(* Basic logical tactics.                                                    *)
(* ------------------------------------------------------------------------- *)

let (DISCH_TAC: tactic) =
  let f_tm = `F` in
  fun (asl,w) ->
    try let ant,c = dest_imp w in
        let th1 = ASSUME ant in
        null_meta,[("",th1)::asl,c],
        fun i [th] -> DISCH (instantiate i ant) th
    with Failure _ -> try
        let ant = dest_neg w in
        let th1 = ASSUME ant in
        null_meta,[("",th1)::asl,f_tm],
        fun i [th] -> NOT_INTRO(DISCH (instantiate i ant) th)
    with Failure _ -> failwith "DISCH_TAC";;

let (MP_TAC: thm_tactic) =
  fun thm (asl,w) ->
    null_meta,[asl,mk_imp(concl thm,w)],
    fun i [th] -> MP th (INSTANTIATE_ALL i thm);;

let (EQ_TAC: tactic) =
  fun (asl,w) ->
    try let l,r = dest_eq w in
        null_meta,[asl, mk_imp(l,r); asl, mk_imp(r,l)],
        fun _ [th1; th2] -> IMP_ANTISYM_RULE th1 th2
    with Failure _ -> failwith "EQ_TAC";;

let (UNDISCH_TAC: term -> tactic) =
 fun tm (asl,w) ->
   try let sthm,asl' = remove (fun (_,asm) -> aconv (concl asm) tm) asl in
       let thm = snd sthm in
       null_meta,[asl',mk_imp(tm,w)],
       fun i [th] -> MP th (INSTANTIATE_ALL i thm)
   with Failure _ -> failwith "UNDISCH_TAC";;

let (SPEC_TAC: term * term -> tactic) =
  fun (t,x) (asl,w) ->
    try null_meta,[asl, mk_forall(x,subst[x,t] w)],
        fun i [th] -> SPEC (instantiate i t) th
    with Failure _ -> failwith "SPEC_TAC";;

let (X_GEN_TAC: term -> tactic) =
  fun x' ->
    if not(is_var x') then failwith "X_GEN_TAC" else
    fun (asl,w) ->
      try let x,bod = dest_forall w in
          let avoids = itlist (union o thm_frees o snd) asl (frees w) in
          if mem x' avoids then failwith "X_GEN_TAC" else
          let afn = CONV_RULE(GEN_ALPHA_CONV x) in
          null_meta,[asl,vsubst[x',x] bod],
          fun i [th] -> afn (GEN x' th)
      with Failure _ -> failwith "X_GEN_TAC";;

let (GEN_TAC: tactic) =
  fun (asl,w) ->
    try let x = fst(dest_forall w) in
        let avoids = itlist (union o thm_frees o snd) asl (frees w) in
        let x' = mk_primed_var avoids x in
        X_GEN_TAC x' (asl,w)
    with Failure _ -> failwith "GEN_TAC";;

let (EXISTS_TAC: term -> tactic) =
  fun t (asl,w) ->
    try let v,bod = dest_exists w in
        null_meta,[asl,vsubst[t,v] bod],
        fun i [th] -> EXISTS (instantiate i w,instantiate i t) th
    with Failure _ -> failwith "EXISTS_TAC";;

let (X_CHOOSE_TAC: term -> thm_tactic) =
  fun x' xth ->
    try let xtm = concl xth in
        let x,bod = dest_exists xtm in
        let pat = vsubst[x',x] bod in
        let xth' = ASSUME pat in
        fun (asl,w) ->
          let avoids = itlist (union o frees o concl o snd) asl
                              (union (frees w) (thm_frees xth)) in
          if mem x' avoids then failwith "X_CHOOSE_TAC" else
          null_meta,[("",xth')::asl,w],
          fun i [th] -> CHOOSE(x',INSTANTIATE_ALL i xth) th
    with Failure _ -> failwith "X_CHOOSE_TAC";;

let (CHOOSE_TAC: thm_tactic) =
  fun xth ->
    try let x = fst(dest_exists(concl xth)) in
        fun (asl,w) ->
          let avoids = itlist (union o thm_frees o snd) asl
                              (union (frees w) (thm_frees xth)) in
          let x' = mk_primed_var avoids x in
          X_CHOOSE_TAC x' xth (asl,w)
      with Failure _ -> failwith "CHOOSE_TAC";;

let (CONJ_TAC: tactic) =
  fun (asl,w) ->
    try let l,r = dest_conj w in
        null_meta,[asl,l; asl,r],fun _ [th1;th2] -> CONJ th1 th2
    with Failure _ -> failwith "CONJ_TAC";;

let (DISJ1_TAC: tactic) =
  fun (asl,w) ->
    try let l,r = dest_disj w in
        null_meta,[asl,l],fun i [th] -> DISJ1 th (instantiate i r)
    with Failure _ -> failwith "DISJ1_TAC";;

let (DISJ2_TAC: tactic) =
  fun (asl,w) ->
    try let l,r = dest_disj w in
          null_meta,[asl,r],fun i [th] -> DISJ2 (instantiate i l) th
    with Failure _ -> failwith "DISJ2_TAC";;

let (DISJ_CASES_TAC: thm_tactic) =
  fun dth ->
    try let dtm = concl dth in
        let l,r = dest_disj dtm in
        let thl = ASSUME l
        and thr = ASSUME r in
        fun (asl,w) ->
          null_meta,[("",thl)::asl,w; ("",thr)::asl,w],
          fun i [th1;th2] -> DISJ_CASES (INSTANTIATE_ALL i dth) th1 th2
    with Failure _ -> failwith "DISJ_CASES_TAC";;

let (CONTR_TAC: thm_tactic) =
  let propagate_thm th i [] = INSTANTIATE_ALL i th in
  fun cth (asl,w) ->
    try let th = CONTR w cth in
        null_meta,[],propagate_thm th
    with Failure _ -> failwith "CONTR_TAC";;

let (MATCH_ACCEPT_TAC:thm_tactic) =
  let propagate_thm th i [] = INSTANTIATE_ALL i th in
  let rawtac th (asl,w) =
    try let ith = PART_MATCH I th w in
        null_meta,[],propagate_thm ith
    with Failure _ -> failwith "ACCEPT_TAC" in
  fun th -> REPEAT GEN_TAC THEN rawtac th;;

let (MATCH_MP_TAC :thm_tactic) =
  fun th ->
    let sth =
      try let tm = concl th in
          let avs,bod = strip_forall tm in
          let ant,con = dest_imp bod in
          let th1 = SPECL avs (ASSUME tm) in
          let th2 = UNDISCH th1 in
          let evs = filter (fun v -> vfree_in v ant & not (vfree_in v con))
                           avs in
          let th3 = itlist SIMPLE_CHOOSE evs (DISCH tm th2) in
          let tm3 = hd(hyp th3) in
          MP (DISCH tm (GEN_ALL (DISCH tm3 (UNDISCH th3)))) th
      with Failure _ -> failwith "MATCH_MP_TAC: Bad theorem" in
    let match_fun = PART_MATCH (snd o dest_imp) sth in
    fun (asl,w) -> try let xth = match_fun w in
                       let lant = fst(dest_imp(concl xth)) in
                       null_meta,[asl,lant],
                       fun i [th] -> MP (INSTANTIATE_ALL i xth) th
                   with Failure _ -> failwith "MATCH_MP_TAC: No match";;

(* ------------------------------------------------------------------------- *)
(* Theorem continuations.                                                    *)
(* ------------------------------------------------------------------------- *)

let (CONJUNCTS_THEN2:thm_tactic->thm_tactic->thm_tactic) =
  fun ttac1 ttac2 cth ->
      let c1,c2 = dest_conj(concl cth) in
      fun gl -> let ti,gls,jfn = (ttac1(ASSUME c1) THEN ttac2(ASSUME c2)) gl in
                let jfn' i ths =
                  let th1,th2 = CONJ_PAIR(INSTANTIATE_ALL i cth) in
                  PROVE_HYP th1 (PROVE_HYP th2 (jfn i ths)) in
                ti,gls,jfn';;

let (CONJUNCTS_THEN: thm_tactical) =
  W CONJUNCTS_THEN2;;

let (DISJ_CASES_THEN2:thm_tactic->thm_tactic->thm_tactic) =
  fun ttac1 ttac2 cth ->
    DISJ_CASES_TAC cth THENL [POP_ASSUM ttac1; POP_ASSUM ttac2];;

let (DISJ_CASES_THEN: thm_tactical) =
  W DISJ_CASES_THEN2;;

let (DISCH_THEN: thm_tactic -> tactic) =
  fun ttac -> DISCH_TAC THEN POP_ASSUM ttac;;

let (X_CHOOSE_THEN: term -> thm_tactical) =
  fun x ttac th -> X_CHOOSE_TAC x th THEN POP_ASSUM ttac;;

let (CHOOSE_THEN: thm_tactical) =
  fun ttac th -> CHOOSE_TAC th THEN POP_ASSUM ttac;;

(* ------------------------------------------------------------------------- *)
(* Various derived tactics and theorem continuations.                        *)
(* ------------------------------------------------------------------------- *)

let STRIP_THM_THEN =
  FIRST_TCL [CONJUNCTS_THEN; DISJ_CASES_THEN; CHOOSE_THEN];;

let (ANTE_RES_THEN: thm_tactical) =                                             
  fun ttac ante ->                                                              
    ASSUM_LIST                                                                 
     (fun asl ->                                                              
        let tacs = mapfilter (fun imp -> ttac (MATCH_MP imp ante)) asl in
        if tacs = [] then failwith "IMP_RES_THEN"
        else EVERY tacs);;

let (IMP_RES_THEN: thm_tactical) =                                             
  fun ttac imp ->                                                              
    ASSUM_LIST                                                                 
     (fun asl ->                                                              
        let tacs = mapfilter (fun ante -> ttac (MATCH_MP imp ante)) asl in
        if tacs = [] then failwith "IMP_RES_THEN"
        else EVERY tacs);;

let STRIP_ASSUME_TAC =
  let DISCARD_TAC th =
    let tm = concl th in
    fun (asl,w as g) ->
       if exists (fun a -> aconv tm (concl(snd a))) asl then ALL_TAC g
       else failwith "DISCARD_TAC: not already present" in
  (REPEAT_TCL STRIP_THM_THEN)
  (fun gth -> FIRST [CONTR_TAC gth; ACCEPT_TAC gth;
                     DISCARD_TAC gth; ASSUME_TAC gth]);;

let STRUCT_CASES_TAC =
    REPEAT_TCL STRIP_THM_THEN
     (fun th -> SUBST1_TAC th ORELSE ASSUME_TAC th);;

let STRIP_GOAL_THEN ttac =  FIRST [GEN_TAC; CONJ_TAC; DISCH_THEN ttac];;

let (STRIP_TAC: tactic) =
  fun g ->
    try STRIP_GOAL_THEN STRIP_ASSUME_TAC g
    with Failure _ -> failwith "STRIP_TAC";;

let (UNDISCH_THEN:term->thm_tactic->tactic) =
  fun tm ttac (asl,w) ->
    let thp,asl' = remove (fun (_,th) -> aconv (concl th) tm) asl in
    ttac (snd thp) (asl',w);;

let FIRST_X_ASSUM ttac =
    FIRST_ASSUM(fun th -> UNDISCH_THEN (concl th) ttac);;

(* ------------------------------------------------------------------------- *)
(* Subgoaling and freezing variables (latter is especially useful now).      *)
(* ------------------------------------------------------------------------- *)

let (SUBGOAL_THEN: term -> thm_tactic -> tactic) =
  fun wa ttac (asl,w) ->
    let meta,gl,just = ttac (ASSUME wa) (asl,w) in
    meta,(asl,wa)::gl,fun i l -> PROVE_HYP (hd l) (just i (tl l));;

let SUBGOAL_TAC s tm prfs =
  match prfs with
   p::ps -> (warn (ps <> []) "SUBGOAL_TAC: additional subproofs ignored";
             SUBGOAL_THEN tm (LABEL_TAC s) THENL [p; ALL_TAC])
  | [] -> failwith "SUBGOAL_TAC: no subproof given";;

let (FREEZE_THEN :thm_tactical) =
  fun ttac th (asl,w) ->
    let meta,gl,just = ttac (ASSUME(concl th)) (asl,w) in
    meta,gl,fun i l -> PROVE_HYP th (just i l);;

(* ------------------------------------------------------------------------- *)
(* Metavariable tactics.                                                     *)
(* ------------------------------------------------------------------------- *)

let (X_META_EXISTS_TAC: term -> tactic) =
  fun t (asl,w) ->
    try if not (is_var t) then fail() else
        let v,bod = dest_exists w in
        ([t],null_inst),[asl,vsubst[t,v] bod],
        fun i [th] -> EXISTS (instantiate i w,instantiate i t) th
    with Failure _ -> failwith "X_META_EXISTS_TAC";;

let META_EXISTS_TAC ((asl,w) as gl) =
  let v = fst(dest_exists w) in
  let avoids = itlist (union o frees o concl o snd) asl (frees w) in
  let v' = mk_primed_var avoids v in
  X_META_EXISTS_TAC v' gl;;

let (META_SPEC_TAC: term -> thm -> tactic) =
  fun t thm (asl,w) ->
    let sth = SPEC t thm in
    ([t],null_inst),[(("",sth)::asl),w],
    fun i [th] -> PROVE_HYP (SPEC (instantiate i t) thm) th;;

(* ------------------------------------------------------------------------- *)
(* If all else fails!                                                        *)
(* ------------------------------------------------------------------------- *)

let (CHEAT_TAC:tactic) =
  fun (asl,w) -> ACCEPT_TAC(mk_thm([],w)) (asl,w);;

(* ------------------------------------------------------------------------- *)
(* Intended for time-consuming rules; delays evaluation till it sees goal.   *)
(* ------------------------------------------------------------------------- *)

let RECALL_ACCEPT_TAC r a g = ACCEPT_TAC(time r a) g;;

(* ------------------------------------------------------------------------- *)
(* Split off antecedent of antecedent as a subgoal.                          *)
(* ------------------------------------------------------------------------- *)

let ANTS_TAC =
  let tm1 = `p /\ (q ==> r)`
  and tm2 = `p ==> q` in
  let th1,th2 = CONJ_PAIR(ASSUME tm1) in
  let th = itlist DISCH [tm1;tm2] (MP th2 (MP(ASSUME tm2) th1)) in
  MATCH_MP_TAC th THEN CONJ_TAC;;

(* ------------------------------------------------------------------------- *)
(* A printer for goals etc.                                                  *)
(* ------------------------------------------------------------------------- *)

let (print_goal:goal->unit) =
  let string_of_int3 n =
    if n < 10 then "  "^string_of_int n
    else if n < 100 then " "^string_of_int n
    else string_of_int n in
  let print_hyp n (s,th) =
    open_hbox();
    Format.print_string(string_of_int3 n);
    Format.print_string " [";
    open_hvbox 0;
    print_qterm (concl th);
    close_box();
    Format.print_string "]";
    (if not (s = "") then (Format.print_string (" ("^s^")")) else ());
    close_box();
    Format.print_newline() in
  let rec print_hyps n asl =
    if asl = [] then () else
    (print_hyp n (hd asl);
     print_hyps (n + 1) (tl asl)) in
  fun (asl,w) ->
    Format.print_newline();
    if asl <> [] then (print_hyps 0 (rev asl); Format.print_newline()) else ();
    print_qterm w; Format.print_newline();;

let (print_goalstack:goalstack->unit) =
  let print_goalstate k gs =
    let (_,gl,_) = gs in
    let n = length gl in
    let s = if n = 0 then "No subgoals" else
              (string_of_int k)^" subgoal"^(if k > 1 then "s" else "")
           ^" ("^(string_of_int n)^" total)" in
    Format.print_string s; Format.print_newline();
    if gl = [] then () else
    do_list (print_goal o C el gl) (rev(0--(k-1))) in
  fun l ->
    if l = [] then Format.print_string "Empty goalstack"
    else if tl l = [] then
      let (_,gl,_ as gs) = hd l in
      print_goalstate 1 gs
    else
      let (_,gl,_ as gs) = hd l
      and (_,gl0,_) = hd(tl l) in
      let p = length gl - length gl0 in
      let p' = if p < 1 then 1 else p + 1 in
      print_goalstate p' gs;;

(* ------------------------------------------------------------------------- *)
(* Convert a tactic into a refinement on head subgoal in current state.      *)
(* ------------------------------------------------------------------------- *)

let (by:tactic->refinement) =
  fun tac ((mvs,inst),gls,just) ->
    if gls = [] then failwith "No goal set" else
    let g = hd gls
    and ogls = tl gls in
    let ((newmvs,newinst),subgls,subjust) = tac g in
    let n = length subgls in
    let mvs' = union newmvs mvs
    and inst' = compose_insts inst newinst
    and gls' = subgls @ map (inst_goal newinst) ogls in
    let just' i ths =
      let i' = compose_insts inst' i in
      let cths,oths = chop_list n ths in
      let sths = (subjust i cths) :: oths in
      just i' sths in
    (mvs',inst'),gls',just';;

(* ------------------------------------------------------------------------- *)
(* Rotate the goalstate either way.                                          *)
(* ------------------------------------------------------------------------- *)

let (rotate:int->refinement) =
  let rotate_p (meta,sgs,just) =
    let sgs' = (tl sgs)@[hd sgs] in
    let just' i ths =
      let ths' = (last ths)::(butlast ths) in
      just i ths' in
    (meta,sgs',just')
  and rotate_n (meta,sgs,just) =
    let sgs' = (last sgs)::(butlast sgs) in
    let just' i ths =
      let ths' = (tl ths)@[hd ths] in
      just i ths' in
    (meta,sgs',just') in
  fun n -> if n > 0 then funpow n rotate_p
           else funpow (-n) rotate_n;;

(* ------------------------------------------------------------------------- *)
(* Perform refinement proof, tactic proof etc.                               *)
(* ------------------------------------------------------------------------- *)

let (mk_goalstate:goal->goalstate) =
  fun (asl,w) ->
    if type_of w = bool_ty then
      null_meta,[asl,w],
      (fun inst [th] -> INSTANTIATE_ALL inst th)
    else failwith "mk_goalstate: Non-boolean goal";;

let (TAC_PROOF : goal * tactic -> thm) =
  fun (g,tac) ->
    let gstate = mk_goalstate g in
    let _,sgs,just = by tac gstate in
    if sgs = [] then just null_inst []
    else failwith "TAC_PROOF: Unsolved goals";;

let prove(t,tac) =
  let th = TAC_PROOF(([],t),tac) in
  let t' = concl th in
  if t' = t then th else
  try EQ_MP (ALPHA t' t) th
  with Failure _ -> failwith "prove: justification generated wrong theorem";;

(* ------------------------------------------------------------------------- *)
(* Interactive "subgoal package" stuff.                                      *)
(* ------------------------------------------------------------------------- *)

let current_goalstack = ref ([] :goalstack);;

let (refine:refinement->goalstack) =
  fun r ->
    let l = !current_goalstack in
    if l = [] then failwith "No current goal" else
    let h = hd l in
    let res = r h :: l in
    current_goalstack := res;
    !current_goalstack;;

let flush_goalstack() =
  let l = !current_goalstack in
  current_goalstack := [hd l];;

let e tac = refine(by(VALID tac));;

let r n = refine(rotate n);;

let set_goal(asl,w) =
  current_goalstack :=
    [mk_goalstate(map (fun t -> "",ASSUME t) asl,w)];
  !current_goalstack;;

let g t =
  let fvs = sort (<) (map (fst o dest_var) (frees t)) in
  (if fvs <> [] then
     let errmsg = end_itlist (fun s t -> s^", "^t) fvs in
     warn true ("Free variables in goal: "^errmsg)
   else ());
   set_goal([],t);;

let b() =
  let l = !current_goalstack in
  if length l = 1 then failwith "Can't back up any more" else
  current_goalstack := tl l;
  !current_goalstack;;

let p() =
  !current_goalstack;;

let top_realgoal() =
  let (_,((asl,w)::_),_)::_ = !current_goalstack in
  asl,w;;

let top_goal() =
  let asl,w = top_realgoal() in
  map (concl o snd) asl,w;;

let top_thm() =
  let (_,[],f)::_ = !current_goalstack in
  f null_inst [];;

(* ------------------------------------------------------------------------- *)
(* Install the goal-related printers.                                        *)
(* ------------------------------------------------------------------------- *)

(* ========================================================================= *)
(* Intuitionistic theorem prover (complete for propositional fragment).      *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let UNIFY_ACCEPT_TAC mvs th (asl,w) =
  let insts = term_unify mvs (concl th) w in
  ([],insts),[],
  let th' = INSTANTIATE insts th in
  fun i [] -> INSTANTIATE i th';;

(* ------------------------------------------------------------------------- *)
(* The actual prover, as a tactic.                                           *)
(* ------------------------------------------------------------------------- *)

let ITAUT_TAC =
  let CONJUNCTS_THEN' ttac cth =
    ttac(CONJUNCT1 cth) THEN ttac(CONJUNCT2 cth) in
  let IMPLICATE t =
    let th1 = AP_THM NOT_DEF (dest_neg t) in
    CONV_RULE (RAND_CONV BETA_CONV) th1 in
  let RIGHT_REVERSIBLE_TAC = FIRST
   [CONJ_TAC;                                                     (* and     *)
    GEN_TAC;                                                      (* forall  *)
    DISCH_TAC;                                                    (* implies *)
    (fun gl -> CONV_TAC(K(IMPLICATE(snd gl))) gl);                (* not     *)
    EQ_TAC]                                                       (* iff     *)
  and LEFT_REVERSIBLE_TAC th gl = tryfind (fun ttac -> ttac th gl)
   [CONJUNCTS_THEN' ASSUME_TAC;                                   (* and    *)
    DISJ_CASES_TAC;                                               (* or     *)
    CHOOSE_TAC;                                                   (* exists *)
    (fun th -> ASSUME_TAC (EQ_MP (IMPLICATE (concl th)) th));     (* not    *)
    (CONJUNCTS_THEN' MP_TAC o uncurry CONJ  o EQ_IMP_RULE)]       (* iff    *)
  in
  let rec ITAUT_TAC mvs n gl =
    if n <= 0 then failwith "ITAUT_TAC: Too deep" else
    ((FIRST_ASSUM (UNIFY_ACCEPT_TAC mvs)) ORELSE
     (ACCEPT_TAC TRUTH) ORELSE
     (FIRST_ASSUM CONTR_TAC) ORELSE
     (RIGHT_REVERSIBLE_TAC THEN TRY (ITAUT_TAC mvs n)) ORELSE
     (FIRST_X_ASSUM LEFT_REVERSIBLE_TAC THEN TRY(ITAUT_TAC mvs n)) ORELSE
     (FIRST_X_ASSUM(fun th -> ASSUME_TAC th THEN
       (let gv = genvar(type_of(fst(dest_forall(concl th)))) in
        META_SPEC_TAC gv th THEN
        ITAUT_TAC (gv::mvs) (n - 2) THEN NO_TAC))) ORELSE
     (DISJ1_TAC THEN ITAUT_TAC mvs n THEN NO_TAC) ORELSE
     (DISJ2_TAC THEN ITAUT_TAC mvs n THEN NO_TAC) ORELSE
     (fun gl -> let gv = genvar(type_of(fst(dest_exists(snd gl)))) in
                (X_META_EXISTS_TAC gv THEN
                 ITAUT_TAC (gv::mvs) (n - 2) THEN NO_TAC) gl) ORELSE
     (FIRST_ASSUM(fun th -> SUBGOAL_THEN (fst(dest_imp(concl th)))
                                      (fun ath -> ASSUME_TAC (MP th ath)) THEN
                           ITAUT_TAC mvs (n - 1) THEN NO_TAC))) gl in
  let rec ITAUT_ITERDEEP_TAC n gl =
    remark ("Searching with limit "^(string_of_int n));
    ((ITAUT_TAC [] n THEN NO_TAC) ORELSE ITAUT_ITERDEEP_TAC (n + 1)) gl in
  ITAUT_ITERDEEP_TAC 0;;

(* ------------------------------------------------------------------------- *)
(* Alternative interface.                                                    *)
(* ------------------------------------------------------------------------- *)

let ITAUT tm = prove(tm,ITAUT_TAC);;
(* ========================================================================= *)
(* Simplification and rewriting.                                             *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

type gconv = int * conv;;

(* ------------------------------------------------------------------------- *)
(* Primitive rewriting conversions: unconditional and conditional equations. *)
(* ------------------------------------------------------------------------- *)

let REWR_CONV = PART_MATCH lhs;;

let IMP_REWR_CONV = PART_MATCH (lhs o snd o dest_imp);;

(* ------------------------------------------------------------------------- *)
(* Versions with ordered rewriting. We must have l' > r' for the rewrite     *)
(* |- l = r (or |- c ==> (l = r)) to apply.                                  *)
(* ------------------------------------------------------------------------- *)

let ORDERED_REWR_CONV ord th =
  let basic_conv = REWR_CONV th in
  fun tm ->
    let thm = basic_conv tm in
    let l,r = dest_eq(concl thm) in
    if ord l r then thm
    else failwith "ORDERED_REWR_CONV: wrong orientation";;

let ORDERED_IMP_REWR_CONV ord th =
  let basic_conv = IMP_REWR_CONV th in
  fun tm ->
    let thm = basic_conv tm in
    let l,r = dest_eq(rand(concl thm)) in
    if ord l r then thm
    else failwith "ORDERED_IMP_REWR_CONV: wrong orientation";;

(* ------------------------------------------------------------------------- *)
(* Standard AC-compatible term ordering: a "dynamic" lexicographic ordering. *)
(*                                                                           *)
(* This is a slight hack to make AC normalization work. However I *think*    *)
(* it's properly AC compatible, i.e. monotonic and total, WF on ground terms *)
(* (over necessarily finite signature) and with the properties for any       *)
(* binary operator +:                                                        *)
(*                                                                           *)
(*         (x + y) + z > x + (y + z)                                         *)
(*         x + y > y + x                   iff x > y                         *)
(*         x + (y + z) > y + (x + z)       iff x > y                         *)
(*                                                                           *)
(* The idea is that when invoking lex ordering with identical head operator  *)
(* "f", one sticks "f" at the head of an otherwise arbitrary ordering on     *)
(* subterms (the built-in CAML one). This avoids the potentially inefficient *)
(* calculation of term size in the standard orderings.                       *)
(* ------------------------------------------------------------------------- *)

let term_order =
  let rec lexify ord l1 l2 =
    if l1 = [] then false
    else if l2 = [] then true else
    let h1 = hd l1 and h2 = hd l2 in
    ord h1 h2 or (h1 = h2 & lexify ord (tl l1) (tl l2)) in
  let rec dyn_order top tm1 tm2 =
    let f1,args1 = strip_comb tm1
    and f2,args2 = strip_comb tm2 in
    if f1 = f2 then
      lexify (dyn_order f1) args1 args2
    else
      if f2 = top then false
      else if f1 = top then true
      else f1 > f2 in
  dyn_order `T`;;

(* ------------------------------------------------------------------------- *)
(* Create a gconv net for a theorem as a (cond) rewrite. The "rep" flag      *)
(* will cause any trivially looping rewrites to be modified, and any that    *)
(* are permutative to be ordered w.r.t. the standard order. The idea is that *)
(* this flag will be set iff the conversion is going to get repeated.        *)
(* This includes a completely ad hoc but useful special case for ETA_AX,     *)
(* which forces a first order match (otherwise it would loop on a lambda).   *)
(* ------------------------------------------------------------------------- *)

let net_of_thm rep th =
  let tm = concl th in
  let lconsts = freesl (hyp th) in
  let matchable = can o term_match lconsts in
  match tm with
    Comb(Comb(Const("=",_),(Abs(x,Comb(Var(s,ty) as v,x')) as l)),v')
         when x' = x & v' = v & not(x = v) ->
        let conv tm =
          match tm with
            Abs(y,Comb(t,y')) when y = y' & not(free_in y t) ->
              INSTANTIATE(term_match [] v t) th
          | _ -> failwith "REWR_CONV (ETA_AX special case)" in
        enter lconsts (l,(1,conv))
  | Comb(Comb(Const("=",_),l),r) ->
      if rep & free_in l r then
        let th' = EQT_INTRO th in
        enter lconsts (l,(1,REWR_CONV th'))
      else if rep & matchable l r & matchable r l then
        enter lconsts (l,(1,ORDERED_REWR_CONV term_order th))
      else enter lconsts (l,(1,REWR_CONV th))
  | Comb(Comb(_,t),Comb(Comb(Const("=",_),l),r)) ->
        if rep & free_in l r then
          let th' = DISCH t (EQT_INTRO(UNDISCH th)) in
          enter lconsts (l,(3,IMP_REWR_CONV th'))
        else if rep & matchable l r & matchable r l then
          enter lconsts (l,(3,ORDERED_IMP_REWR_CONV term_order th))
        else enter lconsts(l,(3,IMP_REWR_CONV th));;

(* ------------------------------------------------------------------------- *)
(* Create a gconv net for a conversion with a term index.                    *)
(* ------------------------------------------------------------------------- *)

let net_of_conv tm conv sofar =
  enter [] (tm,(2,conv)) sofar;;

(* ------------------------------------------------------------------------- *)
(* Create a gconv net for a congruence rule (in canonical form!)             *)
(* ------------------------------------------------------------------------- *)

let net_of_cong th sofar =
  let conc,n = repeat (fun (tm,m) -> snd(dest_imp tm),m+1) (concl th,0) in
  if n = 0 then failwith "net_of_cong: Non-implicational congruence" else
  let pat = lhs conc in
  let conv = GEN_PART_MATCH (lhand o funpow n rand) th in
  enter [] (pat,(4,conv)) sofar;;

(* ------------------------------------------------------------------------- *)
(* Rewrite maker for ordinary and conditional rewrites (via "cf" flag).      *)
(*                                                                           *)
(* We follow Don in going from ~(s = t) to (s = t) = F *and* (t = s) = F.    *)
(* Well, why not? However, we don't abandon s = t where FV(t) is not a       *)
(* subset of FV(s) in favour of (s = t) = T, as he does.                     *)
(* Note: looping rewrites are not discarded here, only when netted.          *)
(* ------------------------------------------------------------------------- *)

let mk_rewrites =
  let IMP_CONJ_CONV = REWR_CONV(ITAUT `p ==> q ==> r <=> p /\ q ==> r`)
  and IMP_EXISTS_RULE =
    let cnv = REWR_CONV(ITAUT `(!x. P x ==> Q) <=> (?x. P x) ==> Q`) in
    fun v th -> CONV_RULE cnv (GEN v th) in
  let collect_condition oldhyps th =
    let conds = subtract (hyp th) oldhyps in
    if conds = [] then th else
    let jth = itlist DISCH conds th in
    let kth = CONV_RULE (REPEATC IMP_CONJ_CONV) jth in
    let cond,eqn = dest_imp(concl kth) in
    let fvs = subtract (subtract (frees cond) (frees eqn)) (freesl oldhyps) in
    itlist IMP_EXISTS_RULE fvs kth in
  let rec split_rewrites oldhyps cf th sofar =
    let tm = concl th in
    if is_forall tm then
      split_rewrites oldhyps cf (SPEC_ALL th) sofar
    else if is_conj tm then
      split_rewrites oldhyps cf (CONJUNCT1 th)
        (split_rewrites oldhyps cf (CONJUNCT2 th) sofar)
    else if is_imp tm & cf then
      split_rewrites oldhyps cf (UNDISCH th) sofar
    else if is_eq tm then
      (if cf then collect_condition oldhyps th else th)::sofar
    else if is_neg tm then
      let ths = split_rewrites oldhyps cf (EQF_INTRO th) sofar in
      if is_eq (rand tm)
      then split_rewrites oldhyps cf (EQF_INTRO (GSYM th)) ths
      else ths
    else
      split_rewrites oldhyps cf (EQT_INTRO th) sofar in
  fun cf th sofar -> split_rewrites (hyp th) cf th sofar;;

(* ------------------------------------------------------------------------- *)
(* Rewriting (and application of other conversions) based on a convnet.      *)
(* ------------------------------------------------------------------------- *)

let REWRITES_CONV net tm =
  let pconvs = lookup tm net in
  try tryfind (fun (_,cnv) -> cnv tm) pconvs
  with Failure _ -> failwith "REWRITES_CONV";;

(* ------------------------------------------------------------------------- *)
(* Decision procedures may accumulate their state in different ways (e.g.    *)
(* term nets and predicate-indexed lists of Horn clauses). To allow mixing   *)
(* of arbitrary types for state storage, we use a trick due to RJB via DRS.  *)
(* ------------------------------------------------------------------------- *)

type prover = Prover of conv * (thm list -> prover);;

let mk_prover applicator augmentor =
  let rec mk_prover state =
    let apply = applicator state
    and augment thms = mk_prover (augmentor state thms) in
    Prover(apply,augment) in
  mk_prover;;

let augment(Prover(_,aug)) thms = aug thms;;

let apply_prover(Prover(conv,_)) tm = conv tm;;

(* ------------------------------------------------------------------------- *)
(* Type of simpsets. We have a convnet containing rewrites (implicational    *)
(* and otherwise), other term-indexed context-free conversions like          *)
(* BETA_CONV, and congruence rules. Then there is a list of provers that     *)
(* have their own way of storing and using context, and finally a rewrite    *)
(* maker function, to allow customization.                                   *)
(*                                                                           *)
(* We also have a type of (traversal) strategy, following Konrad.            *)
(* ------------------------------------------------------------------------- *)

type simpset =
  Simpset of gconv net                          (* Rewrites & congruences *)
           * (strategy -> strategy)             (* Prover for conditions  *)
           * prover list                        (* Subprovers for prover  *)
           * (thm -> thm list -> thm list)      (* Rewrite maker          *)

and strategy = simpset -> int -> term -> thm;;

(* ------------------------------------------------------------------------- *)
(* Very simple prover: recursively simplify then try provers.                *)
(* ------------------------------------------------------------------------- *)

let basic_prover strat (Simpset(net,prover,provers,rewmaker) as ss) lev tm =
  let sth = try strat ss lev tm with Failure _ -> REFL tm in
  try EQT_ELIM sth
  with Failure _ ->
    let tth = tryfind (fun pr -> apply_prover pr (rand(concl sth))) provers in
    EQ_MP (SYM sth) tth;;

(* ------------------------------------------------------------------------- *)
(* Functions for changing or augmenting components of simpsets.              *)
(* ------------------------------------------------------------------------- *)

let ss_of_thms thms (Simpset(net,prover,provers,rewmaker)) =
  let cthms = itlist rewmaker thms [] in
  let net' = itlist (net_of_thm true) cthms net in
  Simpset(net',prover,provers,rewmaker);;

let ss_of_conv keytm conv (Simpset(net,prover,provers,rewmaker)) =
  let net' = net_of_conv keytm conv net in
  Simpset(net',prover,provers,rewmaker);;

let ss_of_congs thms (Simpset(net,prover,provers,rewmaker)) =
  let net' = itlist net_of_cong thms net in
  Simpset(net',prover,provers,rewmaker);;

let ss_of_prover newprover (Simpset(net,_,provers,rewmaker)) =
  Simpset(net,newprover,provers,rewmaker);;

let ss_of_provers newprovers (Simpset(net,prover,provers,rewmaker)) =
  Simpset(net,prover,newprovers@provers,rewmaker);;

let ss_of_maker newmaker (Simpset(net,prover,provers,_)) =
  Simpset(net,prover,provers,newmaker);;

(* ------------------------------------------------------------------------- *)
(* Perform a context-augmentation operation on a simpset.                    *)
(* ------------------------------------------------------------------------- *)

let AUGMENT_SIMPSET cth (Simpset(net,prover,provers,rewmaker)) =
  let provers' = map (C augment [cth]) provers in
  let cthms = rewmaker cth [] in
  let net' = itlist (net_of_thm true) cthms net in
  Simpset(net',prover,provers',rewmaker);;

(* ------------------------------------------------------------------------- *)
(* Depth conversions.                                                        *)
(* ------------------------------------------------------------------------- *)

let ONCE_DEPTH_SQCONV,DEPTH_SQCONV,REDEPTH_SQCONV,
    TOP_DEPTH_SQCONV,TOP_SWEEP_SQCONV =
  let IMP_REWRITES_CONV strat (Simpset(net,prover,provers,rewmaker) as ss) lev
                        pconvs tm =
    tryfind (fun (n,cnv) ->
      if n >= 4 then fail() else
      let th = cnv tm in
      let etm = concl th in
      if is_eq etm then th else
      if lev <= 0 then failwith "IMP_REWRITES_CONV: Too deep" else
      let cth = prover strat ss (lev-1) (lhand etm) in
      MP th cth) pconvs in
  let rec RUN_SUB_CONV strat ss lev triv th =
    let tm = concl th in
    if is_imp tm then
      let subtm = lhand tm in
      let avs,bod = strip_forall subtm in
      let (t,t'),ss',mk_fun =
        try dest_eq bod,ss,I with Failure _ ->
        let cxt,deq = dest_imp bod in
        dest_eq deq,AUGMENT_SIMPSET (ASSUME cxt) ss,DISCH cxt in
      let eth,triv' = try strat ss' lev t,false with Failure _ -> REFL t,triv in
      let eth' = GENL avs (mk_fun eth) in
      let th' = if is_var t' then INST [rand(concl eth),t'] th
                else GEN_PART_MATCH lhand th (concl eth') in
      let th'' = MP th' eth' in
      RUN_SUB_CONV strat ss lev triv' th''
    else if triv then fail() else th in
  let GEN_SUB_CONV strat ss lev pconvs tm =
    try tryfind (fun (n,cnv) ->
          if n < 4 then fail() else
          let th = cnv tm in
          RUN_SUB_CONV strat ss lev true th) pconvs
    with Failure _ ->
        if is_comb tm then
          let l,r = dest_comb tm in
          try let th1 = strat ss lev l in
              try let th2 = strat ss lev r in MK_COMB(th1,th2)
              with Failure _ -> AP_THM th1 r
          with Failure _ -> AP_TERM l (strat ss lev r)
        else if is_abs tm then
          let v,bod = dest_abs tm in
          let th = strat ss lev bod in
          try ABS v th with Failure _ ->
          let gv = genvar(type_of v) in
          let gbod = vsubst[gv,v] bod in
          let gth = ABS gv (strat ss lev gbod) in
          let gtm = concl gth in
          let l,r = dest_eq gtm in
          let v' = variant (frees gtm) v in
          let l' = alpha v' l and r' = alpha v' r in
          EQ_MP (ALPHA gtm (mk_eq(l',r'))) gth
        else failwith "GEN_SUB_CONV" in
  let trivial_prover strat ss lev tm = ASSUME tm in
  let rec ONCE_DEPTH_SQCONV
       (Simpset(net,prover,provers,rewmaker) as ss) lev tm =
    let pconvs = lookup tm net in
    try IMP_REWRITES_CONV ONCE_DEPTH_SQCONV ss lev pconvs tm
    with Failure _ ->
        GEN_SUB_CONV ONCE_DEPTH_SQCONV ss lev pconvs tm in
  let rec DEPTH_SQCONV (Simpset(net,prover,provers,rewmaker) as ss) lev tm =
    let pconvs = lookup tm net in
    try let th1 = GEN_SUB_CONV DEPTH_SQCONV ss lev pconvs tm in
        let tm1 = rand(concl th1) in
        let pconvs1 = lookup tm1 net in
        try TRANS th1 (IMP_REWRITES_CONV DEPTH_SQCONV ss lev pconvs1 tm1)
        with Failure _ -> th1
    with Failure _ ->
        IMP_REWRITES_CONV DEPTH_SQCONV ss lev pconvs tm in
  let rec REDEPTH_SQCONV (Simpset(net,prover,provers,rewmaker) as ss) lev tm =
    let pconvs = lookup tm net in
    let th =
      try let th1 = GEN_SUB_CONV REDEPTH_SQCONV ss lev pconvs tm in
          let tm1 = rand(concl th1) in
          let pconvs1 = lookup tm1 net in
          try TRANS th1 (IMP_REWRITES_CONV REDEPTH_SQCONV ss lev pconvs1 tm1)
          with Failure _ -> th1
      with Failure _ ->
          IMP_REWRITES_CONV REDEPTH_SQCONV ss lev pconvs tm in
    try let th' = REDEPTH_SQCONV ss lev (rand(concl th)) in
        TRANS th th'
    with Failure _ -> th in
  let rec TOP_DEPTH_SQCONV (Simpset(net,prover,provers,rewmaker) as ss) lev tm =
    let pconvs = lookup tm net in
    let th1 =
      try IMP_REWRITES_CONV TOP_DEPTH_SQCONV ss lev pconvs tm
      with Failure _ -> GEN_SUB_CONV TOP_DEPTH_SQCONV ss lev pconvs tm in
    try let th2 = TOP_DEPTH_SQCONV ss lev (rand(concl th1)) in
            TRANS th1 th2
    with Failure _ -> th1 in
  let rec TOP_SWEEP_SQCONV (Simpset(net,prover,provers,rewmaker) as ss) lev tm =
    let pconvs = lookup tm net in
    try let th1 = IMP_REWRITES_CONV TOP_SWEEP_SQCONV ss lev pconvs tm in
        try let th2 = TOP_SWEEP_SQCONV ss lev (rand(concl th1)) in
            TRANS th1 th2
        with Failure _ -> th1
    with Failure _ -> GEN_SUB_CONV TOP_SWEEP_SQCONV ss lev pconvs tm in
  ONCE_DEPTH_SQCONV,DEPTH_SQCONV,REDEPTH_SQCONV,
  TOP_DEPTH_SQCONV,TOP_SWEEP_SQCONV;;

(* ------------------------------------------------------------------------- *)
(* Maintenence of basic rewrites and conv nets for rewriting.                *)
(* ------------------------------------------------------------------------- *)

let set_basic_rewrites,extend_basic_rewrites,basic_rewrites,
    set_basic_convs,extend_basic_convs,basic_convs,basic_net =
  let rewrites = ref ([]:thm list)
  and conversions = ref ([]:(string*(term*conv))list)
  and conv_net = ref (empty_net: gconv net) in
  let rehash_convnet() =
    conv_net := itlist (net_of_thm true) (!rewrites)
        (itlist (fun (_,(pat,cnv)) -> net_of_conv pat cnv) (!conversions)
                empty_net) in
  let set_basic_rewrites thl =
    let canon_thl = itlist (mk_rewrites false) thl [] in
    (rewrites := canon_thl; rehash_convnet())
  and extend_basic_rewrites thl =
    let canon_thl = itlist (mk_rewrites false) thl [] in
    (rewrites := canon_thl @ !rewrites; rehash_convnet())
  and basic_rewrites() = !rewrites
  and set_basic_convs cnvs =
    (conversions := cnvs; rehash_convnet())
  and extend_basic_convs (name,patcong) =
    (conversions :=
      (name,patcong)::filter(fun (name',_) -> name <> name') (!conversions);
     rehash_convnet())
  and basic_convs() = !conversions
  and basic_net() = !conv_net in
  set_basic_rewrites,extend_basic_rewrites,basic_rewrites,
  set_basic_convs,extend_basic_convs,basic_convs,basic_net;;

(* ------------------------------------------------------------------------- *)
(* Same thing for the default congruences.                                   *)
(* ------------------------------------------------------------------------- *)

let set_basic_congs,extend_basic_congs,basic_congs =
  let congs = ref ([]:thm list) in
  (fun thl -> congs := thl),
  (fun thl -> congs := union' equals_thm thl (!congs)),
  (fun () -> !congs);;

(* ------------------------------------------------------------------------- *)
(* Main rewriting conversions.                                               *)
(* ------------------------------------------------------------------------- *)

let GENERAL_REWRITE_CONV rep (cnvl:conv->conv) (builtin_net:gconv net) thl =
  let thl_canon = itlist (mk_rewrites false) thl [] in
  let final_net = itlist (net_of_thm rep) thl_canon builtin_net in
  cnvl (REWRITES_CONV final_net);;

let GEN_REWRITE_CONV (cnvl:conv->conv) thl =
  GENERAL_REWRITE_CONV false cnvl empty_net thl;;

let PURE_REWRITE_CONV thl =
  GENERAL_REWRITE_CONV true TOP_DEPTH_CONV empty_net thl;;

let REWRITE_CONV thl =
  GENERAL_REWRITE_CONV true TOP_DEPTH_CONV (basic_net()) thl;;

let PURE_ONCE_REWRITE_CONV thl =
  GENERAL_REWRITE_CONV false ONCE_DEPTH_CONV empty_net thl;;

let ONCE_REWRITE_CONV thl =
  GENERAL_REWRITE_CONV false ONCE_DEPTH_CONV (basic_net()) thl;;

(* ------------------------------------------------------------------------- *)
(* Rewriting rules and tactics.                                              *)
(* ------------------------------------------------------------------------- *)

let GEN_REWRITE_RULE cnvl thl = CONV_RULE(GEN_REWRITE_CONV cnvl thl);;

let PURE_REWRITE_RULE thl = CONV_RULE(PURE_REWRITE_CONV thl);;

let REWRITE_RULE thl = CONV_RULE(REWRITE_CONV thl);;

let PURE_ONCE_REWRITE_RULE thl = CONV_RULE(PURE_ONCE_REWRITE_CONV thl);;

let ONCE_REWRITE_RULE thl = CONV_RULE(ONCE_REWRITE_CONV thl);;

let PURE_ASM_REWRITE_RULE thl th =
    PURE_REWRITE_RULE ((map ASSUME (hyp th)) @ thl) th;;

let ASM_REWRITE_RULE thl th =
    REWRITE_RULE ((map ASSUME (hyp th)) @ thl) th;;

let PURE_ONCE_ASM_REWRITE_RULE thl th =
    PURE_ONCE_REWRITE_RULE ((map ASSUME (hyp th)) @ thl) th;;

let ONCE_ASM_REWRITE_RULE thl th =
    ONCE_REWRITE_RULE ((map ASSUME (hyp th)) @ thl) th;;

let GEN_REWRITE_TAC cnvl thl = CONV_TAC(GEN_REWRITE_CONV cnvl thl);;

let PURE_REWRITE_TAC thl = CONV_TAC(PURE_REWRITE_CONV thl);;

let REWRITE_TAC thl = CONV_TAC(REWRITE_CONV thl);;

let PURE_ONCE_REWRITE_TAC thl = CONV_TAC(PURE_ONCE_REWRITE_CONV thl);;

let ONCE_REWRITE_TAC thl = CONV_TAC(ONCE_REWRITE_CONV thl);;

let (PURE_ASM_REWRITE_TAC: thm list -> tactic) =
  ASM PURE_REWRITE_TAC;;

let (ASM_REWRITE_TAC: thm list -> tactic) =
  ASM REWRITE_TAC;;

let (PURE_ONCE_ASM_REWRITE_TAC: thm list -> tactic) =
  ASM PURE_ONCE_REWRITE_TAC;;

let (ONCE_ASM_REWRITE_TAC: thm list -> tactic) =
  ASM ONCE_REWRITE_TAC;;

(* ------------------------------------------------------------------------- *)
(* Simplification functions.                                                 *)
(* ------------------------------------------------------------------------- *)

let GEN_SIMPLIFY_CONV (strat:strategy) ss lev thl =
  let ss' = itlist AUGMENT_SIMPSET thl ss in
  TRY_CONV (strat ss' lev);;

let ONCE_SIMPLIFY_CONV ss = GEN_SIMPLIFY_CONV ONCE_DEPTH_SQCONV ss 1;;

let SIMPLIFY_CONV ss = GEN_SIMPLIFY_CONV TOP_DEPTH_SQCONV ss 3;;

(* ------------------------------------------------------------------------- *)
(* Simple but useful default version.                                        *)
(* ------------------------------------------------------------------------- *)

let empty_ss = Simpset(empty_net,basic_prover,[],mk_rewrites true);;

let basic_ss =
  let rewmaker = mk_rewrites true in
  fun thl ->
    let cthms = itlist rewmaker thl [] in
    let net' = itlist (net_of_thm true) cthms (basic_net()) in
    let net'' = itlist net_of_cong (basic_congs()) net' in
  Simpset(net'',basic_prover,[],rewmaker);;

let SIMP_CONV thl = SIMPLIFY_CONV (basic_ss []) thl;;

let PURE_SIMP_CONV thl = SIMPLIFY_CONV empty_ss thl;;

let ONCE_SIMP_CONV thl = ONCE_SIMPLIFY_CONV (basic_ss []) thl;;

let SIMP_RULE thl = CONV_RULE(SIMP_CONV thl);;

let PURE_SIMP_RULE thl = CONV_RULE(PURE_SIMP_CONV thl);;

let ONCE_SIMP_RULE thl = CONV_RULE(ONCE_SIMP_CONV thl);;

let SIMP_TAC thl = CONV_TAC(SIMP_CONV thl);;

let PURE_SIMP_TAC thl = CONV_TAC(PURE_SIMP_CONV thl);;

let ONCE_SIMP_TAC thl = CONV_TAC(ONCE_SIMP_CONV thl);;

let ASM_SIMP_TAC = ASM SIMP_TAC;;

let PURE_ASM_SIMP_TAC = ASM PURE_SIMP_TAC;;

let ONCE_ASM_SIMP_TAC = ASM ONCE_SIMP_TAC;;

(* ------------------------------------------------------------------------- *)
(* Abbreviation tactics.                                                     *)
(* ------------------------------------------------------------------------- *)

let ABBREV_TAC tm =
  let cvs,t = dest_eq tm in
  let v,vs = strip_comb cvs in
  let rs = list_mk_abs(vs,t) in
  let eq = mk_eq(rs,v) in
  let th1 = itlist (fun v th -> CONV_RULE(LAND_CONV BETA_CONV) (AP_THM th v))
                   (rev vs) (ASSUME eq) in
  let th2 = SIMPLE_CHOOSE v (SIMPLE_EXISTS v (GENL vs th1)) in
  let th3 = PROVE_HYP (EXISTS(mk_exists(v,eq),rs) (REFL rs)) th2 in
  fun (asl,w as gl) ->
    let avoids = itlist (union o frees o concl o snd) asl (frees w) in
    if mem v avoids then failwith "ABBREV_TAC: variable already used" else
    CHOOSE_THEN
     (fun th -> RULE_ASSUM_TAC(PURE_ONCE_REWRITE_RULE[th]) THEN
                PURE_ONCE_REWRITE_TAC[th] THEN
                ASSUME_TAC th)
     th3 gl;;

let EXPAND_TAC s = FIRST_ASSUM(SUBST1_TAC o SYM o
  check((=) s o fst o dest_var o rhs o concl)) THEN BETA_TAC;;
(* ========================================================================= *)
(* Additional theorems, mainly about quantifiers.                            *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* More stuff about equality.                                                *)
(* ------------------------------------------------------------------------- *)

let EQ_REFL = prove
 (`!x:A. x = x`,
  GEN_TAC THEN REFL_TAC);;

let EQ_REFL_T = prove
 (`!x:A. (x = x) <=> T`,
  GEN_TAC THEN MATCH_ACCEPT_TAC(EQT_INTRO(SPEC_ALL EQ_REFL)));;

let EQ_SYM = prove
 (`!(x:A) y. (x = y) ==> (y = x)`,
  REPEAT GEN_TAC THEN DISCH_THEN(ACCEPT_TAC o SYM));;

let EQ_SYM_EQ = prove
 (`!(x:A) y. (x = y) <=> (y = x)`,
  REPEAT GEN_TAC THEN EQ_TAC THEN MATCH_ACCEPT_TAC EQ_SYM);;

let EQ_TRANS = prove
 (`!(x:A) y z. (x = y) /\ (y = z) ==> (x = z)`,
  REPEAT STRIP_TAC THEN PURE_ASM_REWRITE_TAC[] THEN REFL_TAC);;

let REFL_CLAUSE = prove
 (`!x:A. (x = x) = T`,
  GEN_TAC THEN ACCEPT_TAC(EQT_INTRO(SPEC `x:A` EQ_REFL)));;

(* ------------------------------------------------------------------------- *)
(* The following is a common special case of ordered rewriting.              *)
(* ------------------------------------------------------------------------- *)

let AC acsuite = EQT_ELIM o PURE_REWRITE_CONV[acsuite; EQ_REFL_T];;

(* ------------------------------------------------------------------------- *)
(* A couple of theorems about beta reduction.                                *)
(* ------------------------------------------------------------------------- *)

let BETA_THM = prove
 (`!(f:A->B) y. (\x. (f:A->B) x) y = f y`,
  REPEAT GEN_TAC THEN BETA_TAC THEN REFL_TAC);;

let ABS_SIMP = prove
 (`!(t1:A) (t2:B). (\x. t1) t2 = t1`,
  REPEAT GEN_TAC THEN REWRITE_TAC[BETA_THM; REFL_CLAUSE]);;

(* ------------------------------------------------------------------------- *)
(* A few "big name" intuitionistic tautologies.                              *)
(* ------------------------------------------------------------------------- *)

let CONJ_ASSOC = prove
 (`!t1 t2 t3. t1 /\ t2 /\ t3 <=> (t1 /\ t2) /\ t3`,
  ITAUT_TAC);;

let CONJ_SYM = prove
 (`!t1 t2. t1 /\ t2 <=> t2 /\ t1`,
  ITAUT_TAC);;

let CONJ_ACI = prove
 (`(p /\ q <=> q /\ p) /\
   ((p /\ q) /\ r <=> p /\ (q /\ r)) /\
   (p /\ (q /\ r) <=> q /\ (p /\ r)) /\
   (p /\ p <=> p) /\
   (p /\ (p /\ q) <=> p /\ q)`,
  ITAUT_TAC);;

let DISJ_ASSOC = prove
 (`!t1 t2 t3. t1 \/ t2 \/ t3 <=> (t1 \/ t2) \/ t3`,
  ITAUT_TAC);;

let DISJ_SYM = prove
 (`!t1 t2. t1 \/ t2 <=> t2 \/ t1`,
  ITAUT_TAC);;

let DISJ_ACI = prove
 (`(p \/ q <=> q \/ p) /\
   ((p \/ q) \/ r <=> p \/ (q \/ r)) /\
   (p \/ (q \/ r) <=> q \/ (p \/ r)) /\
   (p \/ p <=> p) /\
   (p \/ (p \/ q) <=> p \/ q)`,
  ITAUT_TAC);;

let IMP_CONJ = prove
 (`p /\ q ==> r <=> p ==> q ==> r`,
  ITAUT_TAC);;

let IMP_IMP = GSYM IMP_CONJ;;

let IMP_CONJ_ALT = prove
 (`p /\ q ==> r <=> q ==> p ==> r`,
  ITAUT_TAC);;                

(* ------------------------------------------------------------------------- *)
(* A couple of "distribution" tautologies are useful.                        *)
(* ------------------------------------------------------------------------- *)

let LEFT_OR_DISTRIB = prove
 (`!p q r. p /\ (q \/ r) <=> p /\ q \/ p /\ r`,
  ITAUT_TAC);;

let RIGHT_OR_DISTRIB = prove
 (`!p q r. (p \/ q) /\ r <=> p /\ r \/ q /\ r`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Degenerate cases of quantifiers.                                          *)
(* ------------------------------------------------------------------------- *)

let FORALL_SIMP = prove
 (`!t. (!x:A. t) = t`,
  ITAUT_TAC);;

let EXISTS_SIMP = prove
 (`!t. (?x:A. t) = t`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* I also use this a lot (as a prelude to congruence reasoning).             *)
(* ------------------------------------------------------------------------- *)

let EQ_IMP = ITAUT `(a <=> b) ==> a ==> b`;;

(* ------------------------------------------------------------------------- *)
(* Start building up the basic rewrites; we add a few more later.            *)
(* ------------------------------------------------------------------------- *)

let EQ_CLAUSES = prove
 (`!t. ((T <=> t) <=> t) /\ ((t <=> T) <=> t) /\
       ((F <=> t) <=> ~t) /\ ((t <=> F) <=> ~t)`,
  ITAUT_TAC);;

let NOT_CLAUSES_WEAK = prove
 (`(~T <=> F) /\ (~F <=> T)`,
  ITAUT_TAC);;

let AND_CLAUSES = prove
 (`!t. (T /\ t <=> t) /\ (t /\ T <=> t) /\ (F /\ t <=> F) /\
       (t /\ F <=> F) /\ (t /\ t <=> t)`,
  ITAUT_TAC);;

let OR_CLAUSES = prove
 (`!t. (T \/ t <=> T) /\ (t \/ T <=> T) /\ (F \/ t <=> t) /\
       (t \/ F <=> t) /\ (t \/ t <=> t)`,
  ITAUT_TAC);;

let IMP_CLAUSES = prove
 (`!t. (T ==> t <=> t) /\ (t ==> T <=> T) /\ (F ==> t <=> T) /\
       (t ==> t <=> T) /\ (t ==> F <=> ~t)`,
  ITAUT_TAC);;

extend_basic_rewrites
  [REFL_CLAUSE;
   EQ_CLAUSES;
   NOT_CLAUSES_WEAK;
   AND_CLAUSES;
   OR_CLAUSES;
   IMP_CLAUSES;
   FORALL_SIMP;
   EXISTS_SIMP;
   BETA_THM;
   let IMP_EQ_CLAUSE = prove
    (`((x = x) ==> p) <=> p`,
     REWRITE_TAC[EQT_INTRO(SPEC_ALL EQ_REFL); IMP_CLAUSES]) in
   IMP_EQ_CLAUSE];;

extend_basic_congs
  [ITAUT `(p <=> p') ==> (p' ==> (q <=> q')) ==> (p ==> q <=> p' ==> q')`];;

(* ------------------------------------------------------------------------- *)
(* Rewrite rule for unique existence.                                        *)
(* ------------------------------------------------------------------------- *)

let EXISTS_UNIQUE_THM = prove
 (`!P. (?!x:A. P x) <=> (?x. P x) /\ (!x x'. P x /\ P x' ==> (x = x'))`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_DEF]);;

(* ------------------------------------------------------------------------- *)
(* Trivial instances of existence.                                           *)
(* ------------------------------------------------------------------------- *)

let EXISTS_REFL = prove
 (`!a:A. ?x. x = a`,
  GEN_TAC THEN EXISTS_TAC `a:A` THEN REFL_TAC);;

let EXISTS_UNIQUE_REFL = prove
 (`!a:A. ?!x. x = a`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_THM] THEN
  REPEAT(EQ_TAC ORELSE STRIP_TAC) THENL
   [EXISTS_TAC `a:A`; ASM_REWRITE_TAC[]] THEN
  REFL_TAC);;

(* ------------------------------------------------------------------------- *)
(* Unwinding.                                                                *)
(* ------------------------------------------------------------------------- *)

let UNWIND_THM1 = prove
 (`!P (a:A). (?x. (a = x) /\ P x) <=> P a`,
  REPEAT GEN_TAC THEN EQ_TAC THENL
   [DISCH_THEN(CHOOSE_THEN (CONJUNCTS_THEN2 SUBST1_TAC ACCEPT_TAC));
    DISCH_TAC THEN EXISTS_TAC `a:A` THEN
    CONJ_TAC THEN TRY(FIRST_ASSUM MATCH_ACCEPT_TAC) THEN
    REFL_TAC]);;

let UNWIND_THM2 = prove
 (`!P (a:A). (?x. (x = a) /\ P x) <=> P a`,
  REPEAT GEN_TAC THEN CONV_TAC(LAND_CONV(ONCE_DEPTH_CONV SYM_CONV)) THEN
  MATCH_ACCEPT_TAC UNWIND_THM1);;

(* ------------------------------------------------------------------------- *)
(* Permuting quantifiers.                                                    *)
(* ------------------------------------------------------------------------- *)

let SWAP_FORALL_THM = prove
 (`!P:A->B->bool. (!x y. P x y) <=> (!y x. P x y)`,
  ITAUT_TAC);;

let SWAP_EXISTS_THM = prove
 (`!P:A->B->bool. (?x y. P x y) <=> (?y x. P x y)`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Universal quantifier and conjunction.                                     *)
(* ------------------------------------------------------------------------- *)

let FORALL_AND_THM = prove
 (`!P Q. (!x:A. P x /\ Q x) <=> (!x. P x) /\ (!x. Q x)`,
  ITAUT_TAC);;

let AND_FORALL_THM = prove
 (`!P Q. (!x. P x) /\ (!x. Q x) <=> (!x:A. P x /\ Q x)`,
  ITAUT_TAC);;

let LEFT_AND_FORALL_THM = prove
 (`!P Q. (!x:A. P x) /\ Q <=> (!x:A. P x /\ Q)`,
  ITAUT_TAC);;

let RIGHT_AND_FORALL_THM = prove
 (`!P Q. P /\ (!x:A. Q x) <=> (!x. P /\ Q x)`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Existential quantifier and disjunction.                                   *)
(* ------------------------------------------------------------------------- *)

let EXISTS_OR_THM = prove
 (`!P Q. (?x:A. P x \/ Q x) <=> (?x. P x) \/ (?x. Q x)`,
  ITAUT_TAC);;

let OR_EXISTS_THM = prove
 (`!P Q. (?x. P x) \/ (?x. Q x) <=> (?x:A. P x \/ Q x)`,
  ITAUT_TAC);;

let LEFT_OR_EXISTS_THM = prove
 (`!P Q. (?x. P x) \/ Q <=> (?x:A. P x \/ Q)`,
  ITAUT_TAC);;

let RIGHT_OR_EXISTS_THM = prove
 (`!P Q. P \/ (?x. Q x) <=> (?x:A. P \/ Q x)`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Existential quantifier and conjunction.                                   *)
(* ------------------------------------------------------------------------- *)

let LEFT_EXISTS_AND_THM = prove
 (`!P Q. (?x:A. P x /\ Q) <=> (?x:A. P x) /\ Q`,
  ITAUT_TAC);;

let RIGHT_EXISTS_AND_THM = prove
 (`!P Q. (?x:A. P /\ Q x) <=> P /\ (?x:A. Q x)`,
  ITAUT_TAC);;

let TRIV_EXISTS_AND_THM = prove
 (`!P Q. (?x:A. P /\ Q) <=> (?x:A. P) /\ (?x:A. Q)`,
  ITAUT_TAC);;

let LEFT_AND_EXISTS_THM = prove
 (`!P Q. (?x:A. P x) /\ Q <=> (?x:A. P x /\ Q)`,
  ITAUT_TAC);;

let RIGHT_AND_EXISTS_THM = prove
 (`!P Q. P /\ (?x:A. Q x) <=> (?x:A. P /\ Q x)`,
  ITAUT_TAC);;

let TRIV_AND_EXISTS_THM = prove
 (`!P Q. (?x:A. P) /\ (?x:A. Q) <=> (?x:A. P /\ Q)`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Only trivial instances of universal quantifier and disjunction.           *)
(* ------------------------------------------------------------------------- *)

let TRIV_FORALL_OR_THM = prove
 (`!P Q. (!x:A. P \/ Q) <=> (!x:A. P) \/ (!x:A. Q)`,
  ITAUT_TAC);;

let TRIV_OR_FORALL_THM = prove
 (`!P Q. (!x:A. P) \/ (!x:A. Q) <=> (!x:A. P \/ Q)`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Implication and quantifiers.                                              *)
(* ------------------------------------------------------------------------- *)

let RIGHT_IMP_FORALL_THM = prove
 (`!P Q. (P ==> !x:A. Q x) <=> (!x. P ==> Q x)`,
  ITAUT_TAC);;

let RIGHT_FORALL_IMP_THM = prove
 (`!P Q. (!x. P ==> Q x) <=> (P ==> !x:A. Q x)`,
  ITAUT_TAC);;

let LEFT_IMP_EXISTS_THM = prove
 (`!P Q. ((?x:A. P x) ==> Q) <=> (!x. P x ==> Q)`,
  ITAUT_TAC);;

let LEFT_FORALL_IMP_THM = prove
 (`!P Q. (!x. P x ==> Q) <=> ((?x:A. P x) ==> Q)`,
  ITAUT_TAC);;

let TRIV_FORALL_IMP_THM = prove
 (`!P Q. (!x:A. P ==> Q) <=> ((?x:A. P) ==> (!x:A. Q))`,
  ITAUT_TAC);;

let TRIV_EXISTS_IMP_THM = prove
 (`!P Q. (?x:A. P ==> Q) <=> ((!x:A. P) ==> (?x:A. Q))`,
  ITAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* Alternative versions of unique existence.                                 *)
(* ------------------------------------------------------------------------- *)

let EXISTS_UNIQUE_ALT = prove
 (`!P:A->bool. (?!x. P x) <=> (?x. !y. P y <=> (x = y))`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_THM] THEN EQ_TAC THENL
   [DISCH_THEN(CONJUNCTS_THEN2 (X_CHOOSE_TAC `x:A`) ASSUME_TAC) THEN
    EXISTS_TAC `x:A` THEN GEN_TAC THEN EQ_TAC THENL
     [DISCH_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN ASM_REWRITE_TAC[];
      DISCH_THEN(SUBST1_TAC o SYM) THEN FIRST_ASSUM MATCH_ACCEPT_TAC];
    DISCH_THEN(X_CHOOSE_TAC `x:A`) THEN
    ASM_REWRITE_TAC[GSYM EXISTS_REFL] THEN REPEAT GEN_TAC THEN
    DISCH_THEN(CONJUNCTS_THEN (SUBST1_TAC o SYM)) THEN REFL_TAC]);;

let EXISTS_UNIQUE = prove
 (`!P:A->bool. (?!x. P x) <=> (?x. P x /\ !y. P y ==> (y = x))`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_ALT] THEN
  AP_TERM_TAC THEN ABS_TAC THEN
  GEN_REWRITE_TAC (LAND_CONV o BINDER_CONV)
   [ITAUT `(a <=> b) <=> (a ==> b) /\ (b ==> a)`] THEN
  GEN_REWRITE_TAC (LAND_CONV o ONCE_DEPTH_CONV) [EQ_SYM_EQ] THEN
  REWRITE_TAC[FORALL_AND_THM] THEN SIMP_TAC[] THEN
  REWRITE_TAC[LEFT_FORALL_IMP_THM; EXISTS_REFL] THEN
  REWRITE_TAC[CONJ_ACI]);;
(* ========================================================================= *)
(* Mutually inductively defined relations.                                   *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Strip off exactly n arguments from combination.                           *)
(* ------------------------------------------------------------------------- *)

let strip_ncomb =
  let rec strip(n,tm,acc) =
    if n < 1 then tm,acc else
    let l,r = dest_comb tm in
    strip(n - 1,l,r::acc) in
  fun n tm -> strip(n,tm,[]);;

(* ------------------------------------------------------------------------- *)
(* Expand lambda-term function definition with its arguments.                *)
(* ------------------------------------------------------------------------- *)

let RIGHT_BETAS =
  rev_itlist (fun a -> CONV_RULE (RAND_CONV BETA_CONV) o C AP_THM a);;

(* ------------------------------------------------------------------------- *)
(*      A, x = t |- P[x]                                                     *)
(*     ------------------ EXISTS_EQUATION                                    *)
(*        A |- ?x. P[x]                                                      *)
(* ------------------------------------------------------------------------- *)

let EXISTS_EQUATION =
  let pth = prove
   (`!P t. (!x:A. (x = t) ==> P x) ==> (?) P`,
    REWRITE_TAC[EXISTS_DEF] THEN BETA_TAC THEN
    REPEAT STRIP_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN
    EXISTS_TAC `t:A` THEN FIRST_ASSUM MATCH_MP_TAC THEN
    REFL_TAC) in
  fun tm th ->
    let l,r = dest_eq tm in
    let P = mk_abs(l,concl th) in
    let th1 = BETA_CONV(mk_comb(P,l)) in
    let th2 = ISPECL [P; r] pth in
    let th3 = EQ_MP (SYM th1) th in
    let th4 = GEN l (DISCH tm th3) in
    MP th2 th4;;

(* ========================================================================= *)
(* Part 1: The main part of the inductive definitions package.               *)
(* This proves that a certain definition yields the requires theorems.       *)
(* ========================================================================= *)

let derive_nonschematic_inductive_relations =
  let getconcl tm =
    let bod = repeat (snd o dest_forall) tm in
    try snd(dest_imp bod) with Failure _ -> bod
  and CONJ_ACI_RULE = AC CONJ_ACI
  and SIMPLE_DISJ_PAIR th =
    let l,r = dest_disj(hd(hyp th)) in
    PROVE_HYP (DISJ1 (ASSUME l) r) th,PROVE_HYP (DISJ2 l (ASSUME r)) th
  and HALF_BETA_EXPAND args th = GENL args (RIGHT_BETAS args th) in
  let AND_IMPS_CONV tm =
    let ths = CONJUNCTS(ASSUME tm) in
    let avs = fst(strip_forall(concl(hd ths))) in
    let thl = map (DISCH tm o UNDISCH o SPEC_ALL) ths in
    let th1 = end_itlist SIMPLE_DISJ_CASES thl in
    let tm1 = hd(hyp th1) in
    let th2 = GENL avs (DISCH tm1 (UNDISCH th1)) in
    let tm2 = concl th2 in
    let th3 = DISCH tm2 (UNDISCH (SPEC_ALL (ASSUME tm2))) in
    let thts,tht =  nsplit SIMPLE_DISJ_PAIR (tl ths) th3 in
    let proc_fn th =
      let t = hd(hyp th) in GENL avs (DISCH t (UNDISCH th)) in
    let th4 = itlist (CONJ o proc_fn) thts (proc_fn tht) in
    IMP_ANTISYM_RULE (DISCH_ALL th2) (DISCH_ALL th4) in
  let t_tm = `T` in
  let calculate_simp_sequence =
    let rec getequs(avs,plis) =
      if plis = [] then [] else
      let h::t = plis in
      let r = snd h in
      if mem r avs then
        h::(getequs(avs,filter ((<>) r o snd) t))
      else
        getequs(avs,t) in
    fun avs plis ->
      let oks = getequs(avs,plis) in
      oks,subtract plis oks
  and FORALL_IMPS_CONV tm =
    let avs,bod = strip_forall tm in
    let th1 = DISCH tm (UNDISCH(SPEC_ALL(ASSUME tm))) in
    let th2 = itlist SIMPLE_CHOOSE avs th1 in
    let tm2 = hd(hyp th2) in
    let th3 = DISCH tm2 (UNDISCH th2) in
    let th4 = ASSUME (concl th3) in
    let ant = lhand bod in
    let th5 = itlist SIMPLE_EXISTS avs (ASSUME ant) in
    let th6 = GENL avs (DISCH ant (MP th4 th5)) in
    IMP_ANTISYM_RULE (DISCH_ALL th3) (DISCH_ALL th6) in
  let canonicalize_clause cls args =
    let avs,bimp = strip_forall cls in
    let ant,con = try dest_imp bimp with Failure _ -> t_tm,bimp in
    let rel,xargs = strip_comb con in
    let plis = zip args xargs in
    let yes,no = calculate_simp_sequence avs plis in
    let nvs = filter (not o C mem (map snd yes)) avs in
    let eth =
      if is_imp bimp then
        let atm = itlist (curry mk_conj o mk_eq) (yes@no) ant in
        let ths,tth = nsplit CONJ_PAIR plis (ASSUME atm) in
        let thl = map (fun t -> find (fun th -> lhs(concl th) = t) ths) args in
        let th0 = MP (SPECL avs (ASSUME cls)) tth in
        let th1 = rev_itlist (C (curry MK_COMB)) thl (REFL rel) in
        let th2 = EQ_MP (SYM th1) th0 in
        let th3 = INST yes (DISCH atm th2) in
        let tm4 = funpow (length yes) rand (lhand(concl th3)) in
        let th4 = itlist (CONJ o REFL o fst) yes (ASSUME tm4) in
        let th5 = GENL args (GENL nvs (DISCH tm4 (MP th3 th4))) in
        let th6 = SPECL nvs (SPECL (map snd plis) (ASSUME (concl th5))) in
        let th7 = itlist (CONJ o REFL o snd) no (ASSUME ant) in
        let th8 = GENL avs (DISCH ant (MP th6 th7)) in
        IMP_ANTISYM_RULE (DISCH_ALL th5) (DISCH_ALL th8)
      else
        let atm = list_mk_conj(map mk_eq (yes@no)) in
        let ths = CONJUNCTS (ASSUME atm) in
        let thl = map (fun t -> find (fun th -> lhs(concl th) = t) ths) args in
        let th0 = SPECL avs (ASSUME cls) in
        let th1 = rev_itlist (C (curry MK_COMB)) thl (REFL rel) in
        let th2 = EQ_MP (SYM th1) th0 in
        let th3 = INST yes (DISCH atm th2) in
        let tm4 = funpow (length yes) rand (lhand(concl th3)) in
        let th4 = itlist (CONJ o REFL o fst) yes (ASSUME tm4) in
        let th5 = GENL args (GENL nvs (DISCH tm4 (MP th3 th4))) in
        let th6 = SPECL nvs (SPECL (map snd plis) (ASSUME (concl th5))) in
        let th7 = end_itlist CONJ (map (REFL o snd) no) in
        let th8 = GENL avs (MP th6 th7) in
        IMP_ANTISYM_RULE (DISCH_ALL th5) (DISCH_ALL th8) in
    let ftm = funpow (length args) (body o rand) (rand(concl eth)) in
    TRANS eth (itlist MK_FORALL args (FORALL_IMPS_CONV ftm)) in
  let canonicalize_clauses clauses =
    let concls = map getconcl clauses in
    let uncs = map strip_comb concls in
    let rels = itlist (insert o fst) uncs [] in
    let xargs = map (C assoc uncs) rels in
    let closed = list_mk_conj clauses in
    let avoids = variables closed in
    let flargs =
      make_args "a" avoids (map type_of (end_itlist (@) xargs)) in
    let zargs = zip rels (shareout xargs flargs) in
    let cargs = map (fun (r,a) -> assoc r zargs) uncs in
    let cthms = map2 canonicalize_clause clauses cargs in
    let pclauses = map (rand o concl) cthms in
    let collectclauses tm =
      mapfilter (fun t -> if fst t = tm then snd t else fail())
                (zip (map fst uncs) pclauses) in
    let clausell = map collectclauses rels in
    let cclausel = map list_mk_conj clausell in
    let cclauses = list_mk_conj cclausel
    and oclauses = list_mk_conj pclauses in
    let eth = CONJ_ACI_RULE(mk_eq(oclauses,cclauses)) in
    let pth = TRANS (end_itlist MK_CONJ cthms) eth in
    TRANS pth (end_itlist MK_CONJ (map AND_IMPS_CONV cclausel))
  and derive_canon_inductive_relations clauses =
    let closed = list_mk_conj clauses in
    let clauses = conjuncts closed in
    let vargs,bodies = unzip(map strip_forall clauses) in
    let ants,concs = unzip(map dest_imp bodies) in
    let rels = map (repeat rator) concs in
    let avoids = variables closed in
    let rels' = variants avoids rels in
    let crels = zip rels' rels in
    let prime_fn = subst crels in
    let closed' = prime_fn closed in
    let mk_def arg con =
      mk_eq(repeat rator con,
        list_mk_abs(arg,list_mk_forall(rels',mk_imp(closed',prime_fn con)))) in
    let deftms = map2 mk_def vargs concs in
    let defthms = map2 HALF_BETA_EXPAND vargs (map ASSUME deftms) in
    let mk_ind args th =
      let th1 = fst(EQ_IMP_RULE(SPEC_ALL th)) in
      let ant = lhand(concl th1) in
      let th2 = SPECL rels' (UNDISCH th1) in
      GENL args (DISCH ant (UNDISCH th2)) in
    let indthms = map2 mk_ind vargs defthms in
    let indthmr = end_itlist CONJ indthms in
    let indthm = GENL rels' (DISCH closed' indthmr) in
    let mconcs = map2 (fun a t -> list_mk_forall(a,mk_imp(t,prime_fn t)))
      vargs ants in
    let monotm = mk_imp(concl indthmr,list_mk_conj mconcs) in
    let monothm = ASSUME(list_mk_forall(rels,list_mk_forall(rels',monotm))) in
    let closthm = ASSUME closed' in
    let monothms = CONJUNCTS
      (MP (SPEC_ALL monothm) (MP (SPECL rels' indthm) closthm)) in
    let closthms = CONJUNCTS closthm in
    let prove_rule mth (cth,dth) =
      let avs,bod = strip_forall(concl mth) in
      let th1 = IMP_TRANS (SPECL avs mth) (SPECL avs cth) in
      let th2 = GENL rels' (DISCH closed' (UNDISCH th1)) in
      let th3 = EQ_MP (SYM (SPECL avs dth)) th2 in
      GENL avs (DISCH (lhand bod) th3) in
    let rulethms = map2 prove_rule monothms (zip closthms defthms) in
    let rulethm = end_itlist CONJ rulethms in
    let dtms = map2 (curry list_mk_abs) vargs ants in
    let double_fn = subst (zip dtms rels) in
    let mk_unbetas tm dtm =
      let avs,bod = strip_forall tm in
      let il,r = dest_comb bod in
      let i,l = dest_comb il in
      let bth = RIGHT_BETAS avs (REFL dtm) in
      let munb = AP_THM (AP_TERM i bth) r in
      let iunb = AP_TERM (mk_comb(i,double_fn l)) bth in
      let junb = AP_TERM (mk_comb(i,r)) bth in
      let quantify = itlist MK_FORALL avs in
      (quantify munb,(quantify iunb,quantify junb)) in
    let unths = map2 mk_unbetas clauses dtms in
    let irthm = EQ_MP (SYM(end_itlist MK_CONJ (map fst unths))) rulethm in
    let mrthm = MP (SPECL rels (SPECL dtms monothm)) irthm in
    let imrth = EQ_MP (SYM(end_itlist MK_CONJ (map (fst o snd) unths))) mrthm in
    let ifthm = MP (SPECL dtms indthm) imrth in
    let fthm = EQ_MP (end_itlist MK_CONJ (map (snd o snd) unths)) ifthm in
    let mk_case th1 th2 =
      let avs = fst(strip_forall(concl th1)) in
      GENL avs (IMP_ANTISYM_RULE (SPEC_ALL th1) (SPEC_ALL th2)) in
    let casethm = end_itlist CONJ
      (map2 mk_case (CONJUNCTS fthm) (CONJUNCTS rulethm)) in
    CONJ rulethm (CONJ indthm casethm) in
  fun tm ->
    let clauses = conjuncts tm in
    let canonthm = canonicalize_clauses clauses in
    let canonthm' = SYM canonthm in
    let pclosed = rand(concl canonthm) in
    let pclauses = conjuncts pclosed in
    let rawthm = derive_canon_inductive_relations pclauses in
    let rulethm,otherthms = CONJ_PAIR rawthm in
    let indthm,casethm = CONJ_PAIR otherthms in
    let rulethm' = EQ_MP canonthm' rulethm
    and indthm' = CONV_RULE (ONCE_DEPTH_CONV (REWR_CONV canonthm')) indthm in
    CONJ rulethm' (CONJ indthm' casethm);;

(* ========================================================================= *)
(* Part 2: Tactic-integrated tools for proving monotonicity automatically.   *)
(* ========================================================================= *)

let MONO_AND = ITAUT `(A ==> B) /\ (C ==> D) ==> (A /\ C ==> B /\ D)`;;

let MONO_OR = ITAUT `(A ==> B) /\ (C ==> D) ==> (A \/ C ==> B \/ D)`;;

let MONO_IMP = ITAUT `(B ==> A) /\ (C ==> D) ==> ((A ==> C) ==> (B ==> D))`;;

let MONO_NOT = ITAUT `(B ==> A) ==> (~A ==> ~B)`;;

let MONO_FORALL = prove
 (`(!x:A. P x ==> Q x) ==> ((!x. P x) ==> (!x. Q x))`,
  REPEAT STRIP_TAC THEN FIRST_ASSUM MATCH_MP_TAC THEN
  ASM_REWRITE_TAC[]);;

let MONO_EXISTS = prove
 (`(!x:A. P x ==> Q x) ==> ((?x. P x) ==> (?x. Q x))`,
  DISCH_TAC THEN DISCH_THEN(X_CHOOSE_TAC `x:A`) THEN
  EXISTS_TAC `x:A` THEN FIRST_ASSUM MATCH_MP_TAC THEN
  ASM_REWRITE_TAC[]);;

(* ------------------------------------------------------------------------- *)
(* Assignable list of monotonicity theorems, so users can add their own.     *)
(* ------------------------------------------------------------------------- *)

let monotonicity_theorems = ref
 [MONO_AND; MONO_OR; MONO_IMP; MONO_NOT; MONO_EXISTS; MONO_FORALL];;

(* ------------------------------------------------------------------------- *)
(* Attempt to backchain through the monotonicity theorems.                   *)
(* ------------------------------------------------------------------------- *)

let MONO_TAC =
  let imp = `(==>)` and IMP_REFL = ITAUT `!p. p ==> p` in
  let BACKCHAIN_TAC th =
    let match_fn = PART_MATCH (snd o dest_imp) th in
    fun (asl,w) ->
      let th1 = match_fn w in
      let ant,con = dest_imp(concl th1) in
      null_meta,[asl,ant],fun i [t] -> MATCH_MP (INSTANTIATE i th1) t
  and MONO_ABS_TAC (asl,w) =
    let ant,con = dest_imp w in
    let vars = snd(strip_comb con) in
    let rnum = length vars - 1 in
    let hd1,args1 = strip_ncomb rnum ant
    and hd2,args2 = strip_ncomb rnum con in
    let th1 = rev_itlist (C AP_THM) args1 (BETA_CONV hd1)
    and th2 = rev_itlist (C AP_THM) args1 (BETA_CONV hd2) in
    let th3 = MK_COMB(AP_TERM imp th1,th2) in
    CONV_TAC(REWR_CONV th3) (asl,w)
  and APPLY_MONOTAC tacs (asl,w) =
    let a,c = dest_imp w in
    if aconv a c then ACCEPT_TAC (SPEC a IMP_REFL) (asl,w) else
    let cn = try fst(dest_const(repeat rator c)) with Failure _ -> "" in
    tryfind (fun (k,t) -> if k = cn then t (asl,w) else fail()) tacs in
  fun gl ->
    let tacs = itlist
      (fun th l -> let ft = repeat rator (funpow 2 rand (concl th)) in
                   let c = try fst(dest_const ft) with Failure _ -> "" in
                   (c,BACKCHAIN_TAC th THEN REPEAT CONJ_TAC)::l)
      (!monotonicity_theorems) ["",MONO_ABS_TAC] in
    let MONO_STEP_TAC = REPEAT GEN_TAC THEN APPLY_MONOTAC tacs in
    (REPEAT MONO_STEP_TAC THEN ASM_REWRITE_TAC[]) gl;;

(* ------------------------------------------------------------------------- *)
(* Attempt to dispose of the non-equational assumption(s) of a theorem.      *)
(* ------------------------------------------------------------------------- *)

let prove_monotonicity_hyps =
  let tac = REPEAT GEN_TAC THEN
    DISCH_THEN(REPEAT_TCL CONJUNCTS_THEN ASSUME_TAC) THEN
    REPEAT CONJ_TAC THEN MONO_TAC in
  let prove_mth t = prove(t,tac) in
  fun th ->
    let mths = mapfilter prove_mth (filter (not o is_eq) (hyp th)) in
    itlist PROVE_HYP mths th;;

(* ========================================================================= *)
(* Part 3: The final user wrapper, with schematic variables added.           *)
(* ========================================================================= *)

let the_inductive_definitions = ref [];;

let prove_inductive_relations_exist,new_inductive_definition =
  let rec pare_comb qvs tm =
    if intersect (frees tm) qvs = [] & forall is_var (snd(strip_comb tm))
    then tm
    else pare_comb qvs (rator tm) in
  let generalize_schematic_variables gflag vs =
    let generalize_def tm th =
      let l,r = dest_eq tm in
      let lname,lty = dest_var l in
      let l' = mk_var(lname,itlist (mk_fun_ty o type_of) vs lty) in
      let r' = list_mk_abs(vs,r) in
      let tm' = mk_eq(l',r') in
      let th0 = RIGHT_BETAS vs (ASSUME tm') in
      let th1 = INST [lhs(concl th0),l] (DISCH tm th) in
      MP th1 th0 in
    fun th ->
      let defs,others = partition is_eq (hyp th) in
      let th1 = itlist generalize_def defs th in
      if gflag then
        let others' = map (fun t -> let fvs = frees t in
                                    SPECL fvs (ASSUME (list_mk_forall(fvs,t))))
                          others in
        GENL vs (itlist PROVE_HYP others' th1)
      else th1
  and derive_existence th =
    let defs = filter is_eq (hyp th) in
    itlist EXISTS_EQUATION defs th
  and make_definitions th =
    let defs = filter is_eq (hyp th) in
    let dths = map new_definition defs in
    let insts = zip (map (lhs o concl) dths) (map lhs defs) in
    rev_itlist (C MP) dths (INST insts (itlist DISCH defs th))
  and unschematize_clauses clauses =
    let schem = map (fun cls -> let avs,bod = strip_forall cls in
                  pare_comb avs (try snd(dest_imp bod) with Failure _ -> bod))
                            clauses in
      let schems = setify schem in
      if is_var(hd schem) then (clauses,[]) else
      if not (length(setify (map (snd o strip_comb) schems)) = 1)
      then failwith "Schematic variables not used consistently" else
      let avoids = variables (list_mk_conj clauses) in
      let hack_fn tm = mk_var(fst(dest_var(repeat rator tm)),type_of tm) in
      let grels = variants avoids (map hack_fn schems) in
      let crels = zip grels schems in
      let clauses' = map (subst crels) clauses in
      clauses',snd(strip_comb(hd schems)) in
  let find_redefinition tm (rth,ith,cth as trip) =
    if aconv tm (concl rth) then trip else failwith "find_redefinition" in
  let prove_inductive_properties tm =
    let clauses = conjuncts tm in
    let clauses',fvs = unschematize_clauses clauses in
    let th = derive_nonschematic_inductive_relations (list_mk_conj clauses') in
    fvs,prove_monotonicity_hyps th in
  let prove_inductive_relations_exist tm =
    let fvs,th1 = prove_inductive_properties tm in
    let th2 = generalize_schematic_variables true fvs th1 in
    derive_existence th2
  and new_inductive_definition tm =
    try let th = tryfind (find_redefinition tm) (!the_inductive_definitions) in
        warn true "Benign redefinition of inductive predicate"; th
    with Failure _ ->
    let fvs,th1 = prove_inductive_properties tm in
    let th2 = generalize_schematic_variables true fvs th1 in
    let th3 = make_definitions th2 in
    let avs = fst(strip_forall(concl th3)) in
    let r,ic = CONJ_PAIR(SPECL avs th3) in
    let i,c = CONJ_PAIR ic in
    let thtr = GENL avs r,GENL avs i,GENL avs c in
    the_inductive_definitions := thtr::(!the_inductive_definitions);
    thtr in
  prove_inductive_relations_exist,new_inductive_definition;;

(* ------------------------------------------------------------------------- *)
(* Derivation of "strong induction".                                         *)
(* ------------------------------------------------------------------------- *)

let derive_strong_induction =
  let dest_ibod tm =
    let avs,ibod = strip_forall tm in
    let n = length avs in
    let prator = funpow n rator in
    let ant,con = dest_imp ibod in
    n,(prator ant,prator con) in
  let rec prove_triv tm =
    if is_conj tm then CONJ (prove_triv(lhand tm)) (prove_triv(rand tm)) else
    let avs,bod = strip_forall tm in
    let a,c = dest_imp bod in
    let ths = CONJUNCTS(ASSUME a) in
    let th = find (aconv c o concl) ths in
    GENL avs (DISCH a th) in
  let rec weaken_triv th =
    if is_conj(concl th)
    then CONJ (weaken_triv(CONJUNCT1 th)) (weaken_triv(CONJUNCT2 th)) else
    let avs,bod = strip_forall(concl th) in
    let th1 = SPECL avs th in
    let a = fst(dest_imp(concl th1)) in
    GENL avs (DISCH a (CONJUNCT2 (UNDISCH th1))) in
  let MATCH_IMPS = MATCH_MP MONO_AND in
  fun (rth,ith) ->
    let ovs,ibod = strip_forall(concl ith) in
    let iant,icon = dest_imp ibod in
    let ns,prrs = unzip (map dest_ibod (conjuncts icon)) in
    let rs,ps = unzip prrs in
    let gs = variants (variables ibod) ps in
    let svs,tvs = chop_list (length ovs - length ns) ovs in
    let sth = SPECL svs rth and jth = SPECL svs ith in
    let gimps = subst (zip gs rs) icon in
    let prs = map2 (fun n (r,p) ->
      let tys,ty = nsplit dest_fun_ty (1--n) (type_of r) in
      let gvs = map genvar tys in
      list_mk_abs(gvs,mk_conj(list_mk_comb(r,gvs),list_mk_comb(p,gvs))))
     ns prrs in
    let modify_rule rcl itm =
      let avs,bod = strip_forall itm in
      if is_imp bod then
        let a,c = dest_imp bod in
        let mgoal = mk_imp(gimps,mk_imp(vsubst(zip gs ps) a,a)) in
        let mth = ASSUME(list_mk_forall(gs@ps@avs,mgoal)) in
        let ith_r = BETA_RULE(SPECL (prs @ rs @ avs) mth)
        and ith_p = BETA_RULE(SPECL (prs @ ps @ avs) mth) in
        let jth_r = MP ith_r (prove_triv(lhand(concl ith_r)))
        and jth_p = MP ith_p (prove_triv(lhand(concl ith_p))) in
        let t = lhand(concl jth_r) in
        let kth_r = UNDISCH jth_r
        and kth_p = UNDISCH jth_p in
        let ntm = list_mk_forall(avs,mk_imp(t,c)) in
        let lth_r = MP(SPECL avs rcl) kth_r
        and lth_p = UNDISCH(SPECL avs (ASSUME ntm)) in
        DISCH ntm (GENL avs (DISCH t (CONJ lth_r lth_p)))
      else
        DISCH itm (GENL avs (CONJ (SPECL avs rcl) (SPECL avs (ASSUME itm)))) in
    let mimps = map2 modify_rule (CONJUNCTS sth) (conjuncts iant) in
    let th1 = end_itlist (fun th th' -> MATCH_IMPS(CONJ th th')) mimps in
    let th2 = BETA_RULE(SPECL prs jth) in
    let th3 = IMP_TRANS th1 th2 in
    let nasm = lhand(concl th3) in
    let th4 = GENL ps (DISCH nasm (weaken_triv(UNDISCH th3))) in
    GENL svs (prove_monotonicity_hyps th4);;
(* ========================================================================= *)
(* Extensional, classical reasoning with AC starts now!                      *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let ETA_AX = new_axiom
  `!t:A->B. (\x. t x) = t`;;

let ETA_CONV =
  let t = `t:A->B` in
  let pth = prove(`(\x. (t:A->B) x) = t`,MATCH_ACCEPT_TAC ETA_AX) in
  fun tm ->
    try let bv,bod = dest_abs tm in
        let l,r = dest_comb bod in
        if r = bv & not (vfree_in bv l) then
          TRANS (REFL tm) (PINST [type_of bv,aty; type_of bod,bty] [l,t] pth)
        else fail()
    with Failure _ -> failwith "ETA_CONV";;

let EQ_EXT = prove
 (`!(f:A->B) g. (!x. f x = g x) ==> f = g`,
  REPEAT GEN_TAC THEN DISCH_THEN(MP_TAC o ABS `x:A` o SPEC `x:A`) THEN
  REWRITE_TAC[ETA_AX]);;

let FUN_EQ_THM = prove
 (`!(f:A->B) g. f = g <=> (!x. f x = g x)`,
  REPEAT GEN_TAC THEN EQ_TAC THENL
   [DISCH_THEN SUBST1_TAC THEN GEN_TAC THEN REFL_TAC;
    MATCH_ACCEPT_TAC EQ_EXT]);;

(* ------------------------------------------------------------------------- *)
(* Indefinite descriptor (giving AC).                                        *)
(* ------------------------------------------------------------------------- *)

new_constant("@",`:(A->bool)->A`);;

parse_as_binder "@";;

let is_select = is_binder "@";;
let dest_select = dest_binder "@";;
let mk_select = mk_binder "@";;

let SELECT_AX = new_axiom
 `!P (x:A). P x ==> P((@) P)`;;

(* ------------------------------------------------------------------------- *)
(* Useful for compatibility. (The old EXISTS_DEF.)                           *)
(* ------------------------------------------------------------------------- *)

let EXISTS_THM = prove
 (`(?) = \P:A->bool. P ((@) P)`,
  MATCH_MP_TAC EQ_EXT THEN BETA_TAC THEN X_GEN_TAC `P:A->bool` THEN
  GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM ETA_AX] THEN
  EQ_TAC THENL
   [DISCH_THEN(CHOOSE_THEN MP_TAC) THEN MATCH_ACCEPT_TAC SELECT_AX;
    DISCH_TAC THEN EXISTS_TAC `((@) P):A` THEN POP_ASSUM ACCEPT_TAC]);;

(* ------------------------------------------------------------------------- *)
(* Rules and so on for the select operator.                                  *)
(* ------------------------------------------------------------------------- *)

let SELECT_RULE =
  let P = `P:A->bool` in
  let pth = prove
   (`(?) (P:A->bool) ==> P((@) P)`,
    SIMP_TAC[SELECT_AX; ETA_AX]) in
  fun th ->
    try let abs = rand(concl th) in
        let ty = type_of(bndvar abs) in
        CONV_RULE BETA_CONV (MP (PINST [ty,aty] [abs,P] pth) th)
    with Failure _ -> failwith "SELECT_RULE";;

let SELECT_CONV =
  let P = `P:A->bool` in
  let pth = prove
   (`(P:A->bool)((@) P) = (?) P`,
    REWRITE_TAC[EXISTS_THM] THEN BETA_TAC THEN REFL_TAC) in
   fun tm ->
     try let is_epsok t = is_select t &
                          let bv,bod = dest_select t in
                          aconv tm (vsubst [t,bv] bod) in
         let pickeps = find_term is_epsok tm in
         let abs = rand pickeps in
         let ty = type_of (bndvar abs) in
         CONV_RULE (LAND_CONV BETA_CONV) (PINST [ty,aty] [abs,P] pth)
     with Failure _ -> failwith "SELECT_CONV";;

(* ------------------------------------------------------------------------- *)
(* Some basic theorems.                                                      *)
(* ------------------------------------------------------------------------- *)

let SELECT_REFL = prove
 (`!x:A. (@y. y = x) = x`,
  GEN_TAC THEN CONV_TAC SELECT_CONV THEN
  EXISTS_TAC `x:A` THEN REFL_TAC);;

let SELECT_UNIQUE = prove
 (`!P x. (!y:A. P y = (y = x)) ==> ((@) P = x)`,
  REPEAT STRIP_TAC THEN
  GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM ETA_AX] THEN
  ASM_REWRITE_TAC[SELECT_REFL]);;

extend_basic_rewrites [SELECT_REFL];;

(* ------------------------------------------------------------------------- *)
(* Derived principles of definition based on existence.                      *)
(* ------------------------------------------------------------------------- *)

let the_specifications = ref [];;

let new_specification =
  let SEL_RULE =
    CONV_RULE (RATOR_CONV (REWR_CONV EXISTS_THM) THENC BETA_CONV) in
  let check_distinct l =
    try itlist (fun t res -> if mem t res then fail() else t::res) l []; true
    with Failure _ -> false in
  let specify name th =
    let th1 = SEL_RULE th in
    let l,r = dest_comb(concl th1) in
    let ty = type_of r in
    let th2 = new_definition(mk_eq(mk_var(name,ty),r)) in
    CONV_RULE BETA_CONV (EQ_MP (AP_TERM l (SYM th2)) th1) in
  fun names th ->
    let asl,c = dest_thm th in
    if not (asl = []) then
      failwith "new_specification: Assumptions not allowed in theorem" else
    if not (frees c = []) then
      failwith "new_specification: Free variables in predicate" else
    let avs = fst(strip_exists c) in
    if length names = 0 or length names > length avs then
      failwith "new_specification: Unsuitable number of constant names" else
    if not (check_distinct names) then
      failwith "new_specification: Constant names not distinct"
    else
      try let sth = snd(find (fun ((names',th'),sth') ->
                               names' = names & aconv (concl th') (concl th))
                             (!the_specifications)) in
          warn true ("Benign respecification"); sth
      with Failure _ ->
          let sth = rev_itlist specify names th in
          the_specifications := ((names,th),sth)::(!the_specifications); sth;;

(* ------------------------------------------------------------------------- *)
(* Now we can derive type definitions from existence; check benignity.       *)
(* ------------------------------------------------------------------------- *)

let the_type_definitions = ref ([]:((string*string*string)*(thm*thm))list);;

let new_type_definition tyname (absname,repname) th =
  try let th',tth' = assoc (tyname,absname,repname) (!the_type_definitions) in
      if concl th' <> concl th then failwith "" else
      (warn true "Benign redefinition of type"; tth')
  with Failure _ ->
    let th0 =
     CONV_RULE (RATOR_CONV (REWR_CONV EXISTS_THM) THENC BETA_CONV) th in
    let th1,th2 = new_basic_type_definition tyname (absname,repname) th0 in
    let tth = CONJ (GEN_ALL th1)
                   (GEN_ALL (CONV_RULE(LAND_CONV (TRY_CONV BETA_CONV)) th2)) in
    the_type_definitions := ((tyname,absname,repname),(th,tth))::
                            (!the_type_definitions);
    tth;;

(* ------------------------------------------------------------------------- *)
(* Derive excluded middle (the proof is from Beeson's book).                 *)
(* ------------------------------------------------------------------------- *)

let EXCLUDED_MIDDLE = prove
 (`!t. t \/ ~t`,
  GEN_TAC THEN SUBGOAL_THEN
   `(((@x. (x <=> F) \/ (x <=> T) /\ t) <=> F) \/
     ((@x. (x <=> F) \/ (x <=> T) /\ t) <=> T) /\ t) /\
    (((@x. (x <=> T) \/ (x <=> F) /\ t) <=> T) \/
     ((@x. (x <=> T) \/ (x <=> F) /\ t) <=> F) /\ t)`
  MP_TAC THENL
   [CONJ_TAC THEN CONV_TAC SELECT_CONV THENL
     [EXISTS_TAC `F`; EXISTS_TAC `T`] THEN
    DISJ1_TAC THEN REFL_TAC; ALL_TAC] THEN
  DISCH_THEN STRIP_ASSUME_TAC THEN
  TRY(DISJ1_TAC THEN FIRST_ASSUM ACCEPT_TAC) THEN
  MP_TAC(ITAUT `~(T <=> F)`) THEN
  POP_ASSUM_LIST(PURE_ONCE_REWRITE_TAC o map SYM) THEN
  DISCH_THEN(fun th -> DISJ2_TAC THEN MP_TAC th) THEN
  MATCH_MP_TAC(ITAUT `(a ==> b) ==> ~b ==> ~a`) THEN
  DISCH_THEN(SUBST1_TAC o EQT_INTRO) THEN
  GEN_REWRITE_TAC (RAND_CONV o ONCE_DEPTH_CONV)
   [ITAUT `a \/ (b /\ T) <=> b \/ (a /\ T)`] THEN
  REFL_TAC);;

let BOOL_CASES_AX = prove
 (`!t. (t <=> T) \/ (t <=> F)`,
  GEN_TAC THEN DISJ_CASES_TAC(SPEC `t:bool` EXCLUDED_MIDDLE) THEN
  ASM_REWRITE_TAC[]);;

(* ------------------------------------------------------------------------- *)
(* Classically based tactics. (See also COND_CASES_TAC later on.)            *)
(* ------------------------------------------------------------------------- *)

let BOOL_CASES_TAC p = STRUCT_CASES_TAC (SPEC p BOOL_CASES_AX);;

let ASM_CASES_TAC t = DISJ_CASES_TAC(SPEC t EXCLUDED_MIDDLE);;

(* ------------------------------------------------------------------------- *)
(* Set up a reasonable tautology checker for classical logic.                *)
(* ------------------------------------------------------------------------- *)

let TAUT =
  let RTAUT_TAC (asl,w) =
    let ok t = type_of t = bool_ty & can (find_term is_var) t & free_in t w in
    (REWRITE_TAC[] THEN
     W((fun t1 t2 -> t1 THEN t2) (REWRITE_TAC[]) o BOOL_CASES_TAC o
       hd o sort free_in o find_terms ok o snd)) (asl,w) in
  let TAUT_TAC = REPEAT(GEN_TAC ORELSE CONJ_TAC) THEN REPEAT RTAUT_TAC in
  fun tm -> prove(tm,TAUT_TAC);;

(* ------------------------------------------------------------------------- *)
(* A few useful classical tautologies.                                       *)
(* ------------------------------------------------------------------------- *)

let DE_MORGAN_THM = TAUT
  `!t1 t2. (~(t1 /\ t2) <=> ~t1 \/ ~t2) /\ (~(t1 \/ t2) <=> ~t1 /\ ~t2)`;;

let NOT_CLAUSES =
  TAUT `(!t. ~ ~t <=> t) /\ (~T <=> F) /\ (~F <=> T)`;;

let NOT_IMP = TAUT `!t1 t2. ~(t1 ==> t2) <=> t1 /\ ~t2`;;

let CONTRAPOS_THM = TAUT `!t1 t2. (~t1 ==> ~t2) <=> (t2 ==> t1)`;;

extend_basic_rewrites [CONJUNCT1 NOT_CLAUSES];;

(* ------------------------------------------------------------------------- *)
(* Some classically based rules.                                             *)
(* ------------------------------------------------------------------------- *)

let CCONTR =
  let P = `P:bool` in
  let pth = TAUT `(~P ==> F) ==> P` in
  fun tm th ->
    try let tm' = mk_neg tm in
        MP (INST [tm,P] pth) (DISCH tm' th)
    with Failure _ -> failwith "CCONTR";;

let CONTRAPOS_CONV =
  let a = `a:bool` and b = `b:bool` in
  let pth = TAUT `(a ==> b) <=> (~b ==> ~a)` in
  fun tm ->
    try let P,Q = dest_imp tm in
        INST [P,a; Q,b] pth
    with Failure _ -> failwith "CONTRAPOS_CONV";;

(* ------------------------------------------------------------------------- *)
(* A classicalal "refutation" tactic.                                        *)
(* ------------------------------------------------------------------------- *)

let REFUTE_THEN =
  let f_tm = `F`
  and conv = REWR_CONV(TAUT `p <=> ~p ==> F`) in
  fun ttac (asl,w as gl) ->
    if w = f_tm then ALL_TAC gl
    else if is_neg w then DISCH_THEN ttac gl
    else (CONV_TAC conv THEN DISCH_THEN ttac) gl;;

(* ------------------------------------------------------------------------- *)
(* Infinite de Morgan laws.                                                  *)
(* ------------------------------------------------------------------------- *)

let NOT_EXISTS_THM = prove
 (`!P. ~(?x:A. P x) <=> (!x. ~(P x))`,
  GEN_TAC THEN EQ_TAC THEN DISCH_TAC THENL
   [GEN_TAC THEN DISCH_TAC THEN UNDISCH_TAC `~(?x:A. P x)` THEN
    REWRITE_TAC[] THEN EXISTS_TAC `x:A` THEN POP_ASSUM ACCEPT_TAC;
    DISCH_THEN(CHOOSE_THEN MP_TAC) THEN ASM_REWRITE_TAC[]]);;

let EXISTS_NOT_THM = prove
 (`!P. (?x:A. ~(P x)) <=> ~(!x. P x)`,
  ONCE_REWRITE_TAC[TAUT `(a <=> ~b) <=> (~a <=> b)`] THEN
  REWRITE_TAC[NOT_EXISTS_THM]);;

let NOT_FORALL_THM = prove
 (`!P. ~(!x. P x) <=> (?x:A. ~(P x))`,
  MATCH_ACCEPT_TAC(GSYM EXISTS_NOT_THM));;

let FORALL_NOT_THM = prove
 (`!P. (!x. ~(P x)) <=> ~(?x:A. P x)`,
  MATCH_ACCEPT_TAC(GSYM NOT_EXISTS_THM));;

(* ------------------------------------------------------------------------- *)
(* Expand quantification over Booleans.                                      *)
(* ------------------------------------------------------------------------- *)

let FORALL_BOOL_THM = prove
  (`(!b. P b) <=> P T /\ P F`,
   EQ_TAC THEN DISCH_TAC THEN ASM_REWRITE_TAC[] THEN
   GEN_TAC THEN BOOL_CASES_TAC `b:bool` THEN ASM_REWRITE_TAC[]);;

let EXISTS_BOOL_THM = prove
 (`(?b. P b) <=> P T \/ P F`,
  MATCH_MP_TAC(TAUT `(~p <=> ~q) ==> (p <=> q)`) THEN
  REWRITE_TAC[DE_MORGAN_THM; NOT_EXISTS_THM; FORALL_BOOL_THM]);;

(* ------------------------------------------------------------------------- *)
(* Universal quantifier and disjunction                                      *)
(* ------------------------------------------------------------------------- *)

let LEFT_FORALL_OR_THM = prove
 (`!P Q. (!x:A. P x \/ Q) <=> (!x. P x) \/ Q`,
  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[TAUT `(a <=> b) <=> (~a <=> ~b)`] THEN
  REWRITE_TAC[NOT_FORALL_THM; DE_MORGAN_THM; LEFT_EXISTS_AND_THM]);;

let RIGHT_FORALL_OR_THM = prove
 (`!P Q. (!x:A. P \/ Q x) <=> P \/ (!x. Q x)`,
  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[TAUT `(a <=> b) <=> (~a <=> ~b)`] THEN
  REWRITE_TAC[NOT_FORALL_THM; DE_MORGAN_THM; RIGHT_EXISTS_AND_THM]);;

let LEFT_OR_FORALL_THM = prove
 (`!P Q. (!x:A. P x) \/ Q <=> (!x. P x \/ Q)`,
  MATCH_ACCEPT_TAC(GSYM LEFT_FORALL_OR_THM));;

let RIGHT_OR_FORALL_THM = prove
 (`!P Q. P \/ (!x:A. Q x) <=> (!x. P \/ Q x)`,
  MATCH_ACCEPT_TAC(GSYM RIGHT_FORALL_OR_THM));;

(* ------------------------------------------------------------------------- *)
(* Implication and quantifiers.                                              *)
(* ------------------------------------------------------------------------- *)

let LEFT_IMP_FORALL_THM = prove
 (`!P Q. ((!x:A. P x) ==> Q) <=> (?x. P x ==> Q)`,
  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[TAUT `(a <=> b) <=> (~a <=> ~b)`] THEN
  REWRITE_TAC[NOT_EXISTS_THM; NOT_IMP; LEFT_AND_FORALL_THM]);;

let LEFT_EXISTS_IMP_THM = prove
 (`!P Q. (?x. P x ==> Q) <=> ((!x:A. P x) ==> Q)`,
  MATCH_ACCEPT_TAC(GSYM LEFT_IMP_FORALL_THM));;

let RIGHT_IMP_EXISTS_THM = prove
 (`!P Q. (P ==> ?x:A. Q x) <=> (?x:A. P ==> Q x)`,
  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[TAUT `(a <=> b) <=> (~a <=> ~b)`] THEN
  REWRITE_TAC[NOT_EXISTS_THM; NOT_IMP; RIGHT_AND_FORALL_THM]);;

let RIGHT_EXISTS_IMP_THM = prove
 (`!P Q. (?x:A. P ==> Q x) <=> (P ==> ?x:A. Q x)`,
  MATCH_ACCEPT_TAC(GSYM RIGHT_IMP_EXISTS_THM));;

(* ------------------------------------------------------------------------- *)
(* The conditional.                                                          *)
(* ------------------------------------------------------------------------- *)

let COND_DEF = new_definition
  `COND = \t t1 t2. @x:A. ((t <=> T) ==> (x = t1)) /\
                          ((t <=> F) ==> (x = t2))`;;

let COND_CLAUSES = prove
 (`!(t1:A) t2. ((if T then t1 else t2) = t1) /\
               ((if F then t1 else t2) = t2)`,
  REWRITE_TAC[COND_DEF]);;

let is_cond tm =
  try fst(dest_const(rator(rator (rator tm)))) = "COND"
  with Failure _ -> false;;

let mk_cond (b,x,y) =
  try let c = mk_const("COND",[type_of x,aty]) in
      mk_comb(mk_comb(mk_comb(c,b),x),y)
  with Failure _ -> failwith "mk_cond";;

let dest_cond tm =
  try let tm1,y = dest_comb tm in
      let tm2,x = dest_comb tm1 in
      let c,b = dest_comb tm2 in
      if fst(dest_const c) = "COND" then (b,(x,y)) else fail()
  with Failure _ -> failwith "dest_cond";;

extend_basic_rewrites [COND_CLAUSES];;

let COND_EXPAND = prove
 (`!b t1 t2. (if b then t1 else t2) <=> (~b \/ t1) /\ (b \/ t2)`,
  REPEAT GEN_TAC THEN BOOL_CASES_TAC `b:bool` THEN
  REWRITE_TAC[]);;

let COND_ID = prove
 (`!b (t:A). (if b then t else t) = t`,
  REPEAT GEN_TAC THEN BOOL_CASES_TAC `b:bool` THEN REWRITE_TAC[]);;

let COND_RAND = prove
 (`!b (f:A->B) x y. f (if b then x else y) = (if b then f x else f y)`,
  REPEAT GEN_TAC THEN BOOL_CASES_TAC `b:bool` THEN REWRITE_TAC[]);;

let COND_RATOR = prove
 (`!b (f:A->B) g x. (if b then f else g)(x) = (if b then f x else g x)`,
  REPEAT GEN_TAC THEN BOOL_CASES_TAC `b:bool` THEN REWRITE_TAC[]);;

let COND_ABS = prove
 (`!b (f:A->B) g. (\x. if b then f x else g x) = (if b then f else g)`,
  REPEAT GEN_TAC THEN BOOL_CASES_TAC `b:bool` THEN REWRITE_TAC[ETA_AX]);;

(* ------------------------------------------------------------------------- *)
(* Throw monotonicity in.                                                    *)
(* ------------------------------------------------------------------------- *)

let MONO_COND = prove
 (`(A ==> B) /\ (C ==> D) ==> (if b then A else C) ==> (if b then B else D)`,
  STRIP_TAC THEN BOOL_CASES_TAC `b:bool` THEN
  ASM_REWRITE_TAC[]);;

monotonicity_theorems := MONO_COND::(!monotonicity_theorems);;

(* ------------------------------------------------------------------------- *)
(* Tactic for splitting over an arbitrarily chosen conditional.              *)
(* ------------------------------------------------------------------------- *)

let COND_ELIM_THM = prove
 (`(P:A->bool) (if c then x else y) <=> (c ==> P x) /\ (~c ==> P y)`,
  BOOL_CASES_TAC `c:bool` THEN REWRITE_TAC[]);;

let COND_ELIM_CONV = HIGHER_REWRITE_CONV[COND_ELIM_THM] true;;

let (COND_CASES_TAC :tactic) =
  let DENEG_RULE = GEN_REWRITE_RULE I [TAUT `~ ~ p <=> p`] in
  CONV_TAC COND_ELIM_CONV THEN CONJ_TAC THENL
    [DISCH_THEN(fun th -> ASSUME_TAC th THEN SUBST1_TAC(EQT_INTRO th));
     DISCH_THEN(fun th -> try let th' = DENEG_RULE th in
                              ASSUME_TAC th' THEN SUBST1_TAC(EQT_INTRO th')
                          with Failure _ ->
                              ASSUME_TAC th THEN SUBST1_TAC(EQF_INTRO th))];;

(* ------------------------------------------------------------------------- *)
(* Skolemization.                                                            *)
(* ------------------------------------------------------------------------- *)

let SKOLEM_THM = prove
 (`!P. (!x:A. ?y:B. P x y) <=> (?y. !x. P x (y x))`,
  REPEAT(STRIP_TAC ORELSE EQ_TAC) THENL
   [EXISTS_TAC `\x:A. @y:B. P x y` THEN GEN_TAC THEN
    BETA_TAC THEN CONV_TAC SELECT_CONV;
    EXISTS_TAC `(y:A->B) x`] THEN
  POP_ASSUM MATCH_ACCEPT_TAC);;

(* ------------------------------------------------------------------------- *)
(* NB: this one is true intutionistically and intensionally.                 *)
(* ------------------------------------------------------------------------- *)

let UNIQUE_SKOLEM_ALT = prove
 (`!P:A->B->bool. (!x. ?!y. P x y) <=> ?f. !x y. P x y <=> (f x = y)`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_ALT; SKOLEM_THM]);;

(* ------------------------------------------------------------------------- *)
(* and this one intuitionistically and extensionally.                        *)
(* ------------------------------------------------------------------------- *)

let UNIQUE_SKOLEM_THM = prove
 (`!P. (!x:A. ?!y:B. P x y) <=> (?!f. !x. P x (f x))`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_THM; SKOLEM_THM; FORALL_AND_THM] THEN
  EQ_TAC THEN DISCH_THEN(CONJUNCTS_THEN ASSUME_TAC) THEN
  ASM_REWRITE_TAC[] THENL
   [REPEAT STRIP_TAC THEN ONCE_REWRITE_TAC[FUN_EQ_THM] THEN
    X_GEN_TAC `x:A` THEN FIRST_ASSUM MATCH_MP_TAC THEN
    EXISTS_TAC `x:A` THEN ASM_REWRITE_TAC[];
    MAP_EVERY X_GEN_TAC [`x:A`; `y1:B`; `y2:B`] THEN STRIP_TAC THEN
    FIRST_ASSUM(X_CHOOSE_TAC `f:A->B`) THEN
    SUBGOAL_THEN `(\z. if z = x then y1 else (f:A->B) z) =
                  (\z. if z = x then y2 else (f:A->B) z)` MP_TAC THENL
     [FIRST_ASSUM MATCH_MP_TAC THEN
      REPEAT STRIP_TAC THEN BETA_TAC THEN COND_CASES_TAC THEN
      ASM_REWRITE_TAC[];
      DISCH_THEN(MP_TAC o C AP_THM `x:A`) THEN REWRITE_TAC[]]]);;

(* ------------------------------------------------------------------------- *)
(* Extend default congruences for contextual rewriting.                      *)
(* ------------------------------------------------------------------------- *)

let COND_CONG =
  TAUT `(g = g') ==>
        (g' ==> (t = t')) ==>
        (~g' ==> (e = e')) ==>
        ((if g then t else e) = (if g' then t' else e'))` in
  extend_basic_congs [COND_CONG];;

let COND_EQ_CLAUSE = prove
 (`(if x = x then y else z) = y`,
  REWRITE_TAC[]) in
 extend_basic_rewrites [COND_EQ_CLAUSE];;

(* ------------------------------------------------------------------------- *)
(* We can now treat "bool" as an enumerated type for some purposes.          *)
(* ------------------------------------------------------------------------- *)

let bool_INDUCT = prove
 (`!P. P F /\ P T ==> !x. P x`,
  REPEAT STRIP_TAC THEN DISJ_CASES_TAC(SPEC `x:bool` BOOL_CASES_AX) THEN
  ASM_REWRITE_TAC[]);;

let bool_RECURSION = prove
 (`!a b:A. ?f. f F = a /\ f T = b`,
  REPEAT GEN_TAC THEN EXISTS_TAC `\x. if x then b:A else a` THEN
  REWRITE_TAC[]);;

let inductive_type_store = ref
 ["bool",(2,bool_INDUCT,bool_RECURSION)];;
(* ========================================================================= *)
(* Trivial odds and ends.                                                    *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Combinators. We don't bother with S and K, which seem of little use.      *)
(* ------------------------------------------------------------------------- *)

parse_as_infix ("o",(26,"right"));;

let o_DEF = new_definition
 `(o) (f:B->C) g = \x:A. f(g(x))`;;

let I_DEF = new_definition
 `I = \x:A. x`;;

let o_THM = prove
 (`!f:B->C. !g:A->B. !x:A. (f o g) x = f(g(x))`,
  PURE_REWRITE_TAC [o_DEF] THEN
  CONV_TAC (DEPTH_CONV BETA_CONV) THEN
  REPEAT GEN_TAC THEN REFL_TAC);;

let o_ASSOC = prove
 (`!f:C->D. !g:B->C. !h:A->B. f o (g o h) = (f o g) o h`,
  REPEAT GEN_TAC THEN REWRITE_TAC [o_DEF] THEN
  CONV_TAC (REDEPTH_CONV BETA_CONV) THEN
  REFL_TAC);;

let I_THM = prove
 (`!x:A. I x = x`,
  REWRITE_TAC [I_DEF]);;

let I_O_ID = prove
 (`!f:A->B. (I o f = f) /\ (f o I = f)`,
  REPEAT STRIP_TAC THEN
  REWRITE_TAC[FUN_EQ_THM; o_DEF; I_THM]);;

(* ------------------------------------------------------------------------- *)
(* The theory "1" (a 1-element type).                                        *)
(* ------------------------------------------------------------------------- *)

let EXISTS_ONE_REP = prove
 (`?b:bool. b`,
  EXISTS_TAC `T` THEN
  BETA_TAC THEN ACCEPT_TAC TRUTH);;

let one_tydef =
  new_type_definition "1" ("one_ABS","one_REP") EXISTS_ONE_REP;;

let one_DEF = new_definition
 `one = @x:1. T`;;

let one = prove
 (`!v:1. v = one`,
  MP_TAC(GEN_ALL (SPEC `one_REP a` (CONJUNCT2 one_tydef))) THEN
  REWRITE_TAC[CONJUNCT1 one_tydef] THEN DISCH_TAC THEN
  ONCE_REWRITE_TAC[GSYM (CONJUNCT1 one_tydef)] THEN
  ASM_REWRITE_TAC[]);;

let one_axiom = prove
 (`!f g. f = (g:A->1)`,
  REPEAT GEN_TAC THEN ONCE_REWRITE_TAC[FUN_EQ_THM] THEN
  GEN_TAC THEN ONCE_REWRITE_TAC[one] THEN REFL_TAC);;

let one_INDUCT = prove
 (`!P. P one ==> !x. P x`,
  ONCE_REWRITE_TAC[one] THEN REWRITE_TAC[]);;

let one_RECURSION = prove
 (`!e:A. ?fn. fn one = e`,
  GEN_TAC THEN EXISTS_TAC `\x:1. e:A` THEN BETA_TAC THEN REFL_TAC);;

let one_Axiom = prove
 (`!e:A. ?!fn. fn one = e`,
  GEN_TAC THEN REWRITE_TAC[EXISTS_UNIQUE_THM; one_RECURSION] THEN
  REPEAT STRIP_TAC THEN ONCE_REWRITE_TAC[FUN_EQ_THM] THEN
  ONCE_REWRITE_TAC [one] THEN ASM_REWRITE_TAC[]);;

(* ------------------------------------------------------------------------- *)
(* Add the type "1" to the inductive type store.                             *)
(* ------------------------------------------------------------------------- *)

inductive_type_store := 
  ("1",(1,one_INDUCT,one_RECURSION))::(!inductive_type_store);;
(* ========================================================================= *)
(* Reasonably efficient conversions for various canonical forms.             *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let PRESIMP_CONV =
  GEN_REWRITE_CONV TOP_DEPTH_CONV
   [NOT_CLAUSES; AND_CLAUSES; OR_CLAUSES; IMP_CLAUSES; EQ_CLAUSES;
    FORALL_SIMP; EXISTS_SIMP; EXISTS_OR_THM; FORALL_AND_THM;
    LEFT_EXISTS_AND_THM; RIGHT_EXISTS_AND_THM;
    LEFT_FORALL_OR_THM; RIGHT_FORALL_OR_THM];;

(* ------------------------------------------------------------------------- *)
(* ACI rearrangements of conjunctions and disjunctions. This is much faster  *)
(* than AC xxx_ACI on large problems, as well as being more controlled.      *)
(* ------------------------------------------------------------------------- *)

let CONJ_ACI_RULE =
  let rec mk_fun th fn =
    let tm = concl th in
    if is_conj tm then
      let th1,th2 = CONJ_PAIR th in
      mk_fun th1 (mk_fun th2 fn)
    else (tm |-> th) fn
  and use_fun fn tm =
    if is_conj tm then
      let l,r = dest_conj tm in CONJ (use_fun fn l) (use_fun fn r)
    else apply fn tm in
  fun fm ->
    let p,p' = dest_eq fm in
    if p = p' then REFL p else
    let th = use_fun (mk_fun (ASSUME p) undefined) p'
    and th' = use_fun (mk_fun (ASSUME p') undefined) p in
    IMP_ANTISYM_RULE (DISCH_ALL th) (DISCH_ALL th');;

let DISJ_ACI_RULE =
  let pth_left = UNDISCH(TAUT `~(a \/ b) ==> ~a`)
  and pth_right = UNDISCH(TAUT `~(a \/ b) ==> ~b`)
  and pth = repeat UNDISCH (TAUT `~a ==> ~b ==> ~(a \/ b)`)
  and pth_neg = UNDISCH(TAUT `(~a <=> ~b) ==> (a <=> b)`)
  and a_tm = `a:bool` and b_tm = `b:bool` in
  let NOT_DISJ_PAIR th =
    let p,q = dest_disj(rand(concl th)) in
    let ilist = [p,a_tm; q,b_tm] in
    PROVE_HYP th (INST ilist pth_left),
    PROVE_HYP th (INST ilist pth_right)
  and NOT_DISJ th1 th2 =
    let th3 = INST [rand(concl th1),a_tm; rand(concl th2),b_tm] pth in
    PROVE_HYP th1 (PROVE_HYP th2 th3) in
  let rec mk_fun th fn =
    let tm = rand(concl th) in
    if is_disj tm then
      let th1,th2 = NOT_DISJ_PAIR th in
      mk_fun th1 (mk_fun th2 fn)
    else (tm |-> th) fn
  and use_fun fn tm =
    if is_disj tm then
      let l,r = dest_disj tm in NOT_DISJ (use_fun fn l) (use_fun fn r)
    else apply fn tm in
  fun fm ->
    let p,p' = dest_eq fm in
    if p = p' then REFL p else
    let th = use_fun (mk_fun (ASSUME(mk_neg p)) undefined) p'
    and th' = use_fun (mk_fun (ASSUME(mk_neg p')) undefined) p in
    let th1 = IMP_ANTISYM_RULE (DISCH_ALL th) (DISCH_ALL th') in
    PROVE_HYP th1 (INST [p,a_tm; p',b_tm] pth_neg);;

(* ------------------------------------------------------------------------- *)
(* Order canonically, right-associate and remove duplicates.                 *)
(* ------------------------------------------------------------------------- *)

let CONJ_CANON_CONV tm =
  let tm' = list_mk_conj(setify(conjuncts tm)) in
  CONJ_ACI_RULE(mk_eq(tm,tm'));;

let DISJ_CANON_CONV tm =
  let tm' = list_mk_disj(setify(disjuncts tm)) in
  DISJ_ACI_RULE(mk_eq(tm,tm'));;

(* ------------------------------------------------------------------------- *)
(* General NNF conversion. The user supplies some conversion to be applied   *)
(* to atomic formulas.                                                       *)
(*                                                                           *)
(* "Iff"s are split conjunctively or disjunctively according to the flag     *)
(* argument (conjuctively = true) until a universal quantifier (modulo       *)
(* current parity) is passed; after that they are split conjunctively. This  *)
(* is appropriate when the result is passed to a disjunctive splitter        *)
(* followed by a clausal form inner core, such as MESON.                     *)
(*                                                                           *)
(* To avoid some duplicate computation, this function will in general        *)
(* enter a recursion where it simultaneously computes NNF representations    *)
(* for "p" and "~p", so the user needs to supply an atomic "conversion"      *)
(* that does the same.                                                       *)
(* ------------------------------------------------------------------------- *)

let (GEN_NNF_CONV:bool->conv*(term->thm*thm)->conv) =
  let and_tm = `(/\)` and or_tm = `(\/)` and not_tm = `(~)`
  and pth_not_not = TAUT `~ ~ p = p`
  and pth_not_and = TAUT `~(p /\ q) <=> ~p \/ ~q`
  and pth_not_or = TAUT `~(p \/ q) <=> ~p /\ ~q`
  and pth_imp = TAUT `p ==> q <=> ~p \/ q`
  and pth_not_imp = TAUT `~(p ==> q) <=> p /\ ~q`
  and pth_eq = TAUT `(p <=> q) <=> p /\ q \/ ~p /\ ~q`
  and pth_not_eq = TAUT `~(p <=> q) <=> p /\ ~q \/ ~p /\ q`
  and pth_eq' = TAUT `(p <=> q) <=> (p \/ ~q) /\ (~p \/ q)`
  and pth_not_eq' = TAUT `~(p <=> q) <=> (p \/ q) /\ (~p \/ ~q)`
  and [pth_not_forall; pth_not_exists; pth_not_exu] =
   (CONJUNCTS o prove)
   (`(~((!) P) <=> ?x:A. ~(P x)) /\
     (~((?) P) <=> !x:A. ~(P x)) /\
     (~((?!) P) <=> (!x:A. ~(P x)) \/ ?x y. P x /\ P y /\ ~(y = x))`,
    REPEAT CONJ_TAC THEN
    GEN_REWRITE_TAC (LAND_CONV o funpow 2 RAND_CONV) [GSYM ETA_AX] THEN
    REWRITE_TAC[NOT_EXISTS_THM; NOT_FORALL_THM; EXISTS_UNIQUE_DEF;
                DE_MORGAN_THM; NOT_IMP] THEN
    REWRITE_TAC[CONJ_ASSOC; EQ_SYM_EQ])
  and pth_exu = prove
   (`((?!) P) <=> (?x:A. P x) /\ !x y. ~(P x) \/ ~(P y) \/ (y = x)`,
    GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM ETA_AX] THEN
    REWRITE_TAC[EXISTS_UNIQUE_DEF; TAUT `a /\ b ==> c <=> ~a \/ ~b \/ c`] THEN
    REWRITE_TAC[EQ_SYM_EQ])
  and p_tm = `p:bool` and q_tm = `q:bool` in
  let rec NNF_DCONV cf baseconvs tm =
    match tm with
      Comb(Comb(Const("/\\",_),l),r) ->
          let th_lp,th_ln = NNF_DCONV cf baseconvs l
          and th_rp,th_rn = NNF_DCONV cf baseconvs r in
          MK_COMB(AP_TERM and_tm th_lp,th_rp),
          TRANS (INST [l,p_tm; r,q_tm] pth_not_and)
                (MK_COMB(AP_TERM or_tm th_ln,th_rn))
    | Comb(Comb(Const("\\/",_),l),r) ->
          let th_lp,th_ln = NNF_DCONV cf baseconvs l
          and th_rp,th_rn = NNF_DCONV cf baseconvs r in
          MK_COMB(AP_TERM or_tm th_lp,th_rp),
          TRANS (INST [l,p_tm; r,q_tm] pth_not_or)
                (MK_COMB(AP_TERM and_tm th_ln,th_rn))
    | Comb(Comb(Const("==>",_),l),r) ->
          let th_lp,th_ln = NNF_DCONV cf baseconvs l
          and th_rp,th_rn = NNF_DCONV cf baseconvs r in
          TRANS (INST [l,p_tm; r,q_tm] pth_imp)
                (MK_COMB(AP_TERM or_tm th_ln,th_rp)),
          TRANS (INST [l,p_tm; r,q_tm] pth_not_imp)
                (MK_COMB(AP_TERM and_tm th_lp,th_rn))
    | Comb(Comb(Const("=",Tyapp("fun",Tyapp("bool",_)::_)),l),r) ->
          let th_lp,th_ln = NNF_DCONV cf baseconvs l
          and th_rp,th_rn = NNF_DCONV cf baseconvs r in
          if cf then
            TRANS (INST [l,p_tm; r,q_tm] pth_eq')
                  (MK_COMB(AP_TERM and_tm (MK_COMB(AP_TERM or_tm th_lp,th_rn)),
                           MK_COMB(AP_TERM or_tm th_ln,th_rp))),
            TRANS (INST [l,p_tm; r,q_tm] pth_not_eq')
                  (MK_COMB(AP_TERM and_tm (MK_COMB(AP_TERM or_tm th_lp,th_rp)),
                           MK_COMB(AP_TERM or_tm th_ln,th_rn)))
          else
            TRANS (INST [l,p_tm; r,q_tm] pth_eq)
                  (MK_COMB(AP_TERM or_tm (MK_COMB(AP_TERM and_tm th_lp,th_rp)),
                           MK_COMB(AP_TERM and_tm th_ln,th_rn))),
            TRANS (INST [l,p_tm; r,q_tm] pth_not_eq)
                  (MK_COMB(AP_TERM or_tm (MK_COMB(AP_TERM and_tm th_lp,th_rn)),
                           MK_COMB(AP_TERM and_tm th_ln,th_rp)))
    | Comb(Const("!",Tyapp("fun",Tyapp("fun",ty::_)::_)) as q,
           (Abs(x,t) as bod)) ->
          let th_p,th_n = NNF_DCONV true baseconvs t in
          AP_TERM q (ABS x th_p),
          let th1 = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                         (INST_TYPE [ty,aty] pth_not_forall)
          and th2 = TRANS (AP_TERM not_tm (BETA(mk_comb(bod,x)))) th_n in
          TRANS th1 (MK_EXISTS x th2)
    | Comb(Const("?",Tyapp("fun",Tyapp("fun",ty::_)::_)) as q,
           (Abs(x,t) as bod)) ->
          let th_p,th_n = NNF_DCONV cf baseconvs t in
          AP_TERM q (ABS x th_p),
          let th1 = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                         (INST_TYPE [ty,aty] pth_not_exists)
          and th2 = TRANS (AP_TERM not_tm (BETA(mk_comb(bod,x)))) th_n in
          TRANS th1 (MK_FORALL x th2)
    | Comb(Const("?!",Tyapp("fun",Tyapp("fun",ty::_)::_)),
           (Abs(x,t) as bod)) ->
          let y = variant (x::frees t) x
          and th_p,th_n = NNF_DCONV cf baseconvs t in
          let eq = mk_eq(y,x) in
          let eth_p,eth_n = baseconvs eq
          and bth = BETA (mk_comb(bod,x))
          and bth' = BETA_CONV(mk_comb(bod,y)) in
          let th_p' = INST [y,x] th_p and th_n' = INST [y,x] th_n in
          let th1 = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                         (INST_TYPE [ty,aty] pth_exu)
          and th1' = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                          (INST_TYPE [ty,aty] pth_not_exu)
          and th2 =
            MK_COMB(AP_TERM and_tm
                        (MK_EXISTS x (TRANS bth th_p)),
                    MK_FORALL x (MK_FORALL y
                     (MK_COMB(AP_TERM or_tm (TRANS (AP_TERM not_tm bth) th_n),
                              MK_COMB(AP_TERM or_tm
                                    (TRANS (AP_TERM not_tm bth') th_n'),
                                      eth_p)))))
          and th2' =
            MK_COMB(AP_TERM or_tm
                        (MK_FORALL x (TRANS (AP_TERM not_tm bth) th_n)),
                    MK_EXISTS x (MK_EXISTS y
                     (MK_COMB(AP_TERM and_tm (TRANS bth th_p),
                              MK_COMB(AP_TERM and_tm (TRANS bth' th_p'),
                                      eth_n))))) in
          TRANS th1 th2,TRANS th1' th2'
    | Comb(Const("~",_),t) ->
          let th1,th2 = NNF_DCONV cf baseconvs t in
          th2,TRANS (INST [t,p_tm] pth_not_not) th1
    | _ -> try baseconvs tm
           with Failure _ -> REFL tm,REFL(mk_neg tm) in
  let rec NNF_CONV cf (base1,base2 as baseconvs) tm =
    match tm with
      Comb(Comb(Const("/\\",_),l),r) ->
          let th_lp = NNF_CONV cf baseconvs l
          and th_rp = NNF_CONV cf baseconvs r in
          MK_COMB(AP_TERM and_tm th_lp,th_rp)
    | Comb(Comb(Const("\\/",_),l),r) ->
          let th_lp = NNF_CONV cf baseconvs l
          and th_rp = NNF_CONV cf baseconvs r in
          MK_COMB(AP_TERM or_tm th_lp,th_rp)
    | Comb(Comb(Const("==>",_),l),r) ->
          let th_ln = NNF_CONV' cf baseconvs l
          and th_rp = NNF_CONV cf baseconvs r in
          TRANS (INST [l,p_tm; r,q_tm] pth_imp)
                (MK_COMB(AP_TERM or_tm th_ln,th_rp))
    | Comb(Comb(Const("=",Tyapp("fun",Tyapp("bool",_)::_)),l),r) ->
          let th_lp,th_ln = NNF_DCONV cf base2 l
          and th_rp,th_rn = NNF_DCONV cf base2 r in
          if cf then
            TRANS (INST [l,p_tm; r,q_tm] pth_eq')
                  (MK_COMB(AP_TERM and_tm (MK_COMB(AP_TERM or_tm th_lp,th_rn)),
                           MK_COMB(AP_TERM or_tm th_ln,th_rp)))
          else
            TRANS (INST [l,p_tm; r,q_tm] pth_eq)
                  (MK_COMB(AP_TERM or_tm (MK_COMB(AP_TERM and_tm th_lp,th_rp)),
                           MK_COMB(AP_TERM and_tm th_ln,th_rn)))
    | Comb(Const("!",Tyapp("fun",Tyapp("fun",ty::_)::_)) as q,
           (Abs(x,t))) ->
          let th_p = NNF_CONV true baseconvs t in
          AP_TERM q (ABS x th_p)
    | Comb(Const("?",Tyapp("fun",Tyapp("fun",ty::_)::_)) as q,
           (Abs(x,t))) ->
          let th_p = NNF_CONV cf baseconvs t in
          AP_TERM q (ABS x th_p)
    | Comb(Const("?!",Tyapp("fun",Tyapp("fun",ty::_)::_)),
           (Abs(x,t) as bod)) ->
          let y = variant (x::frees t) x
          and th_p,th_n = NNF_DCONV cf base2 t in
          let eq = mk_eq(y,x) in
          let eth_p,eth_n = base2 eq
          and bth = BETA (mk_comb(bod,x))
          and bth' = BETA_CONV(mk_comb(bod,y)) in
          let th_n' = INST [y,x] th_n in
          let th1 = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                         (INST_TYPE [ty,aty] pth_exu)
          and th2 =
            MK_COMB(AP_TERM and_tm
                        (MK_EXISTS x (TRANS bth th_p)),
                    MK_FORALL x (MK_FORALL y
                     (MK_COMB(AP_TERM or_tm (TRANS (AP_TERM not_tm bth) th_n),
                              MK_COMB(AP_TERM or_tm
                                    (TRANS (AP_TERM not_tm bth') th_n'),
                                      eth_p))))) in
          TRANS th1 th2
    | Comb(Const("~",_),t) -> NNF_CONV' cf baseconvs t
    | _ -> try base1 tm with Failure _ -> REFL tm
  and NNF_CONV' cf (base1,base2 as baseconvs) tm =
    match tm with
      Comb(Comb(Const("/\\",_),l),r) ->
          let th_ln = NNF_CONV' cf baseconvs l
          and th_rn = NNF_CONV' cf baseconvs r in
          TRANS (INST [l,p_tm; r,q_tm] pth_not_and)
                (MK_COMB(AP_TERM or_tm th_ln,th_rn))
    | Comb(Comb(Const("\\/",_),l),r) ->
          let th_ln = NNF_CONV' cf baseconvs l
          and th_rn = NNF_CONV' cf baseconvs r in
          TRANS (INST [l,p_tm; r,q_tm] pth_not_or)
                (MK_COMB(AP_TERM and_tm th_ln,th_rn))
    | Comb(Comb(Const("==>",_),l),r) ->
          let th_lp = NNF_CONV cf baseconvs l
          and th_rn = NNF_CONV' cf baseconvs r in
          TRANS (INST [l,p_tm; r,q_tm] pth_not_imp)
                (MK_COMB(AP_TERM and_tm th_lp,th_rn))
    | Comb(Comb(Const("=",Tyapp("fun",Tyapp("bool",_)::_)),l),r) ->
          let th_lp,th_ln = NNF_DCONV cf base2 l
          and th_rp,th_rn = NNF_DCONV cf base2 r in
          if cf then
            TRANS (INST [l,p_tm; r,q_tm] pth_not_eq')
                  (MK_COMB(AP_TERM and_tm (MK_COMB(AP_TERM or_tm th_lp,th_rp)),
                           MK_COMB(AP_TERM or_tm th_ln,th_rn)))
          else
            TRANS (INST [l,p_tm; r,q_tm] pth_not_eq)
                  (MK_COMB(AP_TERM or_tm (MK_COMB(AP_TERM and_tm th_lp,th_rn)),
                           MK_COMB(AP_TERM and_tm th_ln,th_rp)))
    | Comb(Const("!",Tyapp("fun",Tyapp("fun",ty::_)::_)),
           (Abs(x,t) as bod)) ->
          let th_n = NNF_CONV' cf baseconvs t in
          let th1 = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                         (INST_TYPE [ty,aty] pth_not_forall)
          and th2 = TRANS (AP_TERM not_tm (BETA(mk_comb(bod,x)))) th_n in
          TRANS th1 (MK_EXISTS x th2)
    | Comb(Const("?",Tyapp("fun",Tyapp("fun",ty::_)::_)),
           (Abs(x,t) as bod)) ->
          let th_n = NNF_CONV' true baseconvs t in
          let th1 = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                         (INST_TYPE [ty,aty] pth_not_exists)
          and th2 = TRANS (AP_TERM not_tm (BETA(mk_comb(bod,x)))) th_n in
          TRANS th1 (MK_FORALL x th2)
    | Comb(Const("?!",Tyapp("fun",Tyapp("fun",ty::_)::_)),
           (Abs(x,t) as bod)) ->
          let y = variant (x::frees t) x
          and th_p,th_n = NNF_DCONV cf base2 t in
          let eq = mk_eq(y,x) in
          let eth_p,eth_n = base2 eq
          and bth = BETA (mk_comb(bod,x))
          and bth' = BETA_CONV(mk_comb(bod,y)) in
          let th_p' = INST [y,x] th_p in
          let th1' = INST [bod,mk_var("P",mk_fun_ty ty bool_ty)]
                          (INST_TYPE [ty,aty] pth_not_exu)
          and th2' =
            MK_COMB(AP_TERM or_tm
                        (MK_FORALL x (TRANS (AP_TERM not_tm bth) th_n)),
                    MK_EXISTS x (MK_EXISTS y
                     (MK_COMB(AP_TERM and_tm (TRANS bth th_p),
                              MK_COMB(AP_TERM and_tm (TRANS bth' th_p'),
                                      eth_n))))) in
          TRANS th1' th2'
    | Comb(Const("~",_),t) ->
          let th1 = NNF_CONV cf baseconvs t in
          TRANS (INST [t,p_tm] pth_not_not) th1
    | _ -> let tm' = mk_neg tm in try base1 tm' with Failure _ -> REFL tm' in
  NNF_CONV;;

(* ------------------------------------------------------------------------- *)
(* Some common special cases.                                                *)
(* ------------------------------------------------------------------------- *)

let NNF_CONV =
  (GEN_NNF_CONV false (ALL_CONV,fun t -> REFL t,REFL(mk_neg t)) :conv);;

let NNFC_CONV =
  (GEN_NNF_CONV true (ALL_CONV,fun t -> REFL t,REFL(mk_neg t)) :conv);;

(* ------------------------------------------------------------------------- *)
(* Skolemize a term already in NNF (doesn't matter if it's not prenex).      *)
(* ------------------------------------------------------------------------- *)

let SKOLEM_CONV =
  GEN_REWRITE_CONV TOP_DEPTH_CONV
   [EXISTS_OR_THM; LEFT_EXISTS_AND_THM; RIGHT_EXISTS_AND_THM;
    FORALL_AND_THM; LEFT_FORALL_OR_THM; RIGHT_FORALL_OR_THM;
    FORALL_SIMP; EXISTS_SIMP] THENC
  GEN_REWRITE_CONV REDEPTH_CONV
   [RIGHT_AND_EXISTS_THM;
    LEFT_AND_EXISTS_THM;
    OR_EXISTS_THM;
    RIGHT_OR_EXISTS_THM;
    LEFT_OR_EXISTS_THM;
    SKOLEM_THM];;

(* ------------------------------------------------------------------------- *)
(* Put a term already in NNF into prenex form.                               *)
(* ------------------------------------------------------------------------- *)

let PRENEX_CONV =
  GEN_REWRITE_CONV REDEPTH_CONV
   [AND_FORALL_THM; LEFT_AND_FORALL_THM; RIGHT_AND_FORALL_THM;
    LEFT_OR_FORALL_THM; RIGHT_OR_FORALL_THM;
    OR_EXISTS_THM; LEFT_OR_EXISTS_THM; RIGHT_OR_EXISTS_THM;
    LEFT_AND_EXISTS_THM; RIGHT_AND_EXISTS_THM];;

(* ------------------------------------------------------------------------- *)
(* Weak and normal DNF conversion. The "weak" form gives a disjunction of    *)
(* conjunctions, but has no particular associativity at either level and     *)
(* may contain duplicates. The regular forms give canonical right-associate  *)
(* lists without duplicates, but do not remove subsumed disjuncts.           *)
(*                                                                           *)
(* In both cases the input term is supposed to be in NNF already. We do go   *)
(* inside quantifiers and transform their body, but don't move them.         *)
(* ------------------------------------------------------------------------- *)

let WEAK_DNF_CONV,DNF_CONV =
  let pth1 = TAUT `a /\ (b \/ c) <=> a /\ b \/ a /\ c`
  and pth2 = TAUT `(a \/ b) /\ c <=> a /\ c \/ b /\ c`
  and a_tm = `a:bool` and b_tm = `b:bool` and c_tm = `c:bool` in
  let rec distribute tm =
    match tm with
      Comb(Comb(Const("/\\",_),a),Comb(Comb(Const("\\/",_),b),c)) ->
          let th = INST [a,a_tm; b,b_tm; c,c_tm] pth1 in
          TRANS th (BINOP_CONV distribute (rand(concl th)))
    | Comb(Comb(Const("/\\",_),Comb(Comb(Const("\\/",_),a),b)),c) ->
          let th = INST [a,a_tm; b,b_tm; c,c_tm] pth2 in
          TRANS th (BINOP_CONV distribute (rand(concl th)))
    | _ -> REFL tm in
  let strengthen =
    DEPTH_BINOP_CONV `(\/)` CONJ_CANON_CONV THENC DISJ_CANON_CONV in
  let rec weakdnf tm =
    match tm with
      Comb(Const("!",_),Abs(_,_))
    | Comb(Const("?",_),Abs(_,_)) -> BINDER_CONV weakdnf tm
    | Comb(Comb(Const("\\/",_),_),_) -> BINOP_CONV weakdnf tm
    | Comb(Comb(Const("/\\",_) as op,l),r) ->
          let th = MK_COMB(AP_TERM op (weakdnf l),weakdnf r) in
          TRANS th (distribute(rand(concl th)))
    | _ -> REFL tm
  and substrongdnf tm =
    match tm with
      Comb(Const("!",_),Abs(_,_))
    | Comb(Const("?",_),Abs(_,_)) -> BINDER_CONV strongdnf tm
    | Comb(Comb(Const("\\/",_),_),_) -> BINOP_CONV substrongdnf tm
    | Comb(Comb(Const("/\\",_) as op,l),r) ->
          let th = MK_COMB(AP_TERM op (substrongdnf l),substrongdnf r) in
          TRANS th (distribute(rand(concl th)))
    | _ -> REFL tm
  and strongdnf tm =
    let th = substrongdnf tm in
    TRANS th (strengthen(rand(concl th))) in
  weakdnf,strongdnf;;

(* ------------------------------------------------------------------------- *)
(* Likewise for CNF.                                                         *)
(* ------------------------------------------------------------------------- *)

let WEAK_CNF_CONV,CNF_CONV =
  let pth1 = TAUT `a \/ (b /\ c) <=> (a \/ b) /\ (a \/ c)`
  and pth2 = TAUT `(a /\ b) \/ c <=> (a \/ c) /\ (b \/ c)`
  and a_tm = `a:bool` and b_tm = `b:bool` and c_tm = `c:bool` in
  let rec distribute tm =
    match tm with
      Comb(Comb(Const("\\/",_),a),Comb(Comb(Const("/\\",_),b),c)) ->
          let th = INST [a,a_tm; b,b_tm; c,c_tm] pth1 in
          TRANS th (BINOP_CONV distribute (rand(concl th)))
    | Comb(Comb(Const("\\/",_),Comb(Comb(Const("/\\",_),a),b)),c) ->
          let th = INST [a,a_tm; b,b_tm; c,c_tm] pth2 in
          TRANS th (BINOP_CONV distribute (rand(concl th)))
    | _ -> REFL tm in
  let strengthen =
    DEPTH_BINOP_CONV `(/\)` DISJ_CANON_CONV THENC CONJ_CANON_CONV in
  let rec weakcnf tm =
    match tm with
      Comb(Const("!",_),Abs(_,_))
    | Comb(Const("?",_),Abs(_,_)) -> BINDER_CONV weakcnf tm
    | Comb(Comb(Const("/\\",_),_),_) -> BINOP_CONV weakcnf tm
    | Comb(Comb(Const("\\/",_) as op,l),r) ->
          let th = MK_COMB(AP_TERM op (weakcnf l),weakcnf r) in
          TRANS th (distribute(rand(concl th)))
    | _ -> REFL tm
  and substrongcnf tm =
    match tm with
      Comb(Const("!",_),Abs(_,_))
    | Comb(Const("?",_),Abs(_,_)) -> BINDER_CONV strongcnf tm
    | Comb(Comb(Const("/\\",_),_),_) -> BINOP_CONV substrongcnf tm
    | Comb(Comb(Const("\\/",_) as op,l),r) ->
          let th = MK_COMB(AP_TERM op (substrongcnf l),substrongcnf r) in
          TRANS th (distribute(rand(concl th)))
    | _ -> REFL tm
  and strongcnf tm =
    let th = substrongcnf tm in
    TRANS th (strengthen(rand(concl th))) in
  weakcnf,strongcnf;;

(* ------------------------------------------------------------------------- *)
(* Simply right-associate w.r.t. a binary operator.                          *)
(* ------------------------------------------------------------------------- *)

let ASSOC_CONV th =
  let th' = SYM(SPEC_ALL th) in
  let opx,yopz = dest_comb(rhs(concl th')) in
  let op,x = dest_comb opx in
  let y = lhand yopz and z = rand yopz in
  let rec distrib tm =
    match tm with
      Comb(Comb(op',Comb(Comb(op'',p),q)),r) when op' = op & op'' = op ->
          let th1 = INST [p,x; q,y; r,z] th' in
          let l,r' = dest_comb(rand(concl th1)) in
          let th2 = AP_TERM l (distrib r') in
          let th3 = distrib(rand(concl th2)) in
          TRANS th1 (TRANS th2 th3)
    | _ -> REFL tm in
  let rec assoc tm =
    match tm with
      Comb(Comb(op',p) as l,q) when op' = op ->
          let th = AP_TERM l (assoc q) in
          TRANS th (distrib(rand(concl th)))
    | _ -> REFL tm in
  assoc;;

(* ------------------------------------------------------------------------- *)
(* Eliminate select terms from a goal.                                       *)
(* ------------------------------------------------------------------------- *)

let SELECT_ELIM_TAC =
  let SELECT_ELIM_CONV =
    let SELECT_ELIM_THM =
      let pth = prove
       (`(P:A->bool)((@) P) <=> (?) P`,
        REWRITE_TAC[EXISTS_THM] THEN BETA_TAC THEN REFL_TAC)
      and ptm = `P:A->bool` in
      fun tm -> let stm,atm = dest_comb tm in
                if is_const stm & fst(dest_const stm) = "@" then
                 CONV_RULE(LAND_CONV BETA_CONV)
                   (PINST [type_of(bndvar atm),aty] [atm,ptm] pth)
                else failwith "SELECT_ELIM_THM: not a select-term" in
    fun tm ->
      PURE_REWRITE_CONV (map SELECT_ELIM_THM (find_terms is_select tm)) tm in
  let SELECT_ELIM_ICONV =
    let SELECT_AX_THM =
      let pth = ISPEC `P:A->bool` SELECT_AX
      and ptm = `P:A->bool` in
      fun tm -> let stm,atm = dest_comb tm in
                if is_const stm & fst(dest_const stm) = "@" then
                  let fvs = frees atm in
                  let th1 = PINST [type_of(bndvar atm),aty] [atm,ptm] pth in
                  let th2 = CONV_RULE(BINDER_CONV (BINOP_CONV BETA_CONV)) th1 in
                  GENL fvs th2
                else failwith "SELECT_AX_THM: not a select-term" in
    let SELECT_ELIM_ICONV tm =
      let t = find_term is_select tm in
      let th1 = SELECT_AX_THM t in
      let itm = mk_imp(concl th1,tm) in
      let th2 = DISCH_ALL (MP (ASSUME itm) th1) in
      let fvs = frees t in
      let fty = itlist (mk_fun_ty o type_of) fvs (type_of t) in
      let fn = genvar fty
      and atm = list_mk_abs(fvs,t) in
      let rawdef = mk_eq(fn,atm) in
      let def = GENL fvs (SYM(RIGHT_BETAS fvs (ASSUME rawdef))) in
      let th3 = PURE_REWRITE_CONV[def] (lhand(concl th2)) in
      let gtm = mk_forall(fn,rand(concl th3)) in
      let th4 = EQ_MP (SYM th3) (SPEC fn (ASSUME gtm)) in
      let th5 = IMP_TRANS (DISCH gtm th4) th2 in
      MP (INST [atm,fn] (DISCH rawdef th5)) (REFL atm) in
    let rec SELECT_ELIMS_ICONV tm =
      try let th = SELECT_ELIM_ICONV tm in
          let tm' = lhand(concl th) in
          IMP_TRANS (SELECT_ELIMS_ICONV tm') th
      with Failure _ -> DISCH tm (ASSUME tm) in
    SELECT_ELIMS_ICONV in
  CONV_TAC SELECT_ELIM_CONV THEN W(MATCH_MP_TAC o SELECT_ELIM_ICONV o snd);;

(* ------------------------------------------------------------------------- *)
(* Eliminate all lambda-terms except those part of quantifiers.              *)
(* ------------------------------------------------------------------------- *)

let LAMBDA_ELIM_CONV =
  let HALF_MK_ABS_CONV =
    let pth = prove
     (`(s = \x. t x) <=> (!x. s x = t x)`,
      REWRITE_TAC[FUN_EQ_THM]) in
    let rec conv vs tm =
      if vs = [] then REFL tm else
      (GEN_REWRITE_CONV I [pth] THENC BINDER_CONV(conv (tl vs))) tm in
    conv in
  let rec find_lambda tm =
    if is_abs tm then tm
    else if is_var tm or is_const tm then failwith "find_lambda"
    else if is_abs tm then tm else
    if is_forall tm or is_exists tm or is_uexists tm
    then find_lambda (body(rand tm)) else
    let l,r = dest_comb tm in
    try find_lambda l with Failure _ -> find_lambda r in
  let rec ELIM_LAMBDA conv tm =
    try conv tm with Failure _ ->
    if is_abs tm then ABS_CONV (ELIM_LAMBDA conv) tm
    else if is_var tm or is_const tm then REFL tm else
    if is_forall tm or is_exists tm or is_uexists tm
    then BINDER_CONV (ELIM_LAMBDA conv) tm
    else COMB_CONV (ELIM_LAMBDA conv) tm in
  let APPLY_PTH =
    let pth = prove
     (`(!a. (a = c) ==> (P = Q a)) ==> (P <=> !a. (a = c) ==> Q a)`,
      SIMP_TAC[LEFT_FORALL_IMP_THM; EXISTS_REFL]) in
    MATCH_MP pth in
  let LAMB1_CONV tm =
    let atm = find_lambda tm in
    let v,bod = dest_abs atm in
    let vs = frees atm in
    let vs' = vs @ [v] in
    let aatm = list_mk_abs(vs,atm) in
    let f = genvar(type_of aatm) in
    let eq = mk_eq(f,aatm) in
    let th1 = SYM(RIGHT_BETAS vs (ASSUME eq)) in
    let th2 = ELIM_LAMBDA(GEN_REWRITE_CONV I [th1]) tm in
    let th3 = APPLY_PTH (GEN f (DISCH_ALL th2)) in
    CONV_RULE(RAND_CONV(BINDER_CONV(LAND_CONV (HALF_MK_ABS_CONV vs')))) th3 in
  let rec conv tm =
    try (LAMB1_CONV THENC conv) tm with Failure _ -> REFL tm in
  conv;;

(* ------------------------------------------------------------------------- *)
(* Eliminate conditionals; CONDS_ELIM_CONV aims for disjunctive splitting,   *)
(* for refutation procedures, and CONDS_CELIM_CONV for conjunctive.          *)
(* Both switch modes "sensibly" when going through a quantifier.             *)
(* ------------------------------------------------------------------------- *)

let CONDS_ELIM_CONV,CONDS_CELIM_CONV =
  let th_cond = prove
   (`((b <=> F) ==> x = x0) /\ ((b <=> T) ==> x = x1)
     ==> x = (b /\ x1 \/ ~b /\ x0)`,
    BOOL_CASES_TAC `b:bool` THEN ASM_REWRITE_TAC[])
  and th_cond' = prove
   (`((b <=> F) ==> x = x0) /\ ((b <=> T) ==> x = x1)
     ==> x = ((~b \/ x1) /\ (b \/ x0))`,
    BOOL_CASES_TAC `b:bool` THEN ASM_REWRITE_TAC[])
  and propsimps = basic_net()
  and false_tm = `F` and true_tm = `T` in
  let match_th = MATCH_MP th_cond and match_th' = MATCH_MP th_cond'
  and propsimp_conv = DEPTH_CONV(REWRITES_CONV propsimps)
  and proptsimp_conv =
    let cnv = TRY_CONV(REWRITES_CONV propsimps) in
    BINOP_CONV cnv THENC cnv in
  let rec find_conditional fvs tm =
    match tm with
      Comb(s,t) ->
        if is_cond tm & intersect (frees(lhand s)) fvs = [] then tm
        else (try (find_conditional fvs s)
              with Failure _ -> find_conditional fvs t)
    | Abs(x,t) -> find_conditional (x::fvs) t
    | _ -> failwith "find_conditional" in
  let rec CONDS_ELIM_CONV dfl tm =
    try let t = find_conditional [] tm in
        let p = lhand(rator t) in
        let th_new =
          if p = false_tm or p = true_tm then propsimp_conv tm else
          let asm_0 = mk_eq(p,false_tm) and asm_1 = mk_eq(p,true_tm) in
          let simp_0 = net_of_thm false (ASSUME asm_0) propsimps
          and simp_1 = net_of_thm false (ASSUME asm_1) propsimps in
          let th_0 = DISCH asm_0 (DEPTH_CONV(REWRITES_CONV simp_0) tm)
          and th_1 = DISCH asm_1 (DEPTH_CONV(REWRITES_CONV simp_1) tm) in
          let th_2 = CONJ th_0 th_1 in
          let th_3 = if dfl then match_th th_2 else match_th' th_2 in
          TRANS th_3 (proptsimp_conv(rand(concl th_3))) in
        CONV_RULE (RAND_CONV (CONDS_ELIM_CONV dfl)) th_new
    with Failure _ ->
    if is_neg tm then
       RAND_CONV (CONDS_ELIM_CONV (not dfl)) tm
    else if is_conj tm or is_disj tm then
       BINOP_CONV (CONDS_ELIM_CONV dfl) tm
    else if is_imp tm or is_iff tm then
       COMB2_CONV (RAND_CONV (CONDS_ELIM_CONV (not dfl)))
                  (CONDS_ELIM_CONV dfl) tm
    else if is_forall tm then
         BINDER_CONV (CONDS_ELIM_CONV false) tm
    else if is_exists tm or is_uexists tm then
         BINDER_CONV (CONDS_ELIM_CONV true) tm
    else REFL tm in
  CONDS_ELIM_CONV true,CONDS_ELIM_CONV false;;

(* ------------------------------------------------------------------------- *)
(* Fix up all head arities to be consistent, in "first order logic" style.   *)
(* Applied to the assumptions (not conclusion) in a goal.                    *)
(* ------------------------------------------------------------------------- *)

let ASM_FOL_TAC =
  let rec get_heads lconsts tm (cheads,vheads as sofar) =
    try let v,bod = dest_forall tm in
        get_heads (subtract lconsts [v]) bod sofar
    with Failure _ -> try
        let l,r = try dest_conj tm with Failure _ -> dest_disj tm in
        get_heads lconsts l (get_heads lconsts r sofar)
    with Failure _ -> try
        let tm' = dest_neg tm in
        get_heads lconsts tm' sofar
    with Failure _ ->
        let hop,args = strip_comb tm in
        let len = length args in
        let newheads =
          if is_const hop or mem hop lconsts
          then (insert (hop,len) cheads,vheads)
          else if len > 0 then (cheads,insert (hop,len) vheads) else sofar in
        itlist (get_heads lconsts) args newheads in
  let get_thm_heads th sofar =
    get_heads (freesl(hyp th)) (concl th) sofar in
  let APP_CONV =
    let th = prove
     (`!(f:A->B) x. f x = I f x`,
      REWRITE_TAC[I_THM]) in
    REWR_CONV th in
  let rec APP_N_CONV n tm =
    if n = 1 then APP_CONV tm
    else (RATOR_CONV (APP_N_CONV (n - 1)) THENC APP_CONV) tm in
  let rec FOL_CONV hddata tm =
    if is_forall tm then BINDER_CONV (FOL_CONV hddata) tm
    else if is_conj tm or is_disj tm then BINOP_CONV (FOL_CONV hddata) tm else
    let op,args = strip_comb tm in
    let th = rev_itlist (C (curry MK_COMB))
                        (map (FOL_CONV hddata) args) (REFL op) in
    let tm' = rand(concl th) in
    let n = try length args - assoc op hddata with Failure _ -> 0 in
    if n = 0 then th
    else TRANS th (APP_N_CONV n tm') in
  let GEN_FOL_CONV (cheads,vheads) =
    let hddata =
      if vheads = [] then
        let hops = setify (map fst cheads) in
        let getmin h =
          let ns = mapfilter
            (fun (k,n) -> if k = h then n else fail()) cheads in
          if length ns < 2 then fail() else h,end_itlist min ns in
        mapfilter getmin hops
      else
        map (fun t -> if is_const t & fst(dest_const t) = "="
                      then t,2 else t,0)
            (setify (map fst (vheads @ cheads))) in
    FOL_CONV hddata in
  fun (asl,w as gl) ->
    let headsp = itlist (get_thm_heads o snd) asl ([],[]) in
    RULE_ASSUM_TAC(CONV_RULE(GEN_FOL_CONV headsp)) gl;;

(* ------------------------------------------------------------------------- *)
(* Depth conversion to apply at "atomic" formulas in "first-order" term.     *)
(* ------------------------------------------------------------------------- *)

let rec PROP_ATOM_CONV conv tm =
  match tm with
    Comb((Const("!",_) | Const("?",_) | Const("?!",_)),Abs(_,_))
      -> BINDER_CONV (PROP_ATOM_CONV conv) tm
  | Comb(Comb
     ((Const("/\\",_) | Const("\\/",_) | Const("==>",_) |
       (Const("=",Tyapp("fun",[Tyapp("bool",[]);_])))),_),_)
        -> BINOP_CONV (PROP_ATOM_CONV conv) tm
  | Comb(Const("~",_),_) -> RAND_CONV (PROP_ATOM_CONV conv) tm
  | _ -> TRY_CONV conv tm;;
(* ========================================================================= *)
(* Version of the MESON procedure a la PTTP. Various search options.         *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

let meson_depth = ref false;;   (* Use depth not inference bound.            *)

let meson_prefine = ref true;;  (* Use Plaisted's positive refinement.       *)

let meson_dcutin = ref 1;;      (* Min size for d-and-c optimization cut-in. *)

let meson_skew = ref 3;;        (* Skew proof bias (one side is <= n / skew) *)

let meson_brand = ref false;;   (* Use Brand transformation                  *)

let meson_split_limit = ref 8;; (* Limit of case splits before MESON proper  *)

let meson_chatty = ref false;;  (* Old-style verbose MESON output            *)

(* ------------------------------------------------------------------------- *)
(* Prolog exception.                                                         *)
(* ------------------------------------------------------------------------- *)

exception Cut;;

(* ------------------------------------------------------------------------- *)
(* Shadow syntax for FOL terms in NNF. Functions and predicates have         *)
(* numeric codes, and negation is done by negating the predicate code.       *)
(* ------------------------------------------------------------------------- *)

type fol_term = Fvar of int
              | Fnapp of int * fol_term list;;

type fol_atom = int * fol_term list;;

type fol_form = Atom of fol_atom
               | Conj of fol_form * fol_form
               | Disj of fol_form * fol_form
               | Forallq of int * fol_form;;

(* ------------------------------------------------------------------------- *)
(* Type for recording a MESON proof tree.                                    *)
(* ------------------------------------------------------------------------- *)

type fol_goal =
  Subgoal of fol_atom * fol_goal list * (int * thm) *
             int * (fol_term * int)list;;

(* ------------------------------------------------------------------------- *)
(* General MESON procedure, using assumptions and with settable limits.      *)
(* ------------------------------------------------------------------------- *)

let GEN_MESON_TAC =

  let offinc = 10000
  and inferences = ref 0 in

  (* ----------------------------------------------------------------------- *)
  (* Like partition, but with short-circuiting for special situation.        *)
  (* ----------------------------------------------------------------------- *)

  let qpartition p m =
    let rec qpartition l =
      if l == m then raise Unchanged else
      match l with
        [] -> raise Unchanged
      | (h::t) -> if p h then
                    try let yes,no = qpartition t in h::yes,no
                    with Unchanged -> [h],t
                  else
                    let yes,no = qpartition t in yes,h::no in
    function l -> try qpartition l
                  with Unchanged -> [],l in

  (* ----------------------------------------------------------------------- *)
  (* Translate a term (in NNF) into the shadow syntax.                       *)
  (* ----------------------------------------------------------------------- *)

  let reset_vars,fol_of_var,hol_of_var =
    let vstore = ref []
    and gstore = ref []
    and vcounter = ref 0 in
    let inc_vcounter() =
      let n = !vcounter in
      let m = n + 1 in
      if m >= offinc then failwith "inc_vcounter: too many variables" else
      (vcounter := m; n) in
    let reset_vars() = vstore := []; gstore := []; vcounter := 0 in
    let fol_of_var v =
      let currentvars = !vstore in
      try assoc v currentvars with Failure _ ->
      let n = inc_vcounter() in
      vstore := (v,n)::currentvars; n in
    let hol_of_var v =
      try rev_assoc v (!vstore)
      with Failure _ -> rev_assoc v (!gstore) in
    let hol_of_bumped_var v =
      try hol_of_var v with Failure _ ->
      let v' = v mod offinc in
      let hv' = hol_of_var v' in
      let gv = genvar(type_of hv') in
      gstore := (gv,v)::(!gstore); gv in
    reset_vars,fol_of_var,hol_of_bumped_var in

  let reset_consts,fol_of_const,hol_of_const =
    let false_tm = `F` in
    let cstore = ref ([]:(term * int)list)
    and ccounter = ref 2 in
    let reset_consts() = cstore := [false_tm,1]; ccounter := 2 in
    let fol_of_const c =
      let currentconsts = !cstore in
      try assoc c currentconsts with Failure _ ->
      let n = !ccounter in
      ccounter := n + 1; cstore := (c,n)::currentconsts; n in
    let hol_of_const c = rev_assoc c (!cstore) in
    reset_consts,fol_of_const,hol_of_const in

  let rec fol_of_term env consts tm =
    if is_var tm & not (mem tm consts) then
      Fvar(fol_of_var tm)
    else
      let f,args = strip_comb tm in
      if mem f env then failwith "fol_of_term: higher order" else
      let ff = fol_of_const f in
      Fnapp(ff,map (fol_of_term env consts) args) in

  let fol_of_atom env consts tm =
    let f,args = strip_comb tm in
    if mem f env then failwith "fol_of_atom: higher order" else
    let ff = fol_of_const f in
    ff,map (fol_of_term env consts) args in

  let fol_of_literal env consts tm =
    try let tm' = dest_neg tm in
        let p,a = fol_of_atom env consts tm' in
        -p,a
    with Failure _ -> fol_of_atom env consts tm in

  let rec fol_of_form env consts tm =
    try let v,bod = dest_forall tm in
        let fv = fol_of_var v in
        let fbod = fol_of_form (v::env) (subtract consts [v]) bod in
        Forallq(fv,fbod)
    with Failure _ -> try
        let l,r = dest_conj tm in
        let fl = fol_of_form env consts l
        and fr = fol_of_form env consts r in
        Conj(fl,fr)
    with Failure _ -> try
        let l,r = dest_disj tm in
        let fl = fol_of_form env consts l
        and fr = fol_of_form env consts r in
        Disj(fl,fr)
    with Failure _ ->
        Atom(fol_of_literal env consts tm) in

  (* ----------------------------------------------------------------------- *)
  (* Further translation functions for HOL formulas.                         *)
  (* ----------------------------------------------------------------------- *)

  let rec hol_of_term tm =
    match tm with
      Fvar v -> hol_of_var v
    | Fnapp(f,args) -> list_mk_comb(hol_of_const f,map hol_of_term args) in

  let hol_of_atom (p,args) =
    list_mk_comb(hol_of_const p,map hol_of_term args) in

  let hol_of_literal (p,args) =
    if p < 0 then mk_neg(hol_of_atom(-p,args))
    else hol_of_atom (p,args) in

  (* ----------------------------------------------------------------------- *)
  (* Versions of shadow syntax operations with variable bumping.             *)
  (* ----------------------------------------------------------------------- *)

  let rec fol_free_in v tm =
    match tm with
      Fvar x -> x = v
    | Fnapp(_,lis) -> exists (fol_free_in v) lis in

  let rec fol_subst theta tm =
    match tm with
      Fvar v -> rev_assocd v theta tm
    | Fnapp(f,args) ->
          let args' = qmap (fol_subst theta) args in
          if args' == args then tm else Fnapp(f,args') in

  let fol_inst theta ((p,args) as at:fol_atom) =
    let args' = qmap (fol_subst theta) args in
    if args' == args then at else p,args' in

  let rec fol_subst_bump offset theta tm =
    match tm with
      Fvar v -> if v < offinc then
                 let v' = v + offset in
                 rev_assocd v' theta (Fvar(v'))
               else
                 rev_assocd v theta tm
    | Fnapp(f,args) ->
          let args' = qmap (fol_subst_bump offset theta) args in
          if args' == args then tm else Fnapp(f,args') in

  let fol_inst_bump offset theta ((p,args) as at:fol_atom) =
    let args' = qmap (fol_subst_bump offset theta) args in
    if args' == args then at else p,args' in

  (* ----------------------------------------------------------------------- *)
  (* Main unification function, maintaining a "graph" instantiation.         *)
  (* We implicitly apply an offset to variables in the second term, so this  *)
  (* is not symmetric between the arguments.                                 *)
  (* ----------------------------------------------------------------------- *)

  let rec istriv env x t =
    match t with
      Fvar y -> y = x or
                (try let t' = rev_assoc y env in istriv env x t'
                 with Failure "find" -> false)
    | Fnapp(f,args) -> exists (istriv env x) args & failwith "cyclic" in

  let rec fol_unify offset tm1 tm2 sofar =
    match tm1,tm2 with
      Fnapp(f,fargs),Fnapp(g,gargs) ->
          if f <> g then failwith "" else
          itlist2 (fol_unify offset) fargs gargs sofar
    | _,Fvar(x) ->
         (let x' = x + offset in
          try let tm2' = rev_assoc x' sofar in
              fol_unify 0 tm1 tm2' sofar
          with Failure "find" ->
              if istriv sofar x' tm1 then sofar
              else (tm1,x')::sofar)
    | Fvar(x),_ ->
         (try let tm1' = rev_assoc x sofar in
              fol_unify offset tm1' tm2 sofar
          with Failure "find" ->
              let tm2' = fol_subst_bump offset [] tm2 in
              if istriv sofar x tm2' then sofar
              else (tm2',x)::sofar) in

  (* ----------------------------------------------------------------------- *)
  (* Test for equality under the pending instantiations.                     *)
  (* ----------------------------------------------------------------------- *)

  let rec fol_eq insts tm1 tm2 =
    tm1 == tm2 or
    match tm1,tm2 with
      Fnapp(f,fargs),Fnapp(g,gargs) ->
          f = g & forall2 (fol_eq insts) fargs gargs
    | _,Fvar(x) ->
         (try let tm2' = rev_assoc x insts in
              fol_eq insts tm1 tm2'
          with Failure "find" ->
          try istriv insts x tm1 with Failure _ -> false)
    | Fvar(x),_ ->
         (try let tm1' = rev_assoc x insts in
              fol_eq insts tm1' tm2
          with Failure "find" ->
          try istriv insts x tm2 with Failure _ -> false) in

  let fol_atom_eq insts (p1,args1) (p2,args2) =
    p1 = p2 & forall2 (fol_eq insts) args1 args2 in

  (* ----------------------------------------------------------------------- *)
  (* Cacheing continuations. Very crude, but it works remarkably well.       *)
  (* ----------------------------------------------------------------------- *)

  let cacheconts f =
    let memory = ref [] in
    fun (gg,(insts,offset,size) as input) ->
      if exists (fun (_,(insts',_,size')) ->
                     insts = insts' & (size <= size' or !meson_depth))
          (!memory)
      then failwith "cachecont"
      else memory := input::(!memory); f input in

  (* ----------------------------------------------------------------------- *)
  (* Check ancestor list for repetition.                                     *)
  (* ----------------------------------------------------------------------- *)

  let checkan insts (p,a) ancestors =
    let p' = -p in
    let t' = (p',a) in
    try let ours = assoc p' ancestors in
        if exists (fun u -> fol_atom_eq insts t' (snd(fst u))) ours
        then failwith "checkan"
        else ancestors
    with Failure "find" -> ancestors in

  (* ----------------------------------------------------------------------- *)
  (* Insert new goal's negation in ancestor clause, given refinement.        *)
  (* ----------------------------------------------------------------------- *)

  let insertan insts (p,a) ancestors =
    let p' = -p in
    let t' = (p',a) in
    let ourancp,otheranc =
      try remove (fun (pr,_) -> pr = p') ancestors
      with Failure _ -> (p',[]),ancestors in
    let ouranc = snd ourancp in
    if exists (fun u -> fol_atom_eq insts t' (snd(fst u))) ouranc
    then failwith "insertan: loop"
    else (p',(([],t'),(0,TRUTH))::ouranc)::otheranc in

  (* ----------------------------------------------------------------------- *)
  (* Apply a multi-level "graph" instantiation.                              *)
  (* ----------------------------------------------------------------------- *)

  let rec fol_subst_partial insts tm =
    match tm with
      Fvar(v) -> (try let t = rev_assoc v insts in
                      fol_subst_partial insts t
                  with Failure "find" -> tm)
    | Fnapp(f,args) -> Fnapp(f,map (fol_subst_partial insts) args) in

  (* ----------------------------------------------------------------------- *)
  (* Tease apart local and global instantiations.                            *)
  (* At the moment we also force a full evaluation; should eliminate this.   *)
  (* ----------------------------------------------------------------------- *)

  let separate_insts offset oldinsts newinsts =
    let locins,globins =
      qpartition (fun (_,v) -> offset <= v) oldinsts newinsts in
    if globins = oldinsts then
      map (fun (t,x) -> fol_subst_partial newinsts t,x) locins,oldinsts
    else
      map (fun (t,x) -> fol_subst_partial newinsts t,x) locins,
      map (fun (t,x) -> fol_subst_partial newinsts t,x) globins in

  (* ----------------------------------------------------------------------- *)
  (* Perform basic MESON expansion.                                          *)
  (* ----------------------------------------------------------------------- *)

  let meson_single_expand loffset rule ((g,ancestors),(insts,offset,size)) =
    let (hyps,conc),tag = rule in
    let allins = rev_itlist2 (fol_unify loffset) (snd g) (snd conc) insts in
    let locin,globin = separate_insts offset insts allins in
    let mk_ihyp h =
      let h' = fol_inst_bump offset locin h in
      h',checkan insts h' ancestors in
    let newhyps =  map mk_ihyp hyps in
    inferences := !inferences + 1;
    newhyps,(globin,offset+offinc,size-length hyps) in

  (* ----------------------------------------------------------------------- *)
  (* Perform first basic expansion which allows continuation call.           *)
  (* ----------------------------------------------------------------------- *)

  let meson_expand_cont loffset rules state cont =
    tryfind
     (fun r -> cont (snd r) (meson_single_expand loffset r state)) rules in

  (* ----------------------------------------------------------------------- *)
  (* Try expansion and continuation call with ancestor or initial rule.      *)
  (* ----------------------------------------------------------------------- *)

  let meson_expand rules ((g,ancestors),((insts,offset,size) as tup)) cont =
    let pr = fst g in
    let newancestors = insertan insts g ancestors in
    let newstate = (g,newancestors),tup in
    try if !meson_prefine & pr > 0 then failwith "meson_expand" else
        let arules = assoc pr ancestors in
        meson_expand_cont 0 arules newstate cont
    with Cut -> failwith "meson_expand" | Failure _ ->
        try let crules =
              filter (fun ((h,_),_) -> length h <= size) (assoc pr rules) in
            meson_expand_cont offset crules newstate cont
        with Cut -> failwith "meson_expand"
           | Failure _ -> failwith "meson_expand" in

  (* ----------------------------------------------------------------------- *)
  (* Simple Prolog engine organizing search and backtracking.                *)
  (* ----------------------------------------------------------------------- *)

  let expand_goal rules =
    let rec expand_goal depth ((g,_),(insts,offset,size) as state) cont =
      if depth < 0 then failwith "expand_goal: too deep" else
      meson_expand rules state
        (fun apprule (_,(pinsts,_,_) as newstate) ->
            expand_goals (depth-1) newstate
              (cacheconts(fun (gs,(newinsts,newoffset,newsize)) ->
                 let locin,globin = separate_insts offset pinsts newinsts in
                 let g' = Subgoal(g,gs,apprule,offset,locin) in
                 if globin = insts & gs = [] then
                   try cont(g',(globin,newoffset,size))
                   with Failure _ -> raise Cut
                 else
                   try cont(g',(globin,newoffset,newsize))
                   with Cut -> failwith "expand_goal"
                      | Failure _ -> failwith "expand_goal")))

    and expand_goals depth (gl,(insts,offset,size as tup)) cont =
      match gl with
        [] -> cont ([],tup)

      | [g] -> expand_goal depth (g,tup) (fun (g',stup) -> cont([g'],stup))

      | gl -> if size >= !meson_dcutin then
                let lsize = size / (!meson_skew) in
                let rsize = size - lsize in
                let lgoals,rgoals = chop_list (length gl / 2) gl in
                try expand_goals depth (lgoals,(insts,offset,lsize))
                     (cacheconts(fun (lg',(i,off,n)) ->
                         expand_goals depth (rgoals,(i,off,n + rsize))
                           (cacheconts(fun (rg',ztup) -> cont (lg'@rg',ztup)))))
                with Failure _ ->
                    expand_goals depth (rgoals,(insts,offset,lsize))
                      (cacheconts(fun (rg',(i,off,n)) ->
                         expand_goals depth (lgoals,(i,off,n + rsize))
                           (cacheconts (fun (lg',((_,_,fsize) as ztup)) ->
                              if n + rsize <= lsize + fsize
                              then failwith "repetition of demigoal pair"
                              else cont (lg'@rg',ztup)))))
              else
                let g::gs = gl in
                expand_goal depth (g,tup)
                  (cacheconts(fun (g',stup) ->
                      expand_goals depth (gs,stup)
                        (cacheconts(fun (gs',ftup) -> cont(g'::gs',ftup))))) in

    fun g maxdep maxinf cont ->
      expand_goal maxdep (g,([],2 * offinc,maxinf)) cont in

  (* ----------------------------------------------------------------------- *)
  (* With iterative deepening of inferences or depth.                        *)
  (* ----------------------------------------------------------------------- *)

  let solve_goal rules incdepth min max incsize =
    let rec solve n g =
      if n > max then failwith "solve_goal: Too deep" else
      (if !meson_chatty & !verbose then
        (Format.print_string
          ((string_of_int (!inferences))^" inferences so far. "^
              "Searching with maximum size "^(string_of_int n)^".");
         Format.print_newline())
       else if !verbose then
        (Format.print_string(string_of_int (!inferences)^".."); 
         Format.print_flush())
       else ());
      try let gi =
            if incdepth then expand_goal rules g n 100000 (fun x -> x)
            else expand_goal rules g 100000 n (fun x -> x) in
          (if !meson_chatty & !verbose then
            (Format.print_string
              ("Goal solved with "^(string_of_int (!inferences))^
               " inferences.");
             Format.print_newline())
           else if !verbose then
            (Format.print_string("solved at "^string_of_int (!inferences));
             Format.print_newline())
           else ());
          gi
      with Failure _ -> solve (n + incsize) g in
    fun g -> solve min (g,[]) in

  (* ----------------------------------------------------------------------- *)
  (* Creation of tagged contrapositives from a HOL clause.                   *)
  (* This includes any possible support clauses (1 = falsity).               *)
  (* The rules are partitioned into association lists.                       *)
  (* ----------------------------------------------------------------------- *)

  let fol_of_hol_clauses =
    let eqt (a1,(b1,c1)) (a2, (b2,c2)) =
     ((a1 = a2) & (b1 = b2) & (equals_thm c1 c2)) in
    let mk_negated (p,a) = -p,a in
    let rec mk_contraposes n th used unused sofar =
      match unused with
        [] -> sofar
      | h::t -> let nw = (map mk_negated (used @ t),h),(n,th) in
                mk_contraposes (n + 1) th (used@[h]) t (nw::sofar) in
    let fol_of_hol_clause th =
      let lconsts = freesl (hyp th) in
      let tm = concl th in
      let hlits = disjuncts tm in
      let flits = map (fol_of_literal [] lconsts) hlits in
      let basics = mk_contraposes 0 th [] flits [] in
      if forall (fun (p,_) -> p < 0) flits then
        ((map mk_negated flits,(1,[])),(-1,th))::basics
      else basics in
    fun thms ->
      let rawrules = itlist (union' eqt o fol_of_hol_clause) thms [] in
      let prs = setify (map (fst o snd o fst) rawrules) in
      let prules =
        map (fun t -> t,filter ((=) t o fst o snd o fst) rawrules) prs in
      let srules = sort (fun (p,_) (q,_) -> abs(p) <= abs(q)) prules in
      srules in

  (* ----------------------------------------------------------------------- *)
  (* Optimize set of clauses; changing literal order complicates HOL stuff.  *)
  (* ----------------------------------------------------------------------- *)

  let optimize_rules =
    let optimize_clause_order cls =
      sort (fun ((l1,_),_) ((l2,_),_) -> length l1 <= length l2) cls in
    map (fun (a,b) -> a,optimize_clause_order b) in

  (* ----------------------------------------------------------------------- *)
  (* Create a HOL contrapositive on demand, with a cache.                    *)
  (* ----------------------------------------------------------------------- *)

  let clear_contrapos_cache,make_hol_contrapos =
    let DISJ_AC = AC DISJ_ACI
    and imp_CONV = REWR_CONV(TAUT `a \/ b <=> ~b ==> a`)
    and push_CONV =
      GEN_REWRITE_CONV TOP_SWEEP_CONV
       [TAUT `~(a \/ b) <=> ~a /\ ~b`; TAUT `~(~a) <=> a`]
    and pull_CONV = GEN_REWRITE_CONV DEPTH_CONV
       [TAUT `~a \/ ~b <=> ~(a /\ b)`]
    and imf_CONV = REWR_CONV(TAUT `~p <=> p ==> F`) in
    let memory = ref [] in
    let clear_contrapos_cache() = memory := [] in
    let make_hol_contrapos (n,th) =
      let tm = concl th in
      let key = (n,tm) in
      try assoc key (!memory) with Failure _ ->
      if n < 0 then
        CONV_RULE (pull_CONV THENC imf_CONV) th
      else
        let djs = disjuncts tm in
        let acth =
          if n = 0 then th else
          let ldjs,rdjs = chop_list n djs in
          let ndjs = (hd rdjs)::(ldjs@(tl rdjs)) in
          EQ_MP (DISJ_AC(mk_eq(tm,list_mk_disj ndjs))) th in
        let fth =
          if length djs = 1 then acth
          else CONV_RULE (imp_CONV THENC push_CONV) acth in
        (memory := (key,fth)::(!memory); fth) in
    clear_contrapos_cache,make_hol_contrapos in

  (* ----------------------------------------------------------------------- *)
  (* Translate back the saved proof into HOL.                                *)
  (* ----------------------------------------------------------------------- *)

  let meson_to_hol =
    let hol_negate tm =
      try dest_neg tm with Failure _ -> mk_neg tm in
    let merge_inst (t,x) current =
      (fol_subst current t,x)::current in
    let finish_RULE =
      GEN_REWRITE_RULE I
       [TAUT `(~p ==> p) <=> p`; TAUT `(p ==> ~p) <=> ~p`] in
    let rec meson_to_hol insts (Subgoal(g,gs,(n,th),offset,locin)) =
      let newins = itlist merge_inst locin insts in
      let g' = fol_inst newins g in
      let hol_g = hol_of_literal g' in
      let ths = map (meson_to_hol newins) gs in
      let hth =
        if equals_thm th TRUTH then ASSUME hol_g else
        let cth = make_hol_contrapos(n,th) in
        if ths = [] then cth else MATCH_MP cth (end_itlist CONJ ths) in
      let ith = PART_MATCH I hth hol_g in
      finish_RULE (DISCH (hol_negate(concl ith)) ith) in
    meson_to_hol in

  (* ----------------------------------------------------------------------- *)
  (* Create equality axioms for all the function and predicate symbols in    *)
  (* a HOL term. Not very efficient (but then neither is throwing them into  *)
  (* automated proof search!)                                                *)
  (* ----------------------------------------------------------------------- *)

  let create_equality_axioms =
    let eq_thms = (CONJUNCTS o prove)
     (`(x:A = x) /\
       (~(x:A = y) \/ ~(x = z) \/ (y = z))`,
      REWRITE_TAC[] THEN ASM_CASES_TAC `x:A = y` THEN
      ASM_REWRITE_TAC[] THEN CONV_TAC TAUT) in
    let imp_elim_CONV = REWR_CONV
      (TAUT `(a ==> b) <=> ~a \/ b`) in
    let eq_elim_RULE =
      MATCH_MP(TAUT `(a <=> b) ==> b \/ ~a`) in
    let veq_tm = rator(rator(concl(hd eq_thms))) in
    let create_equivalence_axioms (eq,_) =
      let tyins = type_match (type_of veq_tm) (type_of eq) [] in
      map (INST_TYPE tyins) eq_thms in
    let rec tm_consts tm acc =
      let fn,args = strip_comb tm in
      if args = [] then acc
      else itlist tm_consts args (insert (fn,length args) acc) in
    let rec fm_consts tm ((preds,funs) as acc) =
      try fm_consts(snd(dest_forall tm)) acc with Failure _ ->
      try fm_consts(snd(dest_exists tm)) acc with Failure _ ->
      try let l,r = dest_conj tm in fm_consts l (fm_consts r acc)
      with Failure _ -> try
          let l,r = dest_disj tm in fm_consts l (fm_consts r acc)
      with Failure _ -> try
          let l,r = dest_imp tm in fm_consts l (fm_consts r acc)
      with Failure _ -> try
           fm_consts (dest_neg tm) acc with Failure _ ->
      try let l,r = dest_eq tm in
          if type_of l = bool_ty
          then fm_consts r (fm_consts l acc)
          else failwith "atomic equality"
      with Failure _ ->
      let pred,args = strip_comb tm in
      if args = [] then acc else
      insert (pred,length args) preds,itlist tm_consts args funs in
    let create_congruence_axiom pflag (tm,len) =
      let atys,rty = splitlist (fun ty -> let op,l = dest_type ty in
                                          if op = "fun" then hd l,hd(tl l)
                                          else fail())
                               (type_of tm) in
      let ctys = fst(chop_list len atys) in
      let largs = map genvar ctys
      and rargs = map genvar ctys in
      let th1 = rev_itlist (C (curry MK_COMB)) (map (ASSUME o mk_eq)
          (zip largs rargs)) (REFL tm) in
      let th2 = if pflag then eq_elim_RULE th1 else th1 in
      itlist (fun e th -> CONV_RULE imp_elim_CONV (DISCH e th)) (hyp th2) th2 in
    fun tms -> let preds,funs = itlist fm_consts tms ([],[]) in
               let eqs0,noneqs = partition
                  (fun (t,_) -> is_const t & fst(dest_const t) = "=") preds in
               if eqs0 = [] then [] else
               let pcongs = map (create_congruence_axiom true) noneqs
               and fcongs = map (create_congruence_axiom false) funs in
               let preds1,_ =
                 itlist fm_consts (map concl (pcongs @ fcongs)) ([],[]) in
               let eqs1 = filter
                 (fun (t,_) -> is_const t & fst(dest_const t) = "=") preds1 in
               let eqs = union eqs0 eqs1 in
               let equivs =
                 itlist (union' equals_thm o create_equivalence_axioms)
                        eqs [] in
               equivs@pcongs@fcongs in

  (* ----------------------------------------------------------------------- *)
  (* Brand's transformation.                                                 *)
  (* ----------------------------------------------------------------------- *)

  let perform_brand_modification =
    let rec subterms_irrefl lconsts tm acc =
      if is_var tm or is_const tm then acc else
      let fn,args = strip_comb tm in
      itlist (subterms_refl lconsts) args acc
    and subterms_refl lconsts tm acc =
      if is_var tm then if mem tm lconsts then insert tm acc else acc
      else if is_const tm then insert tm acc else
      let fn,args = strip_comb tm in
      itlist (subterms_refl lconsts) args (insert tm acc) in
    let CLAUSIFY = CONV_RULE(REWR_CONV(TAUT `a ==> b <=> ~a \/ b`)) in
    let rec BRAND tms th =
      if tms = [] then th else
      let tm = hd tms in
      let gv = genvar (type_of tm) in
      let eq = mk_eq(gv,tm) in
      let th' = CLAUSIFY (DISCH eq (SUBS [SYM (ASSUME eq)] th))
      and tms' = map (subst [gv,tm]) (tl tms) in
      BRAND  tms' th' in
    let BRAND_CONGS th =
      let lconsts = freesl (hyp th) in
      let lits = disjuncts (concl th) in
      let atoms = map (fun t -> try dest_neg t with Failure _ -> t) lits in
      let eqs,noneqs = partition
        (fun t -> try fst(dest_const(fst(strip_comb t))) = "="
                  with Failure _ -> false) atoms in
      let acc = itlist (subterms_irrefl lconsts) noneqs [] in
      let uts = itlist
        (itlist (subterms_irrefl lconsts) o snd o strip_comb) eqs acc in
      let sts = sort (fun s t -> not(free_in s t)) uts in
      BRAND sts th in
    let BRANDE th =
      let tm = concl th in
      let l,r = dest_eq tm in
      let gv = genvar(type_of l) in
      let eq = mk_eq(r,gv) in
      CLAUSIFY(DISCH eq (EQ_MP (AP_TERM (rator tm) (ASSUME eq)) th)) in
    let LDISJ_CASES th lth rth =
      DISJ_CASES th (DISJ1 lth (concl rth)) (DISJ2 (concl lth) rth) in
    let ASSOCIATE = CONV_RULE(REWR_CONV(GSYM DISJ_ASSOC)) in
    let rec BRAND_TRANS th =
      let tm = concl th in
      try let l,r = dest_disj tm in
          if is_eq l then
            let lth = ASSUME l in
            let lth1 = BRANDE lth
            and lth2 = BRANDE (SYM lth)
            and rth = BRAND_TRANS (ASSUME r) in
            map (ASSOCIATE o LDISJ_CASES th lth1) rth @
            map (ASSOCIATE o LDISJ_CASES th lth2) rth
          else
            let rth = BRAND_TRANS (ASSUME r) in
            map (LDISJ_CASES th (ASSUME l)) rth
      with Failure _ ->
          if is_eq tm then [BRANDE th; BRANDE (SYM th)]
          else [th] in
    let find_eqs =
      find_terms (fun t -> try fst(dest_const t) = "="
                           with Failure _ -> false) in
    let REFLEXATE ths =
      let eqs = itlist (union o find_eqs o concl) ths [] in
      let tys = map (hd o snd o dest_type o snd o dest_const) eqs in
      let gvs = map genvar tys in
      itlist (fun v acc -> (REFL v)::acc) gvs ths in
    fun ths ->
      if exists (can (find_term is_eq o concl)) ths then
        let ths' = map BRAND_CONGS ths in
        let ths'' = itlist (union' equals_thm o BRAND_TRANS) ths' [] in
        REFLEXATE ths''
      else ths in

  (* ----------------------------------------------------------------------- *)
  (* Push duplicated copies of poly theorems to match existing assumptions.  *)
  (* ----------------------------------------------------------------------- *)

  let POLY_ASSUME_TAC =
    let rec uniq' eq =
      fun l ->
        match l with
          x::(y::_ as t) -> let t' = uniq' eq t in
                              if eq x y then t' else
                              if t'==t then l else x::t'
        | _ -> l in
    let setify' le eq s = uniq' eq (sort le s) in
    let rec grab_constants tm acc =
      if is_forall tm or is_exists tm then grab_constants (body(rand tm)) acc
      else if is_iff tm or is_imp tm or is_conj tm or is_disj tm then
        grab_constants (rand tm) (grab_constants (lhand tm) acc)
      else if is_neg tm then grab_constants (rand tm) acc
      else union (find_terms is_const tm) acc in
    let match_consts (tm1,tm2) =
      let s1,ty1 = dest_const tm1
      and s2,ty2 = dest_const tm2 in
      if s1 = s2 then type_match ty1 ty2 []
      else failwith "match_consts" in
    let polymorph mconsts th =
      let tvs = subtract (type_vars_in_term (concl th))
                         (unions (map type_vars_in_term (hyp th))) in
      if tvs = [] then [th] else
      let pconsts = grab_constants (concl th) [] in
      let tyins = mapfilter match_consts
        (allpairs (fun x y -> x,y) pconsts mconsts) in
      let ths' =
        setify' (fun th th' -> dest_thm th <= dest_thm th')
                equals_thm (mapfilter (C INST_TYPE th) tyins) in
      if ths' = [] then
        (warn true "No useful-looking instantiations of lemma"; [th])
      else ths' in
    let rec polymorph_all mconsts ths acc =
      if ths = [] then acc else
      let ths' = polymorph mconsts (hd ths) in
      let mconsts' = itlist grab_constants (map concl ths') mconsts in
      polymorph_all mconsts' (tl ths) (union' equals_thm ths' acc) in
    fun ths (asl,w as gl) ->
      let mconsts = itlist (grab_constants o concl o snd) asl [] in
      let ths' = polymorph_all mconsts ths [] in
      MAP_EVERY ASSUME_TAC ths' gl in

  (* ----------------------------------------------------------------------- *)
  (* Basic HOL MESON procedure.                                              *)
  (* ----------------------------------------------------------------------- *)

  let SIMPLE_MESON_REFUTE min max inc ths =
    clear_contrapos_cache();
    inferences := 0;
    let old_dcutin = !meson_dcutin in
    if !meson_depth then meson_dcutin := 100001 else ();
    let ths' = if !meson_brand then perform_brand_modification ths
               else ths @ create_equality_axioms (map concl ths) in
    let rules = optimize_rules(fol_of_hol_clauses ths') in
    let proof,(insts,_,_) =
      solve_goal rules (!meson_depth) min max inc (1,[]) in
    meson_dcutin := old_dcutin;
    meson_to_hol insts proof in

  let CONJUNCTS_THEN' ttac cth =
    ttac(CONJUNCT1 cth) THEN ttac(CONJUNCT2 cth) in

  let PURE_MESON_TAC min max inc gl =
    reset_vars(); reset_consts();
    (FIRST_ASSUM CONTR_TAC ORELSE
     W(ACCEPT_TAC o SIMPLE_MESON_REFUTE min max inc o map snd o fst)) gl in

  let QUANT_BOOL_CONV =
    PURE_REWRITE_CONV[FORALL_BOOL_THM; EXISTS_BOOL_THM; COND_CLAUSES;
                      NOT_CLAUSES; IMP_CLAUSES; AND_CLAUSES; OR_CLAUSES;
                      EQ_CLAUSES; FORALL_SIMP; EXISTS_SIMP] in

  let rec SPLIT_TAC n g =
    ((FIRST_X_ASSUM(CONJUNCTS_THEN' ASSUME_TAC) THEN SPLIT_TAC n) ORELSE
     (if n > 0 then FIRST_X_ASSUM DISJ_CASES_TAC THEN SPLIT_TAC (n - 1)
      else NO_TAC) ORELSE
     ALL_TAC) g in

  fun min max step ths ->
    REFUTE_THEN ASSUME_TAC THEN
    POLY_ASSUME_TAC (map GEN_ALL ths) THEN
    W(MAP_EVERY(UNDISCH_TAC o concl o snd) o fst) THEN
    SELECT_ELIM_TAC THEN
    W(fun (asl,w) -> MAP_EVERY (fun v -> SPEC_TAC(v,v)) (frees w)) THEN
    CONV_TAC(PRESIMP_CONV THENC
             TOP_DEPTH_CONV BETA_CONV THENC
             LAMBDA_ELIM_CONV THENC
             CONDS_CELIM_CONV THENC
             QUANT_BOOL_CONV) THEN
    REPEAT(GEN_TAC ORELSE DISCH_TAC) THEN
    REFUTE_THEN ASSUME_TAC THEN
    RULE_ASSUM_TAC(CONV_RULE(NNF_CONV THENC SKOLEM_CONV)) THEN
    REPEAT (FIRST_X_ASSUM CHOOSE_TAC) THEN
    ASM_FOL_TAC THEN
    SPLIT_TAC (!meson_split_limit) THEN
    RULE_ASSUM_TAC(CONV_RULE(PRENEX_CONV THENC WEAK_CNF_CONV)) THEN
    RULE_ASSUM_TAC(repeat
     (fun th -> SPEC(genvar(type_of(fst(dest_forall(concl th))))) th)) THEN
    REPEAT (FIRST_X_ASSUM (CONJUNCTS_THEN' ASSUME_TAC)) THEN
    RULE_ASSUM_TAC(CONV_RULE(ASSOC_CONV DISJ_ASSOC)) THEN
    REPEAT (FIRST_X_ASSUM SUBST_VAR_TAC) THEN
    PURE_MESON_TAC min max step;;

(* ------------------------------------------------------------------------- *)
(* Common cases.                                                             *)
(* ------------------------------------------------------------------------- *)

let ASM_MESON_TAC = GEN_MESON_TAC 0 50 1;;

let MESON_TAC ths = POP_ASSUM_LIST(K ALL_TAC) THEN ASM_MESON_TAC ths;;

(* ------------------------------------------------------------------------- *)
(* Also introduce a rule.                                                  *)
(* ------------------------------------------------------------------------- *)

let MESON ths tm = prove(tm,MESON_TAC ths);;
(* ========================================================================= *)
(* Tools for defining quotient types and lifting first order theorems.       *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Given a type name "ty" and a curried binary relation R, this defines      *)
(* a new type "ty" of R-equivalence classes. The abstraction and             *)
(* representation functions for the new type are called "mk_ty" and          *)
(* "dest_ty". The type bijections (after beta-conversion) are returned:      *)
(*                                                                           *)
(*             |- mk_ty (dest_ty a) = a                                      *)
(*                                                                           *)
(*             |- (?x. r = R x) <=> (dest_ty (mk_ty r) = r)                  *)
(* ------------------------------------------------------------------------- *)

let define_quotient_type =
  fun tyname (absname,repname) eqv ->
    let ty = hd(snd(dest_type(type_of eqv))) in
    let pty = mk_fun_ty ty bool_ty in
    let s = mk_var("s",pty) and x = mk_var("x",ty) in
    let eqvx = mk_comb(eqv,x) in
    let pred = mk_abs(s,mk_exists(x,mk_eq(s,eqvx))) in
    let th0 = BETA_CONV(mk_comb(pred,eqvx)) in
    let th1 = EXISTS(rand(concl th0),x) (REFL eqvx) in
    let th2 = EQ_MP (SYM th0) th1 in
    let abs,rep = new_basic_type_definition tyname (absname,repname) th2 in
    abs,CONV_RULE(LAND_CONV BETA_CONV) rep;;

(* ------------------------------------------------------------------------- *)
(* Given a welldefinedness theorem for a curried function f, of the form:    *)
(*                                                                           *)
(* |- !x1 x1' .. xn xn'. (x1 == x1') /\ ... /\ (xn == xn')                   *)
(*                       ==> (f x1 .. xn == f x1' .. f nx')                  *)
(*                                                                           *)
(* where each "==" is either equality or some fixed binary relation R, a     *)
(* new operator called "opname" is introduced which lifts "f" up to the      *)
(* R-equivalence classes. Two theorems are returned: the actual definition   *)
(* and a useful consequence for lifting theorems.                            *)
(*                                                                           *)
(* The function also needs the second (more complicated) type bijection, and *)
(* the reflexivity and transitivity (not symmetry!) of the equivalence       *)
(* relation. The use also gives a name for the new function.                 *)
(* ------------------------------------------------------------------------- *)

let lift_function =
  let SELECT_LEMMA = prove
   (`!x:A. (@y. x = y) = x`,
    GEN_TAC THEN GEN_REWRITE_TAC (LAND_CONV o BINDER_CONV) [EQ_SYM_EQ] THEN
    MATCH_ACCEPT_TAC SELECT_REFL) in
  fun tybij2 ->
    let tybl,tybr = dest_comb(concl tybij2) in
    let eqvx = rand(body(rand(rand tybl))) in
    let eqv,xtm = dest_comb eqvx in
    let dmr,rtm = dest_eq tybr in
    let dest,mrt = dest_comb dmr in
    let mk = rator mrt in
    let ety = type_of mrt in
    fun (refl_th,trans_th) fname wth ->
      let wtm = repeat (snd o dest_forall) (concl wth) in
      let wfvs = frees wtm in
      let hyps,con = try (conjuncts F_F I) (dest_imp wtm)
                     with Failure _ -> [],wtm in
      let eqs,rels = partition is_eq hyps in
      let rvs = map lhand rels in
      let qvs = map lhs eqs in
      let evs =
        variants wfvs (map (fun v -> mk_var(fst(dest_var v),ety)) rvs) in
      let mems = map2 (fun rv ev -> mk_comb(mk_comb(dest,ev),rv)) rvs evs in
      let lcon,rcon = dest_comb con in
      let u = variant (evs @ wfvs) (mk_var("u",type_of rcon)) in
      let ucon = mk_comb(lcon,u) in
      let dbod = list_mk_conj(ucon::mems) in
      let detm = list_mk_exists(rvs,dbod) in
      let datm = mk_abs(u,detm) in
      let def =
        if is_eq con then list_mk_icomb "@" [datm] else mk_comb(mk,datm) in
      let newargs = map
        (fun e -> try lhs e with Failure _ -> assoc (lhand e) (zip rvs evs)) hyps in
      let rdef = list_mk_abs(newargs,def) in
      let ldef = mk_var(fname,type_of rdef) in
      let dth = new_definition(mk_eq(ldef,rdef)) in
      let eth = rev_itlist
        (fun v th -> CONV_RULE(RAND_CONV BETA_CONV) (AP_THM th v))
        newargs dth in
      let targs = map (fun v -> mk_comb(mk,mk_comb(eqv,v))) rvs in
      let dme_th =
        let th = INST [eqvx,rtm] tybij2 in
        EQ_MP th (EXISTS(lhs(concl th),xtm) (REFL eqvx)) in
      let ith = INST (zip targs evs) eth in
      let jth = SUBS (map (fun v -> INST[v,xtm] dme_th) rvs) ith in
      let apop,uxtm = dest_comb(rand(concl jth)) in
      let extm = body uxtm in
      let evs,bod = strip_exists extm in
      let th1 = ASSUME bod in
      let th2 =
        if evs = [] then th1 else
        let th2a,th2b = CONJ_PAIR th1 in
        let ethlist = CONJUNCTS th2b @ map REFL qvs in
        let th2c = end_itlist CONJ (map
          (fun v -> find ((=) (lhand v) o lhand o concl) ethlist) hyps) in
        let th2d = MATCH_MP wth th2c in
        let th2e = try TRANS th2d th2a
                   with Failure _ -> MATCH_MP trans_th (CONJ th2d th2a) in
        itlist SIMPLE_CHOOSE evs th2e in
      let th3 = ASSUME(concl th2) in
      let th4 = end_itlist CONJ (th3::(map (C SPEC refl_th) rvs)) in
      let th5 = itlist SIMPLE_EXISTS evs (ASSUME bod) in
      let th6 = MATCH_MP (DISCH_ALL th5) th4 in
      let th7 = IMP_ANTISYM_RULE (DISCH_ALL th2) (DISCH_ALL th6) in
      let th8 = TRANS jth (AP_TERM apop (ABS u th7)) in
      let fconv = if is_eq con then REWR_CONV SELECT_LEMMA
                  else RAND_CONV ETA_CONV in
      let th9 = CONV_RULE (RAND_CONV fconv) th8 in
      eth,GSYM th9;;

(* ------------------------------------------------------------------------- *)
(* Lifts a theorem. This can be done by higher order rewriting alone.        *)
(*                                                                           *)
(* NB! All and only the first order variables must be bound by quantifiers.  *)
(* ------------------------------------------------------------------------- *)

let lift_theorem =
  let pth = prove
   (`(!x:Repty. R x x) /\
     (!x y. R x y <=> R y x) /\
     (!x y z. R x y /\ R y z ==> R x z) /\
     (!a. mk(dest a) = a) /\
     (!r. (?x. r = R x) <=> (dest(mk r) = r))
     ==> (!x y. R x y <=> (mk(R x) = mk(R y))) /\
         (!P. (!x. P(mk(R x))) <=> (!x. P x)) /\
         (!P. (?x. P(mk(R x))) <=> (?x. P x)) /\
         (!x:Absty. mk(R((@)(dest x))) = x)`,
    STRIP_TAC THEN
    SUBGOAL_THEN
     `!x y. (mk((R:Repty->Repty->bool) x):Absty = mk(R y)) <=> (R x = R y)`
    ASSUME_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN
    MATCH_MP_TAC(TAUT `(a /\ b /\ c) /\ (b ==> a ==> d)
                       ==> a /\ b /\ c /\ d`) THEN
    CONJ_TAC THENL
     [ASM_REWRITE_TAC[] THEN REWRITE_TAC[FUN_EQ_THM] THEN ASM_MESON_TAC[];
      ALL_TAC] THEN
    REPEAT(DISCH_THEN(fun th -> REWRITE_TAC[GSYM th])) THEN
    X_GEN_TAC `x:Repty` THEN
    SUBGOAL_THEN `dest(mk((R:Repty->Repty->bool) x):Absty) = R x`
    SUBST1_TAC THENL [ASM_MESON_TAC[]; ALL_TAC] THEN
    GEN_REWRITE_TAC (LAND_CONV o RAND_CONV) [GSYM ETA_AX] THEN
    FIRST_ASSUM(fun th -> GEN_REWRITE_TAC I [th]) THEN
    CONV_TAC SELECT_CONV THEN ASM_MESON_TAC[]) in
  fun tybij (refl_th,sym_th,trans_th) ->
    let tybij1 = GEN_ALL (fst tybij)
    and tybij2 = GEN_ALL (snd tybij) in
    let cth = end_itlist CONJ [refl_th; sym_th; trans_th; tybij1; tybij2] in
    let ith = MATCH_MP pth cth in
    fun trths ->
      REWRITE_RULE (ith::trths);;
(* ========================================================================= *)
(* Definition by primitive recursion and other tools for inductive types.    *)
(*                                                                           *)
(*       John Harrison, University of Cambridge Computer Laboratory          *)
(*                                                                           *)
(*            (c) Copyright, University of Cambridge 1998                    *)
(*              (c) Copyright, John Harrison 1998-2007                       *)
(* ========================================================================= *)

(* ------------------------------------------------------------------------- *)
(* Prove existence of recursive function. The inner "raw" version requires   *)
(* exact correspondence with recursion theorem; "canon" requires the         *)
(* PR argument to come first in the arg list; the outer one is more general. *)
(* ------------------------------------------------------------------------- *)

let prove_recursive_functions_exist =
  let prove_raw_recursive_functions_exist ax tm =
    let rawcls = conjuncts tm in
    let spcls = map (snd o strip_forall) rawcls in
    let lpats = map (strip_comb o lhand) spcls in
    let ufns = itlist (insert o fst) lpats [] in
    let axth = SPEC_ALL ax in
    let exvs,axbody = strip_exists (concl axth) in
    let axcls = conjuncts axbody in
    let f = fst o dest_const o repeat rator o rand o
            lhand o snd o strip_forall in
    let findax = C assoc (map (fun t -> f t,t) axcls) in
    let raxs =
      map (findax o fst o dest_const o repeat rator o hd o snd) lpats in
    let axfns = map (repeat rator o lhand o snd o strip_forall) raxs in
    let urfns = map (fun v -> assocd v (setify (zip axfns (map fst lpats))) v)
                    exvs in
    let axtm = list_mk_exists(exvs,list_mk_conj raxs)
    and urtm = list_mk_exists(urfns,tm) in
    let insts = term_match [] axtm urtm in
    let ixth = INSTANTIATE insts axth in
    let ixvs,ixbody = strip_exists (concl ixth) in
    let ixtm = subst (zip urfns ixvs) ixbody in
    let ixths = CONJUNCTS (ASSUME ixtm) in
    let rixths = map (fun t -> find (aconv t o concl) ixths) rawcls in
    let rixth = itlist SIMPLE_EXISTS ufns (end_itlist CONJ rixths) in
    PROVE_HYP ixth (itlist SIMPLE_CHOOSE urfns rixth) in
  let canonize t =
    let avs,bod = strip_forall t in
    let l,r = dest_eq bod in
    let fn,args = strip_comb l in
    let rarg = hd args
    and vargs = tl args in
    let l' = mk_comb(fn,rarg)
    and r' = list_mk_abs(vargs,r) in
    let fvs = frees rarg in
    let def = ASSUME(list_mk_forall(fvs,mk_eq(l',r'))) in
    GENL avs (RIGHT_BETAS vargs (SPECL fvs def)) in
  let prove_canon_recursive_functions_exist ax tm =
    let ths = map canonize (conjuncts tm) in
    let atm = list_mk_conj (map (hd o hyp) ths) in
    let aths = CONJUNCTS(ASSUME atm) in
    let rth = end_itlist CONJ (map2 PROVE_HYP aths ths) in
    let eth = prove_raw_recursive_functions_exist ax atm in
    let evs = fst(strip_exists(concl eth)) in
    PROVE_HYP eth (itlist SIMPLE_CHOOSE evs (itlist SIMPLE_EXISTS evs rth)) in
  let reshuffle fn args acc =
    let args' = uncurry (C (@)) (partition is_var args) in
    if args = args' then acc else
    let gvs = map (genvar o type_of) args in
    let gvs' = map (C assoc (zip args gvs)) args' in
    let lty = itlist (mk_fun_ty o type_of) gvs'
              (funpow (length gvs) (hd o tl o snd o dest_type) (type_of fn)) in
    let fn' = genvar lty in
    let def = mk_eq(fn,list_mk_abs(gvs,list_mk_comb(fn',gvs'))) in
    (ASSUME def)::acc
  and scrub_def t th =
    let l,r = dest_eq t in
    MP (INST [r,l] (DISCH t th)) (REFL r) in
  fun ax tm ->
    let rawcls = conjuncts tm in
    let spcls = map (snd o strip_forall) rawcls in
    let lpats = map (strip_comb o lhand) spcls in
    let ufns = itlist (insert o fst) lpats [] in
    let uxargs = map (C assoc lpats) ufns in
    let trths = itlist2 reshuffle ufns uxargs [] in
    let tth = GEN_REWRITE_CONV REDEPTH_CONV (BETA_THM::trths) tm in
    let eth = prove_canon_recursive_functions_exist ax (rand(concl tth)) in
    let evs,ebod = strip_exists(concl eth) in
    let fth = itlist SIMPLE_EXISTS ufns (EQ_MP (SYM tth) (ASSUME ebod)) in
    let gth = itlist scrub_def (map concl trths) fth in
    PROVE_HYP eth (itlist SIMPLE_CHOOSE evs gth);;

(* ------------------------------------------------------------------------- *)
(* Version that defines function(s).                                         *)
(* ------------------------------------------------------------------------- *)

let new_recursive_definition =
  let the_recursive_definitions = ref [] in
  let find_redefinition tm th =
    let th' = PART_MATCH I th tm in
    ignore(PART_MATCH I th' (concl th)); th' in
  fun ax tm ->
    try let th = tryfind (find_redefinition tm) (!the_recursive_definitions) in
        warn true "Benign redefinition of recursive function"; th
    with Failure _ ->
    let rawcls = conjuncts tm in
    let spcls = map (snd o strip_forall) rawcls in
    let lpats = map (strip_comb o lhand) spcls in
    let ufns = itlist (insert o fst) lpats [] in
    let fvs = map (fun t -> subtract (frees t) ufns) rawcls in
    let gcls = map2 (curry list_mk_forall) fvs rawcls in
    let eth = prove_recursive_functions_exist ax (list_mk_conj gcls) in
    let evs,bod = strip_exists(concl eth) in
    let dth = new_specification (map (fst o dest_var) evs) eth in
    let dths = map2 SPECL fvs (CONJUNCTS dth) in
    let th = end_itlist CONJ dths in
    the_recursive_definitions := th::(!the_recursive_definitions); th;;