summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/chart.ml188
-rw-r--r--src/chart.mli5
-rw-r--r--src/dune3
-rw-r--r--src/grump.ml1
-rw-r--r--src/marker.ml57
-rw-r--r--src/marker.mli4
-rw-r--r--src/options.ml8
-rw-r--r--src/options.mli4
-rw-r--r--src/utils.ml53
9 files changed, 129 insertions, 194 deletions
diff --git a/src/chart.ml b/src/chart.ml
index 0aee05d..0826092 100644
--- a/src/chart.ml
+++ b/src/chart.ml
@@ -1,135 +1,61 @@
1exception Empty_list
2let fold fn = function
3 | [] -> raise Empty_list
4 | head :: tail -> List.fold_left fn head tail
5
6let list_min ls = fold Stdlib.min ls
7let list_max ls = fold Stdlib.max ls
8
9let rec repeat n a =
10 if n <= 0
11 then []
12 else a :: repeat (n - 1) a
13
14let empty ls = (ls = [])
15
16let rec zip l1 l2 =
17 match (l1, l2) with
18 | ([], _) -> []
19 | (_, []) -> []
20 | (h1 :: t1, h2 :: t2) -> (h1, h2) :: zip t1 t2
21
22let rec transpose = function
23 | [] :: _ -> []
24 | ls -> List.(map hd ls) :: transpose List.(map tl ls)
25
26let flip f a b = f b a
27
28let rot_right ls = List.(rev ls |> transpose)
29let rot_left ls = List.(transpose ls |> rev)
30
31let to_string c = String.make 1 c 1let to_string c = String.make 1 c
32let space = to_string ' ' 2let space = to_string ' '
33 3let axis = "┬"
34let saturating_sub b a = 4let axis_spc = "─"
35 if a < b then 0 5
36 else a - b 6type t = { vals: int list; opts: Options.t }
37 7let default = { vals = []; opts = Options.default }
38module type Marker = sig 8let plot v c = { c with vals = v; }
39 type t 9let with_options v c = { v with opts = c; }
40 val of_string : string -> t 10let pp channel {vals: int list; opts: Options.t } =
41 val to_string : t -> string 11 let open Utils in
42end 12 let height = opts.height in
43 13 let min_val = list_min vals in
44module Marker = struct 14 let max_val = list_max vals in
45 type t = Point 15 let range = max_val - min_val in
46 | Pixel 16 let scale v = ((v - min_val) * height) / range in
47 | Circle 17 let new_vals = List.map scale vals in
48 | TriangleDown 18 let rec pad left right s =
49 | TriangleUp 19 if left = 0
50 | TriangleLeft 20 then s :: repeat right space
51 | TriangleRight 21 else space :: pad (left - 1) right s
52 | Custom of string 22 in
53 23 let new_vals' = zip new_vals (List.tl new_vals) in
54 exception Invalid_marker_length 24 let make_marker prefix left right s =
55 let of_string s = 25 prefix ::
56 if String.length s <> 1 26 (if left = 0
57 then raise Invalid_marker_length 27 then s :: repeat right space
58 else Custom(s) 28 else space :: pad (left - 1) right s)
59 29 in
60 let to_string = function 30 let make_connector s e =
61 | Point -> "." 31 match Stdlib.compare s e with
62 | Pixel -> "," 32 | 0 -> make_marker axis_spc s (height - s) "-"
63 | Circle -> "o" 33 | x ->
64 | TriangleDown -> "v" 34 let (ltr_chr, rtl_chr) =
65 | TriangleUp -> "^" 35 match x with
66 | TriangleLeft -> ">" 36 | 1 -> ("└", "┐")
67 | TriangleRight -> "<" 37 | _ -> ("┘", "┌")
68 | Custom(s) -> s
69end
70
71module type ChartOptions = sig
72 type t
73 val default : t
74 val with_height : int -> t -> t
75 val with_marker : string -> t -> t
76end
77
78module ChartOptions = struct
79 type t = { height: int; ascii: bool; marker: Marker.t}
80 let default =
81 { height = 14
82 ; ascii = false
83 ; marker = Marker.Point
84 }
85 let with_height v c = {c with height = v; }
86 let with_marker v c = {c with marker = v; }
87end
88
89module Chart = struct
90 let draw vals (opts: ChartOptions.t) =
91 let height = opts.height in
92 (* let width = List.length vals in *)
93 let min_val = list_min vals in
94 let max_val = list_max vals in
95 (*let range = max_val - min_val in*)
96
97 (* rescale from min-max to 0-height *)
98 let scale v = ((v - min_val) * height) / max_val in
99 let new_vals = List.map scale vals in
100 let rec pad left right s =
101 if left = 0
102 then s :: repeat right space
103 else space :: pad (left - 1) right s
104 in
105 let new_vals' = zip new_vals (List.tl new_vals) in
106 let make_connector s e =
107 match Stdlib.compare s e with
108 | 0 -> pad s (height - s - 1) "-"
109 | x ->
110 let (ltr_chr, rtl_chr) =
111 match x with
112 | 1 -> ("└", "┐")
113 | _ -> ("┘", "┌")
114 in
115 let (st, en) = Stdlib.((min s e, max s e)) in
116 let l = en - st |> saturating_sub 1 in
117 let (left, right) = (repeat st space, repeat (height - l - st - 1) space)
118 in
119 List.flatten [left; [ltr_chr]; repeat l "│"; [rtl_chr]; right]
120 in 38 in
121 let m = Marker.to_string opts.marker in 39 let (st, en) = Stdlib.((min s e, max s e)) in
122 let rec make_graph = function 40 let l = en - st |> saturating_sub 1 in
123 | [] -> [] 41 let (left, right) = (repeat st space, repeat (height - l - st) space) in
124 | (s, e) :: [] -> 42 List.flatten [[axis_spc]; left; [ltr_chr]; repeat l "│"; [rtl_chr]; right]
125 pad s (height - s - 1) m
126 :: make_connector s e
127 :: pad e (height - e - 1) m
128 :: []
129 | (s, e) :: tl ->
130 pad s (height - s - 1) m
131 :: make_connector s e
132 :: make_graph tl
133 in 43 in
134 make_graph new_vals' |> rot_left 44 let m = Printf.sprintf opts.marker in
135end 45 let rec make_graph = function
46 | [] -> []
47 | (s, e) :: [] ->
48 make_marker axis s (height - s) m
49 :: make_connector s e
50 :: make_marker axis e (height - e) m
51 :: []
52 | (s, e) :: tl ->
53 make_marker axis s (height - s) m
54 :: make_connector s e
55 :: make_graph tl
56 in
57 make_graph new_vals'
58 |> rot_left
59 |> List.map (String.concat "")
60 |> String.concat "\n"
61 |> Printf.fprintf channel "%s"
diff --git a/src/chart.mli b/src/chart.mli
new file mode 100644
index 0000000..3c758c4
--- /dev/null
+++ b/src/chart.mli
@@ -0,0 +1,5 @@
1type t
2val default : t
3val plot : int list -> t -> t
4val with_options : Options.t -> t -> t
5val pp : out_channel -> t -> unit
diff --git a/src/dune b/src/dune
index 6b1e6d9..328399e 100644
--- a/src/dune
+++ b/src/dune
@@ -1,3 +1,4 @@
1(library 1(library
2 (name grump) 2 (name grump)
3 (public_name grump)) 3 (public_name grump)
4 (wrapped false))
diff --git a/src/grump.ml b/src/grump.ml
deleted file mode 100644
index b4b1288..0000000
--- a/src/grump.ml
+++ /dev/null
@@ -1 +0,0 @@
1print_endline "hello world!"
diff --git a/src/marker.ml b/src/marker.ml
index 19b1be0..0c59804 100644
--- a/src/marker.ml
+++ b/src/marker.ml
@@ -1,36 +1,27 @@
1module type Marker = sig 1type t = Point
2 type t 2 | Pixel
3 val of_string : string -> t 3 | Circle
4 val pp : out_channel -> t -> unit 4 | TriangleDown
5end 5 | TriangleUp
6 | TriangleLeft
7 | TriangleRight
8 | Custom of string
6 9
7module Marker = struct 10exception Invalid_marker_length
8 type t = Point 11let of_string s =
9 | Pixel 12 if String.length s <> 1
10 | Circle 13 then raise Invalid_marker_length
11 | TriangleDown 14 else Custom(s)
12 | TriangleUp
13 | TriangleLeft
14 | TriangleRight
15 | Custom of string
16 15
17 exception Invalid_marker_length 16let pp channel n =
18 let of_string s = 17 (match n with
19 if String.length s <> 1 18 | Point -> "."
20 then raise Invalid_marker_length 19 | Pixel -> ","
21 else Custom(s) 20 | Circle -> "o"
22 21 | TriangleDown -> "v"
23 let pp channel n = 22 | TriangleUp -> "^"
24 (match n with 23 | TriangleLeft -> ">"
25 | Point -> "." 24 | TriangleRight -> "<"
26 | Pixel -> "," 25 | Custom(s) -> s)
27 | Circle -> "o" 26 |> Printf.fprintf channel "%s"
28 | TriangleDown -> "v"
29 | TriangleUp -> "^"
30 | TriangleLeft -> ">"
31 | TriangleRight -> "<"
32 | Custom(s) -> s)
33 |> Printf.fprintf channel "%s"
34
35end
36 27
diff --git a/src/marker.mli b/src/marker.mli
new file mode 100644
index 0000000..391916b
--- /dev/null
+++ b/src/marker.mli
@@ -0,0 +1,4 @@
1type t
2val of_string : string -> t
3val pp : out_channel -> t -> unit
4
diff --git a/src/options.ml b/src/options.ml
new file mode 100644
index 0000000..a57c28b
--- /dev/null
+++ b/src/options.ml
@@ -0,0 +1,8 @@
1type t = { height: int; ascii: bool; marker: Marker.t}
2let default =
3 { height = 14
4 ; ascii = false
5 ; marker = Marker.Point
6 }
7let with_height v c = { c with height = v; }
8let with_marker v c = { c with marker = v; }
diff --git a/src/options.mli b/src/options.mli
new file mode 100644
index 0000000..64bee51
--- /dev/null
+++ b/src/options.mli
@@ -0,0 +1,4 @@
1type t
2val default : t
3val with_height : int -> t -> t
4val with_marker : Marker.t -> t -> t
diff --git a/src/utils.ml b/src/utils.ml
index 8d1094e..62ae3a5 100644
--- a/src/utils.ml
+++ b/src/utils.ml
@@ -1,36 +1,33 @@
1module Utils = struct 1exception Empty_list
2 exception Empty_list 2let fold fn = function
3 let fold fn = function 3 | [] -> raise Empty_list
4 | [] -> raise Empty_list 4 | head :: tail -> List.fold_left fn head tail
5 | head :: tail -> List.fold_left fn head tail
6 5
7 let list_min ls = fold Stdlib.min ls 6let list_min ls = fold Stdlib.min ls
8 let list_max ls = fold Stdlib.max ls 7let list_max ls = fold Stdlib.max ls
9 8
10 let rec repeat n a = 9let rec repeat n a =
11 if n <= 0 10 if n <= 0
12 then [] 11 then []
13 else a :: repeat (n - 1) a 12 else a :: repeat (n - 1) a
14 13
15 let empty ls = (ls = []) 14let empty ls = (ls = [])
16 15
17 let rec zip l1 l2 = 16let rec zip l1 l2 =
18 match (l1, l2) with 17 match (l1, l2) with
19 | ([], _) -> [] 18 | ([], _) -> []
20 | (_, []) -> [] 19 | (_, []) -> []
21 | (h1 :: t1, h2 :: t2) -> (h1, h2) :: zip t1 t2 20 | (h1 :: t1, h2 :: t2) -> (h1, h2) :: zip t1 t2
22 21
23 let rec transpose = function 22let rec transpose = function
24 | [] :: _ -> [] 23 | [] :: _ -> []
25 | ls -> List.(map hd ls) :: transpose List.(map tl ls) 24 | ls -> List.(map hd ls) :: transpose List.(map tl ls)
26 25
27 let flip f a b = f b a 26let flip f a b = f b a
28 27
29 let rot_right ls = List.(rev ls |> transpose) 28let rot_right ls = List.(rev ls |> transpose)
30 let rot_left ls = List.(transpose ls |> rev) 29let rot_left ls = List.(transpose ls |> rev)
31
32 let saturating_sub b a =
33 if a < b then 0
34 else a - b
35end
36 30
31let saturating_sub b a =
32 if a < b then 0
33 else a - b
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 13:44:57 +0000