1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
|
open Deriving_Eq
open Deriving_Dump
open Deriving_Typeable
open Deriving_Pickle
module Env = Bimap.Make(String)
type name = string deriving (Show, Dump, Typeable)
module Eq_string : Eq with type a = name =
struct
type a = name
let eq = (=)
end
module Pickle_name
= Pickle_from_dump(Dump_string)(Eq_string)(Typeable_string)
module rec Exp :
sig
type exp = Var of name
| App of exp * exp
| Abs of name * exp
deriving (Eq,Show,Pickle,Typeable,Dump)
end =
struct
module Eq_exp = struct
open Exp
type a = exp
let eq : exp -> exp -> bool
= let rec alpha_eq env l r = match l, r with
| Var l, Var r when Env.mem l env ->
Env.find l env = r
| Var l, Var r ->
not (Env.rmem r env) && l = r
| App (fl,pl), App (fr,pr) ->
alpha_eq env fl fr && alpha_eq env pl pr
| Abs (vl,bl), Abs (vr,br) ->
alpha_eq (Env.add vl vr env) bl br
| _ -> false
in alpha_eq Env.empty
end
type exp = Var of name
| App of exp * exp
| Abs of name * exp
deriving (Show, Typeable, Pickle,Dump)
end
open Exp
(*
let args = ref []
*)
let discover_sharing : exp -> 'a =
let find (next,dynmap) obj =
let repr = Obj.repr obj in
try List.assq repr dynmap, next, dynmap
with Not_found -> next,next+1,(repr,next)::dynmap in
let rec discover (next,dynmap) = function
| Var s as v ->
let (id,next,dynmap) = find (next,dynmap) v in
Printf.printf "Var %d\n" id;
let (id,next,dynmap) = find (next,dynmap) s in
Printf.printf "string: %s %d\n" s id;
(next, dynmap)
| App (e1,e2) as a ->
let (id,next,dynmap) = find (next,dynmap) a in
Printf.printf "App %d\n" id;
let (next,dynmap) = discover (next,dynmap) e1 in
let (next,dynmap) = discover (next,dynmap) e2 in
(next,dynmap)
| Abs (s,e) as l ->
let (id,next,dynmap) = find (next,dynmap) l in
Printf.printf "Abs %d\n" id;
let (id,next,dynmap) = find (next,dynmap) s in
Printf.printf "string: %s %d\n" s id;
let (next,dynmap) = discover (next,dynmap) e in
(next,dynmap)
in fun e -> (discover (1,[]) e)
let y =
Abs ("a",
App (Abs ("b",
App (Var "a",
Abs ("c",
App (App (Var "b",
Var "b"),
Var "c")))),
Abs ("d",
App (Var "a",
Abs ("e",
App (App (Var "d",
Var "d"),
Var "e"))))))
let app e1 e2 = App (e1, e2)
let abs (v,e) = Abs (v,e)
let freevar x = Var x
let rec term_size = function
| Var _ -> 1
| App (e1,e2) -> term_size e1 + term_size e2
| Abs (_, body) -> 1 + term_size body
|
