package stk

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file pack.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
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
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
(*********************************************************************************)
(*                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                                          *)
(*                                                                               *)
(*********************************************************************************)

(** Boxes to pack widgets. *)

open Misc
open Tsdl
open Widget
open Container

[@@@landmark "auto"]

(** Property ["inter_padding"] use to specify a space between packed children.
  Default is [0]. *)
let inter_padding = Props.int_prop ~inherited:false ~default:0 "inter_padding"
let css_inter_padding = Theme.int_prop inter_padding

(**/**)
let set : 'a. Widget.widget -> 'a Props.prop -> 'a option -> unit = fun w -> fun p -> function
    | None -> ()
    | Some v -> w#set_p p v
(**/**)

(** {2 Stacking boxes} *)

(**/**)

module Elt = struct
    type t = Widget.widget
    let to_string t = Oid.to_string t#id
    module Map = Widget.Map
end
module WPacker = Packer.Make(Elt)

(**/**)

(** A {!class-box} is a {!Container.container} which stacks its children,
  giving each one more or less space according to its size and properties.
  Widgets can be stacked horizontally or vertically (depending on
  the {!Props.val-orientation} property).
  The widget has class ["vertical"] or ["horizontal"] depending on orientation.
*)
class ['a] box ?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 = "box"
    (**/**)

    (** {2 Properties} *)

    method inter_padding = self#get_p inter_padding
    method set_inter_padding = self#set_p inter_padding

    (** {2 Children } *)

    (** [b#widget_data w] returns {!Container.child.data} data associated to the given
      child widget [w], if [w] is a child of [b] and it has data associated. *)
    method widget_data = super#widget_data

    (** [b#widget_index w] returns 0-based index of [w] in [b]'s children,
      if [w] is a child of [b]. *)
    method widget_index = super#widget_index

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

    (** [o#reorder_child w pos] moves child widget [w] to new position [pos]
       (if possible). *)
    method reorder_child w pos = super#reorder_child w pos

    (** [box#get_nth None] returns [None].
        [box#get_nth (Some n)] returns [None] if [n]-th child does not exist,
        or [Some (data, child)].*)
    method get_nth n =
      match n with
      | None -> None
      | Some n ->
          match List.nth_opt self#children n with
          | None -> None
          | Some c -> Some (c.data, c.widget)

    (**/**)
    method! private min_width_ =
      super#min_width_ +
        match self#orientation with
        | Props.Horizontal ->
            let (w, nb, mright) =
              List.fold_left
                (fun (acc_w, acc_nb, prev_margin) c ->
                 if c.widget#visible && c.widget#hexpand >= 0
                   then
                     let (mleft,mright) = c.widget#hmargin in
                     let w = c.widget#min_width - mright - mleft + (max prev_margin mleft) in
                     (acc_w + w, acc_nb + 1, mright)
                   else (acc_w, acc_nb, prev_margin))
                (0, 0, 0) children
            in
            w + mright + ((max 0 (nb - 1)) * self#inter_padding)
        | Vertical ->
            List.fold_left
              (fun acc c ->
                 if c.widget#visible && c.widget#hexpand >= 0
                 then max acc c.widget#min_width
                 else acc)
              0 children

    method! private min_height_ =
      super#min_height_ +
        match self#orientation with
        | Horizontal ->
            List.fold_left
              (fun acc c ->
                 if c.widget#visible && c.widget#vexpand >= 0
                 then max acc c.widget#min_height
                 else acc)
              0 children
        | Vertical ->
            let (h, nb, mbottom) =
              List.fold_left
                (fun (acc_h, acc_nb, prev_margin) c ->
                   if c.widget#visible && c.widget#vexpand >= 0
                   then
                    let (mtop,mbottom) = c.widget#vmargin in
                     let h = c.widget#min_height - mbottom - mtop + (max prev_margin mtop) in
                     (acc_h + h, acc_nb + 1, mbottom)
                   else (acc_h, acc_nb, prev_margin))
              (0, 0, 0) children
            in
            h + mbottom + ((max 0 (nb - 1)) * self#inter_padding)

    method! max_width =
      match self#hexpand with
      | n when n <> 0 -> None
      | _ ->
          let f op (acc_exists_none, max_w) c =
            if c.widget#visible then
              match c.widget#max_width with
              | None -> (true, max_w)
              | Some w -> (acc_exists_none, op max_w w)
            else
              (acc_exists_none, max_w)
          in
          match
            match self#orientation with
            | Horizontal ->
                List.fold_left (f (+)) (false, 0) children
            | Vertical ->
                List.fold_left (f max) (false, 0) children
          with
          | true, _  -> None
          | false, max_w -> Some (max_w + super#min_width_)

    method! max_height =
      match self#vexpand with
      | n when n <> 0 -> None
      | _ ->
          let f op (acc_exists_none, max_h) c =
            if c.widget#visible then
              match c.widget#max_height with
              | None -> (true, max_h)
              | Some h -> (acc_exists_none, op max_h h)
            else
              (acc_exists_none, max_h)
          in
          match
            match self#orientation with
            | Horizontal ->
                List.fold_left (f max) (false, 0) children
            | Vertical ->
                List.fold_left (f (+)) (false, 0) children
          with
          | true, _  -> None
          | false, max_h -> Some (max_h + super#min_height_)

    (**/**)

    (** [o#pack w] adds widget [w] to [o]. Optional parameters are:
      {ul
       {- [pos] indicates a position to insert [w]; default is to
          append [w] to children. If [pos < 0], [pos] indicate a
          position from the end of the children list.}
       {- [hexpand] (resp. [vexpand]) sets {!Props.hexpand} (resp.
          {!Props.vexpand}) property of [w] to the given value. }
       {- [hfill] (resp. [vfill]) sets {!Props.hfill} (resp.
          {!Props.vfill}) property of [w] to the given value. }
       {- [data] associates the given value to [w]. All data associated
          to children must have the same type (this type is the type
          parameter of class {!class-box}. }
      }
       To allocate space for children widgets, the following algorithm
       is applied (here for horizontal packing; for vertical packing,
       replace width by height and [hexpand] by [vexpand]):
       {ol
       {- The minimum widths of children are summed. This sum is deducted
          from the width allocated to [o].}

       {- The remaining space is then distributed among children,
          according to their [hexpand] value.
          [0] means that widget does not require more than its
             minimal width.
          A positive value [p] means that the widget requires
          [p] shares of the remaining space. The remaining space
          is divided by the total number of shares and each widget
          is given as width its minimal width + the width corresponding
          to its required shares.
          For example, if three widgets of same minimum size have [hexpand]
          values of [3], [2] and [1], the first widget will have half
          of the available width, the second will have one third and
           the last on sixth.
       }
       {- When allocated width of each widget is computed, each widget
          is given this width (if value of [hfill] is [true]) of just its
          minimum width (if it is [false]).}
      }
    *)
    method pack ?pos ?hexpand ?vexpand ?hfill ?vfill ?data w =
      [%debug "%s#pack %s" self#me w#me];
      set w Props.hexpand hexpand ;
      set w Props.vexpand vexpand ;
      set w Props.hfill hfill ;
      set w Props.vfill vfill ;
      match super#add ?pos w data with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [o#unpack w] removes child widget [w] from [o]. *)
    method unpack (w : Widget.widget) =
      match super#remove w with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [o#unpack_all ~destroy] removes all children from [o]. [destroy]
       indicates whether to call [#destroy] on children after removing. *)
    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;
          if not old_nr then
            (self#handle_need_resize ;
             self#need_resize)

    (**/**)
    method! set_geometry geom =
      super#set_geometry geom ;
      [%debug "%s#set_geometry g=%a g_inner=%a"
         self#me G.pp g G.pp g_inner];
      [%debug "%a" Widget.pp_widget_tree self#wtree];
      (match self#orientation with
       | Horizontal -> self#set_geometry_horizontal geom
       | Vertical -> self#set_geometry_vertical geom
      );
      self#need_render ~layer:(self#get_p Props.layer) g

    method private set_geometry_horizontal geom =
      let w = self#min_width in
      let w = max w geom.w in
      let w = w - super#min_width_ in
      let visib_children = self#visible_children in
      let ip = self#inter_padding in
      [%debug "%s#set_geometry inter_padding=%d" self#me ip];
      let w_avail =
        let spaces =
          let (w, mright) =
            List.fold_left (fun (acc_w, prev) w ->
               let (mleft,mright) = w#hmargin in
               (acc_w + (max (max ip mleft) prev), mright))
              (0, 0) visib_children
          in
          w + mright
        in
        max 0 (w - spaces)
      in
      let m = WPacker.compute w_avail
        (fun w ->
           let (mleft, mright) = w#hmargin in
           w#min_width - mleft - mright)
          (fun w ->
             match w#max_width with
             | None -> None
             | Some mw ->
                 let (mleft, mright) = w#hmargin in
                 Some (mw - mleft - mright)
          )
          (fun w -> w#hexpand)
          visib_children
      in
      let _ = List.fold_left
        (fun (x,prev_margin) (wid:Widget.widget) ->
           let t = Elt.Map.find wid m in
           let h = match wid#max_height with
             | None -> g_inner.h
             | Some h ->
                 [%debug "%s#set_geometry wid=%s wid#max_height=%d" self#me wid#me h];
                 min h g_inner.h
           in
           [%debug "%s#set_geometry for %s h=%d" self#me wid#me h];
           let m = wid#margin in
           let h =
             let minh = wid#min_height in
             if wid#vfill then
               max minh h
             else
               minh
           in
           let h = h - m.top - m.bottom in
           [%debug "%s#set_geometry for %s h=%d vfill=%b"
              self#me wid#me h wid#vfill];
           let w =
             if wid#hfill then
               t.current
             else
               t.min
           in
           let x =
             let mleft = if x = 0 then m.left else max ip m.left in
             x + max mleft prev_margin
           in
           let geo = {
               G.x; y = m.top;
               w ; h }
           in
           wid#set_geometry geo ;
           geo.x + t.current, m.right
        )
          (0,0)
          visib_children
      in
      ()

    method private set_geometry_vertical geom =
      let h = self#min_height in
      let h = max h geom.h in
      let h = h - super#min_height_ in
      let visib_children = self#visible_children in
      let ip = self#inter_padding in
      let h_avail =
        let spaces =
          let (h, mbottom) =
            List.fold_left (fun (acc_h, prev) w ->
               let (mtop,mbottom) = w#vmargin in
               (acc_h + (max (max ip mtop) prev), mbottom))
              (0, 0) visib_children
          in
          h + mbottom
        in
        max 0 (h - spaces)
      in
      let m = WPacker.compute h_avail
        (fun w ->
           let (mtop,mbottom) = w#vmargin in
           w#min_height - mtop - mbottom)
          (fun w ->
             match w#max_height with
             | None -> None
             | Some h ->
                 let (mtop,mbottom) = w#vmargin in
                 Some (h - mtop - mbottom))
          (fun w -> w#vexpand)
          visib_children
      in
      let _ = List.fold_left
        (fun (y, prev_margin) (wid:Widget.widget) ->
           let t =
             match Elt.Map.find_opt wid m with
             | None -> Log.err (fun pr -> pr
                    "%s#set_geometry: widget with id=%s not found in widget list:[%s]"
                      self#me (Oid.to_string wid#id)
                      (String.concat "; "
                       (List.map
                        (fun (w,_) -> Printf.sprintf "%s"
                           (Elt.to_string w))
                          (Elt.Map.bindings m)
                       )
                      )
                 );
                 raise Not_found
             | Some x -> x
           in
           let m = wid#margin in
           let w = match wid#max_width with
             | None -> g_inner.w
             | Some w -> min w g_inner.w
           in
           let w =
             let minw = wid#min_width in
             if wid#hfill then
               max minw w
             else
               minw
           in
           let w = w - m.left - m.right in
           let h =
             if wid#vfill then
               t.current
             else
               t.min
           in
           let y =
             let mtop = if y = 0 then m.top else max ip m.top in
             y + max mtop prev_margin
           in
           let geo = {
               G.x = m.left ; y;
               w; h }
           in
           wid#set_geometry geo ;
           geo.y + t.current, m.bottom
        )
          (0, 0) visib_children
      in
      ()
  end


(** Convenient function to create a {!class-box}.
  See {!Widget.widget_arguments} for other arguments. *)
let box ~orientation ?classes ?name ?props ?wdata ?inter_padding ?pack () =
  let w = new box ?classes ?name ?props ?wdata () in
  w#set_orientation orientation ;
  Option.iter w#set_inter_padding inter_padding ;
  Widget.may_pack ?pack w ;
  w

(** Same as {!val-box} but orientation is already fixed to [Horizontal].*)
let hbox ?classes ?name ?props ?wdata ?inter_padding ?pack () =
  box ~orientation:Horizontal ?classes ?name ?props ?wdata ?inter_padding ?pack ()

(** Same as {!val-box} but orientation is already fixed to [Vertical].*)
let vbox ?classes ?name ?props ?wdata ?inter_padding ?pack () =
  box ~orientation:Vertical ?classes ?name ?props ?wdata ?inter_padding ?pack ()

(** {2 Paned widgets} *)

(** A handle position, defined either as percentage or absolute position. *)
type handle_position = [`Percent of float | `Absolute of int]

let handle_position_wrapper =
  let to_json ?with_doc = function
  | `Percent v -> `Float v
  | `Absolute v -> `Int v
  in
  let from_json ?def = function
  | `Float v -> `Percent (max 0. (min 100. v))
  | `Int v -> `Absolute (max 0 v)
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

(**/**)
module THandle_positions = struct
    type t = handle_position option list
    let compare = Stdlib.compare
    let wrapper = Some Ocf.Wrapper.(list (option handle_position_wrapper))
    let transition = None
  end
module PHandle_positions = Props.Add_prop_type(THandle_positions)
(**/**)

(** Property ["handle_positions"], to store the positions of the handles
  in a {!class-paned} widget. *)
let handle_positions : handle_position option list Props.prop = PHandle_positions.mk_prop
  ~after:[Props.Resize]
  ~default:[]
  ~inherited:false
  "handle_positions"

let css_handle_positions_prop =
  let string_of_handle_position = function
  | `Percent f -> Printf.sprintf "%f%%" f
  | `Absolute n -> string_of_int n
  in
  let to_string = Theme.(string_of_list (string_of_option_explicit string_of_handle_position)) in
  let handle_position_parser ctx =
    let open Angstrom in
    (Css.U.ws ctx *>
     choice [
       (Css.Vp.number ctx >>= fun f -> Css.U.ws ctx *> char '%' *> return (`Percent f)) ;
       (Theme.Vp.int ctx >>= fun n -> return (`Absolute n)) ;
     ]) <?> "handle_position"
  in
  let parser = Theme.Vp.(list (explicit_opt handle_position_parser)) in
  Theme.mk_prop to_string parser []

let css_handle_positions = css_handle_positions_prop handle_positions

(** How to define handle position when the user moves it: as percentage
  or absolute value. This changes the way handle positions are updated
  when the {!class-paned} widget is resized: with [`Percent], ratios between
  children will be kept, but with [`Absolute] the handles will remain at
  the same position. *)
type user_handle_positionning = [`Percent | `Absolute]

let user_handle_positionnings = [`Percent ; `Absolute]

let string_of_user_handle_positionning = function
| `Percent -> "percent"
| `Absolute -> "absolute"

let user_handle_positionning_of_string =
  Css.T.mk_of_string ~case_sensitive:false
    string_of_user_handle_positionning user_handle_positionnings

let user_handle_positionning_wrapper : user_handle_positionning Ocf.wrapper =
  let to_json ?with_doc x = `String (string_of_user_handle_positionning x) in
  let from_json ?def = function
  | (`String s) as json ->
      (match user_handle_positionning_of_string s with
       | None -> Ocf.invalid_value json
       | Some x -> x
      )
  | json -> Ocf.invalid_value json
  in
  Ocf.Wrapper.make to_json from_json

(**/**)
module TUser_handle_positionning = struct
    type t = user_handle_positionning
    let compare = Stdlib.compare
    let wrapper = Some user_handle_positionning_wrapper
    let transition = None
  end
module PUser_handle_positionning = Props.Add_prop_type(TUser_handle_positionning)
(**/**)

(** Property ["user_handle_positionning"]. *)
let user_handle_positionning : user_handle_positionning Props.prop =
  PUser_handle_positionning.mk_prop
    ~default:`Percent ~inherited:false "user_handle_positionning"

let css_user_handle_positioning_prop = Theme.keyword_prop
  string_of_user_handle_positionning user_handle_positionning_of_string
    `Percent

let css_user_handle_positioning =
  css_user_handle_positioning_prop user_handle_positionning

(**/**)
let default_handle_props =
  let p = Props.empty () in
  Props.(
    set p width 2;
    set p fg_color Color.grey ;
  );
  p
(**/**)

(** Property ["paned_handle_props"] to define appearance of
  handles in {!class-paned} widget.
  Default set {!Props.val-width} to [2] and {!Props.val-fg_color} to
  {!Color.grey}.
*)
let handle_props = Props.props_prop ~after:[Props.Resize]
  ~default:default_handle_props ~inherited:false "paned_handle_props"

(** Property ["paned_user_set_handle_live_update"] defines whether
  to update paned widget on each move of a handle by user ([true]),
  or wait for the user to end moving the handle ([false]).
  Default is [true]. It may be useful to set it to [false] when computation
  of children sizes may take some time. *)
let user_set_handle_live_update =
  Props.bool_prop ~after:[Props.Resize]
    ~default:true ~inherited:false "paned_user_set_handle_live_update"

let css_user_set_handle_live_update = Theme.bool_prop user_set_handle_live_update

(*
let honor_child_min_size = Props.bool_prop ~after:[Props.Resize]
  ~default:true ~inherited:false "paned_honor_child_min_size"
*)

(** Paned widget.

  Contains children widget separated by handles. Horizontal (or vertical
  if orientation is [Vertical]) space allocated to each child depends
  on handle positions. The first handle position defines how to distribute
  paned widget space between first and second children. The second handle
  position indicate how to distribube the remaining space between the
  second and third childreb, and so on.

  The widget has class ["vertical"] or ["horizontal"] depending on orientation.
*)
class paned ?classes ?name ?props ?wdata () =
  object(self)
    inherit [unit] Container.container_list ?classes ?name ?props ?wdata () as super
    inherit Widget.oriented as oriented

    (**/**)
    method kind = "paned"

    (* coordinates of handles relative to g_inner *)
    val mutable g_handles = ([] : G.t list)
    val mutable handle_cursor =
      let> c = Sdl.(create_system_cursor System_cursor.size_ns) in
      c
    val mutable cursor_on_handle = false
    val mutable state_machine = Misc.empty_state_machine

    method! private themable_props = handle_props :: super#themable_props
    (**/**)

    (** {2 Properties} *)

    method handle_props = self#get_p handle_props
    method set_handle_props = self#set_p handle_props

    method handle_positions = self#get_p handle_positions
    method set_handle_positions = self#set_p handle_positions

    method user_handle_positionning = self#get_p user_handle_positionning
    method set_user_handle_positionning = self#set_p user_handle_positionning

    method user_set_handle_live_update = self#get_p user_set_handle_live_update
    method set_user_set_handle_live_update = self#set_p user_set_handle_live_update
(*
    method honor_child_min_size = self#get_p honor_child_min_size
    method set_honor_child_min_size = self#set_p honor_child_min_size
*)

    (** {2 Children} *)

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

    (** [o#reorder_child w pos] moves child widget [w] to new position [pos]
       (if possible). *)
    method reorder_child w pos = super#reorder_child w pos

    (**/**)
    method! private min_width_ = super#min_width_ +
      self#min_handles_width +
        (let vchildren = self#visible_children in
         let op = match self#orientation with
         | Props.Horizontal -> (+)
         | Props.Vertical -> max
         in
         List.fold_left (fun acc w -> op acc w#min_width) 0 vchildren
        )

    method! private min_height_ = super#min_height_ +
      self#min_handles_height +
        (let vchildren = self#visible_children in
         let op = match self#orientation with
           | Props.Horizontal -> max
           | Props.Vertical -> (+)
         in
         List.fold_left (fun acc w -> op acc w#min_height) 0 vchildren
        )

    method private min_handles_width =
      let vchildren = self#visible_children in
      match self#orientation with
      | Horizontal ->
        let w = Props.(get self#handle_props width) in
        (max 0 (List.length vchildren - 1)) * w
      | Vertical -> 0

    method private min_handles_height =
      let vchildren = self#visible_children in
      match self#orientation with
      | Horizontal ->
          let w = Props.(get self#handle_props width) in
          (max 0 (List.length vchildren - 1)) * w
      | Vertical -> 0

    method! max_width =
      match self#hexpand with
      | n when n <> 0 -> None
      | _ ->
          let f op (acc_exists_none, max_w) c =
            if c.widget#visible then
              match c.widget#max_width with
              | None -> (true, max_w)
              | Some w -> (acc_exists_none, op max_w w)
            else
              (acc_exists_none, max_w)
          in
          match
            match self#orientation with
            | Horizontal ->
                List.fold_left (f (+)) (false, 0) children
            | Vertical ->
                List.fold_left (f max) (false, 0) children
          with
          | true, _  -> None
          | false, max_w -> Some (max_w + super#min_width_ + self#min_handles_width)

    method! max_height =
      match self#vexpand with
      | n when n <> 0 -> None
      | _ ->
          let f op (acc_exists_none, max_h) c =
            if c.widget#visible then
              match c.widget#max_height with
              | None -> (true, max_h)
              | Some h -> (acc_exists_none, op max_h h)
            else
              (acc_exists_none, max_h)
          in
          match
            match self#orientation with
            | Horizontal ->
                List.fold_left (f max) (false, 0) children
            | Vertical ->
                List.fold_left (f (+)) (false, 0) children
          with
          | true, _  -> None
          | false, max_h -> Some (max_h + super#min_height_ + self#min_handles_height)

    method private set_geometry_horizontal =
      let handle_w = Props.(get self#handle_props width) in
      let rec iter acc vchildren handle_pos x =
        match vchildren with
        | [] -> List.rev acc
        | [w] ->
            w#set_geometry { G.x ; y = 0 ; w = g_inner.w - x ; h = g_inner.h };
            List.rev acc
        | w1 :: qw ->
            let remain_w = max 0 (g_inner.w - x - handle_w) in
            let (target_w, qpos) =
              match handle_pos with
              | [] as q
              | None :: q -> remain_w / 2, q
              | (Some (`Absolute p)) :: q -> min remain_w p, q
              | (Some (`Percent p)) :: q ->
                  truncate (float remain_w *. (p /. 100.)), q
            in
            let g1 =
              let w =
                let w = max w1#min_width target_w in
                match w1#max_width with
                | None -> w
                | Some maxw -> min w maxw
              in
              { G.x ; y = 0 ; w ; h = g_inner.h }
            in
            w1#set_geometry g1;
            let gh = { G.x = g1.x + g1.w ; y = 0 ; w = handle_w ; h = g_inner.h } in
            iter (gh :: acc) qw qpos (gh.x + gh.w)
      in
      g_handles <- iter [] self#visible_children self#handle_positions 0

    method private set_geometry_vertical =
      let handle_h = Props.(get self#handle_props width) in
      let rec iter acc vchildren handle_pos y =
        match vchildren with
        | [] -> List.rev acc
        | [w] ->
            w#set_geometry { G.x = 0 ; y ; w = g_inner.w ; h = g_inner.h - y };
            List.rev acc
        | w1 :: qw ->
            let remain_h = max 0 (g_inner.h - y - handle_h) in
            let (target_h, qpos) =
              match handle_pos with
              | [] as q
              | None :: q -> remain_h / 2, q
              | (Some (`Absolute p)) :: q -> min remain_h p, q
              | (Some (`Percent p)) :: q ->
                  truncate (float remain_h *. (p /. 100.)), q
            in
            let g1 =
              let h =
                let h = max w1#min_height target_h in
                match w1#max_height with
                | None -> h
                | Some maxh -> min h maxh
              in
              { G.x = 0 ; y ; w = g_inner.w ; h }
            in
            w1#set_geometry g1;
            let gh = { G.x = 0; y = g1.y + g1.h ; w = g_inner.w ; h = handle_h } in
            iter (gh :: acc) qw qpos (gh.y + gh.h)
      in
      g_handles <- iter [] self#visible_children self#handle_positions 0

    method! set_geometry geom =
      super#set_geometry geom ;
      [%debug "%s#set_geometry g=%a" self#me G.pp g];
      (match self#orientation with
      | Horizontal -> self#set_geometry_horizontal
      | Vertical -> self#set_geometry_vertical);
      self#need_render ~layer:(self#get_p Props.layer) g

    (**/**)

    (** [o#pack w] adds widget [w] to [o]. Optional parameter
        [pos] indicates a position to insert [w]; default is to
          append [w] to children. *)
    method pack ?pos w =
      [%debug "%s#add %s" self#me w#me];
      match super#add ?pos w () with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [o#unpack w] removes child widget [w] from [o]. *)
    method unpack (w : Widget.widget) =
      match super#remove w with
      | false -> ()
      | true -> if w#visible then self#need_resize

    (** [o#unpack_all ~destroy] removes all children from [o]. [destroy]
       indicates whether to call [#destroy] on children after removing. *)
    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;
          if not old_nr then
            (self#handle_need_resize ;
             self#need_resize)

    (**/**)

    (* coordinates relative to g_inner *)
    method private handle_from_coords ~x ~y =
      let rec iter n = function
      | [] -> None
      | gh :: q ->
          let gh = match self#orientation with
            | Horizontal -> G.enlarge ~w:2 gh
            | Vertical -> G.enlarge ~h:2 gh
          in
          if G.inside ~x ~y gh then Some n else iter (n+1) q
      in
      iter 0 g_handles

    method private user_set_handle_pos n ~x ~y =
      let rec iter acc prev_bound i (lgh : G.t list) lpos =
        match lgh with
        | [] -> List.rev acc
        | gh :: qgh when i = n ->
            let bound = match self#orientation with
              | Horizontal ->
                  max 0 ((min x g_inner.w) - prev_bound)
              | Vertical ->
                  max 0 ((min y g_inner.h) - prev_bound)
            in
            let bound =
              match self#user_handle_positionning with
              | `Absolute -> `Absolute bound
              | `Percent ->
                  let limit =
                    match self#orientation with
                    | Horizontal -> g_inner.w
                    | Vertical -> g_inner.h
                  in
                  `Percent ((float bound /. float (limit - prev_bound)) *. 100.)
            in
            let lpos =
              match lpos with
              | [] -> [Some bound]
              | _ :: lpos -> (Some bound) :: lpos
            in
            (List.rev acc @ lpos)
        | gh :: qgh ->
            let prev_bound =
              match self#orientation with
              | Horizontal -> gh.x + gh.w + 1
              | Vertical -> gh.y + gh.h + 1
            in
            let (acc, lpos) =
              match lpos with
              | [] -> None :: acc, []
              | p :: q -> (p :: acc), q
            in
            iter acc prev_bound (i+1) qgh lpos
      in
      let new_pos = iter [] 0 0 g_handles self#handle_positions in
      [%debug "%s#user_set_handle_pos n=%d x=%d y=%d handle_positions=%a"
        self#me n x y (Props.pp_prop handle_positions) new_pos];
      self#set_handle_positions new_pos

    method! on_sdl_event_down ~oldpos pos ev =
      if self#sensitive then
        match state_machine.f pos ev with
        | false -> super#on_sdl_event_down ~oldpos pos ev
        | true -> true
      else
        false

    method on_mouse_leave =
      (match state_machine.state () with
       | `Moving_handle _ -> state_machine.set_state `Base
       | _ -> ()
      );
      super#on_mouse_leave

    method private restore_cursor = Sdl.set_cursor self#top_widget#cursor

    method state_on_event state pos ev =
      match state, pos, Sdl.Event.(enum (get ev typ)) with
      | `Base, Some(x,y), `Mouse_motion ->
          (
           (* change cursor if needed *)
           (*Log.warn (fun m -> m "%s#state_on_event mouse_motion g=%a x=%d y=%d"
              self#me G.pp g x y);*)
           let (x, y) = self#to_g_inner_coords ~x ~y in
           match self#handle_from_coords ~x ~y, cursor_on_handle with
           | None, false -> None
           | None, true ->
               self#restore_cursor ;
               cursor_on_handle <- false;
               None
           | Some _, true -> None
           | Some _, false ->
               cursor_on_handle <- true ;
               Sdl.set_cursor (Some handle_cursor);
               None
          )
      | `Moving_handle n, Some (x, y), `Mouse_motion ->
          if G.inside ~x ~y g then
            (
             let (x, y) = self#to_g_inner_coords ~x ~y in
             if self#user_set_handle_live_update then
               self#user_set_handle_pos n ~x ~y;
             Some (`Moving_handle n, true)
            )
          else
            (
             cursor_on_handle <- false ;
             self#restore_cursor ;
             Some (`Base, false)
            )
      | `Base, Some (x,y), `Mouse_button_down ->
          let button = Sdl.Event.(get ev mouse_button_button) in
          if button = 1 then
            let (x, y) = self#to_g_inner_coords ~x ~y in
            match self#handle_from_coords ~x ~y with
            | None -> None
            | Some n -> Some (`Moving_handle n, true)
          else
            None
      | `Moving_handle n, Some (x, y), `Mouse_button_up ->
          let (x, y) = self#to_g_inner_coords ~x ~y in
          self#user_set_handle_pos n ~x ~y;
          Some (`Base, false)
      | (`Base|`Moving_handle _), _, _ -> None

    method! render_me ~(layer:Layer.t) (rend:Sdl.renderer) ~offset:(x,y) (rg:G.t) =
      let off_x = g.x + g_inner.x in
      super#render_me ~layer rend ~offset:(x,y) rg ;
      let off_y = g.y + g_inner.y in
      let offset = (x + off_x, y + off_y) in
      let rg = G.translate ~x:(-off_x) ~y:(-off_y) rg in
      List.iter (self#render_handle ~layer rend ~offset rg) g_handles

    method render_handle ~layer rend ~offset:(x,y) rg gh =
      match G.inter rg gh with
      | None -> ()
      | Some clip ->
          let clip = G.translate ~x ~y clip in
          let f rend =
            let gh = G.translate ~x ~y gh in
            let col = Props.(get self#handle_props fg_color) in
            Render.fill_rect rend (Some gh) col
          in
          Render.with_clip rend (G.to_rect clip) f

    method! destroy =
      super#destroy ;
      Sdl.free_cursor handle_cursor

    initializer
      state_machine <- Misc.mk_state_machine `Base self#state_on_event ;
      ignore(self#connect (Object.Prop_changed Props.orientation)
       (fun ~prev ~now ->
          Sdl.free_cursor handle_cursor ;
          let> c = Sdl.(create_system_cursor
             System_cursor.(
              match self#orientation with
              | Horizontal -> size_we
              | Vertical -> size_ns))
          in
          handle_cursor <- c
       ))

  end

let paned orientation ?classes ?name ?user_set_handle_live_update ?props ?wdata ?pack () =
  let w = new paned ?classes ?name ?props ?wdata () in
  w#set_orientation orientation ;
  Option.iter w#set_user_set_handle_live_update user_set_handle_live_update ;
  Widget.may_pack ?pack w ;
  w

let hpaned = paned Horizontal
let vpaned = paned Vertical
OCaml

Innovation. Community. Security.