├── .gitignore ├── LICENSE ├── Makefile ├── README.md ├── ck.ml ├── debug.sh ├── fd.ml ├── main.ml └── mk.ml /.gitignore: -------------------------------------------------------------------------------- 1 | /_build 2 | /*.byte 3 | /*.native 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Mansheng Yang 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | native: 2 | ocamlbuild main.native 3 | 4 | byte: 5 | ocamlbuild main.byte 6 | 7 | debug: 8 | ocamlbuild main.d.byte 9 | 10 | clean: 11 | rm -rf *.native *.byte _build 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | an implementation of miniKanren in OCaml 2 | -------------------------------------------------------------------------------- /ck.ml: -------------------------------------------------------------------------------- 1 | open Mk 2 | 3 | let op_map = Hashtbl.create 100 4 | let get_op (op : string) : (logic_term -> store -> store option) = 5 | Hashtbl.find op_map op 6 | let add_op = Hashtbl.replace op_map 7 | 8 | (* identitym *) 9 | let identitym a = Some a 10 | 11 | (* composem *) 12 | let composem f g a = 13 | match f a with 14 | | None -> None 15 | | Some b -> g b 16 | 17 | (* goal-construct *) 18 | let goal_construct f a = 19 | match f a with 20 | | None -> MZero 21 | | Some x -> Unit x 22 | 23 | (* process-prefix *) 24 | let process_prefix = ref (fun p c a -> identitym a) 25 | (* enforce-constraints*) 26 | let enforce_constraints = ref (fun x a -> Unit a) 27 | (* reify-constraints*) 28 | let reify_constraints = ref (fun m r a -> Unit m) 29 | 30 | (* oc->proc *) 31 | let proc_of_oc (x, args) = get_op x args 32 | (* oc->rands *) 33 | let rands_of_oc (_, x) = x 34 | 35 | (* any/var? *) 36 | let rec any_var p = 37 | match p with 38 | | Var _ -> true 39 | | Cons (a, b) -> (any_var a) && (any_var b) 40 | | List ls -> List.exists any_var ls 41 | | _ -> false 42 | 43 | (* ext-d *) 44 | let ext_d x fd d : domains = (x, fd)::d 45 | 46 | (* ext-c *) 47 | let ext_c oc c : constraints = 48 | if any_var (rands_of_oc oc) then oc::c 49 | else c 50 | 51 | type constraint_op = logic_term -> store -> (store option) 52 | let constraint_op2 f ls a = 53 | match ls with 54 | | List [u; v] -> f u v a 55 | | _ -> failwith "number of operands is not 2" 56 | let constraint_op3 f ls a = 57 | match ls with 58 | | List [u; v; w] -> f u v w a 59 | | _ -> failwith "number of operands is not 3" 60 | 61 | (* build-oc *) 62 | let build_oc op terms = (op, terms) 63 | 64 | (* rem/run *) 65 | let rem_run oc a = 66 | let (s, d, c) = a in 67 | if List.mem oc c then 68 | let c2 = List.filter (fun x -> x <> oc) c in 69 | (proc_of_oc oc) (make_a s d c2) 70 | else Some a 71 | 72 | (* any-relevant/var? *) 73 | let rec any_relevant_var t x = 74 | match t with 75 | | Var _ -> List.mem t x 76 | | Cons (a, b) -> (any_relevant_var a x) && (any_relevant_var b x) 77 | | List ls -> 78 | List.exists (fun a -> any_relevant_var a x) ls 79 | | _ -> false 80 | 81 | (* run-constraints *) 82 | let rec run_constraints x_all c = 83 | match c with 84 | | [] -> identitym 85 | | hd::tl -> 86 | if any_relevant_var (rands_of_oc hd) x_all then 87 | (composem (rem_run hd) (run_constraints x_all tl)) 88 | else (run_constraints x_all tl) 89 | 90 | (* reify *) 91 | let reify (x : logic_term) a = 92 | let a2 = bind a (!enforce_constraints x) in 93 | let helper a = 94 | let (s, d, c) = a in 95 | let v = walk_all x s in 96 | let r = reify_s v empty_s in 97 | if r = [] then Unit v 98 | else 99 | let v = walk_all v r in 100 | if c = [] then Unit v 101 | else (!reify_constraints v r) a 102 | in bind a2 helper 103 | 104 | (* run *) 105 | let run n x f = 106 | let f = all f in 107 | take n (Func (fun () -> reify x (f empty_a))) 108 | 109 | (* run* *) 110 | let run_all x f = run (-1) x f 111 | 112 | 113 | (* prefix-s *) 114 | let prefix_s s s2 = 115 | if s = [] then s2 116 | else 117 | let rec helper s2 = 118 | if s2 = s then [] 119 | else match s2 with 120 | | hd::tl -> hd::(helper tl) 121 | | [] -> [] 122 | in helper s2 123 | 124 | (* ==-c *) 125 | let eq_c : constraint_op = 126 | let helper u v a = 127 | let (s, d, c) = a in 128 | match unify [(u, v)] s with 129 | | Some s2 -> 130 | if s = s2 then Some (s, d, c) 131 | else 132 | let p = prefix_s s s2 in 133 | let a = make_a s2 d c in 134 | (!process_prefix p c) a 135 | | None -> None 136 | in constraint_op2 helper 137 | 138 | (* == *) 139 | let eq u v = goal_construct (eq_c (List [u; v])) 140 | 141 | (* 142 | let succeed = eq (const_bool false) (const_bool false) 143 | let fail = eq (const_bool true) (const_bool false) 144 | *) 145 | let succeed a = Unit a 146 | let fail a = MZero 147 | -------------------------------------------------------------------------------- /debug.sh: -------------------------------------------------------------------------------- 1 | make debug && OCAMLRUNPARAM=b ./main.d.byte 2 | -------------------------------------------------------------------------------- /fd.ml: -------------------------------------------------------------------------------- 1 | open Mk 2 | open Ck 3 | 4 | type dom = int list 5 | 6 | let logic_term_to_int t = 7 | match t with 8 | | Constant (Int i) -> i 9 | | _ -> failwith "given logic term is not an int " 10 | 11 | let logic_term_to_list l = 12 | match l with 13 | | List l -> l 14 | | _ -> failwith "give logic term is not a list" 15 | 16 | let logic_term_to_var v = 17 | match v with 18 | | Var v -> v 19 | | _ -> failwith "give logic term is not a var" 20 | 21 | let rec range l r = 22 | if l <= r then l::(range (l + 1) r) 23 | else [] 24 | 25 | (* make-dom *) 26 | let make_dom n = n 27 | 28 | (* list-sorted *) 29 | let rec list_sorted pred ls = 30 | match ls with 31 | | x::(y::tl) -> 32 | (pred x y) && list_sorted pred (y::tl) 33 | | _ -> true 34 | 35 | (* list-insert *) 36 | let rec list_insert pred x ls = 37 | match ls with 38 | | [] -> [x] 39 | | y::tl -> 40 | if pred x y then x::ls 41 | else y::(list_insert pred x tl) 42 | 43 | (* map-sum *) 44 | let map_sum f = 45 | let rec helper ls = 46 | match ls with 47 | | [] -> fail 48 | | hd::tl -> conde [[f hd]; [helper tl]] 49 | in helper 50 | 51 | 52 | let null_dom x = x = [] 53 | let singleton_dom x = (List.length x) = 1 54 | let singleton_element_dom x = List.hd x 55 | let min_dom dom = List.hd dom 56 | let max_dom dom = List.hd (List.rev dom) 57 | let mem_dom = List.mem 58 | 59 | let rec intersection_dom dom1 dom2 = 60 | match (dom1, dom2) with 61 | | (hd1::tl1, hd2::tl2) -> 62 | if hd1 = hd2 then hd1::(intersection_dom tl1 tl2) 63 | else if hd1 < hd2 then intersection_dom tl1 dom2 64 | else intersection_dom dom1 tl2 65 | | _ -> [] 66 | 67 | let rec diff_dom dom1 dom2 = 68 | match (dom1, dom2) with 69 | | (hd1::tl1, hd2::tl2) -> 70 | if hd1 = hd2 then diff_dom tl1 tl2 71 | else if hd1 < hd2 then hd1::(diff_dom tl1 dom2) 72 | else diff_dom dom1 tl2 73 | | _ -> dom1 74 | 75 | let rec copy_before pred dom = 76 | match dom with 77 | | [] -> [] 78 | | hd::tl -> 79 | if pred hd then [] 80 | else hd::(copy_before pred tl) 81 | 82 | let rec drop_before pred dom = 83 | match dom with 84 | | [] -> [] 85 | | hd::tl -> 86 | if pred hd then dom 87 | else drop_before pred tl 88 | 89 | let rec disjoint_dom dom1 dom2 = 90 | match (dom1, dom2) with 91 | | (hd1::tl1, hd2::tl2) -> 92 | if hd1 = hd2 then false 93 | else if hd1 < hd2 then disjoint_dom tl1 dom2 94 | else disjoint_dom dom1 tl2 95 | | _ -> true 96 | 97 | let get_dom x d : dom option = 98 | if List.mem_assoc x d then Some (List.assoc x d) 99 | else None 100 | 101 | let resolve_storable_dom dom x (s, d, c) = 102 | let var_x = Var x in 103 | if singleton_dom dom then 104 | let n = singleton_element_dom dom in 105 | let a = make_a (ext_s var_x (const_int n) s) d c in 106 | run_constraints [var_x] c a 107 | else 108 | Some (make_a s (ext_d x dom d) c) 109 | 110 | let update_var_dom x dom a = 111 | let (s, d, c) = a in 112 | match get_dom x d with 113 | | Some xdom -> 114 | let i = intersection_dom xdom dom in 115 | if null_dom i then None 116 | else resolve_storable_dom i x a 117 | | _ -> resolve_storable_dom dom x a 118 | 119 | let process_dom v dom a = 120 | match v with 121 | | Var i -> update_var_dom i dom a 122 | | Constant (Int i) -> 123 | if mem_dom i dom then Some a 124 | else None 125 | | _ -> None 126 | 127 | let rec force_ans (x : logic_term) (a : store) = 128 | let (s, d, c) = a in 129 | let x = walk x s in 130 | let f = match x with 131 | | Var v -> 132 | begin 133 | match get_dom v d with 134 | | Some ls -> 135 | map_sum (fun v -> (eq x (const_int v))) ls 136 | | None -> succeed 137 | end 138 | | List ls -> 139 | all (List.map force_ans ls) 140 | | _ -> succeed 141 | in f a 142 | 143 | let get_walk_dom u (s, d, _) = 144 | let u = walk u s in 145 | match u with 146 | | Var i -> (u, get_dom i d) 147 | | Constant (Int i) -> (u, Some (make_dom [i])) 148 | | _ -> (u, None) 149 | 150 | (* =/=fd-c *) 151 | let neqfd_c : constraint_op = 152 | let helper u v a = 153 | let (u, udom) = get_walk_dom u a in 154 | let (v, vdom) = get_walk_dom v a in 155 | let (s, d, c) = a in 156 | let oc = build_oc "=/=fd" (List [u; v]) in 157 | match (udom, vdom) with 158 | | (Some udom, Some vdom) -> 159 | if (singleton_dom udom) && (singleton_dom vdom) && udom = vdom then 160 | None 161 | else if disjoint_dom udom vdom then 162 | Some a 163 | else 164 | let a = make_a s d (ext_c oc c) in 165 | if singleton_dom udom then 166 | process_dom v (diff_dom vdom udom) a 167 | else if singleton_dom vdom then 168 | process_dom u (diff_dom udom vdom) a 169 | else Some a 170 | | _ -> Some (make_a s d (ext_c oc c)) 171 | in constraint_op2 helper 172 | 173 | let exclude_from_dom dom1 d x_all = 174 | let x_all = List.map logic_term_to_var x_all in 175 | let rec helper x_all = 176 | match x_all with 177 | | [] -> identitym 178 | | xhd::xtl -> 179 | match get_dom xhd d with 180 | | Some dom2 -> 181 | composem 182 | (process_dom (Var xhd) (diff_dom dom2 dom1)) 183 | (helper xtl) 184 | | None -> helper xtl 185 | in helper x_all 186 | 187 | 188 | (* all-diff/fd-c *) 189 | let all_diff_fd_c : constraint_op = 190 | let helper y_all n_all a = 191 | let (s, d, c) = a in 192 | let rec loop y_all n_all xls = 193 | let yls = logic_term_to_list y_all in 194 | let nls = logic_term_to_list n_all in 195 | let n_val_all = List.map logic_term_to_int nls in 196 | match yls with 197 | | [] -> 198 | let oc = build_oc "all-diff/fd" (List [List xls; n_all]) in 199 | let a = make_a s d (ext_c oc c) in 200 | exclude_from_dom (make_dom n_val_all) d xls a 201 | | yhd::ytl -> 202 | let y = walk yhd s in 203 | match y with 204 | | Var _ -> loop (List ytl) n_all (y::xls) 205 | | Constant (Int i) -> 206 | if mem_dom i n_val_all then None 207 | else 208 | let n_val_all = list_insert (<) i n_val_all in 209 | let nls = List.map const_int n_val_all in 210 | loop (List ytl) (List nls) xls 211 | | _ -> None 212 | in loop y_all n_all [] 213 | in constraint_op2 helper 214 | 215 | (* all-difffd-c *) 216 | let all_difffd_c ls a = 217 | let (s, d, c) = a in 218 | let ls = walk ls s in 219 | match ls with 220 | | Var _ -> 221 | let oc = build_oc "all-difffd" ls in 222 | Some (make_a s d (ext_c oc c)) 223 | | List ls -> 224 | let (x_all, n_all) = List.partition is_var ls in 225 | let n_val_all = List.sort compare (List.map logic_term_to_int n_all) in 226 | if list_sorted (<) n_val_all then (* all_diff n_all *) 227 | let n_all = List.map const_int n_val_all in 228 | all_diff_fd_c (List [(List x_all); (List n_all)]) a 229 | else None 230 | | _ -> Some a 231 | 232 | (* process-prefixfd *) 233 | let rec process_prefixfd p c = 234 | match p with 235 | | [] -> identitym 236 | | (x, v)::tl -> 237 | let t = composem (run_constraints [x] c) (process_prefixfd tl c) in 238 | fun a -> 239 | let (s, d, c) = a in 240 | match get_dom (logic_term_to_var x) d with 241 | | Some dom -> 242 | composem (process_dom v dom) t a 243 | | None -> t a 244 | 245 | let rec verify_all_bound c bounds = 246 | match c with 247 | | [] -> () 248 | | hd::tl -> 249 | try 250 | let rands = logic_term_to_list (rands_of_oc hd) in 251 | let all_vars = List.filter is_var rands in 252 | let x = List.find (fun x -> not (List.mem x bounds)) all_vars in 253 | failwith (Printf.sprintf "Constrained variable %s without domain" 254 | (string_of_logic_term x)) 255 | with _ -> verify_all_bound tl bounds 256 | 257 | (* enfore-constraintsfd *) 258 | let enforce_constraintsfd x = 259 | all [ 260 | force_ans x; 261 | (fun a -> 262 | let (s, d, c) = a in 263 | let bounds = List.map (fun x -> Var x) (List.map fst d) in 264 | let _ = verify_all_bound c bounds in 265 | onceo [force_ans (List bounds)] a) 266 | ] 267 | 268 | (* reify-constraintsfd *) 269 | let reify_constraintsfd m r = 270 | failwith "Unbound vars at end" 271 | 272 | (* c-op *) 273 | let c_op op ls f a = 274 | let get_val d = 275 | match d with 276 | | Some v -> v 277 | | None -> failwith "option has no value" 278 | in let (s, d, c) = a in 279 | let ls = List.map (fun x -> get_walk_dom x a) ls in 280 | let (vls, domls) = List.split ls in 281 | let c = ext_c (build_oc op (List vls)) c in 282 | let a = make_a s d c in 283 | if List.mem None domls then Some a 284 | else f vls (List.map get_val domls) a 285 | 286 | (* <=fd-c *) 287 | let lefd_c : constraint_op = 288 | let f vls domls = 289 | match (vls, domls) with 290 | | ([u; v], [udom; vdom]) -> 291 | let umin = min_dom udom in 292 | let vmax = max_dom vdom in 293 | composem 294 | (process_dom u (copy_before (fun u -> vmax < u) udom)) 295 | (process_dom v (drop_before (fun v -> umin <= v) vdom)) 296 | | _ -> failwith "invalid args" (* should never happens*) 297 | in let helper u v a = c_op "<=fd" [u; v] f a 298 | in constraint_op2 helper 299 | 300 | (* +fd-c *) 301 | let plusfd_c : constraint_op = 302 | let f vls domls = 303 | match (vls, domls) with 304 | | ([u; v; w], [udom; vdom; wdom]) -> 305 | let wmin = min_dom wdom in 306 | let wmax = max_dom wdom in 307 | let umin = min_dom udom in 308 | let umax = max_dom udom in 309 | let vmin = min_dom vdom in 310 | let vmax = max_dom vdom in 311 | composem 312 | (process_dom w (range (umin + vmin) (umax + vmax))) 313 | (composem 314 | (process_dom u (range (wmin - vmax) (wmax - vmin))) 315 | (process_dom v (range (wmin - umax) (wmax - umin)))) 316 | | _ -> failwith "invalid args" (* should never happens*) 317 | in let helper u v w a = c_op "+fd" [u; v; w] f a 318 | in constraint_op3 helper 319 | 320 | (* domfd-c *) 321 | let domfd_c x n_all a = 322 | let (s, _, _) = a in 323 | process_dom (walk x s) (make_dom n_all) a 324 | 325 | (* domfd: (domfd x [1; 2; 3] *) 326 | let domfd x n_all = goal_construct (domfd_c x n_all) 327 | 328 | (* infd: (infd [x; y;] [1; 2; 3]) *) 329 | let infd ls e = 330 | all (List.map (fun x -> domfd x e) ls) 331 | 332 | (* =/=fd: (neqfd x y) *) 333 | let neqfd u v = goal_construct (neqfd_c (List [u; v])) 334 | 335 | (* <=fd: (lefd x y) *) 336 | let lefd u v = goal_construct (lefd_c (List [u; v])) 337 | 338 | (* print_string ((string_of_logic_term t) ^ "\n")) 9 | 10 | let test ?limit:(limit = -1) name f = 11 | let _ = print_sep name in 12 | let q = fresh () in 13 | let s = run limit q (f q) in 14 | print_s s 15 | 16 | let _ = test "miniKanren" (fun q -> 17 | let x = fresh () in 18 | [ 19 | conde [ 20 | [succeed]; 21 | [eq q (const_bool true)]; 22 | [ 23 | eq q (List [const_bool true; const_int 1; x]); 24 | eq x (const_int 10) 25 | ]; 26 | (let x = fresh () in [eq q x]); 27 | [eq x q; eq x (const_str "x");]; 28 | [fail; eq q (const_int 1)] 29 | ] 30 | ] 31 | ) 32 | 33 | 34 | let _ = use_fd () 35 | 36 | let _ = test "infd" (fun q -> [infd [q] [1; 2; 3]]) 37 | 38 | let _ = test "neqfd" (fun q -> 39 | let x = fresh () in 40 | let y = fresh () in 41 | [ 42 | infd [x] (range 2 4); 43 | infd [y] (range 1 3); 44 | neqfd x y; 45 | eq q (List [x; y]) 46 | ]) 47 | 48 | let _ = test "lefd" (fun q -> 49 | let x = fresh () in 50 | let y = fresh () in 51 | [ 52 | infd [x] (make_dom [2; 3; 4]); 53 | infd [y] (make_dom [1; 2; 3]); 54 | lefd x y; 55 | eq q (List [x; y]) 56 | ]) 57 | 58 | let _ = test "plusfd" (fun q -> 59 | let x = fresh () in 60 | let y = fresh () in 61 | let z = fresh () in 62 | [ 63 | infd [x] (range 2 8); 64 | infd [y] (range 1 3); 65 | infd [z] (range 5 6); 66 | plusfd x y z; 67 | eq q (List [x; y; z]) 68 | ]) 69 | 70 | let _ = test "all_difffd" (fun q -> 71 | let x = fresh () in 72 | let y = fresh () in 73 | let z = fresh () in 74 | [ 75 | eq q (List [x; y; z]); 76 | infd [x] (range 1 3); 77 | infd [y] (range 1 2); 78 | infd [z] (range 1 1); 79 | all_difffd q; 80 | ]) 81 | 82 | let add_digits aug add cin cout digit = 83 | let par_sum = fresh () in 84 | let sum = fresh () in 85 | all [ 86 | domfd par_sum (range 0 18); 87 | domfd sum (range 0 19); 88 | plusfd aug add par_sum; 89 | plusfd par_sum cin sum; 90 | conde [ 91 | [ 92 | ltfd (const_int 9) sum; 93 | eq cout (const_int 1); 94 | plusfd digit (const_int 10) sum 95 | ]; 96 | [ 97 | lefd sum (const_int 9); 98 | eq cout (const_int 0); 99 | eq digit sum 100 | ] 101 | ] 102 | ] 103 | 104 | let _ = test "send-more-money"(fun letters -> 105 | match fresh_n 11 with 106 | | [s; e; n; d; m; o; r; y; c0; c1; c2] -> 107 | [ 108 | eq letters (List [s; e; n; d; m; o; r; y]); 109 | all_difffd letters; 110 | infd [s; m] (range 1 9); 111 | infd [e; n; d; o; r; y] (range 0 9); 112 | infd [c0; c1; c2] (range 0 1); 113 | add_digits s m c2 m o; 114 | add_digits e o c1 c2 n; 115 | add_digits n r c0 c1 e; 116 | add_digits d e (const_int 0) c0 y; 117 | ] 118 | | _ -> failwith "Fresh_n failed" 119 | ) 120 | 121 | 122 | let diag qi qj d rng = 123 | let qi_d = fresh () in 124 | let qj_d = fresh () in 125 | all [ 126 | infd [qi_d; qj_d] rng; 127 | plusfd qi d qi_d; 128 | neqfd qi_d qj; 129 | plusfd qj d qj_d; 130 | neqfd qj_d qi; 131 | ] 132 | 133 | let diagonals n r = 134 | let rec helper r i s j = 135 | match r with 136 | | [] | [_] -> succeed 137 | | qi::(y::rtl) -> 138 | match s with 139 | | [] -> helper (y::rtl) (i + 1) rtl (i + 2) 140 | | qj::stl -> 141 | all [ 142 | diag qi qj (const_int (j - i)) (range 0 (2 * n)); 143 | helper r i stl (j + 1) 144 | ] 145 | in helper r 0 (List.tl r) 1 146 | 147 | let n_queens q n = 148 | let rec helper i l = 149 | if i = 0 then 150 | all [ 151 | all_difffd (List l); 152 | diagonals n l; 153 | eq q (List l); 154 | ] 155 | else 156 | let x = fresh () in 157 | all [ 158 | infd [x] (range 1 n); 159 | helper (i - 1) (x::l) 160 | ] 161 | in helper n [] 162 | 163 | let _ = test ~limit:5 "eight-queens" (fun q -> [n_queens q 8]) 164 | 165 | let rec appendo l s out = 166 | conde [ 167 | [eq l (List []); eq s out]; 168 | [ 169 | fun ss -> 170 | let a, d = fresh (), fresh () in 171 | all [ 172 | eq (Cons (a, d)) l; 173 | (fun ss -> 174 | let res = fresh () in 175 | all [ 176 | eq (Cons (a, res)) out; 177 | appendo d s res; 178 | ] ss) 179 | ] ss 180 | ] 181 | ] 182 | 183 | let l = 184 | (Cons ((const_int 1), 185 | (Cons ((const_int 2), 186 | (Cons ((const_int 3), 187 | (Cons ((const_int 4), List [])))))))) 188 | 189 | let _ = test ~limit:5 "appendo" (fun q -> 190 | let a, b = fresh (), fresh () in 191 | [ 192 | appendo a b l; 193 | eq q (Cons (a, b)) 194 | ] 195 | ) 196 | -------------------------------------------------------------------------------- /mk.ml: -------------------------------------------------------------------------------- 1 | (* represent a constant value *) 2 | type const_value = 3 | | Bool of bool 4 | | Int of int 5 | | String of string 6 | | Char of char 7 | | Float of float 8 | 9 | let string_of_const_value v = 10 | match v with 11 | | Int i -> string_of_int i 12 | | String s -> s 13 | | Bool b -> string_of_bool b 14 | | Char c -> Char.escaped c 15 | | Float f -> string_of_float f 16 | 17 | type var_id = int 18 | 19 | (* represent a logic term *) 20 | type logic_term = 21 | | Var of var_id 22 | | Constant of const_value 23 | | List of (logic_term list) 24 | | Cons of logic_term * logic_term 25 | 26 | let is_var t = match t with Var _ -> true | _ -> false 27 | 28 | (* helper functions for using Constant *) 29 | let const_bool b = Constant (Bool b) 30 | let const_int i = Constant (Int i) 31 | let const_char c = Constant (Char c) 32 | let const_float f = Constant (Float f) 33 | let const_str s = Constant (String s) 34 | 35 | 36 | type substitutions = (logic_term * logic_term) list 37 | type domains = (var_id * (int list)) list 38 | type constraints = (string * logic_term) list 39 | type store = substitutions * domains * constraints 40 | 41 | let empty_s : substitutions = [] 42 | let empty_d : domains = [] 43 | let empty_c : constraints = [] 44 | let make_a s d c = (s, d, c) 45 | let empty_a = make_a empty_s empty_d empty_c 46 | 47 | let rec string_of_logic_term t = 48 | match t with 49 | | Var i -> "var_" ^ string_of_int i 50 | | Constant v -> string_of_const_value v 51 | | Cons (a, b) -> 52 | "(" ^ (string_of_logic_term a) ^ ", " ^ (string_of_logic_term b) ^ ")" 53 | | List l -> 54 | "(" ^ (String.concat ", " (List.map string_of_logic_term l)) ^ ")" 55 | 56 | let string_of_constraint (x, l) = 57 | Printf.sprintf "(%s, %s)" x (string_of_logic_term l) 58 | 59 | (* walk *) 60 | let rec walk v s = 61 | match v with 62 | | Var _ -> 63 | begin 64 | try walk (List.assoc v s) s 65 | with Not_found -> v 66 | end 67 | | _ -> v 68 | 69 | (* occurs_check *) 70 | let rec occurs_check x v s = 71 | let v = walk v s in 72 | match v with 73 | | Var _ -> v = x 74 | | Cons (a, b) -> 75 | (occurs_check x a s) && (occurs_check x b s) 76 | | List lst -> 77 | List.exists (fun v -> occurs_check x v s) lst 78 | | _ -> false 79 | 80 | (* ext_s *) 81 | let ext_s x v s = (x, v)::s 82 | 83 | (* ext_s_check: check for cycles before extending *) 84 | let ext_s_check x v s = 85 | if occurs_check x v s then None 86 | else Some (ext_s x v s) 87 | 88 | (* unify *) 89 | let rec unify lst s = 90 | match lst with 91 | | [] -> Some s 92 | | (u, v)::rest -> 93 | let rec helper u v rest = 94 | let u = walk u s in 95 | let v = walk v s in 96 | if u == v then unify rest s 97 | else match (u, v) with 98 | | Var _, _ -> 99 | if occurs_check u v s then None 100 | else unify rest (ext_s u v s) 101 | 102 | | _, Var _ -> 103 | if occurs_check v u s then None 104 | else unify rest (ext_s v u s) 105 | 106 | | List (u::ulst), List (v::vlst) -> 107 | helper u v ((List.combine ulst vlst)@rest) 108 | 109 | | Cons (a1, b1), Cons (a2, b2) -> 110 | helper a1 a2 ((b1, b2)::rest) 111 | 112 | | _ -> 113 | if u = v then (unify rest s) else None 114 | in helper u v rest 115 | 116 | (* walk* *) 117 | let rec walk_all v s = 118 | let v = walk v s in 119 | match v with 120 | | Cons (a, b) -> Cons (walk_all a s, walk_all b s) 121 | | List lst -> List (List.map (fun v -> walk_all v s) lst) 122 | | _ -> v 123 | 124 | (* reify-n *) 125 | let reify_name n = Constant (String ("_" ^ (string_of_int n))) 126 | 127 | (* reify-s *) 128 | let rec reify_s v s = 129 | let v = walk v s in 130 | match v with 131 | | Var _ -> ext_s v (reify_name (List.length s)) s 132 | | Cons (a, b) -> reify_s b (reify_s a s) 133 | | List lst -> List.fold_right reify_s lst s 134 | | _ -> s 135 | 136 | type 'a stream = 137 | | MZero 138 | | Func of (unit -> ('a stream)) 139 | | Choice of 'a * (unit -> ('a stream)) 140 | | Unit of 'a 141 | 142 | let empty_f () = MZero 143 | 144 | (* mplus *) 145 | let rec mplus a_inf f = 146 | match a_inf with 147 | | MZero -> f () 148 | | Func f2 -> Func (fun () -> mplus (f ()) f2) 149 | | Unit a -> Choice (a, f) 150 | | Choice (a, f2) -> Choice (a, (fun () -> mplus (f ()) f2)) 151 | 152 | (* mplus* *) 153 | let rec mplus_all lst = 154 | match lst with 155 | | hd::tl -> mplus hd (fun () -> mplus_all tl) 156 | | [] -> MZero 157 | 158 | (* bind *) 159 | let rec bind a_inf g = 160 | match a_inf with 161 | | MZero -> MZero 162 | | Func f -> Func (fun () -> bind (f ()) g) 163 | | Unit a -> g a 164 | | Choice (a, f) -> mplus (g a) (fun () -> bind (f ()) g) 165 | 166 | (* bind*: short-circuiting implementation *) 167 | let rec bind_all e lst = 168 | match (e, lst) with 169 | | (MZero, _) -> MZero 170 | | (_, []) -> e 171 | | (_, hd::tl) -> bind_all (bind e hd) tl 172 | 173 | (* We do not have exist/fresh construct, 174 | * the equivalent construct is: 175 | * let x = fresh () in [...] 176 | *) 177 | (* fresh: create a fresh variable *) 178 | let var_counter = ref 0 179 | let fresh () = 180 | begin 181 | var_counter := !var_counter + 1; 182 | Var !var_counter 183 | end 184 | 185 | let rec fresh_n n = 186 | if n <= 0 then [] 187 | else (fresh ())::(fresh_n (n - 1)) 188 | 189 | (* all: combine a sequence (list) of clauses *) 190 | let all lst a = bind_all (Unit a) lst 191 | 192 | (* conde *) 193 | let conde lst s = 194 | let lst = List.map all lst in 195 | Func (fun () -> mplus_all (List.map (fun f -> (f s)) lst)) 196 | 197 | (* take *) 198 | let rec take n a_inf = 199 | if n = 0 then [] 200 | else match a_inf with 201 | | MZero -> [] 202 | | Func f -> (take n (f ())) 203 | | Choice (a, f) -> a::(take (n - 1) (f ())) 204 | | Unit a -> [a] 205 | 206 | (* ifu *) 207 | let rec ifu lst = 208 | match lst with 209 | | [] -> MZero 210 | | (e, glst)::tl -> 211 | let rec helper a_inf = 212 | match a_inf with 213 | | MZero -> ifu tl 214 | | Func f -> Func (fun () -> helper (f ())) 215 | | Choice (a, _) | Unit a -> bind_all (Unit a) glst 216 | in helper e 217 | 218 | (* condu *) 219 | let condu lst a = 220 | Func (fun () -> 221 | ifu (List.map (fun l -> ((List.hd l) a, List.tl l)) lst)) 222 | 223 | (* onceo *) 224 | let onceo g = condu [g] 225 | --------------------------------------------------------------------------------