note.ml 8.08 KB
Newer Older
Stephane Glondu's avatar
License  
Stephane Glondu committed
1
(***************************************************************************)
Stephane Glondu's avatar
Stephane Glondu committed
2
(*  Copyright © 2010-2013 Stéphane Glondu <steph@glondu.net>               *)
Stephane Glondu's avatar
License  
Stephane Glondu committed
3 4 5 6 7 8 9 10 11 12 13 14 15 16 17
(*                                                                         *)
(*  This program is free software: you can redistribute it and/or modify   *)
(*  it under the terms of the GNU General Public License as published by   *)
(*  the Free Software Foundation, either version 3 of the License, or (at  *)
(*  your option) any later version.                                        *)
(*                                                                         *)
(*  This program is distributed in the hope that it will be useful, but    *)
(*  WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU      *)
(*  Affero General Public License for more details.                        *)
(*                                                                         *)
(*  You should have received a copy of the GNU General Public License      *)
(*  along with this program.  If not, see <http://www.gnu.org/licenses/>.  *)
(***************************************************************************)

Stephane Glondu's avatar
Stephane Glondu committed
18 19
let precision = 2
let epsilon = 10. ** float_of_int (-precision-1)
Stephane Glondu's avatar
Stephane Glondu committed
20 21
let document = Dom_html.window##document

Stephane Glondu's avatar
Stephane Glondu committed
22
let is_class_row class_ x =
Stephane Glondu's avatar
Stephane Glondu committed
23
  Js.Opt.case (x##getAttribute (Js.string "class"))
Stephane Glondu's avatar
Stephane Glondu committed
24
    (fun () -> false)
Stephane Glondu's avatar
Stephane Glondu committed
25
    (fun y -> Js.to_string y = class_)
Stephane Glondu's avatar
Stephane Glondu committed
26

Stephane Glondu's avatar
Stephane Glondu committed
27
let extract_text cell =
Stephane Glondu's avatar
Stephane Glondu committed
28 29 30 31 32 33 34
  let xs = cell##getElementsByTagName (Js.string "p") in
  assert (xs##length = 1);
  let buf = Buffer.create 100 in
  let rec aux x =
    match Js.Opt.to_option x with
      | None -> Buffer.contents buf
      | Some c ->
Stephane Glondu's avatar
Stephane Glondu committed
35 36 37 38
        if c##nodeType = Dom.TEXT then
          Js.Opt.iter (c##nodeValue) (fun s ->
            Buffer.add_string buf (Js.to_string s)
          );
Stephane Glondu's avatar
Stephane Glondu committed
39 40
        aux c##nextSibling
  in
Stephane Glondu's avatar
Stephane Glondu committed
41
  let inner_cell = (Js.Opt.get (xs##item (0)) (fun _ -> assert false)) in
42
  inner_cell, String.trim (aux inner_cell##firstChild)
Stephane Glondu's avatar
Stephane Glondu committed
43 44 45 46 47 48 49 50 51 52 53 54

let extract_float s =
  let buf = Buffer.create 100 in
  String.iter
    (function
      | ' ' -> ()
      | c -> Buffer.add_char buf c)
    s;
  let s = Buffer.contents buf in
  if s = "" then 0.
  else (try float_of_string s with _ -> nan)

Stephane Glondu's avatar
Stephane Glondu committed
55
let format_float x =
Stephane Glondu's avatar
Stephane Glondu committed
56 57 58
  if x > epsilon then Printf.sprintf "+%.*f" precision x
  else if x < (-. epsilon) then Printf.sprintf "%.*f" precision x
  else Printf.sprintf "%.*f" precision 0.
59

Stephane Glondu's avatar
Stephane Glondu committed
60 61 62 63 64 65 66 67 68 69 70 71
let extract_rev_cells row =
  let xs = row##getElementsByTagName (Js.string "td") in
  let xn = xs##length in
  let rec collect accu i =
    if i < xn then
      let cell = Js.Opt.get (xs##item (i)) (fun () -> assert false) in
      collect (cell::accu) (i+1)
    else accu
  in collect [] 0

let ( ++ ) f g x = g (f x)

Stephane Glondu's avatar
Stephane Glondu committed
72
let classify_row row =
Stephane Glondu's avatar
Stephane Glondu committed
73
  if is_class_row "total" row then
Stephane Glondu's avatar
Stephane Glondu committed
74
    `Total row
75 76 77 78 79 80 81
  else if is_class_row "ledger-header" row then (
    match extract_rev_cells row with
    | _ :: xs ->
      let headers = List.rev_map (extract_text ++ snd) xs in
      `Headers headers
    | _ -> `None
  ) else if is_class_row "summable" row then (
Stephane Glondu's avatar
Stephane Glondu committed
82 83
    match extract_rev_cells row with
    | cell :: xs ->
84
      let wtf = snd (extract_text cell) in
Stephane Glondu's avatar
Stephane Glondu committed
85 86 87 88 89 90 91 92 93
      let atoms = List.map (extract_text ++ snd ++ extract_float) xs in
      let atoms = Array.of_list (List.rev atoms) in
      let sum = Array.fold_left ( +. ) 0. atoms in
      let check_text =
        if (abs_float sum) < epsilon then " ✔"
        else Printf.sprintf " ✘ (%s)" (format_float sum)
      in
      Dom.appendChild cell
        (document##createTextNode (Js.string check_text));
94 95
      `Summable (wtf, atoms)
    | _ -> `None
Stephane Glondu's avatar
Stephane Glondu committed
96
  ) else `None
Stephane Glondu's avatar
Stephane Glondu committed
97 98

let parse_rows (xs : Dom_html.element Dom.nodeList Js.t) =
Stephane Glondu's avatar
Stephane Glondu committed
99
  let n = xs##length in
100
  let rec aux (total, accu, headers) i =
Stephane Glondu's avatar
Stephane Glondu committed
101
    if i < n then
Stephane Glondu's avatar
Stephane Glondu committed
102
      let x = Js.Opt.get (xs##item (i)) (fun () -> assert false) in
Stephane Glondu's avatar
Stephane Glondu committed
103 104
      let arg =
        begin match classify_row x with
105 106 107 108
          | `Total x -> Some x, accu, headers
          | `Summable xs -> total, xs::accu, headers
          | `Headers xs -> total, accu, Some xs
          | `None -> total, accu, headers
Stephane Glondu's avatar
Stephane Glondu committed
109 110 111
        end
      in
      aux arg (i+1)
Stephane Glondu's avatar
Stephane Glondu committed
112
    else
113
      (total, accu, headers)
Stephane Glondu's avatar
Stephane Glondu committed
114
  in
115
  aux (None, [], None) 0
Stephane Glondu's avatar
Stephane Glondu committed
116 117

let count lines =
Stephane Glondu's avatar
Stephane Glondu committed
118 119 120 121 122 123
  let n = List.fold_left max 0 (List.map Array.length lines) in
  let res = Array.create n 0. in
  List.iter
    (fun line -> Array.iteri (fun i x -> res.(i) <- res.(i) +. x) line)
    lines;
  res
Stephane Glondu's avatar
Stephane Glondu committed
124

125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153
(* https://en.wikipedia.org/wiki/HSL_and_HSV#From_HSV *)
let rgb_of_hsv h s v =
  let c = v *. s in
  let h' = h /. 60. in
  let x = c *. (1. -. abs_float (mod_float h' 2. -. 1.)) in
  let r1, g1, b1 =
    if h' < 1. then (c, x, 0.)
    else if h' < 2. then (x, c, 0.)
    else if h' < 3. then (0., c, x)
    else if h' < 4. then (0., x, c)
    else if h' < 5. then (x, 0., c)
    else if h' < 6. then (c, 0., x)
    else (0., 0., 0.)
  in
  let m = v -. c in
  (r1 +. m, g1 +. m, b1 +. m)

let convert_byte_ratio x =
  min 255 (max 0 (int_of_float (x *. 255.)))

let format_color r =
  let h = 120. *. r in
  let r, g, b = rgb_of_hsv h 0.5 1. in
  Printf.sprintf "#%02X%02X%02X"
    (convert_byte_ratio r)
    (convert_byte_ratio g)
    (convert_byte_ratio b)

let normalize smin smax x =
Stephane Glondu's avatar
Stephane Glondu committed
154 155
  if x < (-. epsilon) then 0.5 *. (1. -. x /. smin)
  else if x > epsilon then 0.5 *. (1. +. x /. smax)
156
  else 0.5
157

Stephane Glondu's avatar
Stephane Glondu committed
158 159 160 161 162 163 164 165 166 167
let get_parent_table row =
  let node = (row : Dom_html.element Js.t :> Dom.node Js.t) in
  let rec loop node =
    match String.lowercase (Js.to_string node##nodeName) with
    | "body" -> node
    | "table" -> Js.Opt.case (node##parentNode)
      (fun () -> assert false) (fun x -> x)
    | _ -> Js.Opt.case (node##parentNode) (fun () -> node) loop
  in loop node

168
let source_link () =
Stephane Glondu's avatar
Stephane Glondu committed
169 170 171 172 173 174 175 176 177
  let p = document##createElement (Js.string "p") in
  let element = document##createElement (Js.string "a") in
  element##setAttribute (
    Js.string "href",
    Js.string "http://git.crans.org/?p=wikinote.git;a=summary"
  );
  let text = document##createTextNode (Js.string "Source code") in
  Dom.appendChild element text;
  Dom.appendChild p element;
178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202
  p

let block_header = "-----BEGIN LEDGER-----"
let block_footer = "-----END LEDGER-----"

let format_ledger txs =
  let buf = Buffer.create 256 in
  Buffer.add_string buf block_header;
  Buffer.add_string buf "\n";
  List.iter (fun (wtf, line) ->
    Buffer.add_string buf wtf;
    Buffer.add_string buf " |";
    List.iter (fun (k, v) ->
      Printf.bprintf buf " %s(%s)" k (format_float v)
    ) line;
    Buffer.add_string buf "\n";
  ) txs;
  Buffer.add_string buf block_footer;
  Buffer.add_string buf "\n";
  Buffer.contents buf

let ledger_box txs =
  let pre = document##createElement (Js.string "pre") in
  pre##innerHTML <- Js.string (format_ledger txs);
  pre
Stephane Glondu's avatar
Stephane Glondu committed
203

Stephane Glondu's avatar
Stephane Glondu committed
204 205
let start () =
  let ps = document##getElementsByTagName (Js.string "tr") in
206 207 208 209 210 211 212 213 214 215 216 217 218 219 220
  let total, lines, headers = parse_rows ps in
  let txs =
    match headers with
    | Some hs ->
      let assoc = List.map (fun (wtf, cells) ->
        let full_dict = List.combine hs (Array.to_list cells) in
        wtf, List.filter (fun (k, v) ->
          v < (-. epsilon) || v > epsilon
        ) full_dict
      ) lines in
      Some assoc
    | None -> None
  in
  let nums = List.map snd lines in
  let sums = count nums in
221 222 223 224
  let normalize = normalize
    (Array.fold_left min max_float sums)
    (Array.fold_left max min_float sums)
  in
Stephane Glondu's avatar
Stephane Glondu committed
225 226 227 228
  let fill_total x element =
    let z = Js.string (format_float x) in
    let text = document##createTextNode (z) in
    Dom.appendChild element text;
229 230 231 232 233
    let c = format_color (normalize x) in
    element##setAttribute (
      Js.string "style",
      Printf.ksprintf Js.string "background-color: %s" c
    )
Stephane Glondu's avatar
Stephane Glondu committed
234
  in
Stephane Glondu's avatar
Stephane Glondu committed
235
  (match total with
Stephane Glondu's avatar
Stephane Glondu committed
236
    | None -> ()
Stephane Glondu's avatar
Stephane Glondu committed
237 238 239
    | Some row ->
      let ys = row##getElementsByTagName (Js.string "td") in
      let set i x = Js.Opt.iter (ys##item (i)) (fill_total x) in
Stephane Glondu's avatar
Stephane Glondu committed
240
      Array.iteri set sums;
241 242 243 244 245
      let table = get_parent_table row in
      Dom.appendChild table (source_link ());
      (match txs with
      | Some txs -> Dom.appendChild table (ledger_box txs)
      | None -> ());
Stephane Glondu's avatar
Stephane Glondu committed
246
  );
Stephane Glondu's avatar
Stephane Glondu committed
247 248
  Lwt.return ()

Stephane Glondu's avatar
Stephane Glondu committed
249 250 251 252 253
let () =
  Dom_html.window##onload <- Dom_html.handler (fun _ ->
    ignore (start ());
    Js._false
  )