open Util.Vars
open Pure
+(* debug options *)
+let debug_display_arities = false;;
+
(************ Syntax ************************************)
(* Normal forms*)
| n when n > 0 -> `Lam (false, lift 1 (make_lams t (n-1)))
| _ -> assert false
-let free_vars =
+let free_vars' =
let rec aux n = function
`N _ -> []
- | `Var(x,_) -> if x < n then [] else [x-n]
- | `I((x,_),args) ->
- (if x < n then [] else [x-n]) @
+ | `Var(x,ar) -> if x < n then [] else [(x-n,ar)]
+ | `I((x,ar),args) ->
+ (if x < n then [] else [(x-n,ar)]) @
List.concat (List.map (aux n) (Listx.to_list args))
| `Lam(_,t) -> aux (n+1) t
| `Match(t,_,liftno,bs,args) ->
List.concat (List.map (aux n) args)
in aux 0
;;
+let free_vars = (List.map fst) ++ free_vars';;
module ToScott =
struct
(************ Pretty-printing ************************************)
-let rec string_of_term l =
- let rec string_of_term_w_pars l = function
- | `Var(n,ar) -> print_name l n ^ ":" ^ string_of_int ar
+(* let rec string_of_term l = fun _ -> "";; *)
+
+let rec string_of_term =
+ let boundvar x = "v" ^ string_of_int x in
+ let varname lev l n =
+ if n < lev then boundvar (lev-n-1)
+ else if n < List.length l then List.nth l (n-lev)
+ else "`" ^ string_of_int (n-lev) in
+ let rec string_of_term_w_pars lev l = function
+ | `Var(n,ar) -> varname lev l n ^ (if debug_display_arities then ":" ^ string_of_int ar else "")
| `N n -> string_of_int n
- | `I _ as t -> "(" ^ string_of_term_no_pars_app l (t :> nf) ^ ")"
- | `Lam _ as t -> "(" ^ string_of_term_no_pars_lam l t ^ ")"
- | `Match(t,_,bs_lift,bs,args) ->
- "(match " ^ string_of_term_no_pars l (t :> nf) ^
- " with " ^ String.concat " | " (List.map (fun (n,t) -> string_of_int n ^ " => " ^ string_of_term l (lift bs_lift t)) !bs) ^ "] " ^
- String.concat " " (List.map (string_of_term l) args) ^ ")"
- and string_of_term_no_pars_app l = function
- | `I((n,ar), args) -> print_name l n ^ ":" ^ string_of_int ar ^ " " ^ String.concat " " (List.map (string_of_term_w_pars l) (Listx.to_list args))
- | #nf as t -> string_of_term_w_pars l t
- and string_of_term_no_pars_lam l = function
- | `Lam(_,t) -> let name = string_of_var (List.length l) in
- "λ" ^ name ^ ". " ^ (string_of_term_no_pars_lam (name::l) t)
- | _ as t -> string_of_term_no_pars l t
- and string_of_term_no_pars l : nf -> string = function
- | `Lam _ as t -> string_of_term_no_pars_lam l t
- | #nf as t -> string_of_term_no_pars_app l t
- in string_of_term_no_pars l
+ | `I _ as t -> "(" ^ string_of_term_no_pars_app lev l t ^ ")"
+ | `Lam _ as t -> "(" ^ string_of_term_no_pars_lam lev l t ^ ")"
+ | `Match(t,(v,ar),bs_lift,bs,args) ->
+ (* assert (bs_lift = lev); *)
+ "(["^ varname 0 l v ^ (if debug_display_arities then ":"^ string_of_int ar else "") ^",match " ^ string_of_term_no_pars lev l (t :> nf) ^
+ " with " ^ String.concat " | " (List.map (fun (n,t) -> string_of_int n ^ " => " ^ string_of_term l (t :> nf)) !bs) ^ "] " ^
+ String.concat " " (List.map (string_of_term l) (args :> nf list)) ^ ")"
+ and string_of_term_no_pars_app lev l = function
+ | `I((n,ar), args) -> varname lev l n ^ (if debug_display_arities then ":" ^ string_of_int ar else "") ^ " " ^ String.concat " " (List.map (string_of_term_w_pars lev l) (Listx.to_list args :> nf list))
+ | #nf as t -> string_of_term_w_pars lev l t
+ and string_of_term_no_pars_lam lev l = function
+ | `Lam(_,t) -> "λ" ^ boundvar lev ^ ". " ^ (string_of_term_no_pars_lam (lev+1) l t)
+ | _ as t -> string_of_term_no_pars lev l t
+ and string_of_term_no_pars lev l = function
+ | `Lam _ as t -> string_of_term_no_pars_lam lev l t
+ | #nf as t -> string_of_term_no_pars_app lev l t
+ in string_of_term_no_pars 0
;;
let print ?(l=[]) = string_of_term l;;
prerr_endline (print (t :> nf));
assert false (* algorithm failed *)
-let set_arity arity = function
+let rec set_arity arity = function
+(* FIXME because onlt variables should be in branches of matches, one day *)
| `Var(n,_) -> `Var(n,arity)
-| `Lam(false, `N _)
-| `Lam(false, `Lam _) as t -> t
-| `Lam(false, `Match(t,(n,_),bs_lift,bs,args)) -> `Lam(false, `Match(t,(n,arity),bs_lift,bs,args))
-| _ -> assert false
+| `N _ as t -> t
+| `Lam(false, t) -> `Lam(false, set_arity arity t)
+| `Match(t,(n,_),bs_lift,bs,args) -> `Match(t,(n,arity),bs_lift,bs,args)
+| `I _ | `Lam _ -> assert false
let minus1 n = if n = min_int then n else n - 1;;
| `I _ | `Var _ | `Match _ -> `Match(t,(n,ar),bs_lift,bs,args)
and subst truelam delift_by_one what (with_what : nf) (where : nf) =
- let aux_propagate_arity ar = function
- | `Lam(false,`Match(`I(v,args),(x,_),liftno,bs,args')) when not delift_by_one ->
- `Lam(false,`Match(`I(v,args),(x,ar),liftno,bs,args'))
- | `Var(i,_) -> `Var(i,ar)
+ let rec aux_propagate_arity ar = function
+ | `Lam(false, t) when not delift_by_one -> `Lam(false, aux_propagate_arity ar t)
+ | `Match(`I(v,args),(x,_),liftno,bs,args') when not delift_by_one ->
+ `Match(`I(v,args),(x,ar),liftno,bs,args')
+ | `Var(i,oldar) -> `Var(i, if truelam then (assert (oldar = min_int); ar) else oldar)
| _ as t -> t in
let rec aux_i_num_var l =
function
| `N _ as x -> x
| `Match(t,v,bs_lift,bs,args) ->
let bs_lift = bs_lift + if delift_by_one then -1 else 0 in
+ (* Warning! It now applies again the substitution in branches of matches.
+ But careful, it does it many times, for every occurrence of
+ the match. This is okay because what does not occur in with_what. *)
let l' = l - bs_lift in
- let with_what' = lift l' with_what in
+ let with_what' = lift l' (with_what :> nf) in
(* The following line should be the identity when delift_by_one = true because we
are assuming the ts to not contain lambda-bound variables. *)
bs := List.map (fun (n,t) -> n,subst truelam false what with_what' t) !bs ;
- mk_match (cast_to_i_num_var (aux_i_num_var l t)) v bs_lift bs (List.map (aux l) args)
+ let body = cast_to_i_num_var (aux_i_num_var l t) in
+ mk_match body v bs_lift bs (List.map (aux l) (args :> nf list))
and aux l(*lift*) =
(*function iii -> let res = match iii with*)
function
aux 0 where
;;
-(************ Parsing ************************************)
-
-let parse' strs =
- let fix_arity = function
- | `I((n,_),args) -> `I((n,1+Listx.length args),args)
- | _ -> assert false in
- let rec aux = function
- | Parser.Lam t -> `Lam (true, aux t)
- | Parser.App (t1, t2) -> fix_arity (mk_app (aux t1) (aux t2))
- | Parser.Var v -> `Var(v,1) in
- let (tms, free) = Parser.parse_many strs in
- List.map aux tms, free
-;;
-
(************** Algorithm(s) ************************)
let eta_compare x y =
| `Match(u,ar,liftno,bs,args) ->
eta_subterm sub (u :> nf)
|| List.exists (fun (_, t) -> eta_subterm sub (lift liftno t)) !bs
- || List.exists (eta_subterm sub) args
- | `I(v, args) -> List.exists (eta_subterm sub) (Listx.to_list args) || (match sub with
- | `Var v' -> v = v'
- | `I(v', args') -> v = v'
+ || List.exists (eta_subterm sub) (args :> nf list)
+ | `I((v,_), args) -> List.exists (eta_subterm sub) ((Listx.to_list args) :> nf list) || (match sub with
+ | `Var(v',_) -> v = v'
+ | `I((v',_), args') -> v = v'
&& Listx.length args' < Listx.length args
&& List.for_all (fun (x,y) -> eta_eq x y) (List.combine (Util.take (Listx.length args') (Listx.to_list args)) (Listx.to_list args'))
| _ -> false
| `Match(u,_,_,bs,args) -> max (max (aux l (u :> nf)) (aux_tms l args)) (aux_tms l (List.map snd !bs))
| `N _ -> None
and aux_tms l =
- List.fold_left (fun acc t -> Pervasives.max acc (aux l t)) None in
+ List.fold_left (fun acc t -> max acc (aux l t)) None in
fun tms -> aux_tms 0 (tms :> nf list)
;;
projects / fireball-separation.git / blobdiff