monad_delcont.ml

(* sort 関係 *)
type Ordering = LT | GT | EQ;;
 
let rec filter pred lst = match lst with 
    (x::rest) -> if pred x
		 then x :: filter pred rest
		 else filter pred rest
   | [] -> []
;;

let compare_nat (x, y) = if x > y then GT
			 else if x < y then LT
			 else EQ
;;

let rec sort lst = match lst with
    (pivot::rest) -> let lt = filter (fun x -> (compare_nat (pivot, x)) == LT) rest 
		     and gt = filter (fun x -> (compare_nat (pivot, x)) != LT) rest in
		     (sort gt) @ (pivot :: (sort lt))
  | [] -> []
;;

let rec sort_by compare lst = match lst with
    (pivot::rest) -> let lt = filter (fun x -> (compare (pivot, x)) == LT) rest 
		     and gt = filter (fun x -> (compare (pivot, x)) != LT) rest in
		     (sort_by compare gt) @ (pivot :: (sort_by compare lt))
  | [] -> []
;;


let count_compare sort compare lst = 
  let n = ref 0
  in sort (fun (x, y) ->
	   n := !n + 1;
	   compare (x, y))
	  lst;
     !n
;;
  
(* state monad 関係 *)
let return x = fun s -> (x, s);;
let bind mx f = fun s ->
  let (a, s') = mx s in
  f a s'
;;  

let get = fun s -> (s, s);;
let put x = fun _ -> ((), x);;

let runState m s = m s;;
let execState m s = let (_, s') = m s in s';;

(* reify, reflect *)
let reify expr = reset (fun () -> 
			let v = expr() 
			in return v)
;;

let reflect x = shift (fun k -> bind x k);;

(* stateを使ったカウンター *)
let count = reify (fun () ->
		   reflect (put 1);
		   reflect (put (2 * (reflect get))))
;;

let count_compare' sort compare lst = 
  let compare' (x, y) = 
    reflect (put (1 + (reflect get)));
    compare (x, y)
  in execState (reify (fun () -> sort compare' lst)) 0
;;