Commits

Sébastien Ferré committed 76ea607

[sumonad] first stable version

Comments (0)

Files changed (4)

+
+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 state =
+object (self)
+  method print_line s = print_endline s; Sumonad.Stream.Single (Sumonad.Result (), self)
+end
+
+let rec range n = sumonad
+  begin
+    | return n
+    | when n>1; range (n-1)
+  end
+
+let rec nqueens n k = sumonad
+  begin
+    if k=0
+    then begin
+      # print_line "k=0";
+      return [] end
+    else
+      for ps1 <- nqueens n (k-1) do
+	for p <- range n do
+	  when (safe p ps1);
+	  let ps = p::ps1 in
+	  return ps
+	done
+      done
+  end
+
+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
+  let print ps = List.iter (fun p -> print_int p; print_char ' ') ps; print_newline () in
+  Sumonad.kiter print k (nqueens n n) state
+OCAMLC=ocamlc
+INCLUDES= -I ..               # all relevant -I options here
+OCAMLFLAGS= $(INCLUDES)    # add other options for ocamlc here
+OCAMLDOCFLAGS= -d doc $(INCLUDES)
+
+# The list of object files
+OBJ = sumonad.cmo
+
+all: sumonad.cma pa_sumonad.cmo
+	echo
+
+sumonad.cma: $(OBJ)
+	ocamlc $(OCAMLFLAGS) -a -o sumonad.cma $(OBJ)
+	ocamlopt $(OCAMLFLAGS) -a -o sumonad.cmxa $(OBJ:.cmo=.cmx)
+
+pa_sumonad.cmo: pa_sumonad.ml
+	ocamlc -I +camlp4 camlp4lib.cma -pp camlp4orf -c pa_sumonad.ml
+
+essai.exe: essai.ml
+	ocamlc -o essai.exe -pp "camlp4o -I . pa_sumonad.cmo" str.cma sumonad.cma essai.ml
+
+# Common rules
+.SUFFIXES: .ml .mli .cmo .cmi
+
+%.cmo: %.ml
+	ocamlc $(OCAMLFLAGS) -c $<
+	ocamlopt $(OCAMLFLAGS) -c $<
+
+# Documentationg
+html:
+	ocamldoc $(OCAMLDOCFLAGS) -html $(ALL:.cmo=.ml)
+
+# Clean up
+clean:
+	rm -f *.cm[ioax]
+	rm -f *.cmxa
+	rm -f *.[oa]

sumonad/pa_sumonad.ml

+
+open Camlp4.PreCast
+open Syntax
+
+EXTEND Gram
+  GLOBAL: expr;
+
+  expr: LEVEL "top"
+      [ [ "sumonad"; m = atom -> <:expr< (*let open Sumonad in*) fun state -> $m$ state >> ] ];
+
+  block:
+      [ [ "begin"; OPT "|"; m = alt; "end" -> m
+	| "("; OPT "|"; m = alt; ")" -> m 
+	] ];
+    
+  alt:
+      [ [ m1 = seq; m2o = OPT [ "|"; m2 = alt -> m2 ] ->
+        match m2o with
+	| None -> m1
+	| Some m2 -> <:expr< Sumonad.mplus $m1$ $m2$ >>
+	] ];
+
+  seq:
+    [ [ m1 = atom; m2o = OPT [ ";"; m2 = seq -> m2 ] ->
+      match m2o with
+	| None -> m1
+	| Some m2 -> <:expr< Sumonad.bind $m1$ (fun _ -> $m2$) >>
+        ] ];
+
+  atom:
+    [ [ m = block -> m
+      | "return"; e = expr LEVEL "top" -> <:expr< Sumonad.return $e$ >>
+      | "fail" -> <:expr< Sumonad.fail >>
+      | "error"; e = expr LEVEL "top" -> <:expr< Sumonad.error $e$ >>
+      | "when"; b = expr LEVEL "top" -> <:expr< Sumonad.guard $b$ >>
+      | "if"; b = expr LEVEL "top";
+	"then"; m1 = atom;
+	m2o = OPT [ "else"; m2 = atom -> m2 ] ->
+	(match m2o with
+	  | None -> <:expr< Sumonad.ifthenelse $b$ $m1$ Sumonad.fail >>
+	  | Some m2 -> <:expr< Sumonad.ifthenelse $b$ $m1$ $m2$ >>)
+      | "let"; x = ipatt; "="; e = expr LEVEL "top"; "in"; m = seq ->
+        <:expr< (fun s -> let $pat:x$ = $e$ in $m$ s) >>
+      | "match"; e = expr LEVEL "top"; "with"; OPT "|"; f = rules -> f e
+      | "for"; x = ipatt; "<-"; m1 = atom; "do"; m2 = seq; "done" ->
+        <:expr< Sumonad.bind $m1$ (fun $pat:x$ -> $m2$) >>
+      | "#"; id = a_LIDENT; le = LIST0 [ e = expr LEVEL "top" -> e ] ->
+        let app = List.fold_left (fun res arg -> <:expr< $res$ $arg$ >>) <:expr< state # $lid:id$ >> le in 
+	<:expr< fun state -> $app$ >>
+      | m = expr LEVEL "top" -> m ] ];
+
+  rules:
+    [ [ f1 = rule; f2o = OPT [ "|"; f2 = rules -> f2 ] ->
+      match f2o with
+	| None -> f1
+	| Some f2 -> (fun e -> <:expr< Sumonad.mplus $f1 e$ $f2 e$ >>)
+      ] ];
+
+  rule:
+    [ [ x = ipatt; "->"; m = seq -> (fun e -> <:expr< fun s -> match $e$ with [ $pat:x$ -> $m$ s | _ -> Sumonad.Stream.Nil ] >>) ] ];
+ 
+END;

sumonad/sumonad.ml

+
+module Stream =
+struct
+  type 'a t =
+    | Nil
+    | Single of 'a
+    | Cons of 'a * 'a t
+    | Lazy of (unit -> 'a t)
+
+  let rec concat : 'a t * 'a t -> 'a t = function
+    | Nil, str2 -> str2
+    | str1, Nil -> str1
+    | Single x1, str2 -> Cons (x1,str2)
+    | Cons (x1,rest1), str2 -> Cons (x1, concat (rest1, str2))
+    | Lazy f1, str2 -> Lazy (fun () -> concat (f1 (), str2))
+
+  let rec read : 'a t -> ('a * 'a t) option = function
+    | Nil -> None
+    | Single x -> Some (x, Nil)
+    | Cons (x,str) -> Some (x, str)
+    | Lazy f -> read (f ())
+end
+
+type ('a,'e) either = Result of 'a | Error of 'e
+
+type ('a,'e,'s) t = 's -> (('a,'e) either * 's) Stream.t
+
+let return (x : 'a) : ('a,'e,'s) t =
+  fun s -> Stream.Single (Result x, s)
+
+let rec bind (m : ('a,'e,'s) t) (k : 'a -> ('b,'e,'s) t) : ('b,'e,'s) t = 
+  fun s -> bind_aux (m s) k
+and bind_aux ms k =
+  match ms with
+    | Stream.Nil -> Stream.Nil
+    | Stream.Single (x,s') -> bind_either x s' k
+    | Stream.Cons ((x,s'),str) -> Stream.concat (bind_either x s' k, Stream.Lazy (fun () -> bind_aux str k))
+    | Stream.Lazy fstr -> bind_aux (fstr ()) k
+and bind_either x s' k =
+  match x with
+    | Result v -> k v s'
+    | Error e -> Stream.Single (Error e, s')
+
+let fail : ('a,'e,'s) t =
+  fun s -> Stream.Nil
+
+let error msg : ('a,'e,'s) t =
+  fun s -> Stream.Single (Error msg, s)
+
+let mplus (m1 : ('a,'e,'s) t) (m2 : ('a,'e,'s) t) : ('a,'e,'s) t =
+  fun s -> Stream.concat (m1 s, Stream.Lazy (fun () -> m2 s))
+
+let guard (cond : bool) : (unit,'e,'s) t =
+  fun s ->
+    if cond
+    then Stream.Single (Result (), s)
+    else Stream.Nil
+
+let ifthenelse (cond : bool) (m1 : ('a,'e,'s) t) (m2 : ('a,'e,'s) t) : ('a,'e,'s) t =
+  fun s ->
+    if cond
+    then m1 s
+    else m2 s
+
+let update (modif : 's -> ('s,'e) either) : (unit,'e,'s) t =
+  fun s ->
+    match modif s with
+      | Result s' -> Stream.Single (Result (), s')
+      | Error e -> Stream.Single (Error e, s)
+
+let view (access : 's -> ('a,'e) either) : ('a,'e,'s) t =
+  fun s -> Stream.Single (access s, s)
+
+(* syntactic sugar
+
+return v
+fail
+error e
+for x in m1; m2 ---> bind m1 (fun x -> m2)
+m1 | m2 ---> mplus m1 m2
+when cond ---> guard cond
+update modif
+view access
+
+*)
+
+
+let rec kiter (f : 'a -> unit) (k : int) (m : ('a,'e,'s) t) (s : 's) : unit =
+  kiter_aux f k (m s)
+and kiter_aux f k str =
+  if k = 0
+  then ()
+  else
+    match Stream.read str with
+      | None -> ()
+      | Some ((x,s), rest) ->
+	match x with
+	  | Result v -> f v; kiter_aux f (k-1) rest
+	  | Error e -> kiter_aux f k rest
+
+let rec klist (k : int) (m : ('a,'e,'s) t) (s : 's) : 'a list =
+  klist_aux k (m s)
+and klist_aux k str =
+  if k = 0
+  then []
+  else
+    match Stream.read str with
+      | None -> []
+      | Some ((x,s), rest) ->
+	match x with
+	  | Result v -> v :: klist_aux (k-1) rest
+	  | Error e -> klist_aux k rest
+
+let rec fold (f : 'acc -> ('a,'e) either * 's -> 'acc) (acc : 'acc) (m : ('a,'e,'s) t) (s : 's) : unit =
+  iter_aux f acc (m s)
+and iter_aux f acc str =
+  match Stream.read str with
+    | None -> acc
+    | Some (x_s, rest) -> let acc' = f acc x_s in iter_aux f acc' rest
+
+
+module List =
+struct
+  let rec choose : 'a list -> ('a,'e,'s) t = function
+    | [] -> fail
+    | x::l -> mplus (return x) (choose l)
+
+  let rec map (f : 'a -> ('b,'e,'s) t) : 'a list -> ('b list,'e,'s) t = function
+    | [] -> return []
+    | x::lx -> bind (f x) (fun y -> bind (map f lx) (fun ly -> return (y::ly)))
+end