313 NONE => error "Import_Rule.get: not a number" |
313 NONE => error "Import_Rule.get: not a number" |
314 | SOME i => (case Inttab.lookup map (Int.abs i) of |
314 | SOME i => (case Inttab.lookup map (Int.abs i) of |
315 NONE => error "Import_Rule.get: lookup failed" |
315 NONE => error "Import_Rule.get: lookup failed" |
316 | SOME res => (res, (if i < 0 then Inttab.delete (Int.abs i) map else map, no))) |
316 | SOME res => (res, (if i < 0 then Inttab.delete (Int.abs i) map else map, no))) |
317 |
317 |
318 fun getty i (thy, (tyi, tmi, thi)) = let val (i, tyi) = (get tyi i) in (i, (thy, (tyi, tmi, thi))) end |
318 fun typ i (thy, (tyi, tmi, thi)) = let val (i, tyi) = (get tyi i) in (i, (thy, (tyi, tmi, thi))) end |
319 fun gettm i (thy, (tyi, tmi, thi)) = let val (i, tmi) = (get tmi i) in (i, (thy, (tyi, tmi, thi))) end |
319 fun term i (thy, (tyi, tmi, thi)) = let val (i, tmi) = (get tmi i) in (i, (thy, (tyi, tmi, thi))) end |
320 fun getth i (thy, (tyi, tmi, thi)) = let val (i, thi) = (get thi i) in (i, (thy, (tyi, tmi, thi))) end |
320 fun thm i (thy, (tyi, tmi, thi)) = let val (i, thi) = (get thi i) in (i, (thy, (tyi, tmi, thi))) end |
321 fun set (map, no) v = (Inttab.update_new (no + 1, v) map, no + 1) |
321 fun set (map, no) v = (Inttab.update_new (no + 1, v) map, no + 1) |
322 fun setty v (thy, (tyi, tmi, thi)) = (thy, (set tyi v, tmi, thi)) |
322 fun set_typ v (thy, (tyi, tmi, thi)) = (thy, (set tyi v, tmi, thi)) |
323 fun settm v (thy, (tyi, tmi, thi)) = (thy, (tyi, set tmi v, thi)) |
323 fun set_term v (thy, (tyi, tmi, thi)) = (thy, (tyi, set tmi v, thi)) |
324 fun setth v (thy, (tyi, tmi, thi)) = (thy, (tyi, tmi, set thi v)) |
324 fun set_thm v (thy, (tyi, tmi, thi)) = (thy, (tyi, tmi, set thi v)) |
325 |
325 |
326 fun last_thm (_, _, (map, no)) = |
326 fun last_thm (_, _, (map, no)) = |
327 case Inttab.lookup map no of |
327 case Inttab.lookup map no of |
328 NONE => error "Import_Rule.last_thm: lookup failed" |
328 NONE => error "Import_Rule.last_thm: lookup failed" |
329 | SOME th => th |
329 | SOME th => th |
357 [] => error "parse_line: empty command" |
357 [] => error "parse_line: empty command" |
358 | c :: cs => (c, String.implode cs :: args))) |
358 | c :: cs => (c, String.implode cs :: args))) |
359 |
359 |
360 fun process_line str = |
360 fun process_line str = |
361 let |
361 let |
362 fun process (#"R", [t]) = gettm t #>> refl #-> setth |
362 fun process (#"R", [t]) = term t #>> refl #-> set_thm |
363 | process (#"B", [t]) = gettm t #>> beta #-> setth |
363 | process (#"B", [t]) = term t #>> beta #-> set_thm |
364 | process (#"1", [th]) = getth th #>> conj1 #-> setth |
364 | process (#"1", [th]) = thm th #>> conj1 #-> set_thm |
365 | process (#"2", [th]) = getth th #>> conj2 #-> setth |
365 | process (#"2", [th]) = thm th #>> conj2 #-> set_thm |
366 | process (#"H", [t]) = gettm t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Thm.trivial #-> setth |
366 | process (#"H", [t]) = term t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Thm.trivial #-> set_thm |
367 | process (#"A", [_, t]) = |
367 | process (#"A", [_, t]) = |
368 gettm t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Skip_Proof.make_thm_cterm #-> setth |
368 term t #>> Thm.apply \<^cterm>\<open>Trueprop\<close> #>> Skip_Proof.make_thm_cterm #-> set_thm |
369 | process (#"C", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry comb #-> setth |
369 | process (#"C", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry comb #-> set_thm |
370 | process (#"T", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry trans #-> setth |
370 | process (#"T", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry trans #-> set_thm |
371 | process (#"E", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry eq_mp #-> setth |
371 | process (#"E", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry eq_mp #-> set_thm |
372 | process (#"D", [th1, th2]) = getth th1 ##>> getth th2 #>> uncurry deduct #-> setth |
372 | process (#"D", [th1, th2]) = thm th1 ##>> thm th2 #>> uncurry deduct #-> set_thm |
373 | process (#"L", [t, th]) = gettm t ##>> (fn ti => getth th ti) #>> uncurry abs #-> setth |
373 | process (#"L", [t, th]) = term t ##>> (fn ti => thm th ti) #>> uncurry abs #-> set_thm |
374 | process (#"M", [s]) = (fn (thy, state) => |
374 | process (#"M", [s]) = (fn (thy, state) => |
375 let |
375 let |
376 val ctxt = Proof_Context.init_global thy |
376 val ctxt = Proof_Context.init_global thy |
377 val th = freezeT thy (Global_Theory.get_thm thy s) |
377 val th = freezeT thy (Global_Theory.get_thm thy s) |
378 val ((_, [th']), _) = Variable.import true [th] ctxt |
378 val ((_, [th']), _) = Variable.import true [th] ctxt |
379 in |
379 in |
380 setth th' (thy, state) |
380 set_thm th' (thy, state) |
381 end) |
381 end) |
382 | process (#"Q", l) = (fn (thy, state) => |
382 | process (#"Q", l) = (fn (thy, state) => |
383 let |
383 let |
384 val (tys, th) = list_last l |
384 val (tys, th) = list_last l |
385 val (th, tstate) = getth th (thy, state) |
385 val (th, tstate) = thm th (thy, state) |
386 val (tys, tstate) = fold_map getty tys tstate |
386 val (tys, tstate) = fold_map typ tys tstate |
387 in |
387 in |
388 setth (inst_type thy (pair_list tys) th) tstate |
388 set_thm (inst_type thy (pair_list tys) th) tstate |
389 end) |
389 end) |
390 | process (#"S", l) = (fn tstate => |
390 | process (#"S", l) = (fn tstate => |
391 let |
391 let |
392 val (tms, th) = list_last l |
392 val (tms, th) = list_last l |
393 val (th, tstate) = getth th tstate |
393 val (th, tstate) = thm th tstate |
394 val (tms, tstate) = fold_map gettm tms tstate |
394 val (tms, tstate) = fold_map term tms tstate |
395 in |
395 in |
396 setth (inst (pair_list tms) th) tstate |
396 set_thm (inst (pair_list tms) th) tstate |
397 end) |
397 end) |
398 | process (#"F", [name, t]) = (fn tstate => |
398 | process (#"F", [name, t]) = (fn tstate => |
399 let |
399 let |
400 val (tm, (thy, state)) = gettm t tstate |
400 val (tm, (thy, state)) = term t tstate |
401 val (th, thy) = def (make_name name) tm thy |
401 val (th, thy) = def (make_name name) tm thy |
402 in |
402 in |
403 setth th (thy, state) |
403 set_thm th (thy, state) |
404 end) |
404 end) |
405 | process (#"F", [name]) = (fn (thy, state) => setth (mdef thy name) (thy, state)) |
405 | process (#"F", [name]) = (fn (thy, state) => set_thm (mdef thy name) (thy, state)) |
406 | process (#"Y", [name, absname, repname, t1, t2, th]) = (fn tstate => |
406 | process (#"Y", [name, absname, repname, t1, t2, th]) = (fn tstate => |
407 let |
407 let |
408 val (th, tstate) = getth th tstate |
408 val (th, tstate) = thm th tstate |
409 val (t1, tstate) = gettm t1 tstate |
409 val (t1, tstate) = term t1 tstate |
410 val (t2, (thy, state)) = gettm t2 tstate |
410 val (t2, (thy, state)) = term t2 tstate |
411 val (th, thy) = tydef name absname repname t1 t2 th thy |
411 val (th, thy) = tydef name absname repname t1 t2 th thy |
412 in |
412 in |
413 setth th (thy, state) |
413 set_thm th (thy, state) |
414 end) |
414 end) |
415 | process (#"Y", [name, _, _]) = (fn (thy, state) => setth (mtydef thy name) (thy, state)) |
415 | process (#"Y", [name, _, _]) = (fn (thy, state) => set_thm (mtydef thy name) (thy, state)) |
416 | process (#"t", [n]) = (fn (thy, state) => |
416 | process (#"t", [n]) = (fn (thy, state) => |
417 setty (Thm.global_ctyp_of thy (make_tfree n)) (thy, state)) |
417 set_typ (Thm.global_ctyp_of thy (make_tfree n)) (thy, state)) |
418 | process (#"a", n :: l) = (fn (thy, state) => |
418 | process (#"a", n :: l) = (fn (thy, state) => |
419 fold_map getty l (thy, state) |>> |
419 fold_map typ l (thy, state) |>> |
420 (fn tys => Thm.global_ctyp_of thy (make_type thy (n, map Thm.typ_of tys))) |-> setty) |
420 (fn tys => Thm.global_ctyp_of thy (make_type thy (n, map Thm.typ_of tys))) |-> set_typ) |
421 | process (#"v", [n, ty]) = (fn (thy, state) => |
421 | process (#"v", [n, ty]) = (fn (thy, state) => |
422 getty ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_free (n, Thm.typ_of ty))) |-> settm) |
422 typ ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_free (n, Thm.typ_of ty))) |-> set_term) |
423 | process (#"c", [n, ty]) = (fn (thy, state) => |
423 | process (#"c", [n, ty]) = (fn (thy, state) => |
424 getty ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_const thy (n, Thm.typ_of ty))) |-> settm) |
424 typ ty (thy, state) |>> (fn ty => Thm.global_cterm_of thy (make_const thy (n, Thm.typ_of ty))) |-> set_term) |
425 | process (#"f", [t1, t2]) = gettm t1 ##>> gettm t2 #>> uncurry Thm.apply #-> settm |
425 | process (#"f", [t1, t2]) = term t1 ##>> term t2 #>> uncurry Thm.apply #-> set_term |
426 | process (#"l", [t1, t2]) = gettm t1 ##>> gettm t2 #>> uncurry Thm.lambda #-> settm |
426 | process (#"l", [t1, t2]) = term t1 ##>> term t2 #>> uncurry Thm.lambda #-> set_term |
427 | process (#"+", [s]) = (fn (thy, state) => |
427 | process (#"+", [s]) = (fn (thy, state) => |
428 (store_thm (Binding.name (make_name s)) (last_thm state) thy, state)) |
428 (store_thm (Binding.name (make_name s)) (last_thm state) thy, state)) |
429 | process (c, _) = error ("process: unknown command: " ^ String.implode [c]) |
429 | process (c, _) = error ("process: unknown command: " ^ String.implode [c]) |
430 in |
430 in |
431 process (parse_line str) |
431 process (parse_line str) |