src/FOL/fologic.ML
author wenzelm
Thu Oct 04 14:49:38 2001 +0200 (2001-10-04)
changeset 11668 548ba68385a3
parent 10384 a499b9ce2ffe
child 27325 70e4eb732fa9
permissions -rw-r--r--
added dest_conj, dest_concls;
paulson@4349
     1
(*  Title:      FOL/fologic.ML
paulson@4349
     2
    ID:         $Id$
paulson@4349
     3
    Author:     Lawrence C Paulson
paulson@4349
     4
paulson@4349
     5
Abstract syntax operations for FOL.
paulson@4349
     6
*)
paulson@4349
     7
paulson@4349
     8
signature FOLOGIC =
paulson@4349
     9
sig
paulson@6140
    10
  val oT		: typ
paulson@6140
    11
  val mk_Trueprop	: term -> term
paulson@6140
    12
  val dest_Trueprop	: term -> term
wenzelm@9850
    13
  val not		: term
paulson@6140
    14
  val conj		: term
paulson@6140
    15
  val disj		: term
paulson@6140
    16
  val imp		: term
paulson@9543
    17
  val iff		: term
wenzelm@7692
    18
  val mk_conj		: term * term -> term
wenzelm@7692
    19
  val mk_disj		: term * term -> term
wenzelm@7692
    20
  val mk_imp		: term * term -> term
paulson@6140
    21
  val dest_imp	       	: term -> term*term
wenzelm@11668
    22
  val dest_conj         : term -> term list
wenzelm@11668
    23
  val dest_concls       : term -> term list
paulson@9543
    24
  val mk_iff		: term * term -> term
paulson@9543
    25
  val dest_iff	       	: term -> term*term
paulson@6140
    26
  val all_const		: typ -> term
paulson@6140
    27
  val mk_all		: term * term -> term
paulson@6140
    28
  val exists_const	: typ -> term
paulson@6140
    29
  val mk_exists		: term * term -> term
paulson@6140
    30
  val eq_const		: typ -> term
paulson@6140
    31
  val mk_eq		: term * term -> term
paulson@6140
    32
  val dest_eq 		: term -> term*term
paulson@9543
    33
  val mk_binop: string -> term * term -> term
paulson@9543
    34
  val mk_binrel: string -> term * term -> term
paulson@9543
    35
  val dest_bin: string -> typ -> term -> term * term
paulson@4349
    36
end;
paulson@4349
    37
paulson@4349
    38
paulson@4349
    39
structure FOLogic: FOLOGIC =
paulson@4349
    40
struct
paulson@4349
    41
paulson@4349
    42
val oT = Type("o",[]);
paulson@4349
    43
paulson@4349
    44
val Trueprop = Const("Trueprop", oT-->propT);
paulson@4349
    45
paulson@4349
    46
fun mk_Trueprop P = Trueprop $ P;
paulson@4349
    47
paulson@4349
    48
fun dest_Trueprop (Const ("Trueprop", _) $ P) = P
paulson@4349
    49
  | dest_Trueprop t = raise TERM ("dest_Trueprop", [t]);
paulson@4349
    50
paulson@4349
    51
(** Logical constants **)
paulson@4349
    52
wenzelm@9850
    53
val not = Const ("Not", oT --> oT);
wenzelm@9850
    54
val conj = Const("op &", [oT,oT]--->oT);
wenzelm@9850
    55
val disj = Const("op |", [oT,oT]--->oT);
wenzelm@9850
    56
val imp = Const("op -->", [oT,oT]--->oT)
wenzelm@9850
    57
val iff = Const("op <->", [oT,oT]--->oT);
paulson@4349
    58
wenzelm@7692
    59
fun mk_conj (t1, t2) = conj $ t1 $ t2
wenzelm@7692
    60
and mk_disj (t1, t2) = disj $ t1 $ t2
paulson@9543
    61
and mk_imp (t1, t2) = imp $ t1 $ t2
paulson@9543
    62
and mk_iff (t1, t2) = iff $ t1 $ t2;
wenzelm@7692
    63
paulson@4466
    64
fun dest_imp (Const("op -->",_) $ A $ B) = (A, B)
paulson@4466
    65
  | dest_imp  t = raise TERM ("dest_imp", [t]);
paulson@4466
    66
wenzelm@11668
    67
fun dest_conj (Const ("op &", _) $ t $ t') = t :: dest_conj t'
wenzelm@11668
    68
  | dest_conj t = [t];
wenzelm@11668
    69
wenzelm@11668
    70
fun imp_concl_of t = imp_concl_of (#2 (dest_imp t)) handle TERM _ => t;
wenzelm@11668
    71
val dest_concls = map imp_concl_of o dest_conj o dest_Trueprop;
wenzelm@11668
    72
paulson@9543
    73
fun dest_iff (Const("op <->",_) $ A $ B) = (A, B)
paulson@9543
    74
  | dest_iff  t = raise TERM ("dest_iff", [t]);
paulson@9543
    75
paulson@4349
    76
fun eq_const T = Const ("op =", [T, T] ---> oT);
paulson@4349
    77
fun mk_eq (t, u) = eq_const (fastype_of t) $ t $ u;
paulson@4349
    78
paulson@6140
    79
fun dest_eq (Const ("op =", _) $ lhs $ rhs) = (lhs, rhs)
paulson@6140
    80
  | dest_eq t = raise TERM ("dest_eq", [t])
paulson@6140
    81
paulson@4349
    82
fun all_const T = Const ("All", [T --> oT] ---> oT);
paulson@4349
    83
fun mk_all (Free(x,T),P) = all_const T $ (absfree (x,T,P));
paulson@4349
    84
paulson@4349
    85
fun exists_const T = Const ("Ex", [T --> oT] ---> oT);
paulson@4349
    86
fun mk_exists (Free(x,T),P) = exists_const T $ (absfree (x,T,P));
paulson@4349
    87
paulson@9543
    88
(* binary oprations and relations *)
paulson@9543
    89
paulson@9543
    90
fun mk_binop c (t, u) =
paulson@9543
    91
  let val T = fastype_of t in
paulson@9543
    92
    Const (c, [T, T] ---> T) $ t $ u
paulson@9543
    93
  end;
paulson@9543
    94
paulson@9543
    95
fun mk_binrel c (t, u) =
paulson@9543
    96
  let val T = fastype_of t in
paulson@9543
    97
    Const (c, [T, T] ---> oT) $ t $ u
paulson@9543
    98
  end;
paulson@9543
    99
paulson@9543
   100
fun dest_bin c T (tm as Const (c', Type ("fun", [T', _])) $ t $ u) =
paulson@9543
   101
      if c = c' andalso T = T' then (t, u)
paulson@9543
   102
      else raise TERM ("dest_bin " ^ c, [tm])
paulson@9543
   103
  | dest_bin c _ tm = raise TERM ("dest_bin " ^ c, [tm]);
paulson@9543
   104
paulson@9543
   105
paulson@4349
   106
end;