A lightweight reactive document library.
You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
 
 

559 lines
16 KiB

  1. type +'a t =
  2. | Nil
  3. | Leaf of { mutable mark: int; v: 'a; }
  4. | Join of { mutable mark: int; l: 'a t; r: 'a t; }
  5. type 'a seq = 'a t
  6. let empty = Nil
  7. let element v = Leaf { mark = 0; v }
  8. let mask_bits = 2
  9. let old_mask = 1
  10. let new_mask = 2
  11. let both_mask = 3
  12. let rank = function
  13. | Nil | Leaf _ -> 0
  14. | Join t -> t.mark lsr mask_bits
  15. let concat a b = match a, b with
  16. | Nil, x | x, Nil -> x
  17. | l, r -> Join { mark = (max (rank l) (rank r) + 1) lsl mask_bits; l; r }
  18. type ('a, 'b) view =
  19. | Empty
  20. | Element of 'a
  21. | Concat of 'b * 'b
  22. let view = function
  23. | Nil -> Empty
  24. | Leaf t -> Element t.v
  25. | Join t -> Concat (t.l, t.r)
  26. module Balanced : sig
  27. type 'a t = private 'a seq
  28. val empty : 'a t
  29. val element : 'a -> 'a t
  30. val concat : 'a t -> 'a t -> 'a t
  31. val view : 'a t -> ('a, 'a t) view
  32. end = struct
  33. type 'a t = 'a seq
  34. let empty = empty
  35. let element = element
  36. let check l r = abs (l - r) <= 1
  37. let rec node_left l r =
  38. let ml = rank l in
  39. let mr = rank r in
  40. if check ml mr then concat l r else match l with
  41. | Nil | Leaf _ -> assert false
  42. | Join t ->
  43. if check (rank t.l) ml
  44. then concat t.l (node_left t.r r)
  45. else match t.r with
  46. | Nil | Leaf _ -> assert false
  47. | Join tr ->
  48. let trr = node_left tr.r r in
  49. if check (1 + max (rank t.l) (rank tr.l)) (rank trr)
  50. then concat (concat t.l tr.l) trr
  51. else concat t.l (concat tr.l trr)
  52. let rec node_right l r =
  53. let ml = rank l in
  54. let mr = rank r in
  55. if check mr ml then concat l r else match r with
  56. | Nil | Leaf _ -> assert false
  57. | Join t ->
  58. if check (rank t.r) mr
  59. then concat (node_right l t.l) t.r
  60. else match t.l with
  61. | Nil | Leaf _ -> assert false
  62. | Join tl ->
  63. let tll = node_right l tl.l in
  64. if check (1 + max (rank tl.r) (rank t.r)) (rank tll)
  65. then concat tll (concat tl.r t.r)
  66. else concat (concat tll tl.r) t.r
  67. let concat l r =
  68. let ml = rank l in
  69. let mr = rank r in
  70. if check ml mr
  71. then concat l r
  72. else if ml <= mr
  73. then node_right l r
  74. else node_left l r
  75. let view = view
  76. end
  77. module Reducer = struct
  78. type (+'a, 'b) xform =
  79. | XEmpty
  80. | XLeaf of { a: 'a t; mutable b: 'b option; }
  81. | XJoin of { a: 'a t; mutable b: 'b option;
  82. l: ('a, 'b) xform; r: ('a, 'b) xform; }
  83. type stats = {
  84. mutable marked: int;
  85. mutable shared: int;
  86. mutable blocked: int;
  87. }
  88. let mk_stats () = { marked = 0; shared = 0; blocked = 0 }
  89. let new_marked stats = stats.marked <- stats.marked + 1
  90. let new_shared stats = stats.shared <- stats.shared + 1
  91. let new_blocked stats = stats.blocked <- stats.blocked + 1
  92. let rec block stats = function
  93. | Nil -> ()
  94. | Leaf t' ->
  95. let mark = t'.mark in
  96. if mark land both_mask <> both_mask && mark land both_mask <> 0
  97. then (
  98. new_blocked stats;
  99. t'.mark <- mark lor both_mask
  100. )
  101. | Join t' ->
  102. let mark = t'.mark in
  103. if mark land both_mask <> both_mask && mark land both_mask <> 0
  104. then (
  105. new_blocked stats;
  106. t'.mark <- mark lor both_mask;
  107. block stats t'.l;
  108. block stats t'.r;
  109. )
  110. let enqueue stats q mask = function
  111. | Nil -> ()
  112. | Leaf t' ->
  113. let mark = t'.mark in
  114. if mark land mask = 0 then (
  115. (* Not yet seen *)
  116. new_marked stats;
  117. if mark land both_mask <> 0 then (
  118. (* Newly shared, clear mask *)
  119. t'.mark <- -1;
  120. new_blocked stats;
  121. new_shared stats;
  122. ) else
  123. t'.mark <- mark lor mask;
  124. );
  125. if mark <> -1 && mark land both_mask = both_mask then (
  126. t'.mark <- -1;
  127. new_shared stats
  128. )
  129. | Join t' as t ->
  130. let mark = t'.mark in
  131. if mark land mask = 0 then (
  132. (* Not yet seen *)
  133. new_marked stats;
  134. if mark land both_mask <> 0 then (
  135. (* Newly shared, clear mask *)
  136. t'.mark <- -1;
  137. new_blocked stats;
  138. new_shared stats;
  139. block stats t'.l;
  140. block stats t'.r;
  141. ) else (
  142. (* First mark *)
  143. t'.mark <- mark lor mask;
  144. Queue.push t q
  145. )
  146. );
  147. if mark <> -1 && mark land both_mask = both_mask then (
  148. t'.mark <- -1;
  149. new_shared stats
  150. )
  151. let dequeue stats q mask =
  152. match Queue.pop q with
  153. | Join t ->
  154. if t.mark land both_mask = mask then (
  155. enqueue stats q mask t.l;
  156. enqueue stats q mask t.r;
  157. )
  158. | _ -> assert false
  159. let traverse1 stats q mask =
  160. while not (Queue.is_empty q) do
  161. dequeue stats q mask
  162. done
  163. let rec traverse sold snew qold qnew =
  164. if Queue.is_empty qold then
  165. traverse1 snew qnew new_mask
  166. else if Queue.is_empty qnew then
  167. traverse1 sold qold old_mask
  168. else (
  169. dequeue sold qold old_mask;
  170. dequeue snew qnew new_mask;
  171. traverse sold snew qold qnew
  172. )
  173. type ('a, 'b) unmark_state = {
  174. dropped : 'b option array;
  175. mutable dropped_leaf : int;
  176. mutable dropped_join : int;
  177. shared : 'a seq array;
  178. shared_x : ('a, 'b) xform list array;
  179. mutable shared_index: int;
  180. }
  181. let next_shared_index st =
  182. let result = st.shared_index in
  183. st.shared_index <- result + 1;
  184. result
  185. let rec unblock = function
  186. | XEmpty -> ()
  187. | XLeaf {a = Nil | Join _; _} -> assert false
  188. | XJoin {a = Nil | Leaf _; _} -> assert false
  189. | XLeaf {a = Leaf t'; _} ->
  190. let mark = t'.mark in
  191. if mark <> -1 && mark land both_mask = both_mask then
  192. t'.mark <- mark land lnot both_mask;
  193. | XJoin {a = Join t'; l; r; _} ->
  194. let mark = t'.mark in
  195. if mark <> -1 && mark land both_mask = both_mask then (
  196. t'.mark <- mark land lnot both_mask;
  197. unblock l;
  198. unblock r
  199. )
  200. let rec unmark_old st = function
  201. | XEmpty -> ()
  202. | XLeaf {a = Nil | Join _; _} -> assert false
  203. | XJoin {a = Nil | Leaf _; _} -> assert false
  204. | XLeaf {a = Leaf t' as a; b} as t ->
  205. let mark = t'.mark in
  206. if mark land both_mask = old_mask then (
  207. let dropped_leaf = st.dropped_leaf in
  208. if dropped_leaf > -1 then (
  209. st.dropped.(dropped_leaf) <- b;
  210. st.dropped_leaf <- dropped_leaf + 1;
  211. );
  212. t'.mark <- mark land lnot both_mask
  213. ) else if mark = -1 then (
  214. let index = next_shared_index st in
  215. st.shared.(index) <- a;
  216. st.shared_x.(index) <- [t];
  217. t'.mark <- (index lsl mask_bits) lor new_mask;
  218. ) else if mark land both_mask = new_mask then (
  219. let index = mark lsr mask_bits in
  220. st.shared_x.(index) <- t :: st.shared_x.(index);
  221. ) else if mark land both_mask = both_mask then (
  222. assert false
  223. (*t'.mark <- mark land lnot both_mask*)
  224. )
  225. | XJoin {a = Join t' as a; l; r; b} as t ->
  226. let mark = t'.mark in
  227. if mark land both_mask = old_mask then (
  228. let dropped_leaf = st.dropped_leaf in
  229. if dropped_leaf > -1 then (
  230. st.dropped.(dropped_leaf) <- b;
  231. st.dropped_leaf <- dropped_leaf + 1;
  232. );
  233. t'.mark <- mark land lnot both_mask;
  234. unmark_old st l;
  235. unmark_old st r;
  236. ) else if mark = -1 then (
  237. let index = next_shared_index st in
  238. st.shared.(index) <- a;
  239. st.shared_x.(index) <- [t];
  240. t'.mark <- (index lsl mask_bits) lor new_mask;
  241. unblock l;
  242. unblock r;
  243. ) else if mark land both_mask = new_mask then (
  244. let index = mark lsr mask_bits in
  245. st.shared_x.(index) <- t :: st.shared_x.(index);
  246. ) else if mark land both_mask = both_mask then (
  247. assert false
  248. )
  249. let prepare_shared st =
  250. for i = 0 to st.shared_index - 1 do
  251. begin match st.shared.(i) with
  252. | Nil -> ()
  253. | Leaf t -> t.mark <- t.mark lor both_mask
  254. | Join t -> t.mark <- t.mark lor both_mask
  255. end;
  256. match st.shared_x.(i) with
  257. | [] -> assert false
  258. | [_] -> ()
  259. | xs -> st.shared_x.(i) <- List.rev xs
  260. done
  261. let rec unmark_new st = function
  262. | Nil -> XEmpty
  263. | Leaf t' as t ->
  264. let mark = t'.mark in
  265. if mark <> -1 && mark land both_mask = both_mask then (
  266. let index = mark lsr mask_bits in
  267. match st.shared_x.(index) with
  268. | [] -> XLeaf {a = t; b = None}
  269. | x :: xs -> st.shared_x.(index) <- xs; x
  270. ) else (
  271. t'.mark <- 0;
  272. XLeaf {a = t; b = None}
  273. )
  274. | Join t' as t ->
  275. let mark = t'.mark in
  276. if mark = -1 then (
  277. let index = next_shared_index st in
  278. t'.mark <- 0;
  279. st.shared.(index) <- t;
  280. let l = unmark_new st t'.l in
  281. let r = unmark_new st t'.r in
  282. XJoin {a = t; b = None; l; r}
  283. ) else if mark land both_mask = both_mask then (
  284. let index = mark lsr mask_bits in
  285. match st.shared_x.(index) with
  286. | [] -> assert false
  287. | x :: xs ->
  288. st.shared_x.(index) <- xs;
  289. if xs == [] then t'.mark <- 0;
  290. x
  291. ) else (
  292. t'.mark <- t'.mark land lnot both_mask;
  293. let l = unmark_new st t'.l in
  294. let r = unmark_new st t'.r in
  295. XJoin {a = t; b = None; l; r}
  296. )
  297. type 'b dropped = {
  298. leaves: int;
  299. table: 'b option array;
  300. extra_leaf: 'b list;
  301. extra_join: 'b list;
  302. }
  303. let no_dropped =
  304. { leaves = 0; table = [||]; extra_leaf = []; extra_join = [] }
  305. let diff get_dropped xold tnew = match xold, tnew with
  306. | XEmpty, Nil -> no_dropped, XEmpty
  307. | (XLeaf {a; _} | XJoin {a; _}), _ when a == tnew -> no_dropped, xold
  308. | _ ->
  309. (* Cost: 16 words *)
  310. let qold = Queue.create () and sold = mk_stats () in
  311. let qnew = Queue.create () and snew = mk_stats () in
  312. begin match xold with
  313. | XEmpty -> ()
  314. | (XLeaf {a; _} | XJoin {a; _}) ->
  315. enqueue sold qold old_mask a
  316. end;
  317. enqueue snew qnew new_mask tnew;
  318. traverse sold snew qold qnew;
  319. let nb_dropped = sold.marked - (sold.blocked + snew.blocked) in
  320. let st = {
  321. dropped = if get_dropped then Array.make nb_dropped None else [||];
  322. dropped_leaf = if get_dropped then 0 else -1;
  323. dropped_join = if get_dropped then nb_dropped else -1;
  324. shared = Array.make (sold.shared + snew.shared) Nil;
  325. shared_x = Array.make (sold.shared + snew.shared) [];
  326. shared_index = 0;
  327. } in
  328. (*Printf.eprintf "sold.shared:%d sold.marked:%d sold.blocked:%d\n%!"
  329. sold.shared sold.marked sold.blocked;
  330. Printf.eprintf "snew.shared:%d snew.marked:%d snew.blocked:%d\n%!"
  331. snew.shared snew.marked snew.blocked;*)
  332. unmark_old st xold;
  333. assert (st.dropped_leaf = st.dropped_join);
  334. prepare_shared st;
  335. let result = unmark_new st tnew in
  336. (*Printf.eprintf "new_computed:%d%!\n" !new_computed;*)
  337. let restore_rank = function
  338. | Nil -> assert false
  339. | Leaf t -> t.mark <- 0
  340. | Join t ->
  341. t.mark <- (max (rank t.l) (rank t.r) + 1) lsl mask_bits
  342. in
  343. for i = st.shared_index - 1 downto 0 do
  344. restore_rank st.shared.(i)
  345. done;
  346. if get_dropped then (
  347. let xleaf = ref [] in
  348. let xjoin = ref [] in
  349. for i = 0 to st.shared_index - 1 do
  350. List.iter (function
  351. | XLeaf { b = Some b; _} -> xleaf := b :: !xleaf
  352. | XJoin { b = Some b; _} -> xjoin := b :: !xjoin
  353. | _ -> ()
  354. ) st.shared_x.(i)
  355. done;
  356. ({ leaves = st.dropped_leaf;
  357. table = st.dropped;
  358. extra_leaf = !xleaf;
  359. extra_join = !xjoin }, result)
  360. ) else
  361. no_dropped, result
  362. type ('a, 'b) map_reduce = ('a -> 'b) * ('b -> 'b -> 'b)
  363. let map (f, _) x = f x
  364. let reduce (_, f) x y = f x y
  365. let eval map_reduce = function
  366. | XEmpty -> None
  367. | other ->
  368. let rec aux = function
  369. | XEmpty | XLeaf {a = Nil | Join _; _} -> assert false
  370. | XLeaf {b = Some b; _} | XJoin {b = Some b; _} -> b
  371. | XLeaf ({a = Leaf t';_ } as t) ->
  372. let result = map map_reduce t'.v in
  373. t.b <- Some result;
  374. result
  375. | XJoin t ->
  376. let l = aux t.l and r = aux t.r in
  377. let result = reduce map_reduce l r in
  378. t.b <- Some result;
  379. result
  380. in
  381. Some (aux other)
  382. type ('a, 'b) reducer = ('a, 'b) map_reduce * ('a, 'b) xform
  383. let make ~map ~reduce = ((map, reduce), XEmpty)
  384. let reduce (map_reduce, tree : _ reducer) =
  385. eval map_reduce tree
  386. let update (map_reduce, old_tree : _ reducer) new_tree : _ reducer =
  387. let _, tree = diff false old_tree new_tree in
  388. (map_reduce, tree)
  389. let update_and_get_dropped (map_reduce, old_tree : _ reducer) new_tree
  390. : _ dropped * _ reducer =
  391. let dropped, tree = diff true old_tree new_tree in
  392. (dropped, (map_reduce, tree))
  393. let fold_dropped kind f dropped acc =
  394. let acc = ref acc in
  395. let start, bound = match kind with
  396. | `All -> 0, Array.length dropped.table
  397. | `Map -> 0, dropped.leaves
  398. | `Reduce -> dropped.leaves, Array.length dropped.table
  399. in
  400. for i = start to bound - 1 do
  401. match dropped.table.(i) with
  402. | None -> ()
  403. | Some x -> acc := f x !acc
  404. done;
  405. !acc
  406. end
  407. (* Lwd interface *)
  408. let rec pure_map_reduce map reduce = function
  409. | Nil -> assert false
  410. | Leaf t -> map t.v
  411. | Join t ->
  412. reduce
  413. (pure_map_reduce map reduce t.l)
  414. (pure_map_reduce map reduce t.r)
  415. let fold ~map ~reduce seq =
  416. match Lwd.is_pure seq with
  417. | Some Nil -> Lwd.pure None
  418. | Some other -> Lwd.pure (Some (pure_map_reduce map reduce other))
  419. | None ->
  420. let reducer = ref (Reducer.make ~map ~reduce) in
  421. Lwd.map' seq @@ fun seq ->
  422. let reducer' = Reducer.update !reducer seq in
  423. reducer := reducer';
  424. Reducer.reduce reducer'
  425. let fold_monoid map (zero, reduce) seq =
  426. match Lwd.is_pure seq with
  427. | Some Nil -> Lwd.pure zero
  428. | Some other -> Lwd.pure (pure_map_reduce map reduce other)
  429. | None ->
  430. let reducer = ref (Reducer.make ~map ~reduce) in
  431. Lwd.map' seq @@ fun seq ->
  432. let reducer' = Reducer.update !reducer seq in
  433. reducer := reducer';
  434. match Reducer.reduce reducer' with
  435. | None -> zero
  436. | Some x -> x
  437. let monoid = (empty, concat)
  438. let transform_list ls f =
  439. Lwd_utils.map_reduce f monoid ls
  440. let of_list ls = transform_list ls element
  441. let rec of_sub_array f arr i j =
  442. if j < i then empty
  443. else if j = i then f arr.(i)
  444. else
  445. let k = i + (j - i) / 2 in
  446. concat (of_sub_array f arr i k) (of_sub_array f arr (k + 1) j)
  447. let transform_array arr f = of_sub_array f arr 0 (Array.length arr - 1)
  448. let of_array arr = transform_array arr element
  449. let to_list x =
  450. let rec fold x acc = match x with
  451. | Nil -> acc
  452. | Leaf t -> t.v :: acc
  453. | Join t -> fold t.l (fold t.r acc)
  454. in
  455. fold x []
  456. let to_array x =
  457. let rec count = function
  458. | Nil -> 0
  459. | Leaf _ -> 1
  460. | Join t -> count t.l + count t.r
  461. in
  462. match count x with
  463. | 0 -> [||]
  464. | n ->
  465. let rec first = function
  466. | Nil -> assert false
  467. | Leaf t -> t.v
  468. | Join t -> first t.l
  469. in
  470. let first = first x in
  471. let arr = Array.make n first in
  472. let rec fold i = function
  473. | Nil -> i
  474. | Leaf t -> arr.(i) <- t.v; i + 1
  475. | Join t ->
  476. let i = fold i t.l in
  477. let i = fold i t.r in
  478. i
  479. in
  480. let _ : int = fold 0 x in
  481. arr
  482. let lwd_empty : 'a t Lwd.t = Lwd.pure Nil
  483. let lwd_monoid : 'a. 'a t Lwd.t Lwd_utils.monoid =
  484. (lwd_empty, fun x y -> Lwd.map2 concat x y)
  485. let map f seq =
  486. fold_monoid (fun x -> element (f x)) monoid seq
  487. let filter f seq =
  488. fold_monoid (fun x -> if f x then element x else empty) monoid seq
  489. let filter_map f seq =
  490. let select x = match f x with
  491. | Some y -> element y
  492. | None -> empty
  493. in
  494. fold_monoid select monoid seq
  495. let lift (seq : 'a Lwd.t seq Lwd.t) : 'a seq Lwd.t =
  496. Lwd.join (fold_monoid (Lwd.map element) lwd_monoid seq)
  497. let bind (seq : 'a seq Lwd.t) (f : 'a -> 'b seq) : 'b seq Lwd.t =
  498. fold_monoid f monoid seq