Source

ocaml-lib / monad / examples.ml

Full commit

module State =
struct
  type t = { cpt : int }

  let init = { cpt = 0 }
    
  let get = u_def (let s = u_state in return s.cpt)
  let incr = u_def (let s = u_state in u_state <- { cpt = s.cpt + 1 })
  let print_line str = u_def (return (print_endline str))
end

let rec safe_aux (p1,p2,p3) = (* low diagonal, line, high diagonal *)
  function
    | [] -> true
    | p::ps1 -> p <> p1 && p <> p2 && safe_aux (p1-1,p2,p3+1) ps1
let safe p ps1 = safe_aux (p-1,p,p+1) ps1

let rec nqueens n k =
  if k=0
  then u_def (
    let i = State.get in
    State.print_line ("k=" ^ string_of_int i);
    return [])
  else u_def (
    let ps1 = State.incr; nqueens n (k-1) in
    let p = LogicMonad.Int.range 1 n in
    guard (safe p ps1);
    return (p::ps1))

let print_sol ps =
  List.iter (fun p -> print_int p; print_char ' ') ps;
  print_newline ()

let _ = 
  let n = try int_of_string Sys.argv.(1) with _ -> 4 in
  let k = try int_of_string Sys.argv.(2) with _ -> 10 in
  if u_test with u_state = State.init;
    succeeds (nqueens n n)
  then
    print_endline "There are solutions!";
(*
  let sols = u_run with u_state = State.init; bagof ~limit:k (nqueens n n) in
  List.iter print_sol sols
*)
  u_run with u_state = State.init;
    iter ~limit:k
      print_sol
      (nqueens n n)

(* ---------------- *)

class virtual expr =
object (self)
  method virtual get : string -> string u_monad with u_state = State.t and u_error = string
  method virtual look : string -> string u_monad with u_state = State.t and u_error = string

  method parse_add = u_def (
    let v1 = self#parse_mult in
    let f = self#parse_add_aux in
    return (f v1))
  method parse_add_aux = u_def
    begin
      | self#look "+";
        let v2 = self#parse_mult in
	let f = self#parse_add_aux in
	return (fun v1 -> f (v1 + v2))
      | return (fun v1 -> v1)
    end
  method parse_mult = u_def (
    let v1 = self#parse_atom in
    let f = self#parse_mult_aux in
    return (f v1))
  method parse_mult_aux = u_def
    begin
      | self#look "*";
        let v2 = self#parse_atom in
	let f = self#parse_mult_aux in
	return (fun v1 -> f (v1 * v2))
      | return (fun v1 -> v1)
    end
  method parse_atom = u_def
    begin
      | let s = self#get "[0-9]+" in
	return (int_of_string s)
      | self#look "(";
	let v = self#parse_add in
	self#look ")";
	return v
    end
end

(* ----------------- *)

type tree = Leaf | Node of int * tree * tree

let rec post_order = function
  | Leaf -> u_def return 0
  | Node (i,left,right) -> u_def (
    let sum_left = post_order left in
    let sum_right = post_order right in
    let sum = return (sum_left + sum_right + i) in
    yield sum;
    return sum)

let post_order_run =
  u_run
    try post_order (Node (1, Node (2, Leaf, Leaf), Node (3, Leaf, Node (4, Leaf, Leaf)))); return ()
    with sum -> return (print_int sum; print_newline ())
(* post_order sum: 2, 4, 7, 10 *)