diff --git a/Makefile b/Makefile index 8286bcfb..5751211b 100644 --- a/Makefile +++ b/Makefile @@ -49,6 +49,8 @@ examples: all push_doc: doc scp -r containers.docdir/* cedeela.fr:~/simon/root/software/containers/ + scp -r containers_string.docdir/* cedeela.fr:~/simon/root/software/containers/string/ + scp -r containers_misc.docdir/* cedeela.fr:~/simon/root/software/containers/misc/ DONTTEST=myocamlbuild.ml setup.ml QTESTABLE=$(filter-out $(DONTTEST), \ diff --git a/_oasis b/_oasis index ff9b3700..e4567f67 100644 --- a/_oasis +++ b/_oasis @@ -113,6 +113,14 @@ Document containers_misc XOCamlbuildPath: . XOCamlbuildLibraries: containers.misc +Document containers_string + Title: Containers_string docs + Type: ocamlbuild (0.3) + BuildTools+: ocamldoc + Install: true + XOCamlbuildPath: . + XOCamlbuildLibraries: containers.string + Executable benchs Path: tests/ Install: false @@ -172,7 +180,7 @@ Executable run_tests CompiledObject: native MainIs: run_tests.ml Build$: flag(tests) - BuildDepends: containers, oUnit + BuildDepends: containers, oUnit, qcheck Executable web_pwd Path: examples/cgi/ @@ -181,6 +189,13 @@ Executable web_pwd Build$: flag(cgi) BuildDepends: containers, containers.cgi, threads, CamlGI +Executable lambda + Path: examples/ + Install: false + MainIs: lambda.ml + Build$: flag(misc) + BuildDepends: containers,containers.misc + SourceRepository head Type: git Location: https://github.com/c-cube/ocaml-containers diff --git a/examples/lambda.ml b/examples/lambda.ml new file mode 100644 index 00000000..b925f5fc --- /dev/null +++ b/examples/lambda.ml @@ -0,0 +1,113 @@ + +(** Example of printing trees: lambda-term evaluation *) + +open Containers_misc + +type term = + | Lambda of string * term + | App of term * term + | Var of string + +let _gensym = + let r = ref 0 in + fun () -> + let s = Printf.sprintf "x%d" !r in + incr r; + s + +module SSet = Set.Make(String) +module SMap = Map.Make(String) + +let rec fvars t = match t with + | Var s -> SSet.singleton s + | Lambda (v,t') -> + let set' = fvars t' in + SSet.remove v set' + | App (t1, t2) -> SSet.union (fvars t1) (fvars t2) + +(* replace [var] with the term [by] *) +let rec replace t ~var ~by = match t with + | Var s -> if s=var then by else t + | App (t1,t2) -> App (replace t1 ~var ~by, replace t2 ~var ~by) + | Lambda (v, t') when v=var -> t (* no risk *) + | Lambda (v, t') -> Lambda (v, replace t' ~var ~by) + +(* rename [t] so that [var] doesn't occur in it *) +let rename ~var t = + if SSet.mem var (fvars t) + then replace t ~var ~by:(Var (_gensym ())) + else t + +let (>>=) o f = match o with + | None -> None + | Some x -> f x + +let rec one_step t = match t with + | App (Lambda (var, t1), t2) -> + let t2' = rename ~var t2 in + Some (replace t1 ~var ~by:t2') + | App (t1, t2) -> + begin match one_step t1 with + | None -> + one_step t2 >>= fun t2' -> + Some (App (t1,t2')) + | Some t1' -> + Some (App (t1',t2)) + end + | Var _ -> None + | Lambda (v,t') -> + one_step t' >>= fun t'' -> + Some (Lambda (v, t'')) + +let normal_form t = + let rec aux acc t = match one_step t with + | None -> List.rev (t::acc) + | Some t' -> aux (t::acc) t' + in + aux [] t + +let _split_fuel f = + assert (f>=2); + if f=2 then 1,1 + else + let x = 1+Random.int (f-1) in + f-x, x + +let _random_var () = + let v = [| "x"; "y"; "z"; "u"; "w" |] in + v.(Random.int (Array.length v)) + +let _choose_var ~vars = match vars with + | [] -> Var (_random_var ()) + | _::_ -> + let i = Random.int (List.length vars) in + List.nth vars i + +let rec _random_term fuel vars = + match Random.int 2 with + | _ when fuel = 1 -> _choose_var ~vars + | 0 -> + let f1,f2 = _split_fuel fuel in + App (_random_term f1 vars, _random_term f2 vars) + | 1 -> + let v = _random_var () in + Lambda (v, _random_term (fuel-1) (Var v::vars)) + | _ -> assert false + +let print_term t = + PrintBox.mk_tree + (function + | Var v -> PrintBox.line v, [] + | App (t1,t2) -> PrintBox.line "app", [t1;t2] + | Lambda (v,t') -> PrintBox.line "lambda", [Var v; t'] + ) t + +let print_reduction t = + let l = normal_form t in + let l = List.map (fun t -> PrintBox.pad (print_term t)) l in + PrintBox.vlist ~bars:false l + +let () = + Random.self_init (); + let t = _random_term (5 + Random.int 20) [] in + PrintBox.output ~indent:2 stdout (print_reduction t) diff --git a/misc/printBox.ml b/misc/printBox.ml index aed324da..de703a11 100644 --- a/misc/printBox.ml +++ b/misc/printBox.ml @@ -32,9 +32,14 @@ let origin = {x=0; y=0;} let _move pos x y = {x=pos.x + x; y=pos.y + y} let _add pos1 pos2 = _move pos1 pos2.x pos2.y +let _minus pos1 pos2 = _move pos1 (- pos2.x) (- pos2.y) let _move_x pos x = _move pos x 0 let _move_y pos y = _move pos 0 y +let _string_len = ref String.length + +let set_string_len f = _string_len := f + (** {2 Output: where to print to} *) module Output = struct @@ -71,7 +76,7 @@ module Output = struct ) let _ensure_line line i = - if i >= String.length line.bl_str + if i >= !_string_len line.bl_str then ( let str' = String.make (2 * i + 5) ' ' in String.blit line.bl_str 0 str' 0 line.bl_len; @@ -95,7 +100,7 @@ module Output = struct line.bl_len <- max line.bl_len (pos.x+s_len) let _buf_put_string buf pos s = - _buf_put_sub_string buf pos s 0 (String.length s) + _buf_put_sub_string buf pos s 0 (!_string_len s) (* create a new buffer *) let make_buffer () = @@ -146,14 +151,16 @@ let rec _lines s i k = match _find s '\n' i with module Box = struct type grid_shape = - | GridBase - | GridFramed + | GridNone + | GridBars type 'a shape = - | Line of string - | Text of string list (* in a box *) + | Empty + | Text of string list (* list of lines *) | Frame of 'a + | Pad of position * 'a (* vertical and horizontal padding *) | Grid of grid_shape * 'a array array + | Tree of int * 'a * 'a array type t = { shape : t shape; @@ -173,6 +180,9 @@ module Box = struct if Array.length m = 0 then {x=0;y=0} else {y=Array.length m; x=Array.length m.(0); } + let _map_matrix f m = + Array.map (Array.map f) m + (* height of a line composed of boxes *) let _height_line a = _array_foldi @@ -189,50 +199,78 @@ module Box = struct done; !acc + (* width and height of a column as an array *) + let _dim_vertical_array a = + let w = ref 0 and h = ref 0 in + Array.iter + (fun b -> + let s = size b in + w := max !w s.x; + h := !h + s.y + ) a; + {x= !w; y= !h;} + (* from a matrix [m] (line,column), return two arrays [lines] and [columns], with [col.(i)] being the start offset of column [i] and [lines.(j)] being the start offset of line [j]. - Those arrays have one more slot to indicate the end position. *) - let _size_matrix m = + Those arrays have one more slot to indicate the end position. + @param bars if true, leave space for bars between lines/columns *) + let _size_matrix ~bars m = let dim = _dim_matrix m in + (* +1 is for keeping room for the vertical/horizontal line/column *) + let additional_space = if bars then 1 else 0 in (* columns *) let columns = Array.make (dim.x + 1) 0 in for i = 0 to dim.x - 1 do - (* +1 is for keeping room for the vertical/horizontal line/column *) - columns.(i+1) <- columns.(i) + 1 + (_width_column m i) + columns.(i+1) <- columns.(i) + (_width_column m i) + additional_space done; (* lines *) let lines = Array.make (dim.y + 1) 0 in for j = 1 to dim.y do - lines.(j) <- lines.(j-1) + 1 + (_height_line m.(j-1)) + lines.(j) <- lines.(j-1) + (_height_line m.(j-1)) + additional_space done; (* no trailing bars, adjust *) - columns.(dim.x) <- columns.(dim.x) - 1; - lines.(dim.y) <- lines.(dim.y) - 1; + columns.(dim.x) <- columns.(dim.x) - additional_space; + lines.(dim.y) <- lines.(dim.y) - additional_space; lines, columns let _size = function - | Line s -> { x=String.length s; y=1 } + | Empty -> origin | Text l -> let width = List.fold_left - (fun acc line -> max acc (String.length line)) 0 l + (fun acc line -> max acc (!_string_len line)) 0 l in { x=width; y=List.length l; } | Frame t -> let {x;y} = size t in { x=x+2; y=y+2; } - | Grid (_,m) -> + | Pad (dim, b') -> + let {x;y} = size b' in + { x=x+2*dim.x; y=y+2*dim.y; } + | Grid (style,m) -> + let bars = match style with + | GridBars -> true + | GridNone -> false + in let dim = _dim_matrix m in - let lines, columns = _size_matrix m in + let lines, columns = _size_matrix ~bars m in { y=lines.(dim.y); x=columns.(dim.x)} + | Tree (indent, node, children) -> + let dim_children = _dim_vertical_array children in + let s = size node in + { x=max s.x (dim_children.x+3+indent) + ; y=s.y + dim_children.y + } let _make shape = { shape; size=(lazy (_size shape)); } end +let empty = Box._make Box.Empty + let line s = assert (_find s '\n' 0 = None); - Box._make (Box.Line s) + Box._make (Box.Text [s]) let text s = let acc = ref [] in @@ -250,31 +288,67 @@ let bool_ x = line (string_of_bool x) let frame b = Box._make (Box.Frame b) -let grid ?(framed=true) m = - Box._make (Box.Grid ((if framed then Box.GridFramed else Box.GridBase), m)) +let pad' ~col ~lines b = + assert (col >=0 || lines >= 0); + if col=0 && lines=0 + then b + else Box._make (Box.Pad ({x=col;y=lines}, b)) -let init_grid ?framed ~line ~col f = +let pad b = pad' ~col:1 ~lines:1 b + +let hpad col b = pad' ~col ~lines:0 b +let vpad lines b = pad' ~col:0 ~lines b + +let grid ?(pad=fun b->b) ?(bars=true) m = + let m = Box._map_matrix pad m in + Box._make (Box.Grid ((if bars then Box.GridBars else Box.GridNone), m)) + +let init_grid ?bars ~line ~col f = let m = Array.init line (fun j-> Array.init col (fun i -> f ~line:j ~col:i)) in - grid ?framed m + grid ?bars m -let vlist ?framed l = +let vlist ?pad ?bars l = let a = Array.of_list l in - grid ?framed (Array.map (fun line -> [| line |]) a) + grid ?pad ?bars (Array.map (fun line -> [| line |]) a) -let hlist ?framed l = - grid ?framed [| Array.of_list l |] +let hlist ?pad ?bars l = + grid ?pad ?bars [| Array.of_list l |] -let hlist_map ?framed f l = hlist ?framed (List.map f l) -let vlist_map ?framed f l = vlist ?framed (List.map f l) -let grid_map ?framed f m = grid ?framed (Array.map (Array.map f) m) +let hlist_map ?bars f l = hlist ?bars (List.map f l) +let vlist_map ?bars f l = vlist ?bars (List.map f l) +let grid_map ?bars f m = grid ?bars (Array.map (Array.map f) m) -let grid_text ?framed m = grid_map ?framed text m +let grid_text ?(pad=fun x->x) ?bars m = + grid_map ?bars (fun x -> pad (text x)) m let transpose m = let dim = Box._dim_matrix m in Array.init dim.x (fun i -> Array.init dim.y (fun j -> m.(j).(i))) +let tree ?(indent=1) node children = + let children = + List.filter + (function + | {Box.shape=Box.Empty} -> false + | _ -> true + ) children + in + match children with + | [] -> node + | _::_ -> + let children = Array.of_list children in + Box._make (Box.Tree (indent, node, children)) + +let mk_tree ?indent f root = + let rec make x = match f x with + | b, [] -> b + | b, children -> tree ?indent b (List.map make children) + in + make root + +(** {2 Rendering} *) + let _write_vline ~out pos n = for j=0 to n-1 do Output.put_char out (_move_y pos j) '|' @@ -287,10 +361,11 @@ let _write_hline ~out pos n = (* render given box on the output, starting with upper left corner at the given position. [expected_size] is the size of the - available surrounding space *) -let rec _render ?expected_size ~out b pos = + available surrounding space. [offset] is the offset of the box + w.r.t the surrounding box *) +let rec _render ?(offset=origin) ?expected_size ~out b pos = match Box.shape b with - | Box.Line s -> Output.put_string out pos s + | Box.Empty -> () | Box.Text l -> List.iteri (fun i line -> @@ -307,9 +382,16 @@ let rec _render ?expected_size ~out b pos = _write_vline out (_move_y pos 1) y; _write_vline out (_move pos (x+1) 1) y; _render ~out b' (_move pos 1 1) - | Box.Grid (grid_shape,m) -> + | Box.Pad (dim, b') -> + let expected_size = Box.size b in + _render ~offset:(_add dim offset) ~expected_size ~out b' (_add pos dim) + | Box.Grid (style,m) -> let dim = Box._dim_matrix m in - let lines, columns = Box._size_matrix m in + let bars = match style with + | Box.GridNone -> false + | Box.GridBars -> true + in + let lines, columns = Box._size_matrix ~bars m in (* write boxes *) for j = 0 to dim.y - 1 do @@ -329,14 +411,14 @@ let rec _render ?expected_size ~out b pos = in (* write frame if needed *) - begin match grid_shape with - | Box.GridBase -> () - | Box.GridFramed -> + begin match style with + | Box.GridNone -> () + | Box.GridBars -> for j=1 to dim.y - 1 do - _write_hline ~out (_move_y pos (lines.(j)-1)) len_hlines + _write_hline ~out (_move pos (-offset.x) (lines.(j)-1)) len_hlines done; for i=1 to dim.x - 1 do - _write_vline ~out (_move_x pos (columns.(i)-1)) len_vlines + _write_vline ~out (_move pos (columns.(i)-1) (-offset.y)) len_vlines done; for j=1 to dim.y - 1 do for i=1 to dim.x - 1 do @@ -344,6 +426,24 @@ let rec _render ?expected_size ~out b pos = done done end + | Box.Tree (indent, n, a) -> + _render ~out n pos; + (* star position for the children *) + let pos' = _move pos indent (Box.size n).y in + Output.put_char out (_move_x pos' ~-1) '`'; + assert (Array.length a > 0); + let _ = Box._array_foldi + (fun pos' i b -> + Output.put_string out pos' "+- "; + if i int) -> unit +(** Set which function is used to compute string length. Typically + to be used with a unicode-sensitive length function *) + +(** {2 Output} *) + module Output : sig type t = { put_char : position -> char -> unit; @@ -95,6 +101,8 @@ module Output : sig (** Print the buffer on the given channel *) end +(** {2 Box Combinators} *) + module Box : sig type t @@ -102,6 +110,9 @@ module Box : sig (** Size needed to print the box *) end +val empty : Box.t +(** Empty box, of size 0 *) + val line : string -> Box.t (** Make a single-line box. @raise Invalid_argument if the string contains ['\n'] *) @@ -121,34 +132,57 @@ val float_ : float -> Box.t val frame : Box.t -> Box.t (** Put a single frame around the box *) -val grid : ?framed:bool -> Box.t array array -> Box.t +val pad : Box.t -> Box.t +(** Pad the given box with some free space *) + +val pad' : col:int -> lines:int -> Box.t -> Box.t +(** Pad with the given number of free cells for lines and columns *) + +val vpad : int -> Box.t -> Box.t +(** Pad vertically *) + +val hpad : int -> Box.t -> Box.t +(** Pad horizontally *) + +val grid : ?pad:(Box.t -> Box.t) -> ?bars:bool -> + Box.t array array -> Box.t (** Grid of boxes (no frame between boxes). The matrix is indexed with lines first, then columns. The array must be a proper matrix, that is, all lines must have the same number of columns! @param framed if [true], each item of the grid will be framed. default value is [true] *) -val grid_text : ?framed:bool -> string array array -> Box.t +val grid_text : ?pad:(Box.t -> Box.t) -> ?bars:bool -> + string array array -> Box.t (** Same as {!grid}, but wraps every cell into a {!text} box *) val transpose : 'a array array -> 'a array array (** Transpose a matrix *) -val init_grid : ?framed:bool -> +val init_grid : ?bars:bool -> line:int -> col:int -> (line:int -> col:int -> Box.t) -> Box.t (** Same as {!grid} but takes the matrix as a function *) -val vlist : ?framed:bool -> Box.t list -> Box.t +val vlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t (** Vertical list of boxes *) -val hlist : ?framed:bool -> Box.t list -> Box.t +val hlist : ?pad:(Box.t -> Box.t) -> ?bars:bool -> Box.t list -> Box.t (** Horizontal list of boxes *) -val grid_map : ?framed:bool -> ('a -> Box.t) -> 'a array array -> Box.t +val grid_map : ?bars:bool -> ('a -> Box.t) -> 'a array array -> Box.t -val vlist_map : ?framed:bool -> ('a -> Box.t) -> 'a list -> Box.t +val vlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t -val hlist_map : ?framed:bool -> ('a -> Box.t) -> 'a list -> Box.t +val hlist_map : ?bars:bool -> ('a -> Box.t) -> 'a list -> Box.t + +val tree : ?indent:int -> Box.t -> Box.t list -> Box.t +(** Tree structure, with a node label and a list of children nodes *) + +val mk_tree : ?indent:int -> ('a -> Box.t * 'a list) -> 'a -> Box.t +(** Definition of a tree with a local function that maps nodes to + their content and children *) + +(** {2 Rendering} *) val render : Output.t -> Box.t -> unit diff --git a/tests/test_vector.ml b/tests/test_vector.ml index a72d02eb..878937a4 100644 --- a/tests/test_vector.ml +++ b/tests/test_vector.ml @@ -48,7 +48,7 @@ let suite = open QCheck module V = Vector -let gen sub = Arbitrary.(lift V.from_list (list sub)) +let gen sub = Arbitrary.(lift V.of_list (list sub)) let pp v = PP.(list string) (List.map string_of_int (V.to_list v)) let check_append = @@ -66,7 +66,7 @@ let check_sort = let gen = Arbitrary.(gen small_int) in let prop v = let v' = V.copy v in - V.sort v'; + V.sort' Pervasives.compare v'; let l = V.to_list v' in List.sort compare l = l in