Commit 298c4872 authored by Pietro Abate's avatar Pietro Abate
Browse files

[r2003-05-18 20:09:17 by cvscast] Clean up

Original author: cvscast
Date: 2003-05-18 20:09:17+00:00
parent 0e608aea
open Recursive
open Printf
let equal_list e l1 l2 =
if List.length l1 <> List.length l2 then raise NotEqual;
List.iter2 e l1 l2
let equal_line e (p1,n1) (p2,n2) =
equal_list e p1 p2;
equal_list e n1 n2
let equal_bool e a b =
equal_list (equal_line e) a b
module E = struct
(* Internal algebra *)
module I = struct
type 'a t = {
times : ('a * 'a) Boolean.t;
arrow : ('a * 'a) Boolean.t;
atom : string Boolean.t
}
let empty = {
times = Boolean.empty;
arrow = Boolean.empty;
atom = Boolean.empty
}
let any = {
times = Boolean.full;
arrow = Boolean.full;
atom = Boolean.full
}
let atom x = { empty with atom = Boolean.atom x }
let times x y = { empty with times = Boolean.atom (x,y) }
let arrow x y = { empty with arrow = Boolean.atom (x,y) }
let cup x y = {
times = Boolean.cup x.times y.times;
arrow = Boolean.cup x.arrow y.arrow;
atom = Boolean.cup x.atom y.atom
}
let cap x y = {
times = Boolean.cap x.times y.times;
arrow = Boolean.cap x.arrow y.arrow;
atom = Boolean.cap x.atom y.atom
}
let diff x y = {
times = Boolean.diff x.times y.times;
arrow = Boolean.diff x.arrow y.arrow;
atom = Boolean.diff x.atom y.atom
}
let equal e a b =
equal_bool
(fun (x:string) (y:string) -> if x <> y then raise NotEqual)
a.atom b.atom;
equal_bool (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.times b.times;
equal_bool (fun (x1,x2) (y1,y2) -> e x1 y1; e x2 y2) a.arrow b.arrow
let map f a =
{ times = Boolean.map (fun (x1,x2) -> (f x1, f x2)) a.times;
arrow = Boolean.map (fun (x1,x2) -> (f x1, f x2)) a.arrow;
atom = a.atom }
let hash h a =
Hashtbl.hash (map h a)
let iter f a =
ignore (map f a)
let deep = 4
end
type t =
| Arrow of t * t
| Times of t * t
| Diff of t * t
| Or of t * t
| And of t * t
| Atom of string
| Var of string
let make_parser expr =
EXTEND
expr: [
[ x = expr; "->"; y = expr -> Arrow (x,y) ]
| [ x = expr; "*"; y = expr -> Times (x,y) ]
| [ x = expr; "&"; y = expr -> And (x,y)
| x = expr; "-"; y = expr -> Diff (x,y) ]
| [ x = expr; "|"; y = expr -> Or (x,y) ]
| [ "~"; x = expr -> Diff (Atom "Any", x)
| a = LIDENT -> Var a
| a = UIDENT -> Atom a
| "("; x = expr; ")" -> x ]
];
END
let rec compile f var = function
| Atom "Any" -> I.any
| Atom "Empty" -> I.empty
| Atom i -> I.atom i
| Times (a,b) -> I.times (f a) (f b)
| Arrow (a,b) -> I.arrow (f a) (f b)
| Diff (a,b) -> I.diff (compile f var a) (compile f var b)
| And (a,b) -> I.cap (compile f var a) (compile f var b)
| Or (a,b) -> I.cup (compile f var a) (compile f var b)
| Var v ->
(try var v
with Exit -> failwith ("Cyclic definition for " ^ v))
let rec print_list oc f sep un = function
| [] -> fprintf oc "%s" un
| [h] -> f oc h
| h::t -> f oc h; fprintf oc "%s" sep; print_list oc f sep un t
let print_line u f oc (p,n) =
print_list oc f " & " u p;
if n <> [] then
(
fprintf oc " \ ";
print_list oc f " \ " "Empty" n
)
let print_bool u oc f a =
print_list oc (print_line u f) " | " "Empty" a
let print_arrow f oc (i1,i2) =
fprintf oc "%a -> %a" f i1 f i2
let print_times f oc (i1,i2) =
fprintf oc "%a * %a" f i1 f i2
let print_atom f oc x =
fprintf oc "%s" x
let print f oc d =
let b = ref false in
if d.I.atom <> [] then
(
print_bool "AnyAtom" oc (print_atom f) d.I.atom;
b := true
);
if d.I.times <> [] then
(
if !b then fprintf oc " | ";
print_bool "AnyProd" oc (print_times f) d.I.times;
b := true;
);
if d.I.arrow <> [] then
(
if !b then fprintf oc " | ";
print_bool "AnyFun" oc (print_arrow f) d.I.arrow;
b := true;
);
if not !b then fprintf oc "Empty"
end
module M = Example.Make(E)
let _ = M.main ()
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment