├── .gitignore ├── .merlin ├── .ocp-indent ├── BRZO ├── CHANGES.md ├── LICENSE.md ├── README.md ├── _tags ├── doc └── index.mld ├── opam ├── pkg ├── META └── pkg.ml ├── src ├── trel.ml ├── trel.mli ├── trel.mllib ├── trel_list.ml ├── trel_list.mli ├── trel_top.ml ├── trel_top.mllib └── trel_top_init.ml └── test ├── examples.ml ├── mk.ml ├── mk.mli ├── mk_test.ml ├── mkv.ml ├── mkv.mli ├── mkv_test.ml ├── reliza.ml ├── sreliza.ml ├── test.ml ├── test_list.ml ├── test_tree.ml └── utf.ml /.gitignore: -------------------------------------------------------------------------------- 1 | _b0 2 | _build 3 | tmp 4 | -------------------------------------------------------------------------------- /.merlin: -------------------------------------------------------------------------------- 1 | PKG bytes fmt astring 2 | S src 3 | S test 4 | B _build/** 5 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | strict_with=always,match_clause=4,strict_else=never 2 | -------------------------------------------------------------------------------- /BRZO: -------------------------------------------------------------------------------- 1 | (srcs-x pkg test) -------------------------------------------------------------------------------- /CHANGES.md: -------------------------------------------------------------------------------- 1 | vX.Y.Z YYYY-MM-DD Location 2 | -------------------------- 3 | 4 | First release. 5 | -------------------------------------------------------------------------------- /LICENSE.md: -------------------------------------------------------------------------------- 1 | Copyright (c) 2017 Daniel C. Bünzli 2 | 3 | Permission to use, copy, modify, and/or distribute this software for any 4 | purpose with or without fee is hereby granted, provided that the above 5 | copyright notice and this permission notice appear in all copies. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 8 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 9 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 10 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 11 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 12 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 13 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 14 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Trel — Relational programming for OCaml 2 | ------------------------------------------------------------------------------- 3 | %%VERSION%% 4 | 5 | Trel is a typed relational programming language embedded in OCaml. Its 6 | term language is arbitrarily extensible allowing clients to inject and 7 | project OCaml values and functions for seamless interaction between 8 | Trel and regular OCaml programs. 9 | 10 | Trel is a typed and type-safe implementation of [μKanren][microKanren] 11 | distributed under the ISC license. It depends on [fmt][fmt]. 12 | 13 | [microKanren]: http://webyrd.net/scheme-2013/papers/HemannMuKanren2013.pdf 14 | [fmt]: http:/erratique.ch/software/fmt 15 | 16 | Homepage: http://erratique.ch/software/trel 17 | 18 | ## Minimal typed μKanren implementation 19 | 20 | Consult [`mk.mli`](test/mk.mli) and [`mk.ml`](test/mk.ml) and its 21 | [tests](test/mk_test.ml) for an absolute minimal typed and type-safe 22 | μKanren in the spirit of the original one. 23 | 24 | The implementation shows how to define an arbitrarily extensible typed 25 | term language and a simple API for typed reification of states. This 26 | is the core on which `Trel` adds a bit of convenience. 27 | 28 | Other OCaml implementations of {mini,μ}Kanren are listed on the 29 | [miniKanren website](http://minikanren.org/). 30 | 31 | ## Installation 32 | 33 | Trel can be installed with `opam`: 34 | 35 | opam install trel 36 | 37 | If you don't use `opam` consult the [`opam`](opam) file for build 38 | instructions. 39 | 40 | ## Documentation 41 | 42 | The documentation and API reference is generated from the source 43 | interfaces. It can be consulted [online][doc] or via `odig doc 44 | trel`. 45 | 46 | [doc]: http://erratique.ch/software/trel/doc 47 | 48 | ## Sample programs 49 | 50 | If you installed Trel with `opam` sample programs are located in 51 | the directory `opam var trel:doc`. 52 | 53 | In the distribution sample programs and tests are located in the 54 | [`test`](test) directory. They can be built and run 55 | with: 56 | 57 | topkg build --tests true && topkg test 58 | -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | true : bin_annot, package(fmt) 2 | 3 | <_b0> : -traverse 4 | : include 5 | : package(compiler-libs.toplevel) 6 | : package(astring) 7 | : package(astring) 8 | : include -------------------------------------------------------------------------------- /doc/index.mld: -------------------------------------------------------------------------------- 1 | {0 Rel {%html: %%VERSION%%%}} 2 | 3 | Trel is a typed relational programming language embedded in OCaml. Its 4 | term language is arbitrarily extensible allowing clients to inject and 5 | project OCaml values and functions for seamless interaction between 6 | Trel and regular OCaml programs. 7 | 8 | {1:api API} 9 | 10 | {!modules: 11 | Trel 12 | Trel_list 13 | } 14 | -------------------------------------------------------------------------------- /opam: -------------------------------------------------------------------------------- 1 | opam-version: "1.2" 2 | maintainer: "Daniel Bünzli " 3 | authors: ["Daniel Bünzli "] 4 | homepage: "http://erratique.ch/software/rel" 5 | doc: "http://erratique.ch/software/rel/doc" 6 | license: "ISC" 7 | dev-repo: "http://erratique.ch/repos/rel.git" 8 | bug-reports: "https://github.com/dbuenzli/rel/issues" 9 | tags: [ "logic" "relational" "constraint" "declarative" "org:erratique" ] 10 | available: [ ocaml-version >= "4.03.0"] 11 | depends: 12 | [ 13 | "ocamlfind" {build} 14 | "ocamlbuild" {build} 15 | "topkg" {build & >= "0.9.0"} 16 | "fmt" 17 | ] 18 | depopts: [] 19 | build: 20 | [[ 21 | "ocaml" "pkg/pkg.ml" "build" 22 | "--dev-pkg" "%{pinned}%" 23 | ]] 24 | -------------------------------------------------------------------------------- /pkg/META: -------------------------------------------------------------------------------- 1 | version = "%%VERSION_NUM%%" 2 | description = "Relational programming for OCaml" 3 | requires = "fmt" 4 | archive(byte) = "trel.cma" 5 | archive(native) = "trel.cmxa" 6 | plugin(byte) = "trel.cma" 7 | plugin(native) = "trel.cmxs" 8 | 9 | package "top" ( 10 | version = "%%VERSION_NUM%%" 11 | description = "Trel toplevel support" 12 | requires = "trel" 13 | archive(byte) = "trel_top.cma" 14 | archive(native) = "trel_top.cmxa" 15 | plugin(byte) = "trel_top.cma" 16 | plugin(native) = "trel_top.cmxs" 17 | exists_if = "trel_top.cma" 18 | ) -------------------------------------------------------------------------------- /pkg/pkg.ml: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env ocaml 2 | #use "topfind" 3 | #require "topkg" 4 | open Topkg 5 | 6 | let () = 7 | Pkg.describe "trel" @@ fun c -> 8 | Ok [ Pkg.mllib "src/trel.mllib"; 9 | Pkg.mllib ~api:[] "src/trel_top.mllib"; 10 | Pkg.lib "src/trel_top_init.ml"; 11 | Pkg.bin "test/reliza"; 12 | Pkg.bin "test/sreliza"; 13 | Pkg.test "test/test"; 14 | Pkg.test "test/test_tree"; 15 | Pkg.test "test/test_list"; 16 | Pkg.test "test/mk_test"; 17 | Pkg.test "test/mkv_test"; 18 | Pkg.test "test/examples"; ] 19 | -------------------------------------------------------------------------------- /src/trel.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let strf = Fmt.str 8 | 9 | (* Lazy sequences of values. *) 10 | 11 | module Seq = struct 12 | type 'a t = 13 | | Empty 14 | | Cons of 'a * 'a t 15 | | Delay of 'a t Lazy.t 16 | 17 | let empty = Empty 18 | let cons v s = Cons (v, s) 19 | let delay sazy = Delay sazy 20 | 21 | let rec is_empty s = match s with 22 | | Empty -> true 23 | | Cons _ -> false 24 | | Delay xs -> is_empty (Lazy.force xs) 25 | 26 | let rec head = function 27 | | Empty -> None 28 | | Cons (x, _) -> Some x 29 | | Delay xs -> head (Lazy.force xs) 30 | 31 | let rec get_head = function 32 | | Empty -> invalid_arg "Sequence is empty" 33 | | Cons (x, _) -> x 34 | | Delay xs -> get_head (Lazy.force xs) 35 | 36 | let rec tail = function 37 | | Empty -> invalid_arg "Sequence is empty" 38 | | Cons (_, xs) -> xs 39 | | Delay xs -> tail (Lazy.force xs) 40 | 41 | let to_list ?limit s = 42 | let limit = match limit with 43 | | Some l when l < 0 -> invalid_arg (strf "negative limit (%d)" l) 44 | | Some l -> l 45 | | None -> -1 46 | in 47 | let rec loop limit acc s = match limit = 0 with 48 | | true -> List.rev acc 49 | | false -> 50 | match s with 51 | | Empty -> List.rev acc 52 | | Delay s -> loop limit acc (Lazy.force s) 53 | | Cons (x, xs) -> 54 | let limit = if limit = -1 then limit else limit - 1 in 55 | loop limit (x :: acc) xs 56 | in 57 | loop limit [] s 58 | 59 | let rec mplus s0 s1 = match s0 with 60 | | Empty -> s1 61 | | Cons (x, xs) -> Cons (x, Delay (lazy (mplus s1 xs))) 62 | | Delay xs -> 63 | match s1 with 64 | | Empty -> s0 65 | | Cons (y, ys) -> Cons (y, Delay (lazy (mplus (Lazy.force xs) ys))) 66 | | Delay ys -> Delay (lazy (mplus (Lazy.force xs) s1)) 67 | 68 | let rec bind s f = match s with 69 | | Empty -> Empty 70 | | Cons (x, xs) -> mplus (f x) (Delay (lazy (bind xs f))) 71 | | Delay s -> Delay (lazy (bind (Lazy.force s) f)) 72 | 73 | let rec map f s = match s with 74 | | Empty -> Empty 75 | | Cons (x, xs) -> Cons (f x, map f xs) 76 | | Delay s -> Delay (lazy (map f (Lazy.force s))) 77 | end 78 | 79 | type 'a seq = 'a Seq.t 80 | 81 | (* Type identifiers 82 | See http://alan.petitepomme.net/cwn/2015.03.24.html#1 *) 83 | 84 | module Tid = struct type _ t = .. end 85 | module type Tid = sig 86 | type t 87 | type _ Tid.t += Tid : t Tid.t 88 | end 89 | type 'a tid = (module Tid with type t = 'a) 90 | 91 | let tid () (type s) = 92 | let module M = struct 93 | type t = s 94 | type _ Tid.t += Tid : t Tid.t 95 | end 96 | in 97 | (module M : Tid with type t = s) 98 | 99 | type ('a, 'b) teq = Teq : ('a, 'a) teq 100 | 101 | let teq : type r s. r tid -> s tid -> (r, s) teq option = 102 | fun r s -> 103 | let module R = (val r : Tid with type t = r) in 104 | let module S = (val s : Tid with type t = s) in 105 | match R.Tid with 106 | | S.Tid -> Some Teq 107 | | _ -> None 108 | 109 | (* Domains 110 | 111 | FIXME try to be more clever about domains for structural types, 112 | we are generative which is annoying. Give structure to 113 | tid + hash-consing ? *) 114 | 115 | module Dom = struct 116 | 117 | type 'a t = 118 | { name : string; 119 | tid : 'a tid; 120 | equal : 'a -> 'a -> bool; 121 | pp : Format.formatter -> 'a -> unit } 122 | 123 | let pp_abstr ppf _ = Fmt.pf ppf "" 124 | 125 | let v ?(name = "unknown") ?(pp = pp_abstr) ?(equal = ( = )) () = 126 | let tid = tid () in 127 | { name; tid; equal; pp } 128 | 129 | module type V = sig 130 | type t 131 | val equal : t -> t -> bool 132 | val pp : Format.formatter -> t -> unit 133 | end 134 | 135 | let of_type : type a. (module V with type t = a) -> a t = 136 | fun (module V) -> v ~pp:V.pp ~equal:V.equal () 137 | 138 | let with_dom ?name ?pp d = 139 | let name = match name with None -> d.name | Some n -> n in 140 | let pp = match pp with None -> d.pp | Some pp -> pp in 141 | { d with name; pp } 142 | 143 | let name d = d.name 144 | let pp_value d = d.pp 145 | let equal_value d = d.equal 146 | 147 | let equal : type a b. a t -> b t -> bool = 148 | fun d0 d1 -> match teq d0.tid d1.tid with 149 | | None -> false 150 | | Some Teq -> true 151 | 152 | let pp ppf d = Fmt.string ppf d.name 153 | 154 | (* Predefined domains *) 155 | 156 | let unit = 157 | let pp ppf () = Fmt.pf ppf "()" in 158 | v ~name:"unit" ~pp ~equal:(( = ) : unit -> unit -> bool) () 159 | 160 | let bool = 161 | v ~name:"bool" ~pp:Fmt.bool ~equal:(( = ) : bool -> bool -> bool) () 162 | 163 | let int = 164 | v ~name:"int" ~pp:Fmt.int ~equal:(( = ) : int -> int -> bool) () 165 | 166 | let float = 167 | v ~name:"float" ~pp:Fmt.float ~equal:(( = ) : float -> float -> bool) () 168 | 169 | let string = 170 | v ~name:"string" ~pp:Fmt.string ~equal:(( = ) : string -> string -> bool) () 171 | 172 | let pair f s = 173 | let name = strf "%s * %s" f.name s.name in 174 | let pp = Fmt.Dump.pair f.pp s.pp in 175 | let equal (f0, s0) (f1, s1) = f.equal f0 f1 && s.equal s0 s1 in 176 | v ~name ~pp ~equal () 177 | 178 | let list e = 179 | let equal l0 l1 = List.for_all2 e.equal l0 l1 in 180 | let pp = Fmt.Dump.list e.pp in 181 | let name = match String.contains e.name ' ' with 182 | | true -> strf "(%s) list" e.name 183 | | false -> strf "%s list" e.name 184 | in 185 | v ~name ~pp ~equal () 186 | end 187 | 188 | type 'a dom = 'a Dom.t 189 | 190 | (* Variables *) 191 | 192 | type 'a var = { id : int; name : string option; tid : 'a tid; } 193 | 194 | module Var = struct 195 | type t = V : 'a var -> t 196 | let compare (V v0) (V v1) = (compare : int -> int -> int) v0.id v1.id 197 | end 198 | 199 | (* Terms 200 | 201 | N.B. We type function applications rather than pure values and 202 | variables. This allows to keep variables untyped which seems to 203 | lead to a more lightweight edsl. *) 204 | 205 | type 'a term = 206 | | Var of 'a var 207 | | Ret of 'a dom * 'a ret 208 | 209 | and 'a ret = 210 | | App : ('a -> 'b) ret * 'a dom * 'a term -> 'b ret 211 | | Pure : 'a -> 'a ret 212 | 213 | let var ?name id = Var { id; name; tid = tid () } 214 | let const dom v = Ret (dom, Pure v) 215 | let pure f = Pure f 216 | let app dom v ret = App (ret, dom, v) 217 | let ret dom ret = Ret (dom, ret) 218 | 219 | let unit = const Dom.unit () 220 | let bool = const Dom.bool 221 | let int = const Dom.int 222 | let float = const Dom.float 223 | let string = const Dom.string 224 | 225 | let pair fst snd = (fst, snd) 226 | let pair fdom sdom tdom = 227 | fun fst snd -> pure pair |> app fdom fst |> app sdom snd |> ret tdom 228 | 229 | let pp_var ppf v = match v.name with 230 | | Some n -> Fmt.pf ppf "%s" n 231 | | None -> Fmt.pf ppf "_%d" v.id 232 | 233 | let rec pp_term : type a. Format.formatter -> a term -> unit = 234 | (* FIXME not T.R. *) 235 | fun ppf -> function 236 | | Var v -> pp_var ppf v 237 | | Ret (d, ret) -> 238 | match ret with 239 | | Pure v -> d.Dom.pp ppf v 240 | | App _ as ret -> pp_ret ppf ret (* FIXME add a name to Ret ? *) 241 | 242 | and pp_ret : type a. Format.formatter -> a ret -> unit = 243 | fun ppf -> function 244 | | Pure _ -> () 245 | | App (f, d, v) -> 246 | Fmt.pf ppf "@[<1>("; 247 | Fmt.pf ppf "@ %a %a" pp_term v pp_ret f; 248 | Fmt.pf ppf ")@]"; 249 | 250 | (* Substitutions *) 251 | 252 | module Subst = struct 253 | module Vmap = Map.Make (Var) 254 | type binding = B : 'a var * 'a term -> binding 255 | type t = binding Vmap.t 256 | 257 | let empty = Vmap.empty 258 | let add var t s = Vmap.add (Var.V var) (B (var, t)) s 259 | let find : type a. a var -> t -> a term option = 260 | fun v s -> 261 | try 262 | let B (v', t) = Vmap.find (Var.V v) s in 263 | match teq v.tid v'.tid with None -> None | Some Teq -> Some t 264 | with Not_found -> None 265 | 266 | let iter_bindings f = Vmap.iter (fun _ v -> f v) 267 | end 268 | 269 | let rec _term_value : type a. a term -> Subst.t -> a = 270 | fun t s -> match t with 271 | | Ret (d, t) -> _ret_value t s 272 | | Var v -> 273 | match Subst.find v s with 274 | | Some t -> _term_value t s 275 | | None -> raise Exit 276 | 277 | and _ret_value : type a. a ret -> Subst.t -> a = 278 | fun r s -> match r with 279 | | Pure v -> v 280 | | App (f, _, v) -> (_ret_value f s) (_term_value v s) 281 | 282 | let term_value t s = try Some (_term_value t s) with Exit -> None 283 | let ret_value t s = try Some (_ret_value t s) with Exit -> None 284 | 285 | let rec term_ret : type a. a term -> Subst.t -> (a dom * a ret) option = 286 | fun t s -> match t with 287 | | Ret (d, t) -> Some (d, t) 288 | | Var v -> 289 | match Subst.find v s with 290 | | Some t -> term_ret t s 291 | | None -> None 292 | 293 | let pp_var_value pp_value v ppf var = 294 | Fmt.pf ppf "@[<1>(%a@ = %a)@]" pp_var var pp_value v 295 | 296 | let pp_binding ppf (Subst.B (var, term)) = 297 | pp_var_value pp_term term ppf var 298 | 299 | let pp_binding_value subst ppf (Subst.B (var, term) as b) = 300 | match term_ret term subst with 301 | | None -> pp_binding ppf b 302 | | Some (d, ret) -> 303 | match ret_value ret subst with 304 | | Some v -> pp_var_value d.Dom.pp v ppf var 305 | | None -> pp_var_value pp_ret ret ppf var 306 | 307 | let pp_subst ppf subst = 308 | Fmt.pf ppf "@[<1>(%a)@]" 309 | (Fmt.iter ~sep:Fmt.sp Subst.iter_bindings pp_binding) subst 310 | 311 | let pp_subst_values ppf subst = 312 | Fmt.pf ppf "@[<1>(%a)@]" 313 | (Fmt.iter ~sep:Fmt.sp Subst.iter_bindings (pp_binding_value subst)) subst 314 | 315 | (* Unification *) 316 | 317 | let rec walk t s = match t with 318 | | Var v -> (match Subst.find v s with None -> t | Some v -> walk v s) 319 | | t -> t 320 | 321 | let rec unify : type a. a term -> a term -> Subst.t -> Subst.t option = 322 | (* FIXME not T.R. *) 323 | fun t0 t1 s -> match walk t0 s, walk t1 s with 324 | | Var v0, Var v1 when v0.id = v1.id -> Some s 325 | | Var v, t | t, Var v -> Some (Subst.add v t s) 326 | | Ret (d0, r0), Ret (d1, r1) -> 327 | if not (d0.Dom.tid == d1.Dom.tid) then None else 328 | match r0, r1 with 329 | | Pure v0, Pure v1 -> if d0.Dom.equal v0 v1 then Some s else None 330 | | App _, App _ -> unify_ret r0 r1 s 331 | | _, _ -> None 332 | 333 | and unify_ret : type a. a ret -> a ret -> Subst.t -> Subst.t option = 334 | fun r0 r1 s -> match r0, r1 with 335 | | App (f0, d0, v0), App (f1, d1, v1) -> 336 | begin match teq d0.Dom.tid d1.Dom.tid with 337 | | None -> None 338 | | Some Teq -> 339 | match unify v0 v1 s with 340 | | None -> None 341 | | Some s -> unify_ret f0 f1 s 342 | end 343 | | Pure f0, Pure f1 when f0 == f1 -> Some s 344 | | _, _ -> None 345 | 346 | (* State *) 347 | 348 | type state = { next_vid : int; subst : Subst.t } 349 | let empty = { next_vid = 0; subst = Subst.empty } 350 | 351 | let pp_state ppf st = pp_subst_values ppf st.subst 352 | 353 | (* Goals *) 354 | 355 | type goal = state -> state Seq.t 356 | 357 | let fail _ = Seq.empty 358 | let succeed st = Seq.cons st Seq.empty 359 | 360 | let ( = ) t0 t1 st = match unify t0 t1 st.subst with 361 | | None -> Seq.empty 362 | | Some subst -> succeed { st with subst } 363 | 364 | let ( || ) g0 g1 st = Seq.mplus (g0 st) (g1 st) 365 | let ( && ) g0 g1 st = Seq.bind (g0 st) g1 366 | let delay gazy st = Seq.delay (lazy ((Lazy.force gazy) st)) 367 | 368 | let fresh lambda st = 369 | let var = var st.next_vid in 370 | lambda var { st with next_vid = st.next_vid + 1 } 371 | 372 | module Fresh = struct 373 | let v1 = fresh 374 | let v2 lambda st = 375 | let v1 = var (st.next_vid ) in 376 | let v2 = var (st.next_vid + 1) in 377 | (lambda v1 v2) { st with next_vid = st.next_vid + 2 } 378 | 379 | let v3 lambda st = 380 | let v1 = var (st.next_vid ) in 381 | let v2 = var (st.next_vid + 1) in 382 | let v3 = var (st.next_vid + 2) in 383 | (lambda v1 v2 v3) { st with next_vid = st.next_vid + 3 } 384 | 385 | let v4 lambda st = 386 | let v1 = var (st.next_vid ) in 387 | let v2 = var (st.next_vid + 1) in 388 | let v3 = var (st.next_vid + 2) in 389 | let v4 = var (st.next_vid + 3) in 390 | (lambda v1 v2 v3 v4) { st with next_vid = st.next_vid + 4 } 391 | 392 | let v5 lambda st = 393 | let v1 = var (st.next_vid ) in 394 | let v2 = var (st.next_vid + 1) in 395 | let v3 = var (st.next_vid + 2) in 396 | let v4 = var (st.next_vid + 3) in 397 | let v5 = var (st.next_vid + 4) in 398 | (lambda v1 v2 v3 v4 v5) { st with next_vid = st.next_vid + 5 } 399 | 400 | let v6 lambda st = 401 | let v1 = var (st.next_vid ) in 402 | let v2 = var (st.next_vid + 1) in 403 | let v3 = var (st.next_vid + 2) in 404 | let v4 = var (st.next_vid + 3) in 405 | let v5 = var (st.next_vid + 4) in 406 | let v6 = var (st.next_vid + 5) in 407 | (lambda v1 v2 v3 v4 v5 v6) { st with next_vid = st.next_vid + 6 } 408 | end 409 | 410 | (* Reification *) 411 | 412 | module Value = struct 413 | type 'a t = 'a term * Subst.t 414 | 415 | let v var subst = (var, subst) 416 | 417 | let name (var, _) = match var with 418 | | Var v -> strf "%a" pp_var v | _ -> assert false 419 | 420 | let find (var, subst) = term_value var subst 421 | let get (var, subst) = match term_value var subst with 422 | | None -> invalid_arg (strf "%a is undefined" pp_term var) 423 | | Some v -> v 424 | 425 | let term (var, subst) = walk var subst 426 | 427 | let pp ppf (var, subst) = match term_ret var subst with 428 | | None -> pp_term ppf var 429 | | Some (d, ret) -> 430 | match ret_value ret subst with 431 | | Some v -> d.Dom.pp ppf v 432 | | None -> pp_ret ppf ret 433 | 434 | let get1 x = get x 435 | let get2 x y = get x, get y 436 | let get3 x y z = get x, get y, get z 437 | let get4 x y z r = get x, get y, get z, get r 438 | let get5 x y z r s = get x, get y, get z, get r, get s 439 | let get6 x y z r s t = get x, get y, get z, get r, get s, get t 440 | let find1 x = find x 441 | let find2 x y = find x, find y 442 | let find3 x y z = find x, find y, find z 443 | let find4 x y z r = find x, find y, find z, find r 444 | let find5 x y z r s = find x, find y, find z, find r, find s 445 | let find6 x y z r s t = find x, find y, find z, find r, find s, find t 446 | end 447 | 448 | type 'a value = 'a Value.t 449 | type ('q, 'r) reifier = { next_vid : int; query : 'q; reify : state -> 'r } 450 | 451 | let reifier query reify = { next_vid = 0; query; reify = (fun _ -> reify) } 452 | let query ?name r = 453 | let var = var ?name r.next_vid in 454 | let next_vid = r.next_vid + 1 in 455 | let query = r.query var in 456 | let reify st = r.reify st (Value.v var st.subst) in 457 | { next_vid; query; reify } 458 | 459 | let _run r = r.query { empty with next_vid = r.next_vid } 460 | let run r = Seq.map r.reify (_run r) 461 | let rec success g = not (Seq.is_empty (g empty)) 462 | 463 | module Query = struct 464 | let v1 ?n0 r = query ?name:n0 r 465 | let v2 ?n0 ?n1 r = 466 | let v0 = var ?name:n0 (r.next_vid ) in 467 | let v1 = var ?name:n1 (r.next_vid + 1) in 468 | let next_vid = r.next_vid + 2 in 469 | let query = r.query v0 v1 in 470 | let reify st = r.reify st (Value.v v0 st.subst) (Value.v v1 st.subst) in 471 | { next_vid; query; reify } 472 | 473 | let v3 ?n0 ?n1 ?n2 r = 474 | let v0 = var ?name:n0 (r.next_vid ) in 475 | let v1 = var ?name:n1 (r.next_vid + 1) in 476 | let v2 = var ?name:n2 (r.next_vid + 2) in 477 | let next_vid = r.next_vid + 3 in 478 | let query = r.query v0 v1 v2 in 479 | let reify st = r.reify st 480 | (Value.v v0 st.subst) (Value.v v1 st.subst) (Value.v v2 st.subst) 481 | in 482 | { next_vid; query; reify } 483 | 484 | let v4 ?n0 ?n1 ?n2 ?n3 r = 485 | let v0 = var ?name:n0 (r.next_vid ) in 486 | let v1 = var ?name:n1 (r.next_vid + 1) in 487 | let v2 = var ?name:n2 (r.next_vid + 2) in 488 | let v3 = var ?name:n3 (r.next_vid + 3) in 489 | let next_vid = r.next_vid + 4 in 490 | let query = r.query v0 v1 v2 v3 in 491 | let reify st = r.reify st 492 | (Value.v v0 st.subst) (Value.v v1 st.subst) (Value.v v2 st.subst) 493 | (Value.v v3 st.subst) 494 | in 495 | { next_vid; query; reify } 496 | 497 | let v5 ?n0 ?n1 ?n2 ?n3 ?n4 r = 498 | let v0 = var ?name:n0 (r.next_vid ) in 499 | let v1 = var ?name:n1 (r.next_vid + 1) in 500 | let v2 = var ?name:n2 (r.next_vid + 2) in 501 | let v3 = var ?name:n3 (r.next_vid + 3) in 502 | let v4 = var ?name:n4 (r.next_vid + 4) in 503 | let next_vid = r.next_vid + 5 in 504 | let query = r.query v0 v1 v2 v3 v4 in 505 | let reify st = r.reify st 506 | (Value.v v0 st.subst) (Value.v v1 st.subst) (Value.v v2 st.subst) 507 | (Value.v v3 st.subst) (Value.v v4 st.subst) 508 | in 509 | { next_vid; query; reify } 510 | 511 | let v6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 r = 512 | let v0 = var ?name:n0 (r.next_vid ) in 513 | let v1 = var ?name:n1 (r.next_vid + 1) in 514 | let v2 = var ?name:n2 (r.next_vid + 2) in 515 | let v3 = var ?name:n3 (r.next_vid + 3) in 516 | let v4 = var ?name:n4 (r.next_vid + 4) in 517 | let v5 = var ?name:n5 (r.next_vid + 5) in 518 | let next_vid = r.next_vid + 6 in 519 | let query = r.query v0 v1 v2 v3 v4 v5 in 520 | let reify st = r.reify st 521 | (Value.v v0 st.subst) (Value.v v1 st.subst) (Value.v v2 st.subst) 522 | (Value.v v3 st.subst) (Value.v v4 st.subst) (Value.v v5 st.subst) 523 | in 524 | { next_vid; query; reify } 525 | end 526 | 527 | module Reifier = struct 528 | 529 | let get1 ?n0 q = Query.v1 ?n0 (reifier q Value.get1) 530 | let get2 ?n0 ?n1 q = Query.v2 ?n0 ?n1 (reifier q Value.get2) 531 | let get3 ?n0 ?n1 ?n2 q = Query.v3 ?n0 ?n1 ?n2 (reifier q Value.get3) 532 | let get4 ?n0 ?n1 ?n2 ?n3 q = Query.v4 ?n0 ?n1 ?n2 ?n3 (reifier q Value.get4) 533 | let get5 ?n0 ?n1 ?n2 ?n3 ?n4 q = 534 | Query.v5 ?n0 ?n1 ?n2 ?n3 ?n4 (reifier q Value.get5) 535 | 536 | let get6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 q = 537 | Query.v6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 (reifier q Value.get6) 538 | 539 | let find1 ?n0 q = Query.v1 ?n0 (reifier q Value.find1) 540 | let find2 ?n0 ?n1 q = Query.v2 ?n0 ?n1 (reifier q Value.find2) 541 | let find3 ?n0 ?n1 ?n2 q = Query.v3 ?n0 ?n1 ?n2 (reifier q Value.find3) 542 | let find4 ?n0 ?n1 ?n2 ?n3 q = Query.v4 ?n0 ?n1 ?n2 ?n3 (reifier q Value.find4) 543 | let find5 ?n0 ?n1 ?n2 ?n3 ?n4 q = 544 | Query.v5 ?n0 ?n1 ?n2 ?n3 ?n4 (reifier q Value.find5) 545 | 546 | let find6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 q = 547 | Query.v6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 (reifier q Value.find6) 548 | end 549 | 550 | module Run = struct 551 | let get1 ?limit q = Seq.to_list ?limit @@ run (Reifier.get1 q) 552 | let get2 ?limit q = Seq.to_list ?limit @@ run (Reifier.get2 q) 553 | let get3 ?limit q = Seq.to_list ?limit @@ run (Reifier.get3 q) 554 | let get4 ?limit q = Seq.to_list ?limit @@ run (Reifier.get4 q) 555 | let get5 ?limit q = Seq.to_list ?limit @@ run (Reifier.get5 q) 556 | let get6 ?limit q = Seq.to_list ?limit @@ run (Reifier.get6 q) 557 | let find1 ?limit q = Seq.to_list ?limit @@ run (Reifier.find1 q) 558 | let find2 ?limit q = Seq.to_list ?limit @@ run (Reifier.find2 q) 559 | let find3 ?limit q = Seq.to_list ?limit @@ run (Reifier.find3 q) 560 | let find4 ?limit q = Seq.to_list ?limit @@ run (Reifier.find4 q) 561 | let find5 ?limit q = Seq.to_list ?limit @@ run (Reifier.find5 q) 562 | let find6 ?limit q = Seq.to_list ?limit @@ run (Reifier.find6 q) 563 | end 564 | 565 | (* State introspection *) 566 | 567 | let states r = _run r 568 | let inspect ?limit r = Seq.to_list ?limit (states r) 569 | 570 | module Inspect = struct 571 | let v1 ?limit ?n0 q = inspect ?limit (Reifier.find1 ?n0 q) 572 | let v2 ?limit ?n0 ?n1 q = inspect ?limit (Reifier.find2 ?n0 ?n1 q) 573 | let v3 ?limit ?n0 ?n1 ?n2 q = inspect ?limit (Reifier.find3 ?n0 ?n1 ?n2 q) 574 | let v4 ?limit ?n0 ?n1 ?n2 ?n3 q = 575 | inspect ?limit (Reifier.find4 ?n0 ?n1 ?n2 ?n3 q) 576 | 577 | let v5 ?limit ?n0 ?n1 ?n2 ?n3 ?n4 q = 578 | inspect ?limit (Reifier.find5 ?n0 ?n1 ?n2 ?n3 ?n4 q) 579 | 580 | let v6 ?limit ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 q = 581 | inspect ?limit (Reifier.find6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 q) 582 | end 583 | 584 | (*--------------------------------------------------------------------------- 585 | Copyright (c) 2017 Daniel C. Bünzli 586 | 587 | Permission to use, copy, modify, and/or distribute this software for any 588 | purpose with or without fee is hereby granted, provided that the above 589 | copyright notice and this permission notice appear in all copies. 590 | 591 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 592 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 593 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 594 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 595 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 596 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 597 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 598 | ---------------------------------------------------------------------------*) 599 | -------------------------------------------------------------------------------- /src/trel.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Relational programming for OCaml. 8 | 9 | [Rel] is a typed, relational, programming language embedded in OCaml. 10 | 11 | See the {{!basics}basics}. 12 | 13 | {b References.} 14 | {ul 15 | {- Jason Hemann and Daniel P. Friedman. 16 | {{:http://webyrd.net/scheme-2013/papers/HemannMuKanren2013.pdf} 17 | {e microKanren: A Minimal 18 | Functional Core for Relational Programming}}. In (Scheme '13), 2013.} 19 | {- Daniel P. Friedman, William E. Byrd and Oleg Kiselyov. 20 | {e The Reasoned Schemer}. The MIT Press, 2005.}} 21 | 22 | {e %%VERSION%% — {{:%%PKG_HOMEPAGE%% }homepage}} *) 23 | 24 | (** {1:doms Domains} *) 25 | 26 | type 'a dom 27 | (** The type for domains of values of type ['a]. *) 28 | 29 | (** Domains. *) 30 | module Dom : sig 31 | 32 | (** {1:dom Domains} *) 33 | 34 | type 'a t = 'a dom 35 | (** See {!type:dom}. *) 36 | 37 | val v : 38 | ?name:string -> ?pp:(Format.formatter -> 'a -> unit) -> 39 | ?equal:('a -> 'a -> bool) -> unit -> 'a dom 40 | (** [v ~name ~pp ~equal] is a new domain named [name] using [equal] 41 | to test values for equality and [pp] to print them. [name] 42 | defaults to ["unknown"], [equal] defaults to {!Pervasives.( = )} 43 | and [pp] to a formatter that constantly prints [""]). *) 44 | 45 | (** The type for modules that can be seen as domains. *) 46 | module type V = sig 47 | type t 48 | (** The type of the values of the domain. *) 49 | 50 | val equal : t -> t -> bool 51 | (** [equal v v'] is [true] iff [v] and [v'] are equal. *) 52 | 53 | val pp : Format.formatter -> t -> unit 54 | (** [pp ppf v] prints an unspecified representation of [v] 55 | on [ppf]. *) 56 | end 57 | 58 | val of_type : (module V with type t = 'a) -> 'a t 59 | (** [of_type m] is a domain from the module [m]. *) 60 | 61 | val with_dom : 62 | ?name:string -> ?pp:(Format.formatter -> 'a -> unit) -> 'a dom -> 'a dom 63 | (** [with_dom ~name ~pp d] is domain [d] with name [name] and 64 | pretty-printer [pp]. The resulting domain is {!equal} to [d]. *) 65 | 66 | val name : 'a dom -> string 67 | (** [name d] is [d]'s name. *) 68 | 69 | val pp_value : 'a dom -> Format.formatter -> 'a -> unit 70 | (** [pp_value d] is [d]'s value pretty-printer. *) 71 | 72 | val equal_value : 'a dom -> ('a -> 'a -> bool) 73 | (** [equal_value d] is [d]'s value equality function. *) 74 | 75 | val equal : 'a dom -> 'b dom -> bool 76 | (** [equal d0 d1] is [true] iff [d0] and [d1] are the same domain. *) 77 | 78 | val pp : Format.formatter -> 'a dom -> unit 79 | (** [pp ppf d] prints [d]'s {!name} on [ppf]. *) 80 | 81 | (** {1:base Base type domains} *) 82 | 83 | val unit : unit dom 84 | (** [unit] is a domain for the [()] value. *) 85 | 86 | val bool : bool dom 87 | (** [bool] is a domain for [bool] values. *) 88 | 89 | val int : int dom 90 | (** [int] is a domain for [int] values. *) 91 | 92 | val float : float dom 93 | (** [float] is a domain for [float] values. *) 94 | 95 | val string : string dom 96 | (** [string] is a domain for [string] values. *) 97 | 98 | (** {1:poly Domains for polymorphic types} *) 99 | 100 | val pair : 'a dom -> 'b dom -> ('a * 'b) dom 101 | (** [pair fst snd] is a domain for pairs with first projection [fst] 102 | and second projection [snd]. *) 103 | 104 | val list : 'a dom -> 'a list dom 105 | (** [list el] is a domain for lists of type ['a]. *) 106 | end 107 | 108 | (** {1:terms Terms} *) 109 | 110 | type 'a term 111 | (** The type for terms denoting values of type ['a]. *) 112 | 113 | val pp_term : Format.formatter -> 'a term -> unit 114 | (** [pp_term ppf t] prints an unspecified representation of [t] on [ppf]. *) 115 | 116 | (** {2:csts Constants} *) 117 | 118 | val const : 'a dom -> 'a -> 'a term 119 | (** [const dom v] is a term for the constant [v] in domain [dom]. Two 120 | constants of the same type with {{!Dom.equal}different} domains 121 | never unify. *) 122 | 123 | val unit : unit term 124 | (** [unit] is [const Dom.unit ()]. *) 125 | 126 | val bool : bool -> bool term 127 | (** [bool b] is [const Dom.bool b]. *) 128 | 129 | val int : int -> int term 130 | (** [int i] is [const Dom.int i] *) 131 | 132 | val float : float -> float term 133 | (** [float f] is [const Dom.float f]. *) 134 | 135 | val string : string -> string term 136 | (** [string s] is [const Dom.string s]. *) 137 | 138 | (** {2:fapp Function applications (constructors)} 139 | 140 | Two terms that represent function applications unify if 141 | the functions are physically equal, if each of their argument 142 | unifies and if the application's return values are in the 143 | same domain. *) 144 | 145 | type 'a ret 146 | (** The type for function applications returning values of type ['a]. *) 147 | 148 | val pure : 'a -> 'a ret 149 | (** [pure f] is the application that yields [f] itself. *) 150 | 151 | val app : 'a dom -> 'a term -> ('a -> 'b) ret -> 'b ret 152 | (** [app d t ret] is the application of term [t] interpreted in domain [d] 153 | to the function returned by [ret]. *) 154 | 155 | val ret : 'b dom -> 'b ret -> 'b term 156 | (** [ret d app] is a term that interprets the application [app] in 157 | domain [d] and returns a term representing the function application. *) 158 | 159 | (** {2:ptypes Polymorphic types} *) 160 | 161 | val pair : 162 | 'a dom -> 'b dom -> ('a * 'b) dom -> 'a term -> 'b term -> ('a * 'b) term 163 | (** [pair dom fst snd] is a pair for [fst] and [snd] in [dom]. *) 164 | 165 | (** {1 Goals} *) 166 | 167 | type goal 168 | (** The type for goals. In a given state a goal either {e succeeds} or 169 | {e fails}. *) 170 | 171 | val fail : goal 172 | (** [fail] is a goal that always fails. *) 173 | 174 | val succeed : goal 175 | (** [succeed] is a goal that always succeeds. *) 176 | 177 | val ( = ) : 'a term -> 'a term -> goal 178 | (** [t0 = t1] is a goal that succeeds iff there is a unifier for [t0] and 179 | [t1]. The unifier becomes part of the state. *) 180 | 181 | val ( || ) : goal -> goal -> goal 182 | (** [g0 || g1] is a goal that succeeds if either [g0] or [g1] succeeds. *) 183 | 184 | val ( && ) : goal -> goal -> goal 185 | (** [g0 && g1] is a goal succeeds if both [g0] and [g1] succeed. *) 186 | 187 | val delay : goal Lazy.t -> goal 188 | (** [delay gazy] sees the lazy goal [gazy] as a goal. *) 189 | 190 | val fresh : ('a term -> goal) -> goal 191 | (** [fresh f] is the goal [f v] with [v] a fresh logical variable. *) 192 | 193 | (** Multiple freshness introduction. *) 194 | module Fresh : sig 195 | 196 | (** {1 Fresh} *) 197 | 198 | val v1 : ('a term -> goal) -> goal 199 | val v2 : ('a term -> 'b term -> goal) -> goal 200 | val v3 : ('a term -> 'b term -> 'c term -> goal) -> goal 201 | val v4 : ('a term -> 'b term -> 'c term -> 'd term -> goal) -> goal 202 | val v5 : ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> goal) -> goal 203 | val v6 : 204 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'f term -> goal) -> 205 | goal 206 | end 207 | 208 | (** {1 Reification} *) 209 | 210 | type 'a seq 211 | (** The type for (possibly infinite) sequences of values of type ['a]. *) 212 | 213 | (** Sequences of values. *) 214 | module Seq : sig 215 | 216 | (** {1 Sequences} *) 217 | 218 | type 'a t = 'a seq 219 | (** See {!seq}. *) 220 | 221 | val empty : 'a seq 222 | (** [empty] is the empty sequence. *) 223 | 224 | val is_empty : 'a seq -> bool 225 | (** [is_empty s] is true iff [s] is {!empty}. *) 226 | 227 | val head : 'a seq -> 'a option 228 | (** [head s] is [s]'s head (if any). *) 229 | 230 | val get_head : 'a seq -> 'a 231 | (** [get_head s] is like {!head} but @raise Invalid_argument if 232 | if [s] is {!empty}. *) 233 | 234 | val tail : 'a seq -> 'a seq 235 | (** [tail s] is [s]'s tail. 236 | 237 | @raise Invalid_argument if [s] is empty. *) 238 | 239 | val to_list : ?limit:int -> 'a seq -> 'a list 240 | (** [to_list ~limit s] is, at most, the first [limit] elements of [s]. 241 | If [limit] is unspecified it is unbounded. *) 242 | end 243 | 244 | type 'a value 245 | (** The type for representing the value of a variable of type ['a] in 246 | a given state. *) 247 | 248 | (** Variable values. *) 249 | module Value : sig 250 | 251 | type 'a t = 'a value 252 | (** See {!value}. *) 253 | 254 | val name : 'a value -> string 255 | (** [name v] is [v]'s name. See {!query}. *) 256 | 257 | val find : 'a value -> 'a option 258 | (** [find v] is [v]'s value, if any. *) 259 | 260 | val get : 'a value -> 'a 261 | (** [get v] is like {!find} but @raise Invalid_argument if [v] is 262 | undefined. *) 263 | 264 | val term : 'a value -> 'a term 265 | (** [term v] is [v]'s defining term. *) 266 | 267 | val pp : Format.formatter -> 'a value -> unit 268 | (** [pp ppf v] prints, if it exists, [v]'s value using the value's domain 269 | {{!Dom.pp_value}pretty-printer}. Otherwise it prints [v]'s {{!term} 270 | defining term}. *) 271 | 272 | (** {1:gets Multiple value [get]s as tuples} *) 273 | 274 | val get1 : 'a value -> 'a 275 | val get2 : 'a value -> 'b value -> 'a * 'b 276 | val get3 : 'a value -> 'b value -> 'c value -> 'a * 'b * 'c 277 | val get4 : 'a value -> 'b value -> 'c value -> 'd value -> 'a * 'b * 'c * 'd 278 | val get5 : 279 | 'a value -> 'b value -> 'c value -> 'd value -> 'e value -> 280 | 'a * 'b * 'c * 'd * 'e 281 | val get6 : 282 | 'a value -> 'b value -> 'c value -> 'd value -> 'e value -> 'f value -> 283 | 'a * 'b * 'c * 'd * 'e * 'f 284 | 285 | (** {1:finds Multiple value [find]s as tuples} *) 286 | 287 | val find1 : 'a value -> 'a option 288 | val find2 : 'a value -> 'b value -> 'a option * 'b option 289 | val find3 : 290 | 'a value -> 'b value -> 'c value -> 'a option * 'b option * 'c option 291 | 292 | val find4 : 293 | 'a value -> 'b value -> 'c value -> 'd value -> 294 | 'a option * 'b option * 'c option * 'd option 295 | 296 | val find5 : 297 | 'a value -> 'b value -> 'c value -> 'd value -> 'e value -> 298 | 'a option * 'b option * 'c option * 'd option * 'e option 299 | 300 | val find6 : 301 | 'a value -> 'b value -> 'c value -> 'd value -> 'e value -> 'f value -> 302 | 'a option * 'b option * 'c option * 'd option * 'e option * 'f option 303 | end 304 | 305 | type ('q, 'r) reifier 306 | (** The type for reifiers. The type ['q] is the query to reify, 307 | the type ['r] is the state reifying function applied on each state. *) 308 | 309 | val reifier : 'q -> 'r -> ('q, 'r) reifier 310 | (** [reifier q f] reifies the query [q] with reifying function [f]. *) 311 | 312 | val query : 313 | ?name:string -> ('a term -> 'q, 'a value -> 'r) reifier -> ('q, 'r) reifier 314 | (** [query ~name r] introduces a logical query variable in [r]'s query and 315 | binds its value in the state reyifing function. [name] can be 316 | used to name the value. *) 317 | 318 | (** Multiple query introduction. *) 319 | module Query : sig 320 | 321 | (** {1 Query} *) 322 | 323 | val v1 : 324 | ?n0:string -> ('a term -> 'q, 'a value -> 'r) reifier -> ('q, 'r) reifier 325 | 326 | val v2 : 327 | ?n0:string -> ?n1:string -> 328 | ('a term -> 'b term -> 'q, 329 | 'a value -> 'b value -> 'r) reifier -> ('q, 'r) reifier 330 | 331 | val v3 : 332 | ?n0:string -> ?n1:string -> ?n2:string -> 333 | ('a term -> 'b term -> 'c term -> 'q, 334 | 'a value -> 'b value -> 'c value -> 'r) reifier -> ('q, 'r) reifier 335 | 336 | val v4 : 337 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> 338 | ('a term -> 'b term -> 'c term -> 'd term -> 'q, 339 | 'a value -> 'b value -> 'c value -> 'd value -> 'r) reifier -> 340 | ('q, 'r) reifier 341 | 342 | val v5 : 343 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> ?n4:string -> 344 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'q, 345 | 'a value -> 'b value -> 'c value -> 'd value -> 'e value -> 'r) reifier -> 346 | ('q, 'r) reifier 347 | 348 | val v6 : 349 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> ?n4:string -> 350 | ?n5:string -> 351 | ('a term -> 'b term -> 'c term -> 'd term -> 'c term -> 'f term -> 'q, 352 | 'a value -> 'b value -> 'c value -> 'd value -> 'c value -> 'f value ->'r) 353 | reifier -> ('q, 'r) reifier 354 | end 355 | 356 | (** Quick reification. 357 | 358 | A few functions that precompose {!Query} and {!Value} functions 359 | into reifiers. *) 360 | module Reifier : sig 361 | 362 | (** {1:gets {!Value.get} reifiers} *) 363 | 364 | val get1 : ?n0:string -> ('a term -> goal) -> (goal, 'a) reifier 365 | (** [get1 ?n0 q] is [Query.v1 ?n0 (reifier q Value.get1)] *) 366 | 367 | val get2 : 368 | ?n0:string -> ?n1:string -> ('a term -> 'b term -> goal) -> 369 | (goal, 'a * 'b) reifier 370 | (** See {!get1}. *) 371 | 372 | val get3 : 373 | ?n0:string -> ?n1:string -> ?n2:string -> 374 | ('a term -> 'b term -> 'c term -> goal) -> (goal, 'a * 'b * 'c) reifier 375 | (** See {!get1}. *) 376 | 377 | val get4 : 378 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> 379 | ('a term -> 'b term -> 'c term -> 'd term -> goal) -> 380 | (goal, 'a * 'b * 'c * 'd) reifier 381 | (** See {!get1}. *) 382 | 383 | val get5 : 384 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> ?n4:string -> 385 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> goal) -> 386 | (goal, 'a * 'b * 'c * 'd * 'e) reifier 387 | (** See {!get1}. *) 388 | 389 | val get6 : 390 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> ?n4:string -> 391 | ?n5:string -> 392 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'f term -> goal) -> 393 | (goal, 'a * 'b * 'c * 'd * 'e * 'f) reifier 394 | (** See {!get1}. *) 395 | 396 | (** {1:finds {!Value.find} reifiers} *) 397 | 398 | val find1 : ?n0:string -> ('a term -> goal) -> (goal, 'a option) reifier 399 | (** [find1 ?n0 q] is [Query.v1 ?n0 (reifier q Value.find1)] *) 400 | 401 | val find2 : 402 | ?n0:string -> ?n1:string -> ('a term -> 'b term -> goal) -> 403 | (goal, 'a option * 'b option) reifier 404 | (** See {!find1}. *) 405 | 406 | val find3 : 407 | ?n0:string -> ?n1:string -> ?n2:string -> 408 | ('a term -> 'b term -> 'c term -> goal) -> 409 | (goal, 'a option * 'b option * 'c option) reifier 410 | (** See {!find1}. *) 411 | 412 | val find4 : 413 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> 414 | ('a term -> 'b term -> 'c term -> 'd term -> goal) -> 415 | (goal, 'a option * 'b option * 'c option * 'd option) reifier 416 | (** See {!find1}. *) 417 | 418 | val find5 : 419 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> ?n4:string -> 420 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> goal) -> 421 | (goal, 'a option * 'b option * 'c option * 'd option * 'e option) reifier 422 | (** See {!find1}. *) 423 | 424 | val find6 : 425 | ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> ?n4:string -> 426 | ?n5:string -> 427 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'f term -> goal) -> 428 | (goal, 429 | 'a option * 'b option * 'c option * 'd option * 'e option * 'f option) 430 | reifier 431 | (** See {!find1}. *) 432 | end 433 | 434 | val run : (goal, 'r) reifier -> 'r Seq.t 435 | (** [run r] is the sequence of states reified by [r]'s reifying 436 | function and obtained by running [r]'s query on the empty 437 | state. *) 438 | 439 | (** Quick runs. 440 | 441 | A few convenience functions for running queries to lists. *) 442 | module Run : sig 443 | 444 | (** {1:gets {!Value.get} reifications} *) 445 | 446 | val get1 : ?limit:int -> ('a term -> goal) -> 'a list 447 | (** [get1 ?limit q] is [Seq.to_list ?limit @@ run (Reifier.get1 q)]. *) 448 | 449 | val get2 : ?limit:int -> ('a term -> 'b term -> goal) -> ('a * 'b) list 450 | (** See {!get1}. *) 451 | 452 | val get3 : 453 | ?limit:int -> ('a term -> 'b term -> 'c term -> goal) -> ('a * 'b * 'c) list 454 | (** See {!get1}. *) 455 | 456 | val get4 : 457 | ?limit:int -> ('a term -> 'b term -> 'c term -> 'd term -> goal) -> 458 | ('a * 'b * 'c * 'd) list 459 | (** See {!get1}. *) 460 | 461 | val get5 : 462 | ?limit:int -> 463 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> goal) -> 464 | ('a * 'b * 'c * 'd * 'e) list 465 | (** See {!get1}. *) 466 | 467 | val get6 : 468 | ?limit:int -> 469 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'f term -> goal) -> 470 | ('a * 'b * 'c * 'd * 'e * 'f) list 471 | (** See {!get1}. *) 472 | 473 | (** {1:finds {!Value.find} reifications} *) 474 | 475 | val find1 : ?limit:int -> ('a term -> goal) -> 'a option list 476 | (** [find1 ?limit q] is [Seq.to_list ?limit @@ run (Reifier.find1 q)] *) 477 | 478 | val find2 : 479 | ?limit:int -> ('a term -> 'b term -> goal) -> ('a option * 'b option) list 480 | (** See {!find1}. *) 481 | 482 | val find3 : 483 | ?limit:int -> ('a term -> 'b term -> 'c term -> goal) -> 484 | ('a option * 'b option * 'c option) list 485 | (** See {!find1}. *) 486 | 487 | val find4 : 488 | ?limit:int -> 489 | ('a term -> 'b term -> 'c term -> 'd term -> goal) -> 490 | ('a option * 'b option * 'c option * 'd option) list 491 | (** See {!find1}. *) 492 | 493 | val find5 : 494 | ?limit:int -> 495 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> goal) -> 496 | ('a option * 'b option * 'c option * 'd option * 'e option) list 497 | (** See {!find1}. *) 498 | 499 | val find6 : 500 | ?limit:int -> 501 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'f term -> goal) -> 502 | ('a option * 'b option * 'c option * 'd option * 'e option * 'f option) list 503 | (** See {!find1}. *) 504 | end 505 | 506 | val success : goal -> bool 507 | (** [success g] is [true] iff [g] succeeds on the empty state. *) 508 | 509 | (** {1:state State introspection} *) 510 | 511 | type state 512 | (** The type for states. *) 513 | 514 | val pp_state : Format.formatter -> state -> unit 515 | (** [pp_state ppf st] prints an unspecified representation of [st] on 516 | [ppf]. *) 517 | 518 | val states : (goal, 'r) reifier -> state Seq.t 519 | (** [states r] is like {!run} but returns the sequence of unreified 520 | states. *) 521 | 522 | val inspect : ?limit:int -> (goal, 'r) reifier -> state list 523 | (** [inspect ~limit r] is [Seq.to_list ~limit (states r)]. *) 524 | 525 | (** Quick inspection 526 | 527 | A few functions that inspect states using precomposed 528 | {{!Reifier.finds}find reifiers}. *) 529 | module Inspect : sig 530 | 531 | (** {1 Inspection} *) 532 | 533 | val v1 : ?limit:int -> ?n0:string -> ('a term -> goal) -> state list 534 | (** [v1 ?limit ?n0 q] is [inspect ?limit (Reifier.find1 ?n0 q)] *) 535 | 536 | val v2 : 537 | ?limit:int -> ?n0:string -> ?n1:string -> ('a term -> 'b term -> goal) -> 538 | state list 539 | (** [v2 ?limit ?n0 ?n1 q] is [inspect ?limit (Reifier.find2 ?n0 ?n1 q)] *) 540 | 541 | val v3 : 542 | ?limit:int -> ?n0:string -> ?n1:string -> ?n2:string -> 543 | ('a term -> 'b term -> 'c term -> goal) -> state list 544 | (** [v3 ?limit ?n0 ?n1 ?n2 q] is 545 | [inspect ?limit (Reifier.find3 ?n0 ?n1 ?n2 q)]. *) 546 | 547 | val v4 : 548 | ?limit:int -> ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> 549 | ('a term -> 'b term -> 'c term -> 'd term -> goal) -> state list 550 | (** [v4 ?limit ?n0 ?n1 ?n2 ?n3 q] is 551 | [inspect ?limit (Reifier.find4 ?n0 ?n1 ?n2 ?n3 q)]. *) 552 | 553 | val v5 : 554 | ?limit:int -> ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> 555 | ?n4:string -> 556 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> goal) -> state list 557 | (** [v5 ?limit ?n0 ?n1 ?n2 ?n3 ?n4 q] is 558 | [inspect ?limit (Reifier.find5 ?n0 ?n1 ?n2 ?n3 ?n4 q)]. *) 559 | 560 | val v6 : 561 | ?limit:int -> ?n0:string -> ?n1:string -> ?n2:string -> ?n3:string -> 562 | ?n4:string -> ?n5:string -> 563 | ('a term -> 'b term -> 'c term -> 'd term -> 'e term -> 'f term -> goal) -> 564 | state list 565 | (** [v5 ?limit ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 q] is 566 | [inspect ?limit (Reifier.find6 ?n0 ?n1 ?n2 ?n3 ?n4 ?n5 q)]. *) 567 | end 568 | 569 | (** {1:basics Basics} 570 | 571 | Fixme explain terms, goals, unification, recursion through delay and 572 | reification. 573 | 574 | {[ 575 | let q x = Rel.(x = int 5) 576 | let xs = Rel.(Seq.to_list @@ run @@ Query.v1 @@ reifier q Value.get1) 577 | let () = assert (xs = [5]) 578 | ]} 579 | 580 | {[ 581 | let q x y = Rel.(y = int 6 && (x = y || x = int 5)) 582 | let xys = Rel.(Seq.to_list @@ run @@ Query.v2 @@ reifier q Value.get2) 583 | let () = assert (xys = [(6, 6); (5, 6)]) 584 | ]} 585 | 586 | {2:func Unifying function applications (constructors)} 587 | 588 | Represent lists in the term language: 589 | {[ 590 | let intl = Rel.Dom.(list int) 591 | 592 | let empty = Rel.const intl [] 593 | let cons x xs = Rel.(pure List.cons |> app Dom.int x |> app intl xs |> ret intl) 594 | 595 | let rec ilist = function [] -> empty | i :: is -> cons (Rel.int i) (ilist is) 596 | ]} 597 | 598 | Unify lists: 599 | {[ 600 | let l x xs = Rel.(cons x xs = ilist [1;2;3]) in 601 | let ls = Rel.(Seq.to_list @@ run @@ Query.v2 @@ reifier l Value.get2) 602 | let () = assert (ls = [(1;[2;3])] 603 | ]} 604 | 605 | Relational append. Express a predicate [appendo l0 l1 l] that asserts 606 | [l] is the concatenation of [l1] to [l0]. 607 | {[ 608 | let rec appendo l0 l1 l = 609 | let open Rel in 610 | (l0 = empty && l1 = l) || 611 | (Fresh.v3 @@ fun x xs tl -> 612 | cons x xs = l0 && 613 | cons x tl = l && 614 | delay @@ lazy (appendo xs l1 tl)) 615 | ]} 616 | 617 | Find all lists that appended together give the list [[1;2;3]]: 618 | {[ 619 | let q l0 l1 = appendo l0 l1 (ilist [1;2;3]) 620 | let l01s = Rel.(Seq.to_list @@ run @@ Query.v2 @@ reifier q Value.get2) 621 | let () = assert (l01s = 622 | [([], [1;2;3]); 623 | ([1], [2;3]); 624 | ([1;2], [3]); 625 | ([1;2;3], [])]) 626 | ]} 627 | *) 628 | 629 | (*--------------------------------------------------------------------------- 630 | Copyright (c) 2017 Daniel C. Bünzli 631 | 632 | Permission to use, copy, modify, and/or distribute this software for any 633 | purpose with or without fee is hereby granted, provided that the above 634 | copyright notice and this permission notice appear in all copies. 635 | 636 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 637 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 638 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 639 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 640 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 641 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 642 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 643 | ---------------------------------------------------------------------------*) 644 | -------------------------------------------------------------------------------- /src/trel.mllib: -------------------------------------------------------------------------------- 1 | Trel 2 | Trel_list 3 | -------------------------------------------------------------------------------- /src/trel_list.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | module type ELT = sig 8 | type t 9 | val dom : t Trel.dom 10 | end 11 | 12 | module Make_elt (V : Trel.Dom.V) = struct 13 | type t = V.t 14 | let dom = Trel.Dom.of_type (module V) 15 | end 16 | 17 | module Make (Elt : ELT) = struct 18 | 19 | type t = Elt.t list Trel.term 20 | type elt = Elt.t Trel.term 21 | let dom = Trel.Dom.list Elt.dom 22 | 23 | (* Term constructors *) 24 | 25 | let empty = Trel.const dom [] 26 | let cons x xs = Trel.(pure List.cons |> app Elt.dom x |> app dom xs |> ret dom) 27 | 28 | let rec v = function (* not T.R. *) 29 | | [] -> empty 30 | | x :: xs -> cons (Trel.const Elt.dom x) (v xs) 31 | 32 | (* Trelational operations *) 33 | 34 | let is_empty l = Trel.(l = empty) 35 | let hd l x = Trel.(fresh @@ fun xs -> cons x xs = l) 36 | let tl l xs = Trel.(fresh @@ fun x -> cons x xs = l) 37 | let rec mem x l = 38 | let open Trel in 39 | hd l x || Fresh.v1 @@ fun t -> tl l t && delay (lazy (mem x t)) 40 | 41 | let rec append l0 l1 l = 42 | let open Trel in 43 | (l0 = empty && l1 = l) || 44 | (Fresh.v3 @@ fun x xs ltl -> 45 | cons x xs = l0 && 46 | cons x ltl = l && 47 | delay @@ lazy (append xs l1 ltl)) 48 | 49 | let rec rev l r = 50 | let open Trel in 51 | (l = empty && r = empty) || 52 | (Fresh.v3 @@ fun x xs rt -> 53 | cons x xs = l && 54 | append rt (cons x empty) r && 55 | delay @@ lazy (rev xs rt)) 56 | end 57 | 58 | (*--------------------------------------------------------------------------- 59 | Copyright (c) 2017 Daniel C. Bünzli 60 | 61 | Permission to use, copy, modify, and/or distribute this software for any 62 | purpose with or without fee is hereby granted, provided that the above 63 | copyright notice and this permission notice appear in all copies. 64 | 65 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 66 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 67 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 68 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 69 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 70 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 71 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 72 | ---------------------------------------------------------------------------*) 73 | -------------------------------------------------------------------------------- /src/trel_list.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (** Relational lists *) 8 | 9 | (** {1 Lists} *) 10 | 11 | (** The type for list elements *) 12 | module type ELT = sig 13 | type t 14 | (** The type of list elements. *) 15 | 16 | val dom : t Trel.dom 17 | (** The domain of list elements. *) 18 | end 19 | 20 | (** [Make_elt (V)] are list elements from the domainable module [V]. *) 21 | module Make_elt (V : Trel.Dom.V) : ELT with type t = V.t 22 | 23 | (** [Make (E)] is a module for relational lists with elements of type [E]. *) 24 | module Make (Elt : ELT) : sig 25 | 26 | (** {1 Relational lists} *) 27 | 28 | type t = Elt.t list Trel.term 29 | (** The type for relational lists. *) 30 | 31 | type elt = Elt.t Trel.term 32 | (** The type for relational list elements. *) 33 | 34 | val dom : Elt.t list Trel.dom 35 | 36 | (** {1 Term constructors} *) 37 | 38 | val empty : t 39 | (** [empty] is the empty list. *) 40 | 41 | val cons : elt -> t -> t 42 | (** [cons x xs] is the list [x :: xs]. *) 43 | 44 | val v : Elt.t list -> t 45 | (** [v l] is [l] as a relational list. *) 46 | 47 | (** {1 Goals} *) 48 | 49 | val is_empty : t -> Trel.goal 50 | (** [is_empty l] is [Trel.(empty = l)]. *) 51 | 52 | val mem : elt -> t -> Trel.goal 53 | (** [mem e l] succeeds if [e] is a member of [l]. *) 54 | 55 | val hd : t -> elt -> Trel.goal 56 | (** [hd l x] succeeds if [x] is the head of [l]. *) 57 | 58 | val tl : t -> t -> Trel.goal 59 | (** [tl l xs] succeeds if [xs] is the tail of [l]. *) 60 | 61 | val append : t -> t -> t -> Trel.goal 62 | (** [append l0 l1 l] succeeds if [l1] appended to [l0] is [l]. *) 63 | 64 | val rev : t -> t -> Trel.goal 65 | (** [rev l r] succeeds if [r] is the reverse list of [l]. *) 66 | end 67 | 68 | (*--------------------------------------------------------------------------- 69 | Copyright (c) 2017 Daniel C. Bünzli 70 | 71 | Permission to use, copy, modify, and/or distribute this software for any 72 | purpose with or without fee is hereby granted, provided that the above 73 | copyright notice and this permission notice appear in all copies. 74 | 75 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 76 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 77 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 78 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 79 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 80 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 81 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 82 | ---------------------------------------------------------------------------*) 83 | -------------------------------------------------------------------------------- /src/trel_top.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let () = ignore (Toploop.use_file Format.err_formatter "rel_top_init.ml") 8 | 9 | (*--------------------------------------------------------------------------- 10 | Copyright (c) 2017 Daniel C. Bünzli 11 | 12 | Permission to use, copy, modify, and/or distribute this software for any 13 | purpose with or without fee is hereby granted, provided that the above 14 | copyright notice and this permission notice appear in all copies. 15 | 16 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 17 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 19 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 20 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 21 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 22 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 23 | ---------------------------------------------------------------------------*) 24 | -------------------------------------------------------------------------------- /src/trel_top.mllib: -------------------------------------------------------------------------------- 1 | Trel_top -------------------------------------------------------------------------------- /src/trel_top_init.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | #install_printer Trel.Dom.pp;; 8 | #install_printer Trel.pp_term;; 9 | #install_printer Trel.pp_state;; 10 | 11 | (*--------------------------------------------------------------------------- 12 | Copyright (c) 2017 Daniel C. Bünzli 13 | 14 | Permission to use, copy, modify, and/or distribute this software for any 15 | purpose with or without fee is hereby granted, provided that the above 16 | copyright notice and this permission notice appear in all copies. 17 | 18 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 19 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 20 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 21 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 22 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 23 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 24 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 25 | ---------------------------------------------------------------------------*) 26 | -------------------------------------------------------------------------------- /test/examples.ml: -------------------------------------------------------------------------------- 1 | (* These examples are in the public domain *) 2 | 3 | 4 | let q x = Trel.(x = int 5) 5 | let xs = Trel.(Seq.to_list @@ run @@ Query.v1 @@ reifier q Value.get1) 6 | let () = assert (xs = [5]) 7 | 8 | let q x y = Trel.(y = int 6 && (x = y || x = int 5)) 9 | let xys = Trel.(Seq.to_list @@ run @@ Query.v2 @@ reifier q Value.get2) 10 | let () = assert (xys = [(6, 6); (5, 6)]) 11 | 12 | (* int lists *) 13 | 14 | let intl = Trel.Dom.(list int) 15 | 16 | let empty = Trel.const intl [] 17 | let cons x xs = Trel.(pure List.cons |> app Dom.int x |> app intl xs |> ret intl) 18 | 19 | let rec ilist = function [] -> empty | i :: is -> cons (Trel.int i) (ilist is) 20 | 21 | let l x xs = Trel.(cons x xs = ilist [1;2;3]) 22 | let ls = Trel.(Seq.to_list @@ run @@ Query.v2 @@ reifier l Value.get2) 23 | let () = assert (ls = [(1, [2;3])]) 24 | 25 | (* Trelational append *) 26 | 27 | let rec appendo l0 l1 l = 28 | let open Trel in 29 | (l0 = empty && l1 = l) || 30 | (Fresh.v3 @@ fun x xs tl -> 31 | cons x xs = l0 && 32 | cons x tl = l && 33 | delay @@ lazy (appendo xs l1 tl)) 34 | -------------------------------------------------------------------------------- /test/mk.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Straightforward minimal typed implementation of μKanren. The term language 8 | is typed and extensible by the client. 9 | 10 | Domain specifications are on function applications and return 11 | values. It seems much more convenient than having them on variables 12 | (this would mean type fresh variable introductions) and return values. 13 | 14 | Jason Hemann and Daniel P. Friedman. 15 | microKanren: A Minimal Functional Core for Relational Programming. 16 | In Proceedings of the 2013 Workshop on Scheme and Functional Programming 17 | (Scheme '13), Alexandria, VA, 2013. *) 18 | 19 | (* Lazy sequences of values *) 20 | 21 | type 'a seq = Empty | Cons of 'a * 'a seq | Delay of 'a seq Lazy.t 22 | 23 | let seq_to_list ?limit s = 24 | let limit = match limit with 25 | | Some l when l < 0 -> invalid_arg (Printf.sprintf "negative limit (%d)" l) 26 | | Some l -> l 27 | | None -> -1 28 | in 29 | let rec loop limit acc s = match limit = 0 with 30 | | true -> List.rev acc 31 | | false -> 32 | match s with 33 | | Empty -> List.rev acc 34 | | Delay s -> loop limit acc (Lazy.force s) 35 | | Cons (v, s) -> 36 | let limit = if limit = -1 then limit else limit - 1 in 37 | loop limit (v :: acc) s 38 | in 39 | loop limit [] s 40 | 41 | let rec seq_mplus s0 s1 = match s0 with 42 | | Empty -> s1 43 | | Cons (x, xs) -> Cons (x, Delay (lazy (seq_mplus s1 xs))) 44 | | Delay xs -> 45 | match s1 with 46 | | Empty -> s0 47 | | Cons (y, ys) -> Cons (y, Delay (lazy (seq_mplus (Lazy.force xs) ys))) 48 | | Delay ys -> Delay (lazy (seq_mplus (Lazy.force xs) s1)) 49 | 50 | let rec seq_bind s f = match s with 51 | | Empty -> Empty 52 | | Cons (x, xs) -> seq_mplus (f x) (Delay (lazy ((seq_bind xs f)))) 53 | | Delay xs -> Delay (lazy (seq_bind (Lazy.force xs) f)) 54 | 55 | let rec seq_map f s = match s with 56 | | Empty -> Empty 57 | | Cons (x, xs) -> Cons (f x, seq_map f xs) 58 | | Delay xs -> Delay (lazy (seq_map f (Lazy.force xs))) 59 | 60 | (* Type identifiers *) 61 | 62 | module Tid = struct type _ t = .. end 63 | module type Tid = sig 64 | type t 65 | type _ Tid.t += Tid : t Tid.t 66 | end 67 | type 'a tid = (module Tid with type t = 'a) 68 | 69 | let tid () (type s) = 70 | let module M = struct 71 | type t = s 72 | type _ Tid.t += Tid : t Tid.t 73 | end 74 | in 75 | (module M : Tid with type t = s) 76 | 77 | type ('a, 'b) teq = Teq : ('a, 'a) teq 78 | 79 | let teq : type r s. r tid -> s tid -> (r, s) teq option = 80 | fun r s -> 81 | let module R = (val r : Tid with type t = r) in 82 | let module S = (val s : Tid with type t = s) in 83 | match R.Tid with 84 | | S.Tid -> Some Teq 85 | | _ -> None 86 | 87 | (* Domains *) 88 | 89 | type 'a dom = { tid : 'a tid; equal : 'a -> 'a -> bool; } 90 | let dom ~equal = { tid = tid (); equal } 91 | 92 | (* Variables *) 93 | 94 | type 'a var = { id : int; tid : 'a tid; } 95 | 96 | module Var = struct 97 | type t = V : 'a var -> t 98 | let compare (V v0) (V v1) = (compare : int -> int -> int) v0.id v1.id 99 | end 100 | 101 | module Vmap = Map.Make (Var) 102 | 103 | (* Terms *) 104 | 105 | type 'a term = 106 | | Var of 'a var 107 | | Ret of 'a dom * 'a ret 108 | 109 | and 'a ret = 110 | | App : ('a -> 'b) ret * 'a dom * 'a term -> 'b ret 111 | | Pure : 'a -> 'a ret 112 | 113 | let var id = Var { id; tid = tid () } 114 | let const dom v = Ret (dom, Pure v) 115 | let pure f = Pure f 116 | let app dom v ret = App (ret, dom, v) 117 | let ret dom ret = Ret (dom, ret) 118 | 119 | (* Substitutions *) 120 | 121 | type binding = B : 'a var * 'a term -> binding 122 | type subst = binding Vmap.t 123 | 124 | let subst_empty = Vmap.empty 125 | let subst_add var t s = Vmap.add (Var.V var) (B (var, t)) s 126 | let subst_find : type a. a var -> subst -> a term option = fun v s -> 127 | try 128 | let B (v', t) = Vmap.find (Var.V v) s in 129 | match teq v.tid v'.tid with None -> None | Some Teq -> Some t 130 | with Not_found -> None 131 | 132 | (* Unification *) 133 | 134 | let rec walk t s = match t with 135 | | Var v -> (match subst_find v s with None -> t | Some v -> walk v s) 136 | | t -> t 137 | 138 | let rec unify : type a. a term -> a term -> subst -> subst option = 139 | fun t0 t1 s -> match walk t0 s, walk t1 s with 140 | | Var v0, Var v1 when v0.id = v1.id -> Some s 141 | | Var v, t | t, Var v -> Some (subst_add v t s) 142 | | Ret (d0, r0), Ret (d1, r1) -> 143 | if not (d0.tid == d1.tid) then None else 144 | match r0, r1 with 145 | | Pure v0, Pure v1 -> if d0.equal v0 v1 then Some s else None 146 | | App _, App _ -> unify_ret r0 r1 s 147 | | _, _ -> None 148 | 149 | and unify_ret : type a. a ret -> a ret -> subst -> subst option = 150 | fun r0 r1 s -> match r0, r1 with 151 | | App (f0, d0, v0), App (f1, d1, v1) -> 152 | begin match teq d0.tid d1.tid with 153 | | None -> None 154 | | Some Teq -> 155 | match unify v0 v1 s with 156 | | None -> None 157 | | Some s -> unify_ret f0 f1 s 158 | end 159 | | Pure f0, Pure f1 when f0 == f1 -> Some s 160 | | _, _ -> None 161 | 162 | (* State *) 163 | 164 | type state = { next_vid : int; subst : subst } 165 | let state_empty = { next_vid = 0; subst = subst_empty } 166 | 167 | (* Goals *) 168 | 169 | type goal = state -> state seq 170 | 171 | let fail _ = Empty 172 | let succeed st = Cons (st, Empty) 173 | 174 | let ( = ) t0 t1 st = match unify t0 t1 st.subst with 175 | | None -> Empty 176 | | Some subst -> succeed { st with subst } 177 | 178 | let fresh lambda st = 179 | let var = var st.next_vid in 180 | lambda var { st with next_vid = st.next_vid + 1 } 181 | 182 | let ( || ) g0 g1 st = seq_mplus (g0 st) (g1 st) 183 | let ( && ) g0 g1 st = seq_bind (g0 st) g1 184 | let delay gazy st = Delay (lazy ((Lazy.force gazy) st)) 185 | 186 | (* Reification *) 187 | 188 | let term_value t s = 189 | let rec term_value : type a. a term -> subst -> a = 190 | fun t s -> match t with 191 | | Ret (d, t) -> ret_value t s 192 | | Var v -> 193 | match subst_find v s with 194 | | Some t -> term_value t s 195 | | None -> raise Exit 196 | and ret_value : type a. a ret -> subst -> a = 197 | fun r s -> match r with 198 | | Pure v -> v 199 | | App (f, _, v) -> (ret_value f s) (term_value v s) 200 | in 201 | try Some (term_value t s) with Exit -> None 202 | 203 | type 'a value = 'a term * subst 204 | 205 | let value_find (var, subst) = term_value var subst 206 | let value_get (var, subst) = match term_value var subst with 207 | | None -> invalid_arg "undefined value" 208 | | Some v -> v 209 | 210 | type ('q, 'r) reifier = { next_vid : int; query : 'q; reify : state -> 'r } 211 | 212 | let reifier query reify = { next_vid = 0; query; reify = (fun _ -> reify) } 213 | let query r = 214 | let var = var r.next_vid in 215 | let query = r.query var in 216 | let reify st = r.reify st (var, st.subst) in 217 | let next_vid = r.next_vid + 1 in 218 | { next_vid; query; reify } 219 | 220 | let run r = seq_map r.reify (r.query { state_empty with next_vid = r.next_vid }) 221 | 222 | (*--------------------------------------------------------------------------- 223 | Copyright (c) 2017 Daniel C. Bünzli 224 | 225 | Permission to use, copy, modify, and/or distribute this software for any 226 | purpose with or without fee is hereby granted, provided that the above 227 | copyright notice and this permission notice appear in all copies. 228 | 229 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 230 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 231 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 232 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 233 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 234 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 235 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 236 | ---------------------------------------------------------------------------*) 237 | -------------------------------------------------------------------------------- /test/mk.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Straightforward implementation of typed μKanren. *) 8 | 9 | (* Domains *) 10 | 11 | type 'a dom 12 | val dom : equal:('a -> 'a -> bool) -> 'a dom 13 | 14 | (* Terms *) 15 | 16 | type 'a term 17 | type 'a ret 18 | 19 | val const : 'a dom -> 'a -> 'a term 20 | val pure : 'a -> 'a ret 21 | val app : 'a dom -> 'a term -> ('a -> 'b) ret -> 'b ret 22 | val ret : 'a dom -> 'a ret -> 'a term 23 | 24 | (* Goals *) 25 | 26 | type goal 27 | 28 | val fail : goal 29 | val succeed : goal 30 | val ( = ) : 'a term -> 'a term -> goal 31 | val fresh : ('a term -> goal) -> goal 32 | val ( || ) : goal -> goal -> goal 33 | val ( && ) : goal -> goal -> goal 34 | val delay : goal Lazy.t -> goal 35 | 36 | (* Reification *) 37 | 38 | type 'a seq 39 | val seq_to_list : ?limit:int -> 'a seq -> 'a list 40 | 41 | type 'a value 42 | val value_find : 'a value -> 'a option 43 | val value_get : 'a value -> 'a 44 | 45 | type ('q, 'r) reifier 46 | 47 | val reifier : 'q -> 'r -> ('q, 'r) reifier 48 | val query : ('a term -> 'q, 'a value -> 'r) reifier -> ('q, 'r) reifier 49 | val run : (goal, 'a) reifier -> 'a seq 50 | 51 | (*--------------------------------------------------------------------------- 52 | Copyright (c) 2017 Daniel C. Bünzli 53 | 54 | Permission to use, copy, modify, and/or distribute this software for any 55 | purpose with or without fee is hereby granted, provided that the above 56 | copyright notice and this permission notice appear in all copies. 57 | 58 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 59 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 60 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 61 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 62 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 63 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 64 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 65 | ---------------------------------------------------------------------------*) 66 | -------------------------------------------------------------------------------- /test/mk_test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let assert_vals ?limit q vals = 8 | let q = Mk.(query @@ reifier q value_get) in 9 | assert (Mk.(seq_to_list ?limit @@ run q) = vals) 10 | 11 | let assert_find_vals ?limit q vals = 12 | let q = Mk.(query @@ reifier q value_find) in 13 | assert (Mk.(seq_to_list ?limit @@ run q) = vals) 14 | 15 | let assert_2vals ?limit q vals = 16 | let reify x y = Mk.(value_get x, value_get y) in 17 | let q = Mk.(query @@ query @@ reifier q reify) in 18 | assert (Mk.(seq_to_list ?limit @@ run q) = vals) 19 | 20 | let dint = Mk.dom ~equal:(( = ) : int -> int -> bool) 21 | let int = Mk.const dint 22 | 23 | let test_fair_disj () = 24 | let rec fivel x = Mk.(x = int 5 || delay @@ lazy (fivel x)) in 25 | let rec fiver x = Mk.(delay @@ lazy (fiver x) || x = int 5) in 26 | assert_vals ~limit:3 fivel [5;5;5]; 27 | assert_vals ~limit:3 fiver [5;5;5]; 28 | () 29 | 30 | let test_unfair_conj () = 31 | let rec faill x = Mk.(fail && delay @@ lazy (faill x)) in 32 | assert_find_vals ~limit:3 faill []; 33 | (* 34 | let rec failr x = Mk.(delay @@ lazy (failr x) && fail) in 35 | assert_find_vals ~limit:3 failr []; *) 36 | () 37 | 38 | let listo d dl = 39 | let empty = Mk.(const dl []) in 40 | let cons x xs = 41 | Mk.(pure (fun x xs -> x :: xs) |> app d x |> app dl xs |> ret dl) 42 | in 43 | let list l = List.fold_right (fun x xs -> cons (Mk.const d x) xs) l empty in 44 | let rec appendo l0 l1 l = 45 | let open Mk in 46 | (l0 = empty && l1 = l) || 47 | (fresh @@ fun x -> fresh @@ fun xs -> fresh @@ fun tl -> 48 | cons x xs = l0 && 49 | cons x tl = l && 50 | delay @@ lazy (appendo xs l1 tl)) 51 | in 52 | let rec revo l r = 53 | let open Mk in 54 | (l = empty && r = empty) || 55 | (fresh @@ fun x -> fresh @@ fun xs -> fresh @@ fun rt -> 56 | cons x xs = l && 57 | appendo rt (cons x empty) r && 58 | delay @@ lazy (revo xs rt)) 59 | in 60 | empty, cons, list, appendo, revo 61 | 62 | let dilist = Mk.dom ~equal:( = ) 63 | let iempty, icons, ilist, iappendo, irevo = listo dint dilist 64 | 65 | let test_match () = 66 | let m4tch x xs = Mk.(icons x xs = ilist [1;2;3]) in 67 | assert_2vals m4tch [(1, [2;3])]; 68 | () 69 | 70 | let test_appendo () = 71 | assert_vals (fun l -> iappendo l (ilist [3;4]) (ilist [1;2;3;4])) [[1;2]]; 72 | assert_vals (fun l -> iappendo (ilist [1;2]) l (ilist [1;2;3;4])) [[3;4]]; 73 | assert_vals (fun l -> iappendo (ilist [1;2]) (ilist [3;4]) l) [[1;2;3;4]]; 74 | assert_vals (fun l -> iappendo l (ilist [4]) (ilist [1;2;3])) []; 75 | () 76 | 77 | let test_appendo3 () = 78 | let a x y z o = Mk.(fresh @@ fun l -> iappendo x y l && iappendo l z o) in 79 | assert_vals (fun l -> a (ilist [1]) (ilist [2]) (ilist [3]) l) [[1;2;3]]; 80 | assert_vals (fun l -> a (ilist [1]) (ilist [2]) l (ilist [1;2;3])) [[3]]; 81 | assert_vals (fun l -> a (ilist [1]) l (ilist [3]) (ilist [1;2;3])) [[2]]; 82 | assert_vals ~limit:1 83 | (fun l -> a l (ilist [2]) (ilist [3]) (ilist [1;2;3])) [[1]]; 84 | () 85 | 86 | let test_pre_suf () = 87 | let pre l pre = Mk.(fresh @@ fun suf -> iappendo pre suf l) in 88 | let suf l suf = Mk.(fresh @@ fun pre -> iappendo pre suf l) in 89 | let pre_suf l pre suf = iappendo pre suf l in 90 | let l = ilist [1;2;3;4] in 91 | assert_vals (pre l) [[]; [1]; [1;2]; [1;2;3]; [1;2;3;4]]; 92 | assert_vals (suf l) [[1;2;3;4]; [2;3;4]; [3;4]; [4]; []]; 93 | assert_2vals (pre_suf l) 94 | [([], [1;2;3;4]); 95 | ([1], [2;3;4]); 96 | ([1;2], [3;4]); 97 | ([1;2;3], [4]); 98 | ([1;2;3;4], [])]; 99 | () 100 | 101 | let test_revo () = 102 | assert_vals ~limit:1 (fun r -> irevo (ilist [1;2;3]) r) [[3;2;1]]; 103 | assert_vals ~limit:1 (fun r -> irevo r (ilist [1;2;3])) [[3;2;1]]; 104 | () 105 | 106 | let test () = 107 | test_fair_disj (); 108 | test_unfair_conj (); 109 | test_match (); 110 | test_appendo (); 111 | test_appendo3 (); 112 | test_pre_suf (); 113 | test_revo (); 114 | print_endline "All Mk tests succeeded!"; 115 | () 116 | 117 | let () = test () 118 | 119 | (*--------------------------------------------------------------------------- 120 | Copyright (c) 2017 Daniel C. Bünzli 121 | 122 | Permission to use, copy, modify, and/or distribute this software for any 123 | purpose with or without fee is hereby granted, provided that the above 124 | copyright notice and this permission notice appear in all copies. 125 | 126 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 127 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 128 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 129 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 130 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 131 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 132 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 133 | ---------------------------------------------------------------------------*) 134 | -------------------------------------------------------------------------------- /test/mkv.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Straightforward minimal typed implementation of μKanren. Without 8 | bells and whistles, based on the untyped version described in: 9 | 10 | Jason Hemann and Daniel P. Friedman. 11 | microKanren: A Minimal Functional Core for Relational Programming. 12 | In Proceedings of the 2013 Workshop on Scheme and Functional Programming 13 | (Scheme '13), Alexandria, VA, 2013. *) 14 | 15 | (* Lazy sequences of values *) 16 | 17 | type 'a seq = Empty | Cons of 'a * 'a seq | Delay of 'a seq Lazy.t 18 | 19 | let seq_to_list ?limit s = 20 | let limit = match limit with 21 | | Some l when l < 0 -> invalid_arg (Printf.sprintf "negative limit (%d)" l) 22 | | Some l -> l 23 | | None -> -1 24 | in 25 | let rec loop limit acc s = match limit = 0 with 26 | | true -> List.rev acc 27 | | false -> 28 | match s with 29 | | Empty -> List.rev acc 30 | | Delay s -> loop limit acc (Lazy.force s) 31 | | Cons (v, s) -> 32 | let limit = if limit = -1 then limit else limit - 1 in 33 | loop limit (v :: acc) s 34 | in 35 | loop limit [] s 36 | 37 | let rec seq_mplus s0 s1 = match s0 with 38 | | Empty -> s1 39 | | Cons (x, xs) -> Cons (x, Delay (lazy (seq_mplus s1 xs))) 40 | | Delay xs -> 41 | match s1 with 42 | | Empty -> s0 43 | | Cons (y, ys) -> Cons (y, Delay (lazy (seq_mplus (Lazy.force xs) ys))) 44 | | Delay ys -> Delay (lazy (seq_mplus (Lazy.force xs) s1)) 45 | 46 | let rec seq_bind s f = match s with 47 | | Empty -> Empty 48 | | Cons (x, xs) -> seq_mplus (f x) (Delay (lazy (seq_bind xs f))) 49 | | Delay xs -> Delay (lazy (seq_bind (Lazy.force xs) f)) 50 | 51 | let rec seq_map f s = match s with 52 | | Empty -> Empty 53 | | Cons (x, xs) -> Cons (f x, seq_map f xs) 54 | | Delay xs -> Delay (lazy (seq_map f (Lazy.force xs))) 55 | 56 | (* Type identifiers *) 57 | 58 | module Tid = struct type _ t = .. end 59 | module type Tid = sig 60 | type t 61 | type _ Tid.t += Tid : t Tid.t 62 | end 63 | type 'a tid = (module Tid with type t = 'a) 64 | 65 | let tid () (type s) = 66 | let module M = struct 67 | type t = s 68 | type _ Tid.t += Tid : t Tid.t 69 | end 70 | in 71 | (module M : Tid with type t = s) 72 | 73 | type ('a, 'b) teq = Teq : ('a, 'a) teq 74 | 75 | let teq : type r s. r tid -> s tid -> (r, s) teq option = 76 | fun r s -> 77 | let module R = (val r : Tid with type t = r) in 78 | let module S = (val s : Tid with type t = s) in 79 | match R.Tid with 80 | | S.Tid -> Some Teq 81 | | _ -> None 82 | 83 | (* Domains *) 84 | 85 | type 'a dom = { tid : 'a tid; equal : 'a -> 'a -> bool; } 86 | let dom ~equal = { tid = tid (); equal } 87 | 88 | (* Variables *) 89 | 90 | type 'a var = { id : int; dom : 'a dom; } 91 | 92 | module Var = struct 93 | type t = V : 'a var -> t 94 | let compare (V v0) (V v1) = (compare : int -> int -> int) v0.id v1.id 95 | end 96 | 97 | module Vmap = Map.Make (Var) 98 | 99 | (* Terms *) 100 | 101 | type 'a term = 102 | | Var of 'a var 103 | | Ret of 'a dom * 'a ret 104 | 105 | and 'a ret = 106 | | App : ('a -> 'b) ret * 'a term -> 'b ret 107 | | Pure : 'a -> 'a ret 108 | 109 | let var dom id = Var { id; dom } 110 | let const dom v = Ret (dom, Pure v) 111 | let pure f = Pure f 112 | let app v ret = App (ret, v) 113 | let ret dom ret = Ret (dom, ret) 114 | 115 | (* Substitutions *) 116 | 117 | type binding = B : 'a var * 'a term -> binding 118 | type subst = binding Vmap.t 119 | 120 | let subst_empty = Vmap.empty 121 | let subst_add var t s = Vmap.add (Var.V var) (B (var, t)) s 122 | let subst_find : type a. a var -> subst -> a term option = fun v s -> 123 | try 124 | let B (v', t) = Vmap.find (Var.V v) s in 125 | match teq v.dom.tid v'.dom.tid with None -> None | Some Teq -> Some t 126 | with Not_found -> None 127 | 128 | (* Unification *) 129 | 130 | let rec walk t s = match t with 131 | | Var v -> (match subst_find v s with None -> t | Some v -> walk v s) 132 | | t -> t 133 | 134 | let term_dom = function Var v -> v.dom | Ret (d, _) -> d 135 | 136 | let rec unify : type a. a term -> a term -> subst -> subst option = 137 | fun t0 t1 s -> match walk t0 s, walk t1 s with 138 | | Var v0, Var v1 when v0.id = v1.id -> Some s 139 | | Var v, t | t, Var v -> Some (subst_add v t s) 140 | | Ret (d0, r0), Ret (d1, r1) -> 141 | if not (d0.tid == d1.tid) then None else 142 | match r0, r1 with 143 | | Pure v0, Pure v1 -> if d0.equal v0 v1 then Some s else None 144 | | App _, App _ -> unify_ret r0 r1 s 145 | | _, _ -> None 146 | 147 | and unify_ret : type a. a ret -> a ret -> subst -> subst option = 148 | fun r0 r1 s -> match r0, r1 with 149 | | App (f0, v0), App (f1, v1) -> 150 | begin match teq (term_dom v0).tid (term_dom v1).tid with 151 | | None -> None 152 | | Some Teq -> 153 | match unify v0 v1 s with 154 | | None -> None 155 | | Some s -> unify_ret f0 f1 s 156 | end 157 | | Pure f0, Pure f1 when f0 == f1 -> Some s 158 | | _, _ -> None 159 | 160 | (* State *) 161 | 162 | type state = { next_vid : int; subst : subst } 163 | let state_empty = { next_vid = 0; subst = subst_empty } 164 | 165 | (* Goals *) 166 | 167 | type goal = state -> state seq 168 | 169 | let fail _ = Empty 170 | let succeed st = Cons (st, Empty) 171 | 172 | let ( = ) t0 t1 st = match unify t0 t1 st.subst with 173 | | None -> Empty 174 | | Some subst -> succeed { st with subst } 175 | 176 | let fresh dom lambda st = 177 | let var = var dom st.next_vid in 178 | lambda var { st with next_vid = st.next_vid + 1 } 179 | 180 | let ( || ) g0 g1 st = seq_mplus (g0 st) (g1 st) 181 | let ( && ) g0 g1 st = seq_bind (g0 st) g1 182 | let delay gazy st = Delay (lazy ((Lazy.force gazy) st)) 183 | 184 | (* Reification *) 185 | 186 | let term_value t s = 187 | let rec term_value : type a. a term -> subst -> a = 188 | fun t s -> match t with 189 | | Ret (d, t) -> ret_value t s 190 | | Var v -> 191 | match subst_find v s with 192 | | Some t -> term_value t s 193 | | None -> raise Exit 194 | and ret_value : type a. a ret -> subst -> a = 195 | fun r s -> match r with 196 | | Pure v -> v 197 | | App (f, v) -> (ret_value f s) (term_value v s) 198 | in 199 | try Some (term_value t s) with Exit -> None 200 | 201 | type 'a value = 'a term * subst 202 | 203 | let value_find (var, subst) = term_value var subst 204 | let value_get (var, subst) = match term_value var subst with 205 | | None -> invalid_arg "undefined value" 206 | | Some v -> v 207 | 208 | type ('q, 'r) reifier = { next_vid : int; query : 'q; reify : state -> 'r } 209 | 210 | let reifier query reify = { next_vid = 0; query; reify = (fun _ -> reify) } 211 | let query dom r = 212 | let var = var dom r.next_vid in 213 | let query = r.query var in 214 | let reify st = r.reify st (var, st.subst) in 215 | let next_vid = r.next_vid + 1 in 216 | { next_vid; query; reify } 217 | 218 | let run r = seq_map r.reify (r.query { state_empty with next_vid = r.next_vid }) 219 | 220 | (*--------------------------------------------------------------------------- 221 | Copyright (c) 2017 Daniel C. Bünzli 222 | 223 | Permission to use, copy, modify, and/or distribute this software for any 224 | purpose with or without fee is hereby granted, provided that the above 225 | copyright notice and this permission notice appear in all copies. 226 | 227 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 228 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 229 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 230 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 231 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 232 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 233 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 234 | ---------------------------------------------------------------------------*) 235 | -------------------------------------------------------------------------------- /test/mkv.mli: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Straightforward minimal typed implementation of μKanren with 8 | domain specification on variables and return values. It seems 9 | much more inconvenient to have to type fresh and query variables. *) 10 | 11 | (* Domains *) 12 | 13 | type 'a dom 14 | val dom : equal:('a -> 'a -> bool) -> 'a dom 15 | 16 | (* Terms *) 17 | 18 | type 'a term 19 | type 'a ret 20 | 21 | val const : 'a dom -> 'a -> 'a term 22 | val pure : 'a -> 'a ret 23 | val app : 'a term -> ('a -> 'b) ret -> 'b ret 24 | val ret : 'a dom -> 'a ret -> 'a term 25 | 26 | (* Goals *) 27 | 28 | type goal 29 | 30 | val fail : goal 31 | val succeed : goal 32 | val ( = ) : 'a term -> 'a term -> goal 33 | val fresh : 'a dom -> ('a term -> goal) -> goal 34 | val ( || ) : goal -> goal -> goal 35 | val ( && ) : goal -> goal -> goal 36 | val delay : goal Lazy.t -> goal 37 | 38 | (* Reification *) 39 | 40 | type 'a seq 41 | val seq_to_list : ?limit:int -> 'a seq -> 'a list 42 | 43 | type 'a value 44 | val value_find : 'a value -> 'a option 45 | val value_get : 'a value -> 'a 46 | 47 | type ('q, 'r) reifier 48 | 49 | val reifier : 'q -> 'r -> ('q, 'r) reifier 50 | val query : 51 | 'a dom -> ('a term -> 'q, 'a value -> 'r) reifier -> ('q, 'r) reifier 52 | 53 | val run : (goal, 'a) reifier -> 'a seq 54 | 55 | (*--------------------------------------------------------------------------- 56 | Copyright (c) 2017 Daniel C. Bünzli 57 | 58 | Permission to use, copy, modify, and/or distribute this software for any 59 | purpose with or without fee is hereby granted, provided that the above 60 | copyright notice and this permission notice appear in all copies. 61 | 62 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 63 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 64 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 65 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 66 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 67 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 68 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 69 | ---------------------------------------------------------------------------*) 70 | -------------------------------------------------------------------------------- /test/mkv_test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let assert_vals ?limit d q vals = 8 | let q = Mkv.(query d @@ reifier q value_get) in 9 | assert (Mkv.(seq_to_list ?limit @@ run q) = vals) 10 | 11 | let assert_find_vals ?limit d q vals = 12 | let q = Mkv.(query d @@ reifier q value_find) in 13 | assert (Mkv.(seq_to_list ?limit @@ run q) = vals) 14 | 15 | let assert_2vals ?limit d0 d1 q vals = 16 | let reify x y = Mkv.(value_get x, value_get y) in 17 | let q = Mkv.(query d1 @@ query d0 @@ reifier q reify) in 18 | assert (Mkv.(seq_to_list ?limit @@ run q) = vals) 19 | 20 | let dint = Mkv.dom ~equal:(( = ) : int -> int -> bool) 21 | let int = Mkv.const dint 22 | 23 | let test_fair_disj () = 24 | let rec fivel x = Mkv.(x = int 5 || delay @@ lazy (fivel x)) in 25 | let rec fiver x = Mkv.(delay @@ lazy (fiver x) || x = int 5) in 26 | assert_vals ~limit:3 dint fivel [5;5;5]; 27 | assert_vals ~limit:3 dint fiver [5;5;5]; 28 | () 29 | 30 | let test_unfair_conj () = 31 | let rec faill x = Mkv.(fail && delay @@ lazy (faill x)) in 32 | assert_find_vals ~limit:3 dint faill []; 33 | (* 34 | let rec failr x = Mkv.(delay @@ lazy (failr x) && fail) in 35 | assert_find_vals ~limit:3 dint failr []; *) 36 | () 37 | 38 | let listo d dl = 39 | let empty = Mkv.(const dl []) in 40 | let cons x xs = 41 | Mkv.(pure (fun x xs -> x :: xs) |> app x |> app xs |> ret dl) 42 | in 43 | let list l = List.fold_right (fun x xs -> cons (Mkv.const d x) xs) l empty in 44 | let rec appendo l0 l1 l = 45 | let open Mkv in 46 | (l0 = empty && l1 = l) || 47 | (fresh d @@ fun x -> fresh dl @@ fun xs -> fresh dl @@ fun tl -> 48 | cons x xs = l0 && 49 | cons x tl = l && 50 | delay @@ lazy (appendo xs l1 tl)) 51 | in 52 | let rec revo l r = 53 | let open Mkv in 54 | (l = empty && r = empty) || 55 | (fresh d @@ fun x -> fresh dl @@ fun xs -> fresh dl @@ fun rt -> 56 | cons x xs = l && 57 | appendo rt (cons x empty) r && 58 | delay @@ lazy (revo xs rt)) 59 | in 60 | empty, cons, list, appendo, revo 61 | 62 | let dilist = Mkv.dom ~equal:( = ) 63 | let iempty, icons, ilist, iappendo, irevo = listo dint dilist 64 | 65 | let test_match () = 66 | let m4tch x xs = Mkv.(icons x xs = ilist [1;2;3]) in 67 | assert_2vals dint dilist m4tch [(1, [2;3])]; 68 | () 69 | 70 | let test_appendo () = 71 | assert_vals dilist 72 | (fun l -> iappendo (ilist [1;2]) (ilist [3;4]) l) [[1;2;3;4]]; 73 | assert_vals dilist 74 | (fun l -> iappendo l (ilist [3;4]) (ilist [1;2;3;4])) [[1;2]]; 75 | assert_vals dilist 76 | (fun l -> iappendo (ilist [1;2]) l (ilist [1;2;3;4])) [[3;4]]; 77 | () 78 | 79 | let test_pre_suf () = 80 | let pre l pre = Mkv.(fresh dilist @@ fun suf -> iappendo pre suf l) in 81 | let suf l suf = Mkv.(fresh dilist @@ fun pre -> iappendo pre suf l) in 82 | let pre_suf l pre suf = iappendo pre suf l in 83 | let l = ilist [1;2;3;4] in 84 | assert_vals dilist (pre l) [[]; [1]; [1;2]; [1;2;3]; [1;2;3;4]]; 85 | assert_vals dilist (suf l) [[1;2;3;4]; [2;3;4]; [3;4]; [4]; []]; 86 | assert_2vals dilist dilist (pre_suf l) 87 | [([], [1;2;3;4]); 88 | ([1], [2;3;4]); 89 | ([1;2], [3;4]); 90 | ([1;2;3], [4]); 91 | ([1;2;3;4], [])]; 92 | () 93 | 94 | let test_revo () = 95 | assert_vals ~limit:1 dilist (fun r -> irevo (ilist [1;2;3]) r) [[3;2;1]]; 96 | assert_vals ~limit:1 dilist (fun r -> irevo r (ilist [1;2;3])) [[3;2;1]]; 97 | () 98 | 99 | let test () = 100 | test_fair_disj (); 101 | test_unfair_conj (); 102 | test_match (); 103 | test_appendo (); 104 | test_pre_suf (); 105 | test_revo (); 106 | print_endline "All Mkv tests succeeded!"; 107 | () 108 | 109 | let () = test () 110 | 111 | (*--------------------------------------------------------------------------- 112 | Copyright (c) 2017 Daniel C. Bünzli 113 | 114 | Permission to use, copy, modify, and/or distribute this software for any 115 | purpose with or without fee is hereby granted, provided that the above 116 | copyright notice and this permission notice appear in all copies. 117 | 118 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 119 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 120 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 121 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 122 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 123 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 124 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 125 | ---------------------------------------------------------------------------*) 126 | -------------------------------------------------------------------------------- /test/reliza.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Eliza 8 | Most of the rules are from: 9 | Paradigms of Artificial Intelligence Programming. Peter Norvig. 1992. 10 | p. 172. See http://norvig.com/paip/eliza.lisp. 11 | which claim to include most of Weizenbaum's original rules. *) 12 | 13 | open Astring 14 | 15 | let random_elt = Random.self_init (); 16 | fun l -> 17 | let a = Array.of_list l in 18 | let len = Array.length a in 19 | a.(Random.int len) 20 | 21 | module Tok = struct 22 | type t = string 23 | let equal s0 s1 = String.(equal (Ascii.lowercase s0) (Ascii.lowercase s1)) 24 | let pp = Format.pp_print_string 25 | let of_string s = String.fields ~empty:false s 26 | end 27 | 28 | module L = Trel_list.Make (Trel_list.Make_elt (Tok)) 29 | 30 | let eliza input answ = 31 | let open Trel in 32 | let m4tch l x y z = Fresh.v1 @@ fun c -> L.append c z l && L.append x y c in 33 | let _str l = L.v [l] in 34 | let cst s = L.empty, L.v [s], L.empty in 35 | Fresh.v2 @@ fun x y -> 36 | let d pat answs = 37 | m4tch input x (L.v pat) y && 38 | (let add_answ acc (x, y, z) = acc || m4tch answ x y z in 39 | List.fold_left add_answ fail answs) 40 | in 41 | List.fold_left ( || ) fail [ 42 | d ["hello"] [ cst "How do you do ? Please state your problem."]; 43 | (* 44 | d ["computer"] [ 45 | (cst "Do computers worry you ?"); 46 | (cst "What do you think about machines ?"); 47 | (cst "Why do you mention computers ?"); 48 | (cst "What do you think machines have to do with your problem ?")]; 49 | d ["name"] [ cst "I am not interested in names." ]; 50 | d ["sorry"] [ 51 | (cst "Please don't apologize."); 52 | (cst "Apologies are not necessary."); 53 | (cst "What feelings do you have when you apologize") ]; 54 | d ["I"; "remember"] [ 55 | (str "Do you often think of", y, str "?"); 56 | (str "Does thinking of", y, str "bring anything else to mind ?"); 57 | (cst "What else do you remember ?"); 58 | (str "Why do you recall", y, str "right now ?"); 59 | (str "What in the present situation reminds you of", y, str "?"); 60 | (str "What is the connection between me and", y, str "?") ]; 61 | d ["do"; "you"; "remember"] [ 62 | (str "Did you think I would forget", y, str "?"); 63 | (str "Why do you think I should recall", y, str "now ?"); 64 | (str "What about", y, str "?"); 65 | (str "You mentioned", y, str ".") ]; 66 | d ["if"] [ 67 | (str "Do you really think its likely that", y, str "?"); 68 | (str "Do you wish that", y, str "?"); 69 | (str "What do you think about", y, str "?"); 70 | (str "Really--if", y, str "?") ]; 71 | d ["I"; "dreamt"] [ 72 | (cst "What does this dream suggest to you ?"); 73 | (cst "Do you dream often ?"); 74 | (cst "What persons appear in your dreams ?"); 75 | (cst "Don't you believe that dream has to do with your problem ?")]; 76 | d ["my"; "mother"] [ 77 | (str "Who else in your family", y, str "?"); 78 | (cst "Tell me more about your family.") ]; 79 | d ["my"; "father"] [ 80 | (cst "Your father."); 81 | (cst "Does he influence you strongly ?"); 82 | (cst "What else comes to mind when you think of your father ?")]; 83 | d ["I"; "want"] [ 84 | (str "What would it mean if you got", y, str "?"); 85 | (str "Why do you want", y, str "?"); 86 | (str "Suppose you got", y, str "soon.")]; 87 | d ["I"; "am"; "glad"] [ 88 | (str "How have I helped you to be", y, str "?"); 89 | (cst "What makes you happy just now ?"); 90 | (str "Can you explain why you are suddenly", y, str "?") ]; 91 | d ["I"; "am"; "sad"] [ 92 | (cst "I am sorry to hear you are depressed."); 93 | (cst "I'm sure it's not pleasant to be sad.") ]; 94 | (* 95 | d ["are"; "like"] [ 96 | (str "What resemblance do you see between", x, str "and", y) ] 97 | *) 98 | d ["is"; "like"] [ 99 | (* (str "In what way is it that", x, str "is like", y); *) 100 | (cst "What resemblance do you see ?"); 101 | (cst "Could there really be some connection?"); 102 | (cst "How?") ]; 103 | d ["alike"] [ 104 | (cst "In what way ?"); 105 | (cst "What similarities are there ?"); 106 | ]; 107 | d ["same"] [ (cst "What other connections do you see ?") ]; 108 | d ["I"; "was"] [ 109 | (cst "Where you really ?"); 110 | (str "Perhaps I already knew you were", y, str "."); 111 | (str "Why do you tell me you were", y, str "now ?") ]; 112 | d ["was"; "I"] [ 113 | (str "What if you were", y, str "?"); 114 | (str "Do you think you were", y, str "?"); 115 | (str "What would it mean if you were", y, str "?") ]; 116 | d ["I"; "am"] [ 117 | (str "In what way are you", y, str "?"); 118 | (str "Do you want to be", y, str "?") ]; 119 | d ["am"; "I"] [ 120 | (str "Do you believe you are", y, str "?"); 121 | (str "Would you want to be", y, str "?"); 122 | (str "You wish I would tell you you are", y, str "?"); 123 | (str "What would it mean if you were", y, str "?") ]; 124 | d [ "am" ] [ 125 | (cst "Why do you say \"AM\" ?"); 126 | (cst "I don't understand that.") ]; 127 | d ["are"; "you" ] [ 128 | (str "Why are you interested in whether I am", y, str "or not ?"); 129 | (str "Would you prefer if I weren't", y, str "?"); 130 | (str "Perhaps I am", y, str "in your fantasies.") ]; 131 | d ["you"; "are"] [ 132 | (str "What makes you think I am", y, str "?") ]; 133 | d ["because"] [ 134 | (cst "Is that the real reason ?"); 135 | (cst "What other reasons might there be ?"); 136 | (cst "Does that reason seem to explain anything else ?") ]; 137 | d ["were"; "you"] [ 138 | (str "Perhaps I was", y, str "?"); 139 | (cst "What do you think ?"); 140 | (str "What if I had been", y, str "?") ]; 141 | d ["I"; "can't" ] [ 142 | (str "Maybe you could", y, str "now"); 143 | (str "What if you could", y, str "?") ]; 144 | d ["I"; "feel"] [ (str "Do you often feel", y, str "?") ]; 145 | d ["I"; "felt"] [ (cst "What other feelings do you have ?") ]; 146 | (* 147 | (((?* ?x) I (?* ?y) you (?* ?z)) 148 | (Perhaps in your fantasy we ?y each other)) 149 | *) 150 | d ["why"; "don't"; "you"] [ 151 | (str "Should you", y, str "yourself ?"); 152 | (str "Do you believe I don't", y, str "?"); 153 | (str "Perhaps I will", y, str "in good time") ]; 154 | d [ "yes" ] [ 155 | (cst "You seem quite positive."); 156 | (cst "You are sure."); 157 | (cst "I understand.") ]; 158 | d ["no"] [ 159 | (cst "Why not ?"); 160 | (cst "You are being a bit negative."); 161 | (cst "Are you saying \"NO\" just to be negative ?") ]; 162 | d ["someone"] [ (cst "Can you be more specific ?") ]; 163 | d ["everyone"] [ 164 | (cst "Surely not everyone"); 165 | (cst "Can you think of anyone in particular ?"); 166 | (cst "Who for example ?"); 167 | (cst "You are thinking of a special person.")]; 168 | d ["always"] [ 169 | (cst "Can you think of a specific example") ; 170 | (cst "When ?"); 171 | (cst "What incident are you thinking of ?"); 172 | (cst "Really-- always ?"); ]; 173 | d ["what"] [ 174 | (cst "Why do you ask ?"); 175 | (cst "Does that question interest you ?"); 176 | (cst "What is it you really want to know ?"); 177 | (cst "What do you think?"); 178 | (cst "What comes to your mind when you ask that ?") ]; 179 | d ["perhaps"] [ (cst "You do not seem quite certain.") ]; 180 | d ["are"] [ 181 | (str "Did you think they might not be", y, str "?"); 182 | (str "Posysibly they are", y, str "?")]; 183 | d ["obj"] [ 184 | (cst "Obj is not part of the language."); 185 | (cst "Xavier is not going to be happy about this."); ] *)] 186 | 187 | let answer input = 188 | let input = L.v (Tok.of_string input) in 189 | let answs = match Trel.Run.get1 (eliza input) with 190 | | [] -> [["Very intereysting."]; ["I am not sure I understand you fully"]; 191 | ["What does that suggest to you ?"]; ["Please continue."]; 192 | ["Go on"]; ["Do you feel strongly about discussing such things ?"]] 193 | | answs -> answs 194 | in 195 | String.concat ~sep:" " (random_elt answs) 196 | 197 | let rec dialog () = 198 | print_string "eliza> "; flush stdout; 199 | match input_line stdin with 200 | | input -> print_endline (answer input); dialog () 201 | | exception End_of_file -> print_endline ""; print_endline "Bye." 202 | 203 | let () = dialog () 204 | 205 | (*--------------------------------------------------------------------------- 206 | Copyright (c) 2017 Daniel C. Bünzli 207 | 208 | Permission to use, copy, modify, and/or distribute this software for any 209 | purpose with or without fee is hereby granted, provided that the above 210 | copyright notice and this permission notice appear in all copies. 211 | 212 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 213 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 214 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 215 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 216 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 217 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 218 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 219 | ---------------------------------------------------------------------------*) 220 | -------------------------------------------------------------------------------- /test/sreliza.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | (* Eliza *) 8 | 9 | open Astring 10 | 11 | let random_elt = Random.self_init (); 12 | fun l -> 13 | let a = Array.of_list l in 14 | let len = Array.length a in 15 | a.(Random.int len) 16 | 17 | module Tok = struct 18 | type t = string 19 | let equal s0 s1 = String.(equal (Ascii.lowercase s0) (Ascii.lowercase s1)) 20 | let pp = Format.pp_print_string 21 | let of_string s = String.fields ~empty:false s 22 | end 23 | 24 | module L = Trel_list.Make (Trel_list.Make_elt (Tok)) 25 | 26 | let eliza input answ = 27 | let open Trel in 28 | let m4tch l x y z = Fresh.v1 @@ fun t -> L.append x y t && L.append t z l in 29 | let lit l = L.v l in 30 | let str s = L.v [s] in 31 | let nil = L.empty in 32 | Fresh.v2 @@ fun x y -> 33 | (m4tch input x (lit ["Hello"]) y && 34 | answ = str "How do you do ? Please state your problem.") || 35 | (m4tch input x (lit ["I"; "want"]) y && 36 | (m4tch answ (str "What would it mean if you got") y (str "?") || 37 | m4tch answ (str "Why do you want") y (str "?") || 38 | m4tch answ (str "Suppose you got") y (str "soon."))) || 39 | (m4tch input x (lit ["if"]) y && 40 | (m4tch answ (str "Do you really think its likely that") y (str "?") || 41 | m4tch answ (str "Do you wish that") y (str "?") || 42 | m4tch answ (str "What do you think about") y (str "?") || 43 | m4tch answ (str "Really-- if") y (str "?"))) || 44 | (m4tch input x (lit ["no"]) y && 45 | (answ = str "Why not ?" || 46 | answ = str "You are being a bit negative" || 47 | answ = str "Are you saying \"NO\" just to be negative ?")) || 48 | (m4tch input x (lit ["I"; "was"]) y && 49 | (answ = str "Where you really ?" || 50 | m4tch answ (str "Perhaps I already knew you were") y nil || 51 | m4tch answ (str "Why do you tell me you were") y (str "now ?"))) || 52 | (m4tch input x (lit ["I"; "feel"]) y && 53 | m4tch answ (str "Do you often feel") y (str "?")) || 54 | (m4tch input x (lit ["I"; "felt"]) y && 55 | answ = str "What other feelings do you have ?") || 56 | (m4tch input x (lit ["obj"]) y && 57 | (answ = str "Obj is not part of the language" || 58 | answ = str "Xavier is not going to be happy about this")) 59 | 60 | let answer input = 61 | let input = L.v (Tok.of_string input) in 62 | let answs = match Trel.Run.get1 (eliza input) with 63 | | [] -> [["Very interesting."]; ["I am not sure I understand you fully"]; 64 | ["What does that suggest to you ?"]; ["Please continue."]; 65 | ["Go on"]; ["Do you feel strongly about discussing such things ?"]] 66 | | answs -> answs 67 | in 68 | String.concat ~sep:" " (random_elt answs) 69 | 70 | let rec dialog () = 71 | print_string "eliza> "; flush stdout; 72 | match input_line stdin with 73 | | input -> print_endline (answer input); dialog () 74 | | exception End_of_file -> print_endline ""; print_endline "Bye." 75 | 76 | let () = dialog () 77 | 78 | (*--------------------------------------------------------------------------- 79 | Copyright (c) 2017 Daniel C. Bünzli 80 | 81 | Permission to use, copy, modify, and/or distribute this software for any 82 | purpose with or without fee is hereby granted, provided that the above 83 | copyright notice and this permission notice appear in all copies. 84 | 85 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 86 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 87 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 88 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 89 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 90 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 91 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 92 | ---------------------------------------------------------------------------*) 93 | -------------------------------------------------------------------------------- /test/test.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let assert_vals ?limit q vals = assert (Trel.Run.get1 ?limit q = vals) 8 | let assert_find_vals ?limit q vals = assert (Trel.Run.find1 ?limit q = vals) 9 | let assert_2vals ?limit q vals = assert (Trel.Run.get2 ?limit q = vals) 10 | 11 | let test_simple_unify () = 12 | assert_vals (fun q -> Trel.(q = int 5)) [5]; 13 | assert_vals (fun q -> Trel.(q = int 5 || q = int 6)) [5;6]; 14 | assert_2vals 15 | (fun a b -> Trel.(a = int 7 && (b = int 5 || b = int 6))) [(7, 5); (7, 6)]; 16 | assert_vals 17 | (fun x -> Trel.(Fresh.v2 @@ fun y z -> x = y && y = z && z = int 3)) [3]; 18 | () 19 | 20 | let test_pair () = 21 | let p2 = Trel.(pair Dom.int Dom.bool Dom.(pair int bool)) in 22 | let p p = 23 | let open Trel in 24 | Fresh.v2 @@ fun x y -> 25 | p = (p2 x y) && x = int 5 && y = bool true 26 | in 27 | assert_vals p [5, true]; 28 | () 29 | 30 | let test_fapp () = 31 | let triple x y z = (x, y, z) in 32 | let t3 x y z = 33 | let open Trel in 34 | pure triple |> app Dom.int x |> app Dom.bool y |> app Dom.string z |> 35 | ret (Dom.v ()) 36 | in 37 | let t t = 38 | let open Trel in 39 | Fresh.v3 @@ fun x y z -> 40 | t = t3 x y z && x = int 5 && y = bool true && z = string "bla" 41 | in 42 | assert_vals t [(5, true, "bla")]; 43 | () 44 | 45 | let test_delay () = 46 | let rec fives x = Trel.(x = int 5 || delay (lazy (fives x))) in 47 | assert_vals ~limit:2 fives [5;5] 48 | 49 | let test_fair_disj () = 50 | let rec fivel x = Trel.(x = int 5 || delay @@ lazy (fivel x)) in 51 | let rec fiver x = Trel.(delay @@ lazy (fiver x) || x = int 5) in 52 | assert_vals ~limit:3 fivel [5;5;5]; 53 | assert_vals ~limit:3 fiver [5;5;5]; 54 | () 55 | 56 | let test_unfair_conj () = 57 | let rec faill x = Trel.(fail && delay @@ lazy (faill x)) in 58 | assert_find_vals ~limit:3 faill []; 59 | (* let rec failr x = Trel.(delay @@ lazy (failr x) && fail) in 60 | assert_find_vals ~limit:3 failr []; *) 61 | () 62 | 63 | let listo d dl = 64 | let empty = Trel.(const dl []) in 65 | let cons x xs = 66 | Trel.(pure (fun x xs -> x :: xs) |> app d x |> app dl xs |> ret dl) 67 | in 68 | let hd l = Trel.(pure List.hd |> app dl l |> ret d) in 69 | let tl l = Trel.(pure List.tl |> app dl l |> ret dl) in 70 | let list l = List.fold_right (fun x xs -> cons (Trel.const d x) xs) l empty in 71 | let conso x xs l = Trel.(cons x xs = l) in 72 | let heado l x = Trel.(fresh @@ fun xs -> cons x xs = l) in 73 | let tailo l xs = Trel.(fresh @@ fun x -> cons x xs = l) in 74 | let rec appendo l0 l1 l = 75 | (* List.append [] l = l || 76 | List.append (x :: xs) l = x :: (List.append xs l) *) 77 | let open Trel in 78 | (l0 = empty && l1 = l) || 79 | (Fresh.v3 @@ fun x xs tl -> 80 | (cons x xs) = l0 && 81 | (cons x tl) = l && 82 | delay @@ lazy (appendo xs l1 tl)) 83 | in 84 | let rec revo l r = 85 | let open Trel in 86 | (l = empty && r = empty) || 87 | (Fresh.v3 @@ fun x xs rt -> 88 | (cons x xs) = l && 89 | delay @@ lazy (revo xs rt) && 90 | appendo rt (cons x empty) r) 91 | in 92 | empty, cons, hd, tl, list, conso, heado, tailo, appendo, revo 93 | 94 | let iempty, icons, ihd, itl, ilist, iconso, iheado, tailo, iappendo, irevo = 95 | listo Trel.Dom.int Trel.Dom.(list int) 96 | 97 | let test_ilist () = 98 | let il = ilist [1;2;3] in 99 | let ilh = ihd il in 100 | let ilt = itl il in 101 | assert_vals Trel.(fun l -> il = l) [[1;2;3]]; 102 | assert_vals Trel.(fun l -> ilh = l) [1]; 103 | assert_vals Trel.(fun l -> ilt = l) [[2;3]]; 104 | assert_vals (Trel.(fun l -> iconso (Trel.int 1) (ilist [2;3]) l)) [[1;2;3]]; 105 | assert_2vals (fun x xs -> Trel.(iconso x xs (ilist [1;2;3]))) [(1,[2;3])]; 106 | () 107 | 108 | let test_ilist_appendo () = 109 | assert_vals (fun l -> iappendo (ilist [1;2]) (ilist [3;4]) l) [[1;2;3;4]]; 110 | assert_vals (fun l -> iappendo l (ilist [4]) (ilist [1;2;3;4])) [[1;2;3]]; 111 | assert_vals (fun l -> iappendo (ilist [1;2]) l (ilist [1;2;3;4])) [[3;4]]; 112 | assert (not (Trel.success (iappendo (ilist [1]) (ilist [2]) (ilist [3])))); 113 | () 114 | 115 | let test_ilist_pre_suf () = 116 | let pre l pre = Trel.(fresh @@ fun suf -> iappendo pre suf l) in 117 | let suf l suf = Trel.(fresh @@ fun pre -> iappendo pre suf l) in 118 | let pre_suf l pre suf = iappendo pre suf l in 119 | let l = ilist [1;2;3;4] in 120 | assert_vals (pre l) [[]; [1]; [1;2]; [1;2;3]; [1;2;3;4]]; 121 | assert_vals (suf l) [[1;2;3;4]; [2;3;4]; [3;4]; [4]; []]; 122 | assert_2vals (pre_suf l) 123 | [([], [1;2;3;4]); 124 | ([1], [2;3;4]); 125 | ([1;2], [3;4]); 126 | ([1;2;3], [4]); 127 | ([1;2;3;4], [])]; 128 | () 129 | 130 | let test_ilist_revo () = 131 | assert_vals (fun r -> irevo (ilist [1;2;3]) r) [[3;2;1]]; 132 | () 133 | 134 | let test_pure_unify () = 135 | let sin x = Trel.(pure sin |> app Dom.float x |> ret Dom.float) in 136 | let cos x = Trel.(pure cos |> app Dom.float x |> ret Dom.float) in 137 | assert_vals Trel.(fun x -> cos x = sin x && x = float 0.) []; 138 | assert_vals Trel.(fun x -> cos x = cos x && x = float 0.) [0.]; 139 | () 140 | 141 | let test () = 142 | test_simple_unify (); 143 | test_pair (); 144 | test_fapp (); 145 | test_delay (); 146 | test_fair_disj (); 147 | test_unfair_conj (); 148 | test_ilist_appendo (); 149 | test_ilist_pre_suf (); 150 | test_ilist_revo (); 151 | test_pure_unify (); 152 | print_endline "All tests succeeded!"; 153 | () 154 | 155 | let () = test () 156 | 157 | (*--------------------------------------------------------------------------- 158 | Copyright (c) 2017 Daniel C. Bünzli 159 | 160 | Permission to use, copy, modify, and/or distribute this software for any 161 | purpose with or without fee is hereby granted, provided that the above 162 | copyright notice and this permission notice appear in all copies. 163 | 164 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 165 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 166 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 167 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 168 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 169 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 170 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 171 | ---------------------------------------------------------------------------*) 172 | -------------------------------------------------------------------------------- /test/test_list.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let assert_vals ?limit q vals = assert (Trel.Run.get1 ?limit q = vals) 8 | let assert_fvals ?limit q vals = assert (Trel.Run.find1 ?limit q = vals) 9 | 10 | module L = Trel_list.Make (struct type t = int let dom = Trel.Dom.int end) 11 | 12 | let test_base () = 13 | assert_vals (fun x -> L.(hd (v [1;2;3]) x)) [1]; 14 | assert_vals (fun x -> L.(tl (v [1;2;3]) x)) [[2;3]]; 15 | () 16 | 17 | let test_mem () = 18 | assert_vals (fun u -> Trel.(L.(mem (int 1) (v [1;2;3])) && (u = unit))) [()]; 19 | assert_vals (fun u -> Trel.(L.(mem (int 4) (v [1;2;3])) && (u = unit))) []; 20 | assert_vals (fun x -> Trel.(L.(mem x (v [1;2;3])))) [1;2;3]; 21 | assert_vals (fun x -> Trel.(L.(mem x (v [])))) []; 22 | assert_vals 23 | (fun x -> Trel.(L.(mem (int 3) (cons (int 1) (cons x empty))))) [3]; 24 | assert_fvals 25 | (fun x -> Trel.(L.(mem (int 3) (cons (int 3) (cons x empty))))) 26 | [None; Some 3]; 27 | () 28 | 29 | let test_rev () = 30 | assert_vals (fun u -> Trel.(L.(rev (v [1;2;3]) (v [3;2;1])) && (u = unit))) 31 | [()]; 32 | assert_vals ~limit:1 (fun l -> Trel.(L.(rev l (v [1;2;3])))) [[3;2;1]]; 33 | assert_vals ~limit:1 (fun l -> Trel.(L.(rev (v [1;2;3]) l))) [[3;2;1]]; 34 | () 35 | 36 | let test () = 37 | test_base (); 38 | test_mem (); 39 | test_rev (); 40 | print_endline "All list tests succeeded!"; 41 | () 42 | 43 | let () = test () 44 | 45 | 46 | (*--------------------------------------------------------------------------- 47 | Copyright (c) 2017 Daniel C. Bünzli 48 | 49 | Permission to use, copy, modify, and/or distribute this software for any 50 | purpose with or without fee is hereby granted, provided that the above 51 | copyright notice and this permission notice appear in all copies. 52 | 53 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 54 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 55 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 56 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 57 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 58 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 59 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 60 | ---------------------------------------------------------------------------*) 61 | -------------------------------------------------------------------------------- /test/test_tree.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | let assert_vals ?limit q vals = assert (Trel.Run.get1 ?limit q = vals) 8 | 9 | module Tree = struct 10 | type t = Node of int * t * t | Leaf 11 | 12 | let rec equal t0 t1 = match t0, t1 with 13 | | Leaf, Leaf -> true 14 | | Node (v0,l0,r0), Node (v1,l1,r1) -> v0 = v1 && equal l0 l1 && equal r0 r1 15 | | _, _ -> false 16 | 17 | let rec pp ppf = function 18 | | Leaf -> Format.fprintf ppf "Leaf" 19 | | Node (v, l, r) -> 20 | Format.fprintf ppf "@[Node @[<1>(%d,@ %a,@ %a)@]" v pp l pp r 21 | 22 | let leaf = Leaf 23 | let node v l r = Node (v, l, r) 24 | end 25 | 26 | module Treeo = struct 27 | 28 | let lt i i' = failwith "TODO" 29 | 30 | let dom = Trel.Dom.of_type (module Tree) 31 | let leaf = Trel.const dom Tree.leaf 32 | let node v l r = 33 | let open Trel in 34 | pure Tree.node |> app Dom.int v |> app dom l |> app dom r |> ret dom 35 | 36 | let rec insert v t t' = 37 | let open Trel in 38 | (t = leaf && t' = node v leaf leaf) || 39 | (Fresh.v4 @@ fun i l r b -> 40 | (t = node i l r) && 41 | ((t' = t) && (i = v)) || 42 | ((t' = node i b r) && (lt i v) && delay @@ lazy (insert v l b)) || 43 | ((t' = node i l b) && (lt v i) && delay @@ lazy (insert v r b))) 44 | end 45 | 46 | 47 | let test () = 48 | print_endline "All tree tests succeeded!"; 49 | () 50 | 51 | let () = test () 52 | 53 | 54 | (*--------------------------------------------------------------------------- 55 | Copyright (c) 2017 Daniel C. Bünzli 56 | 57 | Permission to use, copy, modify, and/or distribute this software for any 58 | purpose with or without fee is hereby granted, provided that the above 59 | copyright notice and this permission notice appear in all copies. 60 | 61 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 62 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 63 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 64 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 65 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 66 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 67 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 68 | ---------------------------------------------------------------------------*) 69 | -------------------------------------------------------------------------------- /test/utf.ml: -------------------------------------------------------------------------------- 1 | (*--------------------------------------------------------------------------- 2 | Copyright (c) 2017 Daniel C. Bünzli. All rights reserved. 3 | Distributed under the ISC license, see terms at the end of the file. 4 | %%NAME%% %%VERSION%% 5 | ---------------------------------------------------------------------------*) 6 | 7 | 8 | (* https://github.com/ocaml/ocaml/pull/1091 *) 9 | 10 | let utf_8_spec = 11 | (* UTF-8 byte sequences, cf. table 3.7 Unicode 9. *) 12 | [(0x0000,0x007F), [|(0x00,0x7F)|]; 13 | (0x0080,0x07FF), [|(0xC2,0xDF); (0x80,0xBF)|]; 14 | (0x0800,0x0FFF), [|(0xE0,0xE0); (0xA0,0xBF); (0x80,0xBF)|]; 15 | (0x1000,0xCFFF), [|(0xE1,0xEC); (0x80,0xBF); (0x80,0xBF)|]; 16 | (0xD000,0xD7FF), [|(0xED,0xED); (0x80,0x9F); (0x80,0xBF)|]; 17 | (0xE000,0xFFFF), [|(0xEE,0xEF); (0x80,0xBF); (0x80,0xBF)|]; 18 | (0x10000,0x3FFFF), [|(0xF0,0xF0); (0x90,0xBF); (0x80,0xBF); (0x80,0xBF)|]; 19 | (0x40000,0xFFFFF), [|(0xF1,0xF3); (0x80,0xBF); (0x80,0xBF); (0x80,0xBF)|]; 20 | (0x100000,0x10FFFF), [|(0xF4,0xF4); (0x80,0x8F); (0x80,0xBF); (0x80,0xBF)|]] 21 | ;; 22 | 23 | let utf_16be_spec = 24 | (* UTF-16BE byte sequences, derived from table 3.5 Unicode 9. *) 25 | [(0x0000,0xD7FF), [|(0x00,0xD7); (0x00,0xFF)|]; 26 | (0xE000,0xFFFF), [|(0xE0,0xFF); (0x00,0xFF)|]; 27 | (0x10000,0x10FFFF), [|(0xD8,0xDB); (0x00,0xFF); (0xDC,0xDF); (0x00,0xFF)|]] 28 | ;; 29 | 30 | 31 | let udom = Rel.Dom.v ~equal:Uchar.equal () 32 | 33 | let 34 | 35 | 36 | 37 | 38 | 39 | (*--------------------------------------------------------------------------- 40 | Copyright (c) 2017 Daniel C. Bünzli 41 | 42 | Permission to use, copy, modify, and/or distribute this software for any 43 | purpose with or without fee is hereby granted, provided that the above 44 | copyright notice and this permission notice appear in all copies. 45 | 46 | THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES 47 | WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF 48 | MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR 49 | ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES 50 | WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN 51 | ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF 52 | OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. 53 | ---------------------------------------------------------------------------*) 54 | --------------------------------------------------------------------------------