helm/gTopLevel/logicalOperations.ml

   1 (* Copyright (C) 2002, HELM Team.
   2  *
   3  * This file is part of HELM, an Hypertextual, Electronic
   4  * Library of Mathematics, developed at the Computer Science
   5  * Department, University of Bologna, Italy.
   6  *
   7  * HELM is free software; you can redistribute it and/or
   8  * modify it under the terms of the GNU General Public License
   9  * as published by the Free Software Foundation; either version 2
  10  * of the License, or (at your option) any later version.
  11  *
  12  * HELM is distributed in the hope that it will be useful,
  13  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  14  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15  * GNU General Public License for more details.
  16  *
  17  * You should have received a copy of the GNU General Public License
  18  * along with HELM; if not, write to the Free Software
  19  * Foundation, Inc., 59 Temple Place - Suite 330, Boston,
  20  * MA  02111-1307, USA.
  21  *
  22  * For details, see the HELM World-Wide-Web page,
  23  * http://cs.unibo.it/helm/.
  24  *)
  25
  26 let get_parent id ids_to_terms ids_to_father_ids =
  27  match Hashtbl.find ids_to_father_ids id with
  28     None -> None
  29   | Some id -> Some (id, Hashtbl.find ids_to_terms id)
  30 ;;
  31
  32 let get_context ids_to_terms ids_to_father_ids =
  33  let module C = Cic in
  34   let rec aux id =
  35    match get_parent id ids_to_terms ids_to_father_ids with
  36       None -> []
  37     | Some (parentid,parent) ->
  38        let term = Hashtbl.find ids_to_terms id in
  39        let binding =
  40         match parent with
  41            C.Rel _
  42          | C.Var _
  43          | C.Meta _
  44          | C.Sort _
  45          | C.Implicit
  46          | C.Cast _ -> []
  47          | C.Prod (n,s,t) when t == term -> [Some (n,C.Decl s)]
  48          | C.Prod _ -> []
  49          | C.Lambda (n,s,t) when t == term -> [Some (n,C.Decl s)]
  50          | C.Lambda _ -> []
  51          | C.LetIn (n,s,t) when t == term -> [Some (n,C.Def s)]
  52          | C.LetIn _ -> []
  53          | C.Appl _
  54          | C.Const _ -> []
  55          | C.MutInd _
  56          | C.MutConstruct _
  57          | C.MutCase _ -> []
  58 (*CSC: sbagliato: manca il when *)
  59          | C.Fix (_,ifl) ->
  60             let counter = ref 0 in
  61              List.rev_map
  62               (function (name,_,ty,bo) ->
  63                 let res = Some (C.Name name, (C.Def (C.Fix (!counter,ifl)))) in
  64                  incr counter ;
  65                  res
  66               ) ifl
  67          | C.CoFix (_,ifl) ->
  68             let counter = ref 0 in
  69              List.rev_map
  70               (function (name,ty,bo) ->
  71                 let res = Some (C.Name name,(C.Def (C.CoFix (!counter,ifl)))) in
  72                  incr counter ;
  73                  res
  74               ) ifl
  75        in
  76         binding@(aux parentid)
  77   in
  78    aux
  79 ;;
  80
  81 exception NotImplemented;;
  82
  83 (* A subterm is changed into a fresh meta *)
  84 let to_sequent id ids_to_terms ids_to_father_ids =
  85  let module P = ProofEngine in
  86   let term = Hashtbl.find ids_to_terms id in
  87   let context = get_context ids_to_terms ids_to_father_ids id in
  88    let metasenv =
  89     match !P.proof with
  90        None -> assert false
  91      | Some (_,metasenv,_,_) -> metasenv
  92    in
  93     let ty = CicTypeChecker.type_of_aux' metasenv context term in
  94      P.perforate context term ty (* P.perforate also sets the goal *)
  95 ;;
  96
  97 exception FocusOnlyOnMeta;;
  98
  99 (* If the current selection is a Meta, that Meta becomes the current goal *)
 100 let focus id ids_to_terms ids_to_father_ids =
 101  let module P = ProofEngine in
 102   let term = Hashtbl.find ids_to_terms id in
 103   let context = get_context ids_to_terms ids_to_father_ids id in
 104    let metasenv =
 105     match !P.proof with
 106        None -> assert false
 107      | Some (_,metasenv,_,_) -> metasenv
 108    in
 109     let ty = CicTypeChecker.type_of_aux' metasenv context term in
 110      match term with
 111         Cic.Meta (n,_) -> P.goal := Some n
 112       | _ -> raise FocusOnlyOnMeta
 113 ;;