]> matita.cs.unibo.it Git - helm.git/blob - helm/software/components/ng_kernel/oCic2NCic.ml
j off by one in error message
[helm.git] / helm / software / components / ng_kernel / oCic2NCic.ml
1 module Ref = NReference
2
3 let cn_to_s = function
4   | Cic.Anonymous -> "_"
5   | Cic.Name s -> s
6 ;;
7
8 type ctx = 
9   | Ce of NCic.hypothesis 
10   | Fix of Ref.reference * string * NCic.term
11
12 let splat mk_pi ctx t =
13   List.fold_left
14     (fun t c -> 
15       match c with
16       | Ce (name, NCic.Def (bo,ty)) -> NCic.LetIn (name, ty, bo, t)
17       | Ce (name, NCic.Decl ty) when mk_pi -> NCic.Prod (name, ty, t)
18       | Ce (name, NCic.Decl ty) -> NCic.Lambda (name, ty, t)
19       | Fix (_,name,ty) when mk_pi -> NCic.Prod (name, ty, t)
20       | Fix (_,name,ty) -> NCic.Lambda (name,ty,t))
21     t ctx
22 ;;
23
24 let context_tassonomy ctx = 
25     let rec split inner acc acc1 = function 
26       | Ce _ :: tl when inner -> split inner (acc+1) (acc1+1) tl
27       | Fix _ ::tl -> split false acc (acc1+1) tl
28       | _ as l -> acc, List.length l, acc1
29     in
30       split true 0 1 ctx
31 ;;
32
33 let splat_args_for_rel ctx t = 
34   let bound, free, primo_ce_dopo_fix = context_tassonomy ctx in
35   if free = 0 then t 
36   else
37     let rec aux = function
38       | 0 -> []
39       | n -> 
40          (match List.nth ctx (n+bound) with
41          | Fix (refe, _, _) when (n+bound) < primo_ce_dopo_fix -> NCic.Const refe
42          | Fix _ | Ce _ -> NCic.Rel (n+bound)) :: aux (n-1)
43     in
44     NCic.Appl (t:: aux free)
45 ;;
46
47 let splat_args ctx t n_fix = 
48   let bound, free, primo_ce_dopo_fix = context_tassonomy ctx in
49   if ctx = [] then t
50   else
51    let rec aux = function
52      | 0 -> []
53      | n -> 
54         (match List.nth ctx (n-1) with
55          | Ce _ when n <= bound -> NCic.Rel n
56          | Fix (refe, _, _) when n < primo_ce_dopo_fix ->
57             splat_args_for_rel ctx (NCic.Const refe)
58          | Fix _ | Ce _ -> NCic.Rel (n - n_fix)
59         ) :: aux (n-1)
60    in
61    NCic.Appl (t:: aux (List.length ctx))
62 ;;
63
64 exception Nothing_to_do;;
65
66 let fix_outty curi tyno t context outty =
67  let leftno,rightno =
68   match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with
69      Cic.InductiveDefinition (tyl,_,leftno,_) ->
70       let _,_,arity,_ = List.nth tyl tyno in
71       let rec count_prods leftno context arity =
72        match leftno, CicReduction.whd context arity with
73           0, Cic.Sort _ -> 0
74         | 0, Cic.Prod (name,so,ty) ->
75            1 + count_prods 0 (Some (name, Cic.Decl so)::context) ty
76         | n, Cic.Prod (name,so,ty) ->
77            count_prods (leftno - 1) (Some (name, Cic.Decl so)::context) ty
78         | _,_ -> assert false
79       in
80 (*prerr_endline (UriManager.string_of_uri curi);
81 prerr_endline ("LEFTNO: " ^ string_of_int leftno ^ "  " ^ CicPp.ppterm arity);*)
82        leftno, count_prods leftno [] arity
83    | _ -> assert false in
84  let ens,args =
85   let tty,_= CicTypeChecker.type_of_aux' [] context t CicUniv.oblivion_ugraph in
86   match CicReduction.whd context tty with
87      Cic.MutInd (_,_,ens) -> ens,[]
88    | Cic.Appl (Cic.MutInd (_,_,ens)::args) ->
89       ens,fst (HExtlib.split_nth leftno args)
90    | _ -> assert false
91  in
92   let rec aux n irl context outsort =
93    match n, CicReduction.whd context outsort with
94       0, Cic.Prod _ -> raise Nothing_to_do
95     | 0, _ ->
96        let irl = List.rev irl in
97        let ty = CicSubstitution.lift rightno (Cic.MutInd (curi,tyno,ens)) in
98        let ty =
99         if args = [] && irl = [] then ty
100         else
101          Cic.Appl (ty::(List.map (CicSubstitution.lift rightno) args)@irl) in
102        let he = CicSubstitution.lift (rightno + 1) outty in
103        let t =
104         if irl = [] then he
105         else Cic.Appl (he::List.map (CicSubstitution.lift 1) irl)
106        in
107         Cic.Lambda (Cic.Anonymous, ty, t)
108     | n, Cic.Prod (name,so,ty) ->
109        let ty' =
110         aux (n - 1) (Cic.Rel n::irl) (Some (name, Cic.Decl so)::context) ty
111        in
112         Cic.Lambda (name,so,ty')
113     | _,_ -> assert false
114   in
115 (*prerr_endline ("RIGHTNO = " ^ string_of_int rightno ^ " OUTTY = " ^ CicPp.ppterm outty);*)
116    let outsort =
117     fst (CicTypeChecker.type_of_aux' [] context outty CicUniv.oblivion_ugraph)
118    in
119     try aux rightno [] context outsort
120     with Nothing_to_do -> outty
121 (*prerr_endline (CicPp.ppterm outty ^ " <==> " ^ CicPp.ppterm outty');*)
122 ;;
123
124 (* we are lambda-lifting also variables that do not occur *)
125 (* ctx does not distinguish successive blocks of cofix, since there may be no
126  *   lambda separating them *)
127 let convert_term uri t = 
128   let rec aux octx (ctx : ctx list) n_fix uri = function
129     | Cic.CoFix (k, fl) ->
130         let buri = 
131           UriManager.uri_of_string 
132            (UriManager.buri_of_uri uri^"/"^
133             UriManager.name_of_uri uri ^ string_of_int (List.length ctx)^".con")
134         in
135         let bctx, fixpoints_tys, tys, _ = 
136           List.fold_right 
137             (fun (name,ty,_) (ctx, fixpoints, tys, idx) -> 
138               let ty, fixpoints_ty = aux octx ctx n_fix uri ty in
139               let r = Ref.reference_of_ouri buri(Ref.CoFix idx) in
140               Fix (r,name,ty) :: ctx, fixpoints_ty @ fixpoints,ty::tys,idx+1)
141             fl ([], [], [], 0)
142         in
143         let bctx = bctx @ ctx in
144         let n_fl = List.length fl in
145         let boctx,_ =
146          List.fold_left
147           (fun (types,len) (n,ty,_) ->
148              (Some (Cic.Name n,(Cic.Decl (CicSubstitution.lift len ty)))::types,
149               len+1)) (octx,0) fl
150         in
151         let fl, fixpoints =
152           List.fold_right2 
153             (fun (name,_,bo) ty  (l,fixpoints) -> 
154                let bo, fixpoints_bo = aux boctx bctx n_fl buri bo in
155                (([],name,~-1,splat true ctx ty, splat false ctx bo)::l),
156                fixpoints_bo @ fixpoints)
157             fl tys ([],fixpoints_tys)
158         in
159         let obj = 
160           NUri.nuri_of_ouri buri,0,[],[],
161             NCic.Fixpoint (false, fl, (`Generated, `Definition)) 
162         in
163         splat_args ctx 
164          (NCic.Const (Ref.reference_of_ouri buri (Ref.CoFix k)))
165          n_fix,
166         fixpoints @ [obj]
167     | Cic.Fix (k, fl) ->
168         let buri = 
169           UriManager.uri_of_string 
170            (UriManager.buri_of_uri uri^"/"^
171             UriManager.name_of_uri uri ^ string_of_int (List.length ctx)^".con")
172         in
173         let bad_bctx, fixpoints_tys, tys, _ = 
174           List.fold_right 
175             (fun (name,recno,ty,_) (bctx, fixpoints, tys, idx) -> 
176               let ty, fixpoints_ty = aux octx ctx n_fix uri ty in
177               let r =  (* recno is dummy here, must be lifted by the ctx len *)
178                 Ref.reference_of_ouri buri (Ref.Fix (idx,recno)) 
179               in
180               Fix (r,name,ty) :: bctx, fixpoints_ty@fixpoints,ty::tys,idx+1)
181             fl ([], [], [], 0)
182         in
183         let _, free, _ = context_tassonomy (bad_bctx @ ctx) in
184         let bctx = 
185           List.map (function 
186             | Fix (Ref.Ref (_,_,Ref.Fix (idx, recno)),name, ty) ->
187               Fix (Ref.reference_of_ouri buri(Ref.Fix (idx,recno+free)),name,ty)
188             | _ -> assert false) bad_bctx @ ctx
189         in
190         let n_fl = List.length fl in
191         let boctx,_ =
192          List.fold_left
193           (fun (types,len) (n,_,ty,_) ->
194              (Some (Cic.Name n,(Cic.Decl (CicSubstitution.lift len ty)))::types,
195               len+1)) (octx,0) fl
196         in
197         let rno_k = ref 0 in
198         let fl, fixpoints,_ =
199           List.fold_right2 
200             (fun (name,rno,_,bo) ty (l,fixpoints,idx) -> 
201                let bo, fixpoints_bo = aux boctx bctx n_fl buri bo in
202                let rno = rno + free in
203                if idx = k then rno_k := rno;
204                (([],name,rno,splat true ctx ty, splat false ctx bo)::l),
205                fixpoints_bo @ fixpoints,idx+1)
206             fl tys ([],fixpoints_tys,0)
207         in
208         let obj = 
209           NUri.nuri_of_ouri buri,max_int,[],[],
210             NCic.Fixpoint (true, fl, (`Generated, `Definition)) 
211         in
212         splat_args ctx
213           (NCic.Const 
214             (Ref.reference_of_ouri buri (Ref.Fix (k,!rno_k))))
215           n_fix,
216         fixpoints @ [obj]
217     | Cic.Rel n ->
218         let bound, _, primo_ce_dopo_fix = context_tassonomy ctx in
219         (match List.nth ctx (n-1) with
220         | Fix (r,_,_) when n < primo_ce_dopo_fix -> 
221             splat_args_for_rel ctx (NCic.Const r), []
222         | Ce _ when n <= bound -> NCic.Rel n, []
223         | Fix _ (* BUG 3 fix nested *) 
224         | Ce _ -> NCic.Rel (n-n_fix), [])
225     | Cic.Lambda (name, (s as old_s), t) ->
226         let s, fixpoints_s = aux octx ctx n_fix uri s in
227         let ctx = Ce (cn_to_s name, NCic.Decl s) :: ctx in
228         let octx = Some (name, Cic.Decl old_s) :: octx in
229         let t, fixpoints_t = aux octx ctx n_fix uri t in
230         NCic.Lambda (cn_to_s name, s, t), fixpoints_s @ fixpoints_t
231     | Cic.Prod (name, (s as old_s), t) ->
232         let s, fixpoints_s = aux octx ctx n_fix uri s in
233         let ctx = Ce (cn_to_s name, NCic.Decl s) :: ctx in
234         let octx = Some (name, Cic.Decl old_s) :: octx in
235         let t, fixpoints_t = aux octx ctx n_fix uri t in
236         NCic.Prod (cn_to_s name, s, t), fixpoints_s @ fixpoints_t
237     | Cic.LetIn (name, (te as old_te), (ty as old_ty), t) ->
238         let te, fixpoints_s = aux octx ctx n_fix uri te in
239         let ty, fixpoints_ty = aux octx ctx n_fix uri ty in
240         let ctx = Ce (cn_to_s name, NCic.Def (te, ty)) :: ctx in
241         let octx = Some (name, Cic.Def (old_te, old_ty)) :: octx in
242         let t, fixpoints_t = aux octx ctx n_fix uri t in
243         NCic.LetIn (cn_to_s name, ty, te, t), 
244         fixpoints_s @ fixpoints_t @ fixpoints_ty
245     | Cic.Cast (t,ty) ->
246         let t, fixpoints_t = aux octx ctx n_fix uri t in
247         let ty, fixpoints_ty = aux octx ctx n_fix uri ty in
248         NCic.LetIn ("cast", ty, t, NCic.Rel 1), fixpoints_t @ fixpoints_ty
249     | Cic.Sort Cic.Prop -> NCic.Sort NCic.Prop,[]
250     | Cic.Sort Cic.CProp -> NCic.Sort NCic.CProp,[]
251     | Cic.Sort (Cic.Type _) -> NCic.Sort (NCic.Type 0),[] 
252     | Cic.Sort Cic.Set -> NCic.Sort (NCic.Type 0),[] 
253        (* calculate depth in the univ_graph*)
254     | Cic.Appl l -> 
255         let l, fixpoints =
256           List.fold_right 
257              (fun t (l,acc) -> 
258                let t, fixpoints = aux octx ctx n_fix uri t in 
259                (t::l,fixpoints@acc))
260              l ([],[])
261         in
262         (match l with
263         | (NCic.Appl l1)::l2 -> NCic.Appl (l1@l2), fixpoints
264         | _ -> NCic.Appl l, fixpoints)
265     | Cic.Const (curi, ens) -> 
266        aux_ens octx ctx n_fix uri ens
267         (match fst(CicEnvironment.get_obj CicUniv.oblivion_ugraph curi) with
268         | Cic.Constant (_,Some _,_,_,_) ->
269                NCic.Const (Ref.reference_of_ouri curi Ref.Def)
270         | Cic.Constant (_,None,_,_,_) ->
271                NCic.Const (Ref.reference_of_ouri curi Ref.Decl)
272         | _ -> assert false)
273     | Cic.MutInd (curi, tyno, ens) -> 
274        aux_ens octx ctx n_fix uri ens
275         (NCic.Const (Ref.reference_of_ouri curi (Ref.Ind tyno)))
276     | Cic.MutConstruct (curi, tyno, consno, ens) -> 
277        aux_ens octx ctx n_fix uri ens
278         (NCic.Const (Ref.reference_of_ouri curi (Ref.Con (tyno,consno))))
279     | Cic.MutCase (curi, tyno, outty, t, branches) ->
280         let outty = fix_outty curi tyno t octx outty in
281         let r = Ref.reference_of_ouri curi (Ref.Ind tyno) in
282         let outty, fixpoints_outty = aux octx ctx n_fix uri outty in
283         let t, fixpoints_t = aux octx ctx n_fix uri t in
284         let branches, fixpoints =
285           List.fold_right 
286              (fun t (l,acc) -> 
287                let t, fixpoints = aux octx ctx n_fix uri t in 
288                (t::l,fixpoints@acc))
289              branches ([],[])
290         in
291         NCic.Match (r,outty,t,branches), fixpoints_outty@fixpoints_t@fixpoints
292     | Cic.Implicit _ | Cic.Meta _ | Cic.Var _ -> assert false
293   and aux_ens octx ctx n_fix uri ens he =
294    match ens with
295       [] -> he,[]
296     | _::_ ->
297       let ens,objs =
298        List.fold_right
299         (fun (_,t) (l,objs) ->
300           let t,o = aux octx ctx n_fix uri t in
301            t::l, o@objs
302         ) ens ([],[])
303       in
304        NCic.Appl (he::ens),objs
305   in
306    aux [] [] 0 uri t
307 ;;
308
309 let cook mode vars t =
310  let t = CicSubstitution.lift (List.length vars) t in
311  snd (List.fold_right
312   (fun uri (n,t) ->
313     let t = CicSubstitution.subst_vars [uri,Cic.Rel 1] t in
314     let bo,ty =
315      match fst (CicEnvironment.get_obj CicUniv.oblivion_ugraph uri) with
316         Cic.Variable (_,bo,ty,_,_) -> bo,ty
317       | _ -> assert false in
318     let id = Cic.Name (UriManager.name_of_uri uri) in
319     let t =
320      match bo,ty,mode with
321         None,ty,`Lambda -> Cic.Lambda (id,ty,t)
322       | None,ty,`Pi -> Cic.Prod (id,ty,t)
323       | Some bo,ty,_ -> Cic.LetIn (id,bo,ty,t)
324     in
325      n+1,t
326   ) vars (1,t))
327 ;;
328
329 let convert_obj_aux uri = function
330  | Cic.Constant (name, None, ty, vars, _) ->
331      let ty = cook `Pi vars ty in
332      let nty, fixpoints = convert_term uri ty in
333      assert(fixpoints = []);
334      NCic.Constant ([], name, None, nty, (`Provided,`Theorem,`Regular)),
335      fixpoints
336  | Cic.Constant (name, Some bo, ty, vars, _) ->
337      let bo = cook `Lambda vars bo in
338      let ty = cook `Pi vars ty in
339      let nbo, fixpoints_bo = convert_term uri bo in
340      let nty, fixpoints_ty = convert_term uri ty in
341      assert(fixpoints_ty = []);
342      NCic.Constant ([], name, Some nbo, nty, (`Provided,`Theorem,`Regular)),
343      fixpoints_bo @ fixpoints_ty
344  | Cic.InductiveDefinition (itl,vars,leftno,_) -> 
345      let ind = let _,x,_,_ = List.hd itl in x in
346      let itl, fix_itl = 
347        List.fold_right
348          (fun (name, _, ty, cl) (itl,acc) ->
349             let ty = cook `Pi vars ty in
350             let ty, fix_ty = convert_term uri ty in
351             let cl, fix_cl = 
352               List.fold_right
353                (fun (name, ty) (cl,acc) -> 
354                  let ty = cook `Pi vars ty in
355                  let ty, fix_ty = convert_term uri ty in
356                  ([], name, ty)::cl, acc @ fix_ty)
357                cl ([],[])
358             in
359             ([], name, ty, cl)::itl, fix_ty @ fix_cl @ acc)
360          itl ([],[])
361      in
362      NCic.Inductive(ind, leftno + List.length vars, itl, (`Provided, `Regular)),
363      fix_itl
364  | Cic.Variable _ 
365  | Cic.CurrentProof _ -> assert false
366 ;;
367
368 let convert_obj uri obj = 
369   let o, fixpoints = convert_obj_aux uri obj in
370   let obj = NUri.nuri_of_ouri uri,max_int, [], [], o in
371   fixpoints @ [obj]
372 ;;