Source file flex.ml

(*********************************************************************************)
(*                OCaml-Stk                                                      *)
(*                                                                               *)
(*    Copyright (C) 2023-2024 INRIA All rights reserved.                         *)
(*    Author: Maxence Guesdon, INRIA Saclay                                      *)
(*                                                                               *)
(*    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, version 3 of the License.       *)
(*                                                                               *)
(*    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 General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public                  *)
(*    License along with this program; if not, write to the Free Software        *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    As a special exception, you have permission to link this program           *)
(*    with the OCaml compiler and distribute executables, as long as you         *)
(*    follow the requirements of the GNU GPL in regard to all of the             *)
(*    software in the executable aside from the OCaml compiler.                  *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Flex container widget. *)

open Misc
open Tsdl
open Widget
open Container

[@@@landmark "auto"]

(** {2 Properties} *)

(** Property to specify the size of space between two items. *)
let inter_space = Props.int_prop ~default:0 "inter_space"

let css_inter_space = Theme.int_prop inter_space

(** Property ["flex_wrap"] to specify whether lines can be wrapped
  when they don't fit. *)
let wrap = Props.(bool_prop ~after:[Resize] ~inherited:false ~default:true "flex_wrap")

let css_wrap = Theme.bool_prop wrap

(** Property ["flex_wrap_on_break"] to specify whether a line
  is broken when a [`Break] item is encountered.*)
let wrap_on_break =
  Props.(bool_prop ~after:[Resize] ~inherited:false ~default:false "flex_wrap_on_break")

let css_wrap_on_break = Theme.bool_prop wrap_on_break

(** Property ["flex_collapse_spaces"] to specify whether [`Space] items must
  be collapsed. *)
let collapse_spaces =
  Props.(bool_prop ~after:[Resize] ~inherited:false ~default:true "flex_collapse_spaces")

let css_collapse_spaces = Theme.bool_prop collapse_spaces

(** Property ["flex_item_expand"] to specify how an item must expand.
  A value higher than the other items on the same line will give more space
  to this item. *)
let expand = Props.(int_prop ~after:[Resize] ~inherited:false ~default:0 "flex_item_expand")

let css_expand = Theme.int_prop expand

(** Item kind indicates how to handle an item:
  {ul
   {- [`Break] indicates a break of line, which can be considered as space or
      real break, depending on the {!wrap_on_break} property,}
   {- [`Block] indicates that this item must be arranged alone on a line,}
   {- [`Item] indicates that this item is "normal" and can be arranged inline,}
   {- [`Space b] indicates that this item is a space in arrangement algorithm.
     [b = true] is used internally to indicate that this space must be taken
     into account when computing coordinates. }
  }
*)
type item_kind = [`Block | `Break | `Item | `Space of bool]

(**/**)
let string_of_item_kind = function
| `Block -> "block"
| `Break -> "break"
| `Item -> "item"
| `Space true -> Printf.sprintf "space_true"
| `Space false -> Printf.sprintf "space_false"

let item_kind_of_string s =
  match String.lowercase_ascii s with
  | "block" -> `Block
  | "break" -> `Break
  | "item" -> `Item
  | "space"
  | "space_true" -> `Space true
  | "space_false" -> `Space false
  | _ ->
      Log.warn (fun m -> m "Invalid item_kind %S" s);
      `Item
module TItem_kind = struct
    type t = item_kind
    let compare = Stdlib.compare
    let wrapper =
      let to_json ?with_doc k = `String (string_of_item_kind k) in
      let from_json ?def = function
      | `String s -> item_kind_of_string s
      | json -> Ocf.invalid_value json
      in
      Some (Ocf.Wrapper.make to_json from_json)
    let transition = None
  end
module PItem_kind = Props.Add_prop_type(TItem_kind)
(**/**)

(** ["flex_item_kind"] property. Default value is [`Item]. *)
let item_kind : item_kind Props.prop = PItem_kind.mk_prop
  ~inherited:false ~default:`Item "flex_item_kind"

(** {2 Justification} *)

(** Justification of items:
  {ul
   {- [`Start] aligns items on the left in horizontal flex, on top in vertical flex.}
   {- [`End] aligns items on the right in horizontal flex, on bottom in vertical flex.}
   {- [`Center] centers items #CaptainObvious.}
   {- [`Space_around] distributes spaces at the beginning of line, between items and at
      the end of line.}
   {- [`Space_betwwen] distributes spaces between items, leaving no space at the beginning
      and the end of the line.}
   {- [`Justified] is like [`Space_between] except that the last line is justified as [`Start]
     (like a regular text paragraph). }
  }
*)
type justification = [`Center | `End | `Justified | `Space_around | `Space_between | `Start]

let justifications = [`Center ; `End ; `Justified ; `Space_around ; `Space_between ; `Start]

let string_of_justification : justification -> string = function
| `Center -> "center"
| `End -> "end"
| `Justified -> "justified"
| `Space_around -> "space-around"
| `Space_between -> "space-between"
| `Start -> "start"

let justification_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_justification justifications

module TJustification =
  struct
    type t = justification
    let compare = Stdlib.compare
    let wrapper =
      let to_json ?with_doc j = `String (string_of_justification j) in
      let from_json ?def = function
      | (`String s) as json->
          (match justification_of_string s with
           | None -> Ocf.invalid_value json
           | Some x -> x
          )
      | json -> Ocf.invalid_value json
      in
      Some (Ocf.Wrapper.make to_json from_json)
    let transition = None
  end
module PJustification = Props.Add_prop_type(TJustification)

(** ["flex_justification"] property. Default value is [`Start]. *)
let justification : justification Props.prop = PJustification.mk_prop
  ~inherited:false ~after:[Resize] ~default:`Start "flex_justification"

let css_justification_prop = Theme.keyword_prop
  string_of_justification justification_of_string `Start

let css_justification = css_justification_prop justification

(** {2 Items alignement} *)

type items_alignment = [`Baseline | `Center | `End | `Start | `Stretch]
let items_alignments = [`Baseline ; `Center ; `End ; `Start ; `Stretch]

let string_of_items_alignment = function
| `Baseline -> "baseline"
| `Center -> "center"
| `End -> "end"
| `Start -> "start"
| `Stretch -> "stretch"

let items_alignment_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_items_alignment items_alignments

module TItems_alignment =
  struct
    type t = items_alignment
    let compare = Stdlib.compare
    let wrapper =
      let to_json ?with_doc a = `String (string_of_items_alignment a) in
      let from_json ?def = function
      | (`String s) as json ->
          (match items_alignment_of_string s with
           | None -> Ocf.invalid_value json
           | Some x -> x
          )
      | json -> Ocf.invalid_value json
      in
      Some (Ocf.Wrapper.make to_json from_json)
    let transition = None
  end
module PItems_alignement = Props.Add_prop_type(TItems_alignment)

(** ["flex_items_alignment"] property. Default is [`Baseline]. *)
let items_alignment : items_alignment Props.prop = PItems_alignement.mk_prop
  ~after:[Resize] ~inherited:false ~default:`Baseline "flex_items_alignment"

let css_items_alignment_prop = Theme.keyword_prop
  string_of_items_alignment items_alignment_of_string `Baseline

let css_items_alignment = css_items_alignment_prop items_alignment

(** {2 Content alignement} *)

type content_alignment = [`Center | `End | `Space_around | `Space_between | `Start | `Stretch]
let content_alignments = [`Center ; `End ; `Space_around ; `Space_between ; `Start ; `Stretch]

let string_of_content_alignment = function
| `Center -> "center"
| `End -> "end"
| `Space_around -> "space-around"
| `Space_between -> "space-between"
| `Start -> "start"
| `Stretch -> "stretch"

let content_alignment_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_content_alignment content_alignments

module TContent_alignment =
  struct
    type t = content_alignment
    let compare = Stdlib.compare
    let wrapper =
      let to_json ?with_doc a = `String (string_of_content_alignment a) in
      let from_json ?def = function
      | (`String s) as json ->
          (match content_alignment_of_string s with
           | None -> Ocf.invalid_value json
           | Some x -> x
          )
      | json -> Ocf.invalid_value json
      in
      Some (Ocf.Wrapper.make to_json from_json)
    let transition = None
  end
module PContent_alignment = Props.Add_prop_type(TContent_alignment)

(** ["flex_content_alignment"] property. Default is [`Stretch]. *)
let content_alignment : content_alignment Props.prop = PContent_alignment.mk_prop
  ~inherited:false ~after:[Resize] ~default:`Stretch "flex_content_alignment"

let css_content_alignment_prop = Theme.keyword_prop
  string_of_content_alignment content_alignment_of_string `Stretch

let css_content_alignment = css_content_alignment_prop content_alignment

(**/**)

module type PG = sig
  val margin : Widget.widget -> int * int
  val size : Widget.widget -> int
  val mk_g : int -> int -> G.t
  val set_gpos : G.t -> int -> G.t
  val set_gsize : G.t -> int -> G.t
  val set_g : G.t -> int -> int -> G.t
  val shift_g : G.t -> int -> G.t
  val baseline : Widget.widget -> int
  end

module PGH = struct
    let margin w = w#hmargin
    let size w = w#min_width
    let mk_g x w = { G.zero with x ; w }
    let set_gpos g x = { g with G.x }
    let set_gsize g w = { g with G.w }
    let set_g g x w = { g with G.x ; w }
    let shift_g (g:G.t) n = { g with G.x = g.x + n }
    let baseline w = w#min_width
  end

module PGV = struct
    let margin w = w#vmargin
    let size w = w#min_height
    let mk_g y h = { G.zero with y ; h }
    let set_gpos g y = { g with G.y }
    let set_gsize g h = { g with G.h }
    let set_g g y h = { g with G.y ; h }
    let shift_g (g:G.t) n = { g with G.y = g.y + n }
    let baseline w = w#baseline
  end

module Justify (P:PG) =
  struct
    let nb_holes =
      let rec iter bound n acc_size first was_space = function
      | [] -> (n, acc_size)
      | ((`Space _|`Break), _, _) :: q -> iter bound n acc_size false true q
      | (_,item,_) :: q ->
          let isize = if Props.get item#props expand > 0 then bound else P.size item in
          let n = if (not first) && was_space then n + 1 else n in
          iter bound n (acc_size + isize) false false q
      in
      fun bound line -> bound iter 0 0 true false line

    let prepare bound container line =
      [%debug "%s: Flex.prepare bound=%d" container#me bound];
      let collapse_spaces = container#collapse_spaces in
      let rec iter acc_pos prev_margin holes holes_size used_size last_item_margin
        first_item prev_space items = function
      | [] -> (acc_pos, prev_margin, holes, holes_size, used_size, last_item_margin, List.rev items)
      | ((`Space _) as k, item) :: q when collapse_spaces && first_item ->
          (* first space on line, set zero geometry and keep pos and prev_margin *)
          let g = P.mk_g acc_pos 0 in
          iter acc_pos prev_margin holes holes_size used_size last_item_margin
            first_item true ((k, item, g) :: items) q
      | [((`Space _) as k, item)] when collapse_spaces ->
          (* last space *)
          let (mbefore,mafter) = P.margin item in
          let pos = acc_pos +
            max (if items = [] then 0 else prev_margin) mbefore
          in
          let g = P.mk_g pos 0 in
          let used_size = used_size + if prev_space then 0 else last_item_margin in
          iter acc_pos prev_margin holes holes_size used_size mafter
            first_item true ((k, item, g) :: items) []
      | (k, item) :: q ->
          (* `Break should appear only at the end of line, since
             cut_lines should have mapped `Break to `Space when
             warp_on_break is false. *)
          match k with
          | `Break ->
              if q <> [] then
                Log.err
                  (fun m -> m "%s: Flex.prepare: `Break not at the end of a line" container#me);
              let g = P.mk_g (acc_pos+prev_margin) 0 in
              iter acc_pos prev_margin holes holes_size used_size last_item_margin
                first_item true ((k, item, g) :: items) q
          | _ ->
              let (mbefore, mafter) = P.margin item in
              let size =
                match k with
                | `Space false -> 0
                | `Block when Props.get item#props expand > 0 -> bound - mbefore - mafter
                | _ -> P.size item - mbefore - mafter
              in
              let pos = acc_pos +
                max (if items = [] then 0 else prev_margin) mbefore
              in
              let g = P.mk_g pos size in
              [%debug "%s: Flex.prepare: (%s, %a)" container#me item#me G.pp g];
              let holes, holes_size, used_size, first_item, was_space, last_item_margin =
                match k with
                | `Space false ->
                    (holes, holes_size + size, used_size, first_item, true, last_item_margin)
                | `Space true when collapse_spaces ->
                    let used_size = used_size + prev_margin in
                    (holes, holes_size + size, used_size, first_item, true, mafter)
                | `Space true ->
                    (holes, holes_size + size, used_size + pos - acc_pos + size, first_item, true, mafter)
                | _ ->
                    let holes = if prev_space && not first_item then holes + 1 else holes in
                    let used_size = used_size + pos - acc_pos + size in
                    (holes, holes_size, used_size, false, false, mafter)
              in
              let acc_pos = pos + size in
              iter acc_pos mafter holes holes_size used_size last_item_margin
                first_item was_space ((k, item, g)::items) q
      in
      let (pos, margin, holes, holes_size, used_size, last_item_margin, items) as x =
        iter 0 0 0 0 0 0 true false [] line
      in
      [%debug "Flex.prepare => pos=%d, margin=%d, holes=%d, holes_size=%d, used_size=%d, last_item_margin=%d"
         pos margin holes holes_size used_size last_item_margin];
      x

    let justify_start bound container (line,_in_block) =
      let (pos, margin, holes, holes_size, used_size, last_item_margin, items) =
        prepare bound container line
      in
      items

    let justify_center bound container (line, _in_block) =
      let (pos, margin, holes, holes_size, used_size, last_item_margin, items) =
        prepare bound container line
      in
      let remaining_space =
        match container#collapse_spaces with
        | true -> float (bound - holes_size - used_size - last_item_margin)
        | false -> float (bound - pos - margin)
      in
      let shift = truncate (remaining_space /. 2.) in
      List.map (fun (k,w,(g:G.t)) -> (k,w, P.shift_g g shift)) items

    let justify_end bound container (line, _in_block) =
      let (pos, margin, holes, holes_size, used_size, last_item_margin, items) =
        prepare bound container line
      in
      let shift =
        match container#collapse_spaces with
        | true -> bound - holes_size - used_size - last_item_margin
        | false -> bound - pos - margin
      in
      List.map (fun (k,w,(g:G.t)) -> (k,w, P.shift_g g shift)) items

    let justify_space_around bound container (line, _in_block) =
      let (pos, margin, holes, holes_size, used_size, last_item_margin, items) =
        prepare bound container line
      in
      let collapse_spaces = container#collapse_spaces in
      if not collapse_spaces then
        Log.warn (fun m -> m "%s: justifying with space around but collapse_spaces is false"
           container#me);
      let space = bound - used_size in
      let space_size = (float space) /. (float (holes + 2)) in
      [%debug "%s justify_space_around: pos=%d, margin=%d, bound=%d, space=%d, holes=%d, space_size=%f" container#me pos margin bound space holes space_size];
      let rec iter n line was_space shift_diff = function
      | [] -> List.rev line
      | ((`Break|`Space false) as k,item,g) :: q ->
          let shift = truncate (float n *. space_size) - shift_diff in
          let g = P.shift_g g shift in
          iter n ((k, item, g)::line) true shift_diff q
      | ((`Space true) as k, item, g) :: q ->
          let size = P.size item in
          let g = P.set_gsize g (truncate space_size) in
          let shift = truncate (float n *. space_size) - shift_diff in
          let g = P.shift_g g shift in
          (* first space size was set to 0 so no shift_diff to add here *)
          let shift_diff = shift_diff + if n = 0 then 0 else size in
          iter n ((k, item, g)::line) true shift_diff q
      | (k, item, g) :: q ->
          let n = if was_space then n + 1 else n in
          let shift = truncate (float n *. space_size) - shift_diff in
          iter n ((k, item, P.shift_g g shift)::line) false shift_diff q
      in
      iter 0 [] true 0 items

    let justify_space_between bound container (line, _in_block) =
      let (pos, margin, holes, holes_size, used_size, last_item_margin, items) =
        prepare bound container line
      in
      let collapse_spaces = container#collapse_spaces in
      if not collapse_spaces then
        Log.warn (fun m -> m "%s: justifying with space between but collapse_spaces is false"
           container#me);
      let space = bound - used_size in
      let space_size = (float space) /. (float holes) in
      [%debug "%s justify_space_between: pos=%d, margin=%d, bound=%d, space=%d, holes=%d, space_size=%f" 
        container#me pos margin bound space holes space_size];
      let rec iter n line first was_space shift_diff = function
      | [] -> List.rev line
      | ((`Break|`Space false) as k,item,g) :: q ->
          let g = if first then
              g
            else
              let shift = truncate (float (n-1) *. space_size) - shift_diff in
              P.shift_g g shift
          in
          iter n ((k, item, g)::line) false true shift_diff q
      | ((`Space true) as k, item, g) :: q ->
          let size = P.size item in
          let n = if first then n else n + 1 in
          let g = P.set_gsize g (if first then 0 else (truncate space_size)) in
          let g =
            if first then
              g
            else
              (
              let shift = truncate (float (n-1) *. space_size) - shift_diff in
              [%debug "shifting %s by %d" item#me shift];
              P.shift_g g shift
              )
          in
          (* first space size was set to 0 so no shift_diff to add here *)
          let shift_diff = shift_diff + if first then 0 else size in
          iter n ((k, item, g)::line) false true shift_diff q
      | (k, item, g) :: q ->
          let shift = truncate (float n *. space_size) - shift_diff in
          [%debug "shifting %s by %d" item#me shift];
          iter n ((k, item, P.shift_g g shift)::line) false false shift_diff q
      in
      iter 0 [] true true 0 items

    let justify_line j =
      match j with
      | `Center -> justify_center
      | `End -> justify_end
      | `Justified -> assert false
      | `Space_around -> justify_space_around
      | `Space_between -> justify_space_between
      | `Start -> justify_start

    let justify_justified =
      let f bound container (line, in_block) =
        (if in_block then justify_space_between else justify_start)
          bound container (line, in_block)
      in
      fun bound container lines -> List.map (f bound container) lines

    let justify bound container lines =
      match container#justification with
      | `Justified -> justify_justified bound container lines
      | j -> List.map (justify_line j bound container) lines
  end


module HJustify = Justify(PGH)
module VJustify = Justify(PGV)

module Items_align (P:PG) =
  struct
    let only_spaces =
    let pred = function
    | (`Space _, _, _) -> true
    | _ -> false
    in
    fun l -> List.for_all pred l

    let align_constraints ispace container prev_pos prev_pos_with_margin line =
      let f (max_start, max_baseline, max_sup_bl, max_sub_bl) (k,item,_) =
        let (mbefore, mafter) = P.margin item in
        let size = P.size item - mbefore - mafter in
        let start = max prev_pos_with_margin (prev_pos + max ispace mbefore) in
        let bl = P.baseline item in
        let (bl, sup_bl, sub_bl) =
          match item#text_valign with
          | Props.Baseline -> (bl, bl, size-bl)
          | Super ->
              let bl = bl + bl / 2 in
              (bl, bl, size-bl)
          | Sub ->
              let bl = bl / 2 in
              (bl, bl, size-bl)
          | Top -> (bl, bl, size-bl)
          | Text_top ->
              let fh = Font.font_height container#font in
              let bl = bl + fh in
              (bl, bl, size-bl)
          | Middle -> (0, size/2, size/2)
          | Bottom -> (bl, bl, size-bl)
          | Text_bottom ->
              let f = container#font in
              let fh = Font.font_height f in
              let fd = Font.font_descent f in
              let bl  = bl + fh in
              (bl, 0, fd+size)
        in
        [%debug "align_constraints: %s => bl=%d, sup_bl=%d, sub_bl=%d"
           item#me bl sup_bl sub_bl];
        (max max_start start, max max_baseline (start + bl),
         max max_sup_bl sup_bl, max max_sub_bl sub_bl)
      in
      List.fold_left f (0, 0, 0, 0) line

    let zero_line collapse_spaces prev_pos_with_margin line =
      match collapse_spaces && only_spaces line with
      | false -> None
      | true ->
          let line = List.map
            (fun (k,item,g) ->
               let g = P.set_g g prev_pos_with_margin 0 in
               (k,item,g)
            ) line
          in
          Some line

    let align_baseline_ collapse_spaces ispace container (prev_pos, prev_pos_with_margin, lines) line =
      match zero_line collapse_spaces prev_pos_with_margin line with
      | Some line -> (prev_pos, prev_pos_with_margin, line :: lines)
      | None ->
          let (start, bl, max_sup_bl, max_sub_bl) =
            align_constraints ispace container
              prev_pos prev_pos_with_margin line
          in
          let bl = max (max 0 (bl-start)) max_sup_bl in
          let bottom = start + bl + max_sub_bl in
          [%debug "align_baseline: start=%d, bl=%d, max_sup_bl=%d, max_sub_bl=%d, bottom=%d"
             start bl max_sub_bl max_sub_bl bottom];
          let (max_pos, max_pos_with_margin, line) =
            List.fold_left
              (fun (max_pos, max_pos_with_margin, line) (k,item, g) ->
                 let (mbefore, mafter) = P.margin item in
                 let size = P.size item - mbefore - mafter in
                 let baseline = P.baseline item in
                 let pos =
                   match item#text_valign with
                   | Baseline -> start + bl - baseline
                   | Super -> start + bl - (baseline+baseline/2)
                   | Sub -> start + bl - (baseline/2)
                   | Top -> start
                   | Text_top ->
                       let fa = Font.font_ascent container#font in
                       start + bl - fa - baseline
                   | Middle -> start + (bottom - start - size) / 2
                   | Bottom -> bottom - size
                   | Text_bottom ->
                       let fd = Font.font_descent container#font in
                       start + bl + fd
                 in
                 let size = (* if item is a `Space false, force its size to 0 *)
                   match k with
                   | `Space false -> 0
                   | _ -> size
                 in
                 let g = P.set_g g pos size in
                 [%debug "%s align_items, item %s: set_g %d %d" container#me item#me pos size];
                 let max_pos = max max_pos (pos + size) in
                 let max_pos_with_margin = max max_pos_with_margin (pos + size + mafter) in
                 (max_pos, max_pos_with_margin, (k,item, g) :: line)
          )
          (0, 0, []) line
      in
      (max_pos, max_pos_with_margin, (List.rev line) :: lines)

    let align_stretch collapse_spaces ispace container (prev_pos, prev_margin, lines) line =
      (prev_pos, prev_margin, line :: lines)

    let prepare_align ispace container prev_pos prev_pos_with_margin line =
      let f (max_start, max_size) (k,item,_) =
        let (mbefore, mafter) = P.margin item in
        let size = P.size item - mbefore - mafter in
        let start = max prev_pos_with_margin (prev_pos + max ispace mbefore) in
        (max max_start start, max max_size size)
      in
      List.fold_left f (0, 0) line

    let align_start collapse_spaces ispace container (prev_pos, prev_pos_with_margin, lines) line =
      match zero_line collapse_spaces prev_pos_with_margin line with
      | Some line -> (prev_pos, prev_pos_with_margin, line :: lines)
      | None ->
          let (start, _) = prepare_align ispace container
            prev_pos prev_pos_with_margin line
          in
          let (max_pos, max_pos_with_margin, items) = List.fold_left
            (fun (max_pos, max_pos_with_margin, items) (k,item,g) ->
               let (mbefore,mafter) = P.margin item in
               let size = P.size item - mbefore - mafter in
               let pos = start in
               let g = P.set_g g pos size in
               let max_pos = max max_pos (pos+size) in
               let max_pos_with_margin = max max_pos_with_margin (pos+size+mafter) in
               (max_pos, max_pos_with_margin, (k, item, g)::items)
            ) (0, 0, []) line
          in
          (max_pos, max_pos_with_margin, (List.rev items) :: lines)

    let align_center collapse_spaces ispace container (prev_pos, prev_pos_with_margin, lines) line =
      match zero_line collapse_spaces prev_pos_with_margin line with
      | Some line -> (prev_pos, prev_pos_with_margin, line :: lines)
      | None ->
          let (start, max_size) = prepare_align ispace container
            prev_pos prev_pos_with_margin line
          in
          let middle = float start +. (float max_size /. 2.) in
          let (max_pos, max_pos_with_margin, items) = List.fold_left
            (fun (max_pos, max_pos_with_margin, items) (k,item,g) ->
               let (mbefore,mafter) = P.margin item in
               let size = P.size item - mbefore - mafter in
               let pos = truncate (middle -. (float size /. 2.)) in
               let g = P.set_g g pos size in
               let max_pos = max max_pos (pos+size) in
               let max_pos_with_margin = max max_pos_with_margin (pos+size+mafter) in
               (max_pos, max_pos_with_margin, (k, item, g)::items)
            ) (0, 0, []) line
          in
          (max_pos, max_pos_with_margin, (List.rev items) :: lines)

    let align_end collapse_spaces ispace container (prev_pos, prev_pos_with_margin, lines) line =
      match zero_line collapse_spaces prev_pos_with_margin line with
      | Some line -> (prev_pos, prev_pos_with_margin, line :: lines)
      | None ->
          let (start, max_size) = prepare_align ispace container
            prev_pos prev_pos_with_margin line
          in
          let bottom = start + max_size in
          let (max_pos, max_pos_with_margin, items) = List.fold_left
            (fun (max_pos, max_pos_with_margin, items) (k,item,g) ->
               let (mbefore,mafter) = P.margin item in
               let size = P.size item - mbefore - mafter in
               let pos = bottom - size in
               let g = P.set_g g pos size in
               let max_pos = max max_pos (pos+size) in
               let max_pos_with_margin = max max_pos_with_margin (pos+size+mafter) in
               (max_pos, max_pos_with_margin, (k, item, g)::items)
            ) (0, 0, []) line
          in
          (max_pos, max_pos_with_margin, (List.rev items) :: lines)

    let align_baseline collapse_spaces ispace container =
      (match container#orientation with
       | Props.Vertical -> align_baseline_
       | Props.Horizontal -> align_baseline_) collapse_spaces ispace container

    let align_line = function
    | `Baseline -> align_baseline
    | `Center -> align_center
    | `End -> align_end
    | `Start -> align_start
    | `Stretch -> align_stretch

    let align container lines =
      let collapse_spaces = container#collapse_spaces in
      let ispace = container#inter_space in
      let (pos, last_margin, lines) =
        List.fold_left
          (align_line container#items_alignment collapse_spaces ispace container)
          (0, 0, []) lines
      in
      (pos, last_margin, lines)
  end

module HItems_align = Items_align(PGH)
module VItems_align = Items_align(PGV)

module Cut_lines (P:PG) =
  struct
    let is_space = function
    | `Space _ | `Break -> true
    | _ -> false

    let only_spaces =
      let pred = function
      | (`Space _, _) -> true
      | _ -> false
      in
      fun l -> List.for_all pred l

    let min_size =
      let rec iter ~wrap ~collapse_spaces ~wrap_on_break ~ispace
        cur_size max_size prev_space prev_margin = function
      | [] -> max (cur_size + prev_margin) max_size
      | item :: q ->
          match Props.get item#props item_kind with
          | `Break when wrap_on_break ->
              let max_size = max (cur_size+prev_margin) max_size in
              iter ~wrap ~collapse_spaces ~wrap_on_break ~ispace 0 max_size true 0 q
          | `Space _ | `Break when collapse_spaces && prev_space ->
              iter ~wrap ~collapse_spaces ~wrap_on_break ~ispace
                cur_size max_size true prev_margin q
          | `Block ->
              let size = P.size item in
              let max_size = max size (max (cur_size + prev_margin) max_size) in
              iter ~wrap ~collapse_spaces ~wrap_on_break ~ispace
                0 max_size true 0 q
          | k ->
              let is_space = is_space k in
              let mbefore, mafter = P.margin item in
              let size = P.size item - mbefore - mafter in
              let cur_size, max_size, mafter =
                if prev_space && wrap then
                  (
                   let max_size = max (cur_size + prev_margin) max_size in
                   (size, max_size, mafter)
                  )
                else
                  (
                   let cur_size = cur_size + max (max ispace prev_margin) mbefore + size in
                   (cur_size, max_size, mafter)
                  )
              in
              iter ~wrap ~collapse_spaces ~wrap_on_break ~ispace
                cur_size max_size is_space mafter q
      in
      fun ~wrap ~collapse_spaces ~wrap_on_break ~ispace items ->
        iter ~wrap ~collapse_spaces ~wrap_on_break ~ispace 0 0 true 0 items

    let size_to_next_cutpoint =
      let rec iter cur_size prev_margin wrap_on_nl collapse_spaces = function
      | [] -> cur_size+prev_margin
      | (k, item) :: q ->
          match k with
          | `Break when wrap_on_nl -> cur_size+prev_margin
          | `Space _
          | `Break  -> cur_size+prev_margin
          | `Block
          | `Item ->
              let mbefore, mafter = P.margin item in
              let isize = P.size item - mbefore - mafter in
              let size = max prev_margin mbefore + isize in
              iter (cur_size+size) mafter wrap_on_nl collapse_spaces q
      in
      iter 0

    (** Returns a list of lines. Each line is composed of
        a list of pairs (item kind, item) and a flag indicating whether
        this is a line in a block of lines, i.e. lines automatically
        wrapped, but not the last line of this block. *)
    let cut_lines bound container items =
      [%debug "%s cut_lines: g=%a" container#me G.pp container#geometry];
      let b =
        if container#wrap then
          bound
        else
          max_int
      in
      let wrap_on_break = container#wrap_on_break in
      let collapse_spaces = container#collapse_spaces in
      let ispace = container#inter_space in
      let items = List.map (fun i -> Props.get i#props item_kind, i) items in
      let rec iter (line, lines, cur_size, prev_margin, prev_was_space) items =
        match items with
        | [] when collapse_spaces && only_spaces line ->
            let f (first, acc) (_,i) = (false, (`Space first, i) :: acc) in
            let (_,line) = List.fold_left f (true, []) line in
            let lines = (List.rev line, false) :: lines in
            ([], lines, 0, 0, false)
        | [] -> (line, lines, cur_size, prev_margin, prev_was_space)
        | (k, item) :: q ->
            let (mbefore, mafter) = P.margin item in
            let size = P.size item - mbefore - mafter in
            match line, k with
            | [], `Block ->
                (*let lines = List.rev line :: lines in*)
                iter ([], ([(k, item)], false) :: lines, 0, 0, false) q
            | line, `Block when collapse_spaces && only_spaces line ->
                let f (first, acc) (_,i) = (false, (`Space first, i) :: acc) in
                let (_,line) = List.fold_left f (true, []) line in
                iter ([], ([k, item], false) :: (List.rev line, false) :: lines, 0, 0, false) q
            | _, `Block ->
                let lines = (List.rev line, false) :: lines in
                iter ([], ([k, item], false) :: lines, 0, 0, false) q
            | _, `Break when wrap_on_break ->
                let line = List.rev ((k, item) :: line) in
                iter ([], (line,false) :: lines, 0, 0, false) q
            | [], _ ->
                let k = if k = `Break || k = `Space false then `Space true else k in
                let line = (k, item) :: line in
                let cur_size = mbefore + size in
                iter (line, lines, cur_size, mafter, is_space k) q
            | _ ->
                let is_space = is_space k in
                let k, fit_on_line, size =
                  match k with
                  | (`Break | `Space _) when collapse_spaces && prev_was_space -> `Space false, true, 0
                  | `Break when collapse_spaces -> `Space true, true, size
                  | k ->
                      let to_cutpoint = size_to_next_cutpoint mafter wrap_on_break collapse_spaces q in
                      let fit_on_line =
                        line = [] ||
                          not prev_was_space ||
                          cur_size + (max (max ispace prev_margin) mbefore) + size + to_cutpoint <= b
                      in
                      [%debug "%s fit_on_line: %b, prev_was_space:%b, is_space:%b, cur_size=%d, prev_margin=%d, mbefore=%d, size=%d, mafter=%d, to_cutpoint=%d, bound=%d" item#me fit_on_line prev_was_space is_space cur_size prev_margin mbefore size mafter to_cutpoint bound];
                      k, fit_on_line, size
                in
                if fit_on_line then
                  (
                   let pos = cur_size + max (max ispace prev_margin) mbefore in
                   let line = (k, item) :: line in
                   let cur_size = pos + size in
                   iter (line, lines, cur_size, mafter, is_space) q
                  )
                else
                  let lines = (List.rev line, true) :: lines in
                  iter ([], lines, 0, 0, false) items
      in
      let (line, lines, _, _, _) = iter ([], [], 0, 0, collapse_spaces) items in
      let lines =
        match line with
        | [] -> List.rev lines
        | l -> List.rev ((List.rev l, false) :: lines)
      in
      [%debug "%s cut_lines -> %d lines" container#me (List.length lines)];
      List.iter
        (function
           | ((`Space false,_) :: _), _ ->
             Log.err (fun m -> m "Flex.cut_lines: a line begins with `Space false")
           | _ -> ()) lines;

      lines
  end
module HCut = Cut_lines(PGH)
module VCut = Cut_lines(PGV)

(**/**)

(** A space item. Use {!val-space} or {!val-break} to create it,
  as it will set the correct value for {!val-item_kind} property.
  Widget kind is ["flex_space"].
*)
class space ?classes ?name ?props ?wdata () =
  object(self)
    inherit Widget.widget ?classes ?name ?props ?wdata () as super
    (**/**)
    method kind = "flex_space"
    method! private min_width_ =
      let> (w,_) = Font.size_utf8 self#font " " in
      super#min_width_ + w
    method! private min_height_ = super#min_height_ + Font.font_height self#font
    method! baseline =
      (* g_inner may no be set yet *)
      let ptop = self#padding.top in
      let btop = self#border_width.top in
      ptop + btop + Font.font_ascent self#font

    method! set_geometry geom =
      [%debug "%s#set_geometry %a" self#me G.pp geom];
      super#set_geometry geom
(*
    initializer
      self#set_p Props.bg_color Color.cyan;
      self#set_p Props.fill true;
*)
  end

(** Create a {!class-space} item with correct {!val-item_kind} value.
  See {!Widget.widget_arguments} for arguments. *)
let space ?classes ?name ?props ?wdata () =
  let w = new space ?classes ?name ?props ?wdata () in
  w#set_p item_kind (`Space true);
  w

(** Create a {!class-space} item with [`Break] for {!val-item_kind} property.
  Widget has same kind as {!class-space} with additional class ["break"].
  See {!Widget.widget_arguments} for arguments. *)
let break ?(classes=[]) ?name ?props ?wdata () =
  let classes = "break" :: classes in
  let w = new space ~classes ?name ?props ?wdata () in
  w#set_p item_kind `Break;
  w

(** Container widget behaving like CSS flex box.
  The widget has class ["vertical"] or ["horizontal"] depending on orientation.
*)
class ['a] flex ?classes ?name ?props ?wdata () =
  object(self)
    inherit ['a option] Container.container_list ?classes ?name ?props ?wdata () as super
    inherit Widget.oriented as oriented
    (**/**)
    method kind = "flex"
    (**/**)

    (** {2 Properties} *)

    method inter_space = self#get_p inter_space
    method set_inter_space = self#set_p inter_space

    method justification = self#get_p justification
    method set_justification = self#set_p justification

    method items_alignment = self#get_p items_alignment
    method set_items_alignment = self#set_p items_alignment

    method content_alignment = self#get_p content_alignment
    method set_content_alignment = self#set_p content_alignment

    method wrap = self#get_p wrap
    method set_wrap = self#set_p wrap

    method wrap_on_break = self#get_p wrap_on_break
    method set_wrap_on_break = self#set_p wrap_on_break

    method collapse_spaces = self#get_p collapse_spaces
    method set_collapse_spaces = self#set_p collapse_spaces

    (** {2 Accessing children } *)

    (** [f#widget_data w] returns the [wdata] associated the given widget [w],
     or [None] if [w] is not a child of [f].*)
    method widget_data = super#widget_data

    (** [f#widget_index w] returns the 0-based position of [w] in the
         children, or [None] if [w] is not a child of [f]. *)
    method widget_index = super#widget_index

    (** [f#children_widgets] returns the list of children widgets.*)
    method children_widgets = List.map (fun c -> c.widget) self#children

    (** [f#reorder_child w pos] moves [w] to [pos] in the children list.
     Does nothing if [w] is not a child of [f]. *)
    method reorder_child w pos = super#reorder_child w pos

    (**/**)
    val mutable lines = ([] : (item_kind * Widget.widget) list list)
    val mutable g_arranged = (None : G.t option)
    method g_arranged = g_arranged

    method! baseline =
      match List.find_opt (function [] -> false | _ -> true) lines with
      | None -> super#baseline
      | Some [] -> assert false
      | Some ((_,w) :: _) ->
          (* g_inner may not be set yet *)
          let ptop = self#padding.top in
          let btop = self#border_width.top in
          ptop + btop +  w#baseline

    method! need_resize =
      if not ignore_need_resize then
        (
         g_arranged <- None;
         super#need_resize
        )

    method! private min_width_ =
      let w =
        match self#orientation with
        | Props.Horizontal ->
            HCut.min_size ~wrap:self#wrap
              ~wrap_on_break:self#wrap_on_break
              ~collapse_spaces:self#collapse_spaces
              ~ispace:self#inter_space self#visible_children
        | Props.Vertical ->
            (match g_arranged with None -> 0 | Some ga -> ga.w)
      in
      let w = super#min_width_ + w in
      (*Log.err (fun m -> m "%s#min_width_ = %d, props=%a" self#me w Props.pp self#props);*)
      (*Log.err (fun m -> m "%s#min_width_ = %d" self#me w);*)
      w

    method! private min_height_ =
      let h =
        match self#orientation with
        | Props.Horizontal ->
            (match g_arranged with None -> 0 | Some ga -> ga.h)
        | Props.Vertical ->
            VCut.min_size ~wrap:self#wrap
              ~wrap_on_break:self#wrap_on_break
              ~collapse_spaces:self#collapse_spaces
              ~ispace:self#inter_space self#visible_children
      in
      super#min_height_ + h

    method! max_width = None
    method! max_height = None

    (**/**)

    (** {2 Packing/unpacking widgets} *)

    (** [f#pack w] adds [w] to the children of [f] if it is not yet
      a child of [f]. Optional arguments are:
      {ul
       {- [pos] indicate the 0-based position to insert [w]. Default is
          to append [w] after all children.}
       {- [data] associates the given [data] to [w].}
       {- [kind] specifies how [w] must be considered when arranging elements.
          Default is not to specify any kind, so that this property
         for this widget has default value (see {!Flex.val-item_kind}).}
      }
    *)
    method pack ?pos ?data ?kind (w:Widget.widget) =
      [%debug "%s#add %s" self#me w#me];
      Option.iter (w#set_p item_kind) kind;
      match super#add ?pos w data with
      | false -> ()
      | true -> if w#visible then (g_arranged <- None; self#need_resize)

    (** [f#pack_space ()] creates a {!Flex.class-space} widget and packs it.
       See {!flex.method-pack} for arguments. Returns the created widget. *)
    method pack_space ?props ?wdata ?pos ?data () =
      let w = space ?props ?wdata () in
      self#pack ?pos ?data w#coerce;
      w

    (** [f#pack_break ()] creates a {!Flex.class-space} widget with
       [`Break] item kind and packs it.
       See {!flex.method-pack} for arguments. Returns the created widget. *)
    method pack_break ?props ?wdata ?pos ?data () =
      let w = break ?props ?wdata () in
      self#pack ?pos ?data w#coerce;
      w

    (** [f#unpack w] removes [w] from children. Does nothing if [w]
      is not a child of [f]. *)
    method unpack (w : Widget.widget) =
      match super#remove w with
      | false -> ()
      | true ->
          if w#visible then
            (
             lines <- [];
             g_arranged <- None;
             self#need_resize
            )

    (** [f#unpack_all ~destroy] removes all children from [f].
      [destroy] indicates whether the [destroy] method must be called
      on each child after unpacking. *)
    method unpack_all ~destroy =
      match self#children_widgets with
      | [] -> ()
      | l ->
          let old_nr = ignore_need_resize in
          self#ignore_need_resize ;
          List.iter
            (fun w ->
              self#unpack w;
              if destroy then w#destroy
            )
            l;
          g_arranged <- None;
          if not old_nr then
            (self#handle_need_resize ;
             self#need_resize)

    (**/**)
    method! set_geometry geom =
      match self#orientation with
      | Props.Horizontal -> self#set_geometry_horizontal geom
      | Props.Vertical -> self#set_geometry_vertical geom

    method private set_geometry_horizontal geom =
      let update = geom.w <> g.w in
      super#set_geometry geom;
      if update || g_arranged = None then self#arrange_horizontal

    method private set_geometry_vertical geom =
      let update = geom.h <> g.h in
      super#set_geometry geom;
      if update || g_arranged = None then self#arrange_vertical

    method private arrange =
      match self#orientation with
      | Props.Horizontal -> self#arrange_horizontal
      | Props.Vertical -> self#arrange_vertical

    method private arrange_horizontal =
      let bound = g_inner.w in
      let wlines = HCut.cut_lines bound self self#visible_children in
      let wlines = HJustify.justify bound self wlines in
      let old = ignore_need_resize in
      self#ignore_need_resize ;
      List.iter (fun line ->
         List.iter (fun (k,w,g) -> w#set_geometry { g with G.h = w#min_height}) line) wlines;
      let (max_y, max_y_with_margin, wlines) = VItems_align.align self wlines in
      g_arranged <- Some { g with h = max_y_with_margin };
      [%debug "%s#arrange_horizontal => g_inner=%a, g_arranged = %a, %d children"
         self#me G.pp g_inner G.pp (Option.value ~default:G.zero g_arranged)
           (List.length self#children)];
      lines <- List.map (fun line ->
         List.map (fun (k,w,g) -> w#set_geometry g; (k,w)) line) wlines;
      if not old then self#handle_need_resize;
      if lines <> [] then super#need_resize

    method private arrange_vertical =
      let bound = g_inner.h in
      let wlines = VCut.cut_lines bound self self#visible_children in
      let wlines : (item_kind * Widget.widget * G.t) list list =
        VJustify.justify bound self wlines
      in
      let old = ignore_need_resize in
      self#ignore_need_resize;
      List.iter (fun line ->
         List.iter (fun (k,w,g) -> w#set_geometry { g with G.w = w#min_width}) line) wlines;
      let (max_x, max_x_with_margin, wlines) = HItems_align.align self wlines in
      g_arranged <- Some { g with w = max_x_with_margin };
      [%debug "%s#arrange_vertical => g_inner=%a, g_arranged = %a, %d children"
         self#me G.pp g_inner G.pp (Option.value ~default:G.zero g_arranged)
           (List.length self#children)];
      lines <- List.map (fun line ->
         List.map (fun (k,w,g) -> w#set_geometry g; (k,w)) line) wlines;
      if not old then self#handle_need_resize;
      if lines <> [] then super#need_resize

    method! private render_me ~layer rend ~offset rg =
      [%debug "%s#render_me" self#me];
      super#render_me ~layer rend ~offset rg

(*    initializer
      ignore(self#connect (Object.Prop_changed Props.orientation)
       (fun ~prev ~now -> self#arrange));
      ignore(self#connect (Object.Prop_changed items_alignment)
       (fun ~prev ~now -> self#arrange));*)
  end


(** Convenient function to create a {!class-flex}.
  Optional arguments:
  {ul
   {- [orientation] specifies horizontal or vertical packing. Default is
     {!Props.orientation.Horizontal}.}
   {- [justification], [items_alignment], [content_alignment],
    [inter_space], [wrap], [wrap_on_break] and [collapse_spaces]
    are used to set the corresponding properties.}
  }
  See {!Widget.widget_arguments} for other arguments. *)
let flex ?classes ?name ?props ?wdata ?(orientation=Props.Horizontal)
  ?justification ?items_alignment ?content_alignment
    ?inter_space ?wrap ?wrap_on_break ?collapse_spaces ?pack () =
  let w = new flex ?classes ?name ?props ?wdata () in
  w#set_orientation orientation ;
  Option.map w#set_justification justification ;
  Option.map w#set_items_alignment items_alignment ;
  Option.map w#set_content_alignment content_alignment ;
  Option.map w#set_inter_space inter_space ;
  Option.map w#set_wrap wrap ;
  Option.map w#set_wrap_on_break wrap_on_break ;
  Option.map w#set_collapse_spaces collapse_spaces;
  Widget.may_pack ?pack w ;
  w

let hflex = flex ~orientation:Props.Horizontal
let vlfex = flex ~orientation:Props.Vertical