Commits

Anonymous committed a6e7cec

init

Comments (0)

Files changed (19)

+~$
+\.(byte|native)$
+^_build/
+<*.ml> | <*.mli> : warn_A
+<tests.byte> | <tests.native> : use_unix
+
+@call c:\overbld\ocaml\set-vars.bat
+@bash clean.sh
+ocamlbuild -clean && rm -f *.byte *.native
+open LogicM_ops
+
+module Stream =
+  struct
+    include Stream
+
+    let get_opt s = try Some (next s) with Failure -> None
+
+    let map f s = from & fun _ ->
+      match get_opt s with None -> None | Some x -> Some (f x)
+
+    let map2 ?(strict=true) f s1 s2 = from & fun _ ->
+      match get_opt s1, get_opt s2 with
+      | None, None -> None
+      | Some _, None | None, Some _ ->
+          if strict then raise Failure else None
+      | Some x, Some y -> Some (f x y)
+
+    let ints ?(nstep=1) ?(nend=max_int) nstart =
+      let cur = ref nstart in
+      from & fun _ ->
+        let r = !cur in
+        if r > nend
+        then None
+        else
+          ( cur := !cur + nstep;
+            Some r
+          )
+
+    let from_repeat f x =
+      from & fun _ -> Some (f x)
+
+
+  end
+
+
+module type LogicM_type
+ =
+  sig
+    type 'a m
+
+    val mzero : 'a m
+    val return : 'a -> 'a m
+
+    val interleave : 'a m -> 'a m -> 'a m
+    val ( <+> ) : 'a m -> 'a m -> 'a m
+
+    val bind : 
+
+    val ifm : 'a m -> ('a m -> 'b) -> 'b -> 'b
+
+    val runL : int option -> 'a m -> 'a list
+
+    val filter : ('a -> bool) -> 'a m -> 'a m
+
+    val from_stream : 'a Stream.t -> 'a m
+  end
+let dbg ?t fmt =
+  (
+   if t = Some `S then Printf.fprintf else Printf.ifprintf
+  )
+  stdout fmt
+
+
+module type Monad
+ =
+  sig
+    type 'a m
+    val return : 'a -> 'a m
+    val bind : ('a -> 'b m) -> 'a m -> 'b m
+  end
+
+
+let ( & ) f x = f x
+
+
+module LogicT (M : Monad)
+ =
+  struct
+    open M
+
+    type 'a sfkt =
+      { sfkt : 'ans . (('ans m), 'a) sk -> ('ans m) fk -> 'ans m }
+    and 'ans fk = 'ans Lazy.t
+    and ('ans, 'a) sk = 'a -> 'ans fk -> 'ans
+
+    let return e = { sfkt = fun sk fk -> sk e fk }
+
+    let bind f m =
+      { sfkt = fun sk fk ->
+          m.sfkt (fun a fk2 -> (f a).sfkt sk fk2) fk
+      }
+
+    let mzero = { sfkt = fun _sk fk -> Lazy.force fk }
+
+    let mplusl m1 m2l =
+      { sfkt = fun sk fk ->
+          m1.sfkt sk (lazy ((Lazy.force m2l).sfkt sk fk))
+      }
+
+    let mplus m1 m2 =
+      { sfkt = fun sk fk ->
+          m1.sfkt sk (lazy (m2.sfkt sk fk))
+      }
+
+    let ( !! ) l = Lazy.lazy_from_val (Lazy.force l)
+
+    let (liftl : 'a m Lazy.t -> 'a sfkt) = fun m ->
+      { sfkt = fun sk fk ->
+let () = dbg "lift.%!" in
+ M.bind (fun a -> 
+let () = dbg "lift-bind.%!" in
+sk a fk) (Lazy.force m) }
+
+    let lift m = liftl (Lazy.lazy_from_val m)
+
+    let (reflect : ('a * 'a sfkt) option -> 'a sfkt) = fun r ->
+let () = dbg "reflect.%!" in
+      match r with
+      | None -> mzero
+      | Some (a, tmr) -> mplus (return a) tmr
+
+    let (ssk : ('a, 'b) sk) = fun a fk ->
+let () = dbg "ssk.%!" in
+      M.return (Some (a, (bind reflect (
+let () = dbg "ssk1.%!" in
+let r = liftl fk in
+let () = dbg "ssk2.%!" in
+r
+))))
+
+    let (msplit : 'a sfkt -> ('a * 'a sfkt) option sfkt) = fun tma ->
+let () = dbg "msplit.%!" in
+      lift ( (
+let () = dbg "lift-tma1.%!" in
+            let r = tma.sfkt ssk (lazy (M.return None)) in
+let () = dbg "lift-tma2.%!" in
+            r
+           ))
+
+    let once tma =
+      let retfirst r =
+        match r with
+        | None -> mzero
+        | Some (h, _tm) -> return h
+      in
+        bind retfirst (msplit tma)
+
+
+    let destruct_bindu tma th el =
+      let db r =
+        match r with
+        | None -> el ()
+        | Some (h, tma) -> th h tma
+      in
+        bind db (msplit tma)
+
+
+    let destruct_bind tma th el =
+      destruct_bindu tma th (fun () -> el)
+
+
+    let ifteu tma th el =
+      let inner r =
+        match r with
+        | None -> el ()
+        | Some (h, t) -> bind th (mplus (return h) t)
+      in 
+        bind inner (msplit tma)
+
+
+    let guard cond =
+      if cond then return () else mzero
+
+    (******************************************)
+
+    type 'a m = 'a sfkt
+
+    let ( >>= ) m f = bind f m
+
+    let rec interleave m1 m2 =
+let () = dbg "il.%!" in
+      msplit m1 >>= fun r ->
+let () = dbg "msplit-got.%!" in
+      match r with
+      | None -> m2
+      | Some (h, m1') -> mplus (return h) (interleave m2 m1')
+
+    let ( <+> ) = interleave
+
+    let bagof optnum tma =
+      let rec inner acc optnum tma =
+        let more, optnum =
+          match optnum with
+          | None -> (true, None)
+          | Some n -> (n > 0, Some (n-1))
+        in
+          dbg "bagof inner\n";
+          if more
+          then
+            msplit tma >>= fun destr ->
+              match destr with
+              | None -> return acc
+              | Some (hd, tma) -> inner (hd :: acc) optnum tma
+          else
+            return acc
+      in
+        inner [] optnum tma
+
+
+    let observe tma =
+      let r = ref None in
+      ( ( try ignore (
+           tma.sfkt (fun a _fk -> (r := Some a; raise Exit)) (lazy (M.return ())))
+          with Exit -> ()
+        );
+        !r
+      )
+
+    let runL optnum tma =
+      match observe (bagof optnum tma) with
+      | None -> dbg "runL none\n"; []
+      | Some lst -> dbg "runL some %i\n" (List.length lst); lst
+
+(*
+    let runL optnum tma =
+      let rec inner optnum acc tma =
+        let more, optnum =
+          match optnum with
+          | None -> (true, None)
+          | Some n -> (n <= 0, Some (n-1))
+        in
+          if more
+          then
+            tma.sfkt
+              (fun sk fk -> sk)
+              acc
+          else
+            acc
+      in
+        inner [] optnum tma
+*)
+
+
+    (**************)
+
+    open ExtStream
+
+    let rec from_stream s =
+let () = dbg "from_stream.%!" in
+      match Stream.get_opt s with
+      | None -> mzero
+      | Some x -> mplusl (return x) (lazy (from_stream s))
+
+    let filter p m =
+      m >>= fun x -> if p x then return x else mzero
+
+
+    let ifm m ~th ~el =
+      match observe m with
+      | None -> el ()
+      | Some _ -> th m
+
+
+    let impl_name = "cps"
+
+  end
+
+module type Monad =
+  sig
+    type 'a m
+    val return : 'a -> 'a m
+    val bind : ('a -> 'b m) -> 'a m -> 'b m
+  end
+
+module LogicT :
+  functor (M : Monad) ->
+    sig
+      type 'a m
+      val return : 'a -> 'a m
+      val bind : ('a -> 'b m) -> 'a m -> 'b m
+      val mzero : 'a m
+
+      val mplusl : 'a m -> 'a m Lazy.t -> 'a m
+      val mplus : 'a m -> 'a m -> 'a m
+      val interleave : 'a m -> 'a m -> 'a m
+      val ( <+> ) : 'a m -> 'a m -> 'a m
+
+      val lift : 'a M.m -> 'a m
+      val liftl : 'a M.m Lazy.t -> 'a m
+
+      val reflect : ('a * 'a m) option -> 'a m
+      val msplit : 'a m -> ('a * 'a m) option m
+      val once : 'a m -> 'a m
+      val destruct_bindu :
+        'a m -> ('a -> 'a m -> 'b m) -> (unit -> 'b m) -> 'b m
+      val destruct_bind :
+        'a m -> ('a -> 'a m -> 'b m) -> 'b m -> 'b m
+      val ifteu : 'a m -> ('a -> 'b m) -> (unit -> 'b m) -> 'b m
+      val guard : bool -> unit m
+      val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m
+
+
+      val bagof : int option -> 'a m -> 'a list m
+      val observe : 'a m -> 'a option
+      val runL : int option -> 'a m -> 'a list
+      val from_stream : 'a ExtStream.Stream.t -> 'a m
+      val filter : ('a -> bool) -> 'a m -> 'a m
+      val ifm : 'a m -> th:('a m -> 'b) -> el:(unit -> 'b) -> 'b
+
+      val impl_name : string
+    end
+      type 'a m = 'a list
+
+      let return x = [x]
+
+(*
+      let list_rev_map_append f a b =
+        let inner a acc =
+          match a with
+          | [] -> acc
+          | h::t -> inner t ((f h) :: acc)
+        in
+          inner a b
+*)
+
+      let bind f m =
+        List.fold_left (fun acc x -> List.rev_append (f x) acc) [] m
+
+      let mzero = []
+
+      let mplus = List.rev_append
+
+      let mplusl a bl = mplus a (Lazy.force bl)
+
+      let interleave = mplus
+
+      let ( <+> ) = mplus
+
+      let reflect r =
+        match r with
+        | None -> []
+        | Some (h, t) -> h::t
+
+      let msplit m =
+        match m with
+        | [] -> None
+        | h::t -> Some (h, t)
+
+      let once m =
+        match m with
+        | [] -> []
+        | h::_t -> [h]
+
+      let destruct_bindu m th el =
+        match m with
+        | [] -> el ()
+        | h::t -> th h t
+
+      let destruct_bind m th el =
+        destruct_bindu m th (fun () -> el)
+
+      let ifteu m th el =
+        if m = []
+        then el ()
+        else bind th m
+
+      let ret_unit = [()]
+
+      let guard cond =
+        if cond then ret_unit else []
+
+      let ( >>= ) m f = bind f m
+
+      let runL optnum m =
+        match optnum with
+        | None -> m
+        | Some n ->
+            if n >= List.length m
+            then m
+            else
+              let rec inner acc n m =
+                if n <= 0
+                then acc
+                else
+                  match m with
+                  | [] -> assert false
+                  | h::t -> inner (h::acc) (n-1) t
+              in
+                inner [] n m
+
+      let bagof optnum m =
+        return (runL optnum m)
+
+      let observe m =
+        match m with
+        | [] -> None
+        | h::_t -> Some h
+
+      let from_stream s =
+        let rec inner acc =
+          match ExtStream.Stream.get_opt s with
+          | None -> acc
+          | Some x -> inner (x :: acc)
+        in
+          inner []
+
+      let filter cond m =
+        let rec inner acc m =
+          match m with
+          | [] -> acc
+          | h::t -> if cond h then inner (h::acc) t else inner acc t
+        in
+          inner [] m
+
+      let ifm m ~th ~el =
+        if m = []
+        then el ()
+        else th m
+
+      let impl_name = "list"
+(** ���������� �������� ��������������� ����� �������:
+    123 >> string_of_int >> print_string
+*)
+let ( >> ) x f = f x
+
+(** ��������� �������� � �������:
+    print_string & string_of_int & 123
+
+    NB: �������� "&" �������� �������� ������ � jocaml
+
+    ���� ����������� �������� "let ( $ ) f x = f x",
+    �� ���������� �������� ����� �����������������,
+    ��� ������������ � ������ ������.
+*)
+let ( & ) f x = f x
+
+(** ���������� �������:
+    let print_int = print_string % string_of_int
+    let print_int = print_string $ string_of_int
+    let print_int_sum = print_string % string_of_int %% ( + )
+    let print_int_sum = print_string %% (string_of_int %% ( + ) )
+    let for_all pred = not % List.exists (not % pred)
+    let for_all2 pred = not %% List.exists2 (not %% pred)
+
+    ��������� ����������������, � ��������� ($) ��������� ����,
+    ��� � (%), � ����, ��� � �������������� ����������.
+*)
+let ( % ) f g = fun x -> f (g x)
+let ( $ ) = ( % )
+let ( %% ) f g = fun x y -> f (g x y)
+let ( %%% ) f g = fun x y z -> f (g x y z)
+
+(** ��������� ��������� �������:
+    123L /* Int64.add */ 234L
+*)
+let ( /* ) x y = y x
+let ( */ ) x y = x y
+
+
+(* ��� �������� ������������� ��������� ����������
+   ���������� �������� �������: pa_do
+   ( http://pa-do.forge.ocamlcore.org/ )
+   ���� ������������ ��� �� ������, �� � ��������
+   ������� ������� ����� ����� ������������� ������.
+   �� �������� ����� ��� "���1_as_���2", � ��� ��������
+   ������ ������ �� ���������� ����1 ����� ����� ��������
+   ���� �����������, �������� ������ �������� �� ����������
+   ����2.
+   ��������,
+   let my_int64 =
+     let module M =
+       struct
+         open Int32_as_int
+         open Int64_as_float
+         let x = (Int64.of_int32 (123l + 234l)) +. 345L
+       end
+     in
+       M.x
+*)
+
+(* ���������: ��� ��������������� ������ "���1_as_���2"
+   ������ ������ �������������� ���� � �� �� ���������.
+*)
+
+(* todo: �������� � Int* �������� mod, rem, ������� *)
+
+module Int_as_int =
+  struct
+    let ( + ) = Pervasives.( + )
+    let ( - ) = Pervasives.( - )
+    let ( * ) = Pervasives.( * )
+    let ( / ) = Pervasives.( / )
+    let ( ~- ) = Pervasives.( ~- )
+  end
+
+module Float_as_float =
+  struct
+    let ( +. ) = Pervasives.( +. )
+    let ( -. ) = Pervasives.( -. )
+    let ( *. ) = Pervasives.( *. )
+    let ( /. ) = Pervasives.( /. )
+    let ( ~-. ) = Pervasives.( ~-. )
+  end
+
+
+(** TODO core, pa_do, pa_openin *)
+
+module Int32_as_int =
+  struct
+    let ( + ) = Int32.add
+    let ( - ) = Int32.sub
+    let ( * ) = Int32.mul
+    let ( / ) = Int32.div
+    let ( ~- ) = Int32.neg
+  end
+
+module Int64_as_int =
+  struct
+    let ( + ) = Int64.add
+    let ( - ) = Int64.sub
+    let ( * ) = Int64.mul
+    let ( / ) = Int64.div
+    let ( ~- ) = Int64.neg
+  end
+
+module Int_as_float =
+  struct
+    let ( +. ) = Pervasives.( + )
+    let ( -. ) = Pervasives.( - )
+    let ( *. ) = Pervasives.( * )
+    let ( /. ) = Pervasives.( / )
+    let ( ~-. ) = Pervasives.( ~- )
+  end
+
+module Float_as_int =
+  struct
+    let ( + ) = Pervasives.( +. )
+    let ( - ) = Pervasives.( -. )
+    let ( * ) = Pervasives.( *. )
+    let ( / ) = Pervasives.( /. )
+    let ( ~- ) = Pervasives.( ~-. )
+  end
+
+module Int32_as_float =
+  struct
+    let ( +. ) = Int32.add
+    let ( -. ) = Int32.sub
+    let ( *. ) = Int32.mul
+    let ( /. ) = Int32.div
+    let ( ~-. ) = Int32.neg
+  end
+
+module Int64_as_float =
+  struct
+    let ( +. ) = Int64.add
+    let ( -. ) = Int64.sub
+    let ( *. ) = Int64.mul
+    let ( /. ) = Int64.div
+    let ( ~-. ) = Int64.neg
+  end
+
+module Int_as_int_overflow =
+  (* from http://alan.petitepomme.net/cwn/2004.06.22.html *)
+  struct
+    exception Overflow
+
+    let ( + ) a b =
+      let c = a + b in
+      if (a lxor b) lor (a lxor (lnot c)) < 0 then c else raise Overflow
+
+    let ( - ) a b =
+      let c = a - b in
+      if (a lxor (lnot b)) lor (b lxor c) < 0 then c else raise Overflow
+
+    let ( * ) a b =
+      let c = a * b in
+      if Int64.of_int c = Int64.mul (Int64.of_int a) (Int64.of_int b)
+      then c else raise Overflow
+
+    let ( / ) a b =
+      if a = min_int && b = -1 then raise Overflow else a / b
+
+    let ( ~- ) x =
+      if x <> min_int then -x else raise Overflow
+
+  end
+let impl_name = "stream"
+
+    open ExtStream
+
+    type 'a m = 'a Stream.t
+    type 'a mplus_sig = ?chunk:int -> 'a m -> 'a m -> 'a m
+
+    let mzero = Stream.sempty
+
+    let return = Stream.ising
+
+    let get = Stream.get_opt
+
+    let rec take n m =
+      if n = 0
+      then []
+      else
+        match get m with
+        | None -> ( (* Printf.printf "take finished\n%!"; *) [] )
+        | Some x -> x :: take (n-1) m
+
+    let take_all m =
+      let rec inner acc =
+        match get m with
+        | None -> acc
+        | Some x -> inner (x :: acc)
+      in
+        inner []
+
+    let runL optcount m =
+      match optcount with
+      | None -> take_all m
+      | Some n -> take n m
+
+    let from_stream s = s
+
+    let rec interleave ?(chunk=100) a b =
+      let cont = ref `Empty in
+      let do_cont () =
+        match !cont with
+        | `Empty -> assert false
+        | `Interleave (a, b) -> interleave ~chunk a b
+        | `One a -> a
+      in
+      let rec inner ~left ~acc a b =
+        if left = 0
+        then
+          (cont := `Interleave (a, b); acc)
+        else
+          match get a with
+          | None -> (cont := `One b; acc)
+          | Some x -> inner ~left:(left-1) ~acc:(Stream.icons x acc) b a
+      in
+        inner ~left:chunk ~acc:(Stream.slazy do_cont) a b
+
+    let ( <+> ) ?(chunk=100) a b = interleave ~chunk a b
+
+    let limit n m =
+      let rec inner acc n m =
+        if n <= 0
+        then acc
+        else
+          match get m with
+          | None -> mzero
+          | Some x -> inner (Stream.icons x acc) (n-1) m
+      in
+        inner mzero n m
+
+    let once m =
+        match get m with
+        | None -> mzero
+        | Some x -> return x
+
+    let join_list_step ~chunk lst : 'a m * 'a m list * (unit -> 'a m) ref =
+      let cont = ref (fun () -> assert false) in
+      let do_cont () = !cont () in
+      let rec join_m ~left ~sacc m =
+        if left = 0
+        then (sacc, Some m)
+        else
+          match get m with
+          | None -> (sacc, None)
+          | Some x ->
+              join_m m ~left:(left-1)
+                ~sacc:(Stream.icons x sacc)
+      in
+      let join_list accs lst =
+        List.fold_left
+          (fun (sacc, macc) m ->
+             let (sacc, mres) = join_m ~left:chunk ~sacc m in
+             (sacc, match mres with None -> macc | Some m -> m :: macc)
+          )
+          accs
+          lst
+      in
+        let (sacc, macc) = join_list ((Stream.slazy do_cont), []) lst in
+        (sacc, macc, cont)
+
+    let map ?(chunk=100) f m =
+      let cont = ref (fun () -> assert false) in
+      let do_cont () = !cont () in
+      let rec inner acc ~left =
+        if left = 0
+        then acc
+        else
+          match get m with
+          | None -> acc
+          | Some x -> inner (Stream.icons (f x) acc) ~left:(left-1)
+      in
+        inner (Stream.slazy do_cont) ~left:chunk
+
+    let rec bind_diag_inner ~chunk ~blist f m =
+      let (stream, blist, cont) = join_list_step ~chunk blist in
+      let mtook = take chunk m in
+      let new_b's = List.rev_map f mtook in
+      let blist = List.rev_append new_b's blist in
+      ( cont :=
+          (match (blist, mtook) with
+           | [], [] -> fun () -> mzero
+           | _ -> fun () -> bind_diag_inner ~chunk ~blist f m
+          );
+        stream
+      )
+
+    let bind_diag ~chunk f m =
+      bind_diag_inner ~chunk ~blist:[] f m
+
+    let map_all_rev f m =
+      let rec inner acc =
+        match get m with
+        | None -> acc
+        | Some x -> inner ((f x) :: acc)
+      in
+        inner []
+
+    let bind_wide ~chunk f m =
+      let all_b = map_all_rev f m in
+      bind_diag_inner ~chunk ~blist:all_b f mzero
+
+    let bind_deep ~chunk f m =
+      let rec inner ~chunk ~blist m =
+        let (stream, blist, cont) =
+          join_list_step ~chunk blist in
+        ( cont :=
+            (if blist = []
+             then
+               match get m with
+                 None -> fun () -> mzero
+               | Some a -> fun () -> inner ~chunk ~blist:[f a] m
+             else
+               fun () -> inner ~chunk ~blist m
+            );
+          stream
+        )
+      in
+        inner ~chunk ~blist:[] m
+
+
+    let default_diag_n = 20
+    and default_wide_n = 10
+    and default_deep_n = 100
+
+    type alg =
+      [ `Diag
+      | `Diagn of int
+      | `Wide
+      | `Widen of int
+      | `Deep
+      | `Deepn of int
+      ]
+
+    let ( >>= ) m f = bind_diag ~chunk:default_diag_n f m
+
+    let bind ?(alg=`Diag) f m =
+      match alg with
+      | `Diag -> bind_diag ~chunk:default_diag_n f m
+      | `Diagn n -> bind_diag ~chunk:n f m
+
+      | `Wide -> bind_wide ~chunk:default_wide_n f m
+      | `Widen n -> bind_wide ~chunk:n f m
+
+      | `Deep -> bind_deep ~chunk:default_deep_n f m
+      | `Deepn n -> bind_deep ~chunk:n f m
+
+    external identity : 'a -> 'a = "%identity"
+
+    let join ?(alg=`Diag) m =
+      match alg with
+      | `Diag -> bind_diag ~chunk:default_diag_n identity m
+      | `Diagn n -> bind_diag ~chunk:n identity m
+
+      | `Wide -> bind_wide ~chunk:default_wide_n identity m
+      | `Widen n -> bind_wide ~chunk:n identity m
+
+      | `Deep -> bind_deep ~chunk:default_deep_n identity m
+      | `Deepn n -> bind_deep ~chunk:n identity m
+
+
+    let filter f m =  (* TODO: more optimal impl. *)
+      m >>= (fun x -> if f x then return x else mzero)
+
+    let ifteu ?(alg=`Diag) m th el =
+      match get m with
+      | None -> el ()
+      | Some h -> bind ~alg th (Stream.icons h m)
+
+    let ifte ?(alg=`Diag) m th el =
+      ifteu ~alg m th (fun () -> el)
+
+    let ifm m ~th ~el =
+      match get m with
+      | None -> el ()
+      | Some h -> th (Stream.icons h m)
+
+    let guard cond =
+      if cond then return () else mzero
+
+    let (stream_assign_data : 'a Stream.t -> 'a Stream.t -> unit) =
+    fun sfrom sto ->
+      Obj.set_field (Obj.repr sto) 1 (Obj.field (Obj.repr sfrom) 1)
+
+    let (obj_dup : 'a -> 'a) = fun x -> Obj.obj (Obj.dup (Obj.repr x))
+
+    let msplit m =
+      match Stream.peek m with
+      | None -> None
+      | Some hd ->
+          ( Stream.junk m;
+            let tl = obj_dup m in
+            stream_assign_data (Stream.icons hd tl) m;
+            Some (hd, tl)
+          )
+
+    let destruct_bind m th el =
+      match msplit m with
+      | None -> el
+      | Some (h, t) -> th h t
+
+    let destruct_bindu m th el =
+      match msplit m with
+      | None -> el ()
+      | Some (h, t) -> th h t
+
+    let iter = Stream.iter

logicM_stream.mli

+(** An attempt to port LogicM (Backtracking, Interleaving,
+    and Terminating Monad, see paper http://okmij.org/ftp/papers/LogicT.pdf )
+    to OCaml, implementing it using Streams.
+
+    If you have questions about the design or semantics of some function,
+    please take a look at this paper first.
+
+    Computations are destructive: once one gets result from computation,
+    this operation can't be undone.
+
+    Computations are not ordered, unlike Streams or Lists.
+
+    Although it's possible to get results from computation ([runL], [get])
+    and put them back ([from_stream], [return]), it's preferable to use
+    combinators that get the computations (values of type ['a m]) and
+    return the computations too, to make possible some future optimizations. *)
+
+(** Type of computation returning values of type ['a]. *)
+    type 'a m
+
+(** Computation that returns no results. *)
+    val mzero : 'a m
+
+(** [return x] is the computation that returns [x] as the only result. *)
+    val return : 'a -> 'a m
+
+(** maps values of computation with given function. *)
+    val map : ?chunk:int -> ('a -> 'b) -> 'a m -> 'b m
+
+(** Type of mplus-like functions ([interleave], [( <+> )]).
+    The optional argument [?chunk] determine the count of values
+    to be added to resulting stream before suspending the
+    computation. *)
+    type 'a mplus_sig = ?chunk:int -> 'a m -> 'a m -> 'a m
+
+(** Interleave two calculations: resulting calculation [interleave m1 m2]
+    will return results from [m1] and [m2] both.
+
+    We could have the classic [mplus] too, but since the computations'
+    results are not ordered anyway, and [mplus] imposes ordering on
+    computation, there are no [mplus] here.  Use [interleave]. *)
+    val interleave : 'a mplus_sig
+
+(** Infix operator equal to [interleave]. *)
+    val ( <+> ) : 'a mplus_sig
+
+(** Pass value of this type to [join] and [bind] functions to choose
+    the algorithm to be used while binding/joining. *)
+    type alg =
+      [ `Diag
+      | `Diagn of int
+      | `Wide
+      | `Widen of int
+      | `Deep
+      | `Deepn of int
+      ]
+
+
+(** [join ms] "concatenates" the results of computation [ms],
+    which are the computations itself.
+    Equivalent to [bind (fun x -> x) ms]. *)
+    val join : ?alg:alg -> ('a m) m -> 'a m
+
+(** [bind f m] for computation [m] consisting of results [[a1;a2;..]]
+    returns joined results of computations [[f a1;f a2;..]]. *)
+    val bind : ?alg:alg -> ('a -> 'b m) -> 'a m -> 'b m
+
+(** [m >>= f] is equivalent to [bind f m]. *)
+    val ( >>= ) : 'a m -> ('a -> 'b m) -> 'b m
+
+(** [from_stream s] is the computation that returns all the results
+    that return stream [s].
+
+    Use this function (with Stream.of_list) to get results from list. *)
+    val from_stream : 'a Stream.t -> 'a m
+
+(** [runL None m] returns list with all results of computation [m].
+    [runL (Some n) m] returns list with at most [n] results of
+    computation [m]. *)
+    val runL : int option -> 'a m -> 'a list
+
+(** [limit n m] returns no more that [n] results from computation [m]. *)
+    val limit : int -> 'a m -> 'a m
+
+(** [once m] == [limit 1 m] *)
+    val once : 'a m -> 'a m
+
+(** [filter pred m] returns new computation with the results of [m]
+    that satisfy the predicate [pred].
+
+    It can be implemented as
+    [let filter f m = m >>= (fun x -> if pred x then return x else mzero)] *)
+    val filter : ('a -> bool) -> 'a m -> 'a m
+
+(** [ifte ?alg m th el] returns [bind ?alg th m] if [m] returns at least one
+    result, and returns [el] otherwise. *)
+    val ifte : ?alg:alg -> 'a m -> ('a -> 'b m) -> 'b m -> 'b m
+
+(** [ifteu ?alg m th el] returns [bind ?alg th m] if [m] returns at least one
+    result, and returns [el ()] otherwise. *)
+    val ifteu : ?alg:alg -> 'a m -> ('a -> 'b m) -> (unit -> 'b m) -> 'b m
+
+(** 
+ *)
+    val ifm : 'a m -> th:('a m -> 'b) -> el:(unit -> 'b) -> 'b
+
+    val guard : bool -> unit m
+
+(** . *)
+    val msplit : 'a m -> ('a * 'a m) option
+
+    val destruct_bind : 'a m -> ('a -> 'a m -> 'b m) -> 'b m -> 'b m
+    val destruct_bindu : 'a m -> ('a -> 'a m -> 'b m) -> (unit -> 'b m) -> 'b m
+
+    val iter : ('a -> unit) -> 'a m -> unit
+
+(** {6 Algorithms} *)
+
+(** You can choose the algorithm to be used by [join] and [bind] functions.
+
+    There are three algorithms: wide-first, depth-first and diagonal walking.
+
+    Since Streams can be composed either eagerly or lazy, and lazy
+    composition has some overhead, every algorithm has parameter that
+    determines how many stream items will be added eagerly before
+    suspending the Stream building.
+
+    The [join] function can be trivially expressed using [bind]:
+    [let join ma = bind (fun a -> a) ma]
+    That's how the [join] is implemented now, and values of type [alg]
+    affect the [join]'s behaviour too, the same way.
+
+    Assume we have computation [ma] returning [a1;a2;..].
+    Let the "bind function" [f] will be the [f] for [bind f ma]
+    and [identity] for [join ma].
+
+    With [`Wide] and [`Widen n], functions will read the whole
+    [ma] = [a1;a2;..;ak] into memory, map it with [f], then the
+    resulting stream will be composed from [n] results taken
+    sequentially from [a1], [a2] and so on, so [n*k] values will be
+    added to the result eagerly.
+
+    When you choose wide-first walking, and [ma] is infinite,
+    the algorithm will eat up all memory while reading [ma].
+
+    You can choose wide-first walking if [ma] is finite, if you
+    want to get all its results (for example, to free some resources
+    associated with [ma]), and if the results you need are returned
+    at the beginning of [f an] computations.
+
+    With [`Deep] and [`Deepn n], functions will read results of
+    [f a1], then results from [f a2] and so on, adding
+    approximately [n] values to the result eagerly.
+
+    When you choose depth-first walking, and there exists some [n]
+    that computation [f an] is infinite, then [bind] will read results
+    from this [f an] infinitely, and [f an+1] will be left untouched.
+
+    You can choose depth-first walking if you want to keep used
+    memory low, if you want to have at most one of [f an] computation
+    active at time (for example, to avoid concurrent use of resources
+    associated with [f an]), or if the results you need are returned
+    by processing first [an]'s ([f a1], [f a2]).
+
+    With [`Diag] and [`Diagn n], functions will read values
+    diagonally, adding approximately [n^2] values to the result
+    eagerly.  In worst case, there will be [s*n] values of type
+    ['b m] (computations [f a1; f a2; .. f a_s*n]) present
+    in memory, where [s] is the number of step, and if all
+    [f ai] are infinite, then used memory will grow linearly.
+
+    (todo: do we need to limit the number of ['b m] values present
+    in memory?)
+
+    (todo: do we need to specify the chunk size for reading [ma]
+    and for reading [f an] separately?)
+
+    You can choose diagonal walking if you want to get results
+    when [ma] and [f an] are possibly infinite computations, or
+    when the results you need are distributed uniformly in [f an].
+
+    The default algorithm is diagonal walking.
+
+    The default chunk sizes are: for `Wide -- 10, for `Deep -- 100,
+    for `Diag -- 20.
+*)
+
+    val impl_name : string
+@call c:\overbld\ocaml\set-vars.bat
+@bash run.sh
+TARGET=tests.native
+# rm -f $TARGET && ocamlbuild $TARGET && echo "------------------" && ( ./$TARGET | head -c 1200 ) || echo "exit code: $?"
+ocamlbuild logicM_cps.inferred.mli || exit 1
+rm -f $TARGET && ocamlbuild $TARGET && echo "------------------" && ./$TARGET || echo "exit code: $?"
+open ExtStream
+open LogicM_ops
+
+
+module type Tests_sig
+ =
+  sig
+    module LogicM
+     :
+      sig
+        type 'a m
+        val return : 'a -> 'a m
+        val from_stream : 'a Stream.t -> 'a m
+(*
+        type 'a mplus_sig = 'a m -> 'a m -> 'a m
+        val ( <+> ) : 'a mplus_sig
+*)
+        val ( <+> ) : 'a m -> 'a m -> 'a m
+        val filter : ('a -> bool) -> 'a m -> 'a m
+        val runL : int option -> 'a m -> 'a list
+        val mzero : 'a m
+        val ifm : 'a m -> th:('a m -> 'b) -> el:(unit -> 'b) -> 'b
+        val ifteu : 'a m -> ('a -> 'b m) -> (unit -> 'b m) -> 'b m
+        val guard : bool -> unit m
+
+        val destruct_bind : 'a m -> ('a -> 'a m -> 'b m) -> 'b m -> 'b m
+        val destruct_bindu : 'a m -> ('a -> 'a m -> 'b m) -> (unit -> 'b m) -> 'b m
+
+        val once : 'a m -> 'a m
+
+        val impl_name : string
+      end
+
+    type bindr = { bind : 'a 'b .
+      ('a -> 'b LogicM.m) -> 'a LogicM.m -> 'b LogicM.m
+    }
+
+    val run_test : time:((unit -> unit) -> unit -> unit) ->
+      fn:string -> (bindr:bindr -> unit -> unit) -> unit
+
+  end
+
+
+
+module TestsF (T : Tests_sig)
+ =
+  struct
+
+    open T
+    open LogicM
+
+(*
+module Lz
+ =
+  struct
+
+    type 'a partial_list = ('a list -> 'a list)
+
+    let empty_partial_list : 'a partial_list =
+    (fun x -> x)
+
+    let cons : 'a -> 'a list -> 'a list = fun h t -> h :: t
+
+    let append : 'a partial_list -> 'a -> 'a partial_list =
+    fun prefix x ->
+      (fun xs -> (prefix (cons x (xs))))
+
+    let (to_list : 'a partial_list -> 'a list) =
+    fun p ->
+      let () = Printf.printf "to_list#1\n%!" in
+      let pf = p in
+      let () = Printf.printf "to_list#2\n%!" in
+      pf []
+
+
+    let to_list_take : int -> 'a partial_list -> 'a list =
+fun _ _ -> raise Exit
+
+
+    let nums =
+      let rec loop lst i =
+        if i = 20
+        then lst
+        else
+          let () = Printf.printf "loop/i=%i %!" i in
+          (* тут энергично строится список вызовами loop *)
+          loop (append lst i) (i+1)
+      in
+        loop empty_partial_list 0
+
+
+    let print_list lst =
+      ( List.iter (Printf.printf "%i %!") lst;
+        Printf.printf "\n%!"
+      )
+
+    let () = print_list (to_list (nums))
+
+  end
+
+let () = exit 0
+*)
+
+
+
+(* let point n = (Printf.printf "point %s... %!" n; ignore (read_line ())) *)
+
+(*
+let run_test_interleave () =
+  Printf.printf "test_interleave: %!";
+  let s_odds = Stream.ints ~nstep:2 1 in
+(*
+  let s_odds = Stream.map (fun x -> Printf.printf "odd: %i\n" x; x) s_odds in
+*)
+let () = point "before fromstream" in
+  let odds = from_stream s_odds in
+  let four = return 4 in
+let () = point "before +" in
+  let odds_and_four = odds <+> four in
+(*
+  let evens = filter (fun x -> x mod 2 = 0) odds_and_four in
+*)
+let () = point "before filter" in
+  let evens = filter (fun x -> x mod 2 = 0) odds_and_four in
+let () = point "before runL" in
+  List.iter (Printf.printf "%i %!") (runL (Some 1) evens);
+  print_newline ()
+
+
+let () = run_test_interleave ()
+
+
+let () = exit 0
+*)
+
+
+
+let test_interleave ~bindr () =
+  ignore bindr;
+  Printf.printf "test_interleave: %!";
+  let odds : int LogicM.m = from_stream (Stream.ints ~nstep:2 1) in
+  let four : int LogicM.m = return 4 in
+  let odds_and_four = odds <+> four in
+  let evens = filter (fun x -> x mod 2 = 0) odds_and_four in
+  List.iter (Printf.printf "%i %!") (runL (Some 1) evens);
+  print_newline ()
+
+
+
+let test_bind ~bindr () =
+  Random.init 12345678;
+  let ( >>= ) m f = bindr.bind f m in
+  let gen_randoms = Stream.from_repeat (fun () -> Random.int 10) ()
+  and mkpair x y = (x, y)
+  and gen_numbers : int Stream.t = Stream.ints 0 ~nend:10 in
+  let gen_randoms_numbered = Stream.map2 mkpair gen_randoms gen_numbers in
+  let gen_randoms_numbered = Stream.map
+     (fun (n, ord) ->
+(*
+        Printf.printf "pre:ord=%i,n=%i\n%!" ord n;
+*)
+        (n, ord)
+     )
+     gen_randoms_numbered in
+  let m1 = from_stream gen_randoms_numbered in
+  let bindfunc (n, ord) =
+    from_stream
+      (Stream.map
+         (fun m -> Printf.sprintf "d:ord=%i,n=%i,m=%i" ord n m)
+         (Stream.ints ~nend:n 1)
+      )
+  in
+  let m2 = m1 >>= bindfunc in
+  List.iter (Printf.printf "r:%s\n%!") (runL (Some 1000) m2);
+  print_newline ()
+
+
+let step_colatz n : int m =
+(*
+  Printf.printf "c:%i %!" n;
+*)
+  if n = 1 then mzero else
+  if n mod 2 = 0 then return & n/2 else
+  let r = 3*n+1 in
+    if r <= 0 then mzero else return r
+
+
+let test_colatz1 nmax ~bindr () =
+  let s = Stream.ints 1 ~nend:nmax in
+  let m = from_stream s in
+  let rec inner m : int m =
+   ifm m ~th:(fun m -> inner (bindr.bind step_colatz m)) ~el:(fun () -> mzero)
+  in
+    ignore &
+    runL (Some 1) &
+    ifteu (inner m) (fun x -> Printf.printf "left value: %i\n" x; mzero)
+      (fun () -> (*Printf.printf "colatz ok for ints <= %i\n" nmax;*) mzero)
+
+
+let test_colatz2 nmax ~bindr () =
+  let ( >>= ) m f = bindr.bind f m in
+  let s = Stream.ints 1 ~nend:nmax in
+  let m = from_stream s in
+  let rec inner n : int m =
+    step_colatz n >>= inner
+  in
+    ignore &
+    runL (Some 1) &
+    (m >>= inner >>= fun x -> Printf.printf "left value: %i\n" x; mzero)
+
+
+let ( -- ) nfrom nto =
+  assert (nfrom <= nto);
+  from_stream (Stream.ints nfrom ~nend:nto)
+
+
+module Su
+ :
+  sig
+    val test : bindr:T.bindr -> unit -> unit
+  end
+ =
+  struct
+    type cell = { x : int; y : int; n : int }
+    type board = cell list
+
+    let xsize = 9
+    let ysize = 9
+
+(*
+let () =
+((  (0 -- (ysize-1) >>= fun q -> guard (q mod 3 = 0) >>= fun () -> return q)
+   >>
+  iter (fun q -> Printf.printf "%i \n" q)
+)
+; raise Exit
+)
+*)
+
+    let lines_of_board b : string list =
+      let a = Array.make_matrix ysize xsize '.' in
+      let () =
+        List.iter
+          (fun {x=x; y=y; n=n} ->
+             assert (a.(y).(x) = '.');
+             a.(y).(x) <- Char.chr ((Char.code '0') + n)
+          )
+          b
+      in
+      a >> Array.map
+        (fun line ->
+           Array.fold_left
+             (fun (str, i) c ->
+                ( Printf.sprintf "%s%c %s" str c (if i = 2 then "  " else "")
+                , (i+1) mod 3
+                )
+             )
+             ("", 0)
+             line
+        ) >>
+    Array.fold_left
+      (fun (acc, i) (l, _) ->
+         let acc = l :: acc in
+         let acc = if i = 2 then "" :: acc else acc in
+         (acc, (i+1) mod 3)
+      )
+      ([], 0)
+   >> fst >> List.rev
+
+    let print_board b =
+      b >> lines_of_board >>
+      List.iter (Printf.printf "%s\n");
+      print_newline ()
+
+
+(*
+    module Ennum =
+      struct
+(*
+        module H = Hashtbl.Make(struct type t = .... m let equal = (==) let hash _ = 0)
+        open H
+        let ht = create 7
+        let find_opt m = try find ht m with 
+*)
+        let l = ref []
+        let get_opt m = try Some (List.assq m !l) with Not_found -> None
+
+        let get =
+          let n = ref 0 in
+          fun m ->
+            match get_opt m with
+            | None ->
+                let c = !n in
+                ( l := (m, c) :: !l;
+                  incr n;
+                  c
+                )
+            | Some c -> c
+
+      end
+*)
+
+
+    let solve ~bindr board =
+      let ( >>= ) m f = bindr.bind f m in
+      let cell_is_empty x y =
+        not & List.exists (fun {x=cx; y=cy} -> cx = x && cy = y) board
+      in
+      (0 -- (ysize-1) >>= fun y ->
+       0 -- (xsize-1) >>= fun x ->
+       guard (cell_is_empty x y) >>= fun () -> return (x, y)
+      ) >>
+      fun empty_cells ->
+      let rec inner depth board empty_cells =
+(*
+let () = Printf.printf "depth=%i, ec#=%i   %!" depth (Ennum.get empty_cells) in
+*)
+        destruct_bindu empty_cells
+          (fun (x, y) empty_cells ->
+(*
+let () = Printf.printf "empty cell: (%i, %i)\n%!" x y in
+*)
+             1 -- 9 >>= fun n ->
+             guard (not & List.exists
+               (fun {x=cx; y=cy; n=cn} ->
+                  (n = cn) &&
+                  ((x = cx) || (y = cy) || (x/3 = cx/3 && y/3 = cy/3))
+               ) board) >>= fun () ->
+(*
+let () = Printf.printf "cont with (%i, %i) := %i\n%!" x y n in
+*)
+               inner (depth+1) ({x=x; y=y; n=n} :: board) empty_cells
+          )
+          (fun () ->
+(*
+let () = Printf.printf "solution found!\n%!" in
+*)
+             return board)
+      in
+        inner 0 board empty_cells
+
+
+    let example_txt =
+        ".9..1.3.26.1.......2.8...91..8.....74"
+      ^ "....8..3....3185.9....2.....2..5.493.549..2."
+
+    let board_of_txt txt =
+      assert (String.length txt = xsize * ysize);
+      let cellch ch =
+        match ch with
+        | '.' -> None
+        | '1'..'9' -> Some ((Char.code ch) - (Char.code '0'))
+        | _ -> assert false in
+      let r = ref [] in
+      ( for y = 0 to ysize-1 do
+          for x = 0 to xsize-1 do
+            match (cellch txt.[xsize*y + x]) with
+            | None -> ()
+            | Some n -> r := {x=x; y=y; n=n} :: !r
+          done
+        done
+      ; !r
+      )
+
+    let example : board = board_of_txt example_txt
+
+    let test ~bindr () =
+      print_board example;
+      runL None (once (solve ~bindr example)) >>
+      let c = ref 0 in
+      List.iter (fun board ->
+         incr c; Printf.printf "sol#%i\n%!" !c; print_board board
+        )
+
+  end
+
+
+let time f x =
+  let t_beg = Unix.gettimeofday () in
+  let r = f x in
+  let t_end = Unix.gettimeofday () in
+  ( Printf.printf "time = %.2f\n%!" (t_end -. t_beg)
+  ; r
+  )
+
+
+let __test1 ~bindr () =
+  let () = ignore bindr in
+  1 -- 2 >> fun m ->
+  let th_pr h _t = (Printf.printf "h=%i\n%!" h; mzero)
+  and el_pr () = (Printf.printf "fin\n%!"; return ()) in
+  ( ( (destruct_bindu m th_pr el_pr) <+>
+      (destruct_bindu m th_pr el_pr) <+>
+      (destruct_bindu m th_pr el_pr) <+>
+      (destruct_bindu m th_pr el_pr) <+>
+      (destruct_bindu m th_pr el_pr)
+    ) >>
+    runL None >> ignore
+  )
+
+
+let _test1 ~bindr () =
+  let ( >>= ) m f = bindr.bind f m in
+  let _map f m = m >>= fun x -> return (f x) in
+  let rec inner acc m =
+    destruct_bind m
+      (fun x m ->
+         guard (0 = x land (x-1)) >>= fun () ->
+         inner (x::acc) m
+      )
+      (return acc)
+(*
+    if n = 1 then return a else
+    guard (n mod 2 = 0) >>= fun () ->
+    inner (n/2, a*2)
+*)
+  in
+    let r = (1 -- 100) >> inner [] in
+    let l = runL None r in
+    List.iter (fun q -> List.iter (Printf.printf "%i %!") q; print_newline ()) l;
+    print_newline ()
+
+
+
+let run_tests () =
+  let run_test = run_test ~time in
+  (
+    Printf.printf "====== STARTED TESTING LogicM_%s ======\n%!"
+      LogicM.impl_name;
+
+    run_test ~fn:"interleave" test_interleave;
+    run_test ~fn:"bind" test_bind;
+    run_test ~fn:"colatz1" (test_colatz1 30000);
+    run_test ~fn:"colatz2" (test_colatz2 30000);
+    run_test ~fn:"sudoku" Su.test;
+
+    Printf.printf "====== FINISHED TESTING LogicM_%s ======\n%!"
+      LogicM.impl_name;
+  )
+
+
+end
+
+
+module T_stream = TestsF(Tests_stream)
+
+module T_cps = TestsF(Tests_cps)
+
+module T_list = TestsF(Tests_list)
+
+
+let () =
+  (
+    T_stream.run_tests ();
+    T_cps.run_tests ();
+    T_list.run_tests ();
+  )
+

tests_common.ml

Empty file added.
+open LogicM_cps
+
+
+module MonadIdentity : Monad
+ =
+  struct
+    type 'a m = 'a
+    let return x = x
+    let bind f m = f m
+  end
+
+
+module LogicM = LogicT(MonadIdentity)
+
+type bindr = { bind : 'a 'b .
+  ('a -> 'b LogicM.m) -> 'a LogicM.m -> 'b LogicM.m
+}
+
+
+let run_test ~time ~fn testfunc =
+  Printf.printf "%s/cps:\n%!" fn;
+  time (testfunc ~bindr:{bind = LogicM.bind}) ();
+  print_newline ()
+module LogicM = LogicM_list
+
+type bindr = { bind : 'a 'b .
+  ('a -> 'b LogicM.m) -> 'a LogicM.m -> 'b LogicM.m
+}
+
+let run_test ~time ~fn testfunc =
+  Printf.printf "%s/list:%!" fn;
+  if fn = "interleave"
+  then Printf.printf "  skipped.\n%!"
+  else
+    (
+      Printf.printf "\n%!";
+      time (testfunc ~bindr:{bind = LogicM.bind}) ();
+      print_newline ()
+    )
+open Tests_common
+
+module LogicM =
+  struct
+    include LogicM_stream
+    let ( <+> ) a b = interleave ~chunk:100 a b
+    let ifteu m th el = ifteu ~alg:`Diag m th el
+  end
+
+open LogicM
+
+type bindr = { bind : 'a 'b . ('a -> 'b m) -> 'a m -> 'b m }
+
+let run_test ~time ~fn testfunc =
+    List.iter
+      (fun (alg_name, alg) ->
+         Printf.printf "%s/%s\n%!" fn alg_name;
+         let () = time
+           (testfunc ~bindr:{bind = fun f m -> (LogicM.bind ~alg f m)}) () in
+         print_newline ()
+      )
+      [
+        ("diag50", (`Diagn 50));
+        ("deep", `Deep)
+      ; ("wide", `Wide)
+      ]