summaryrefslogtreecommitdiff
path: root/motus/js/fieldList.ml
blob: 85755aae61ab90b47f070b7413ba10d7e06cc7d5 (plain)
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
open Brr
open Note
open Brr_note
open StdLabels

type elements = Brr.El.t list

(** Depending of the class, extract the letter validity. 

  If no class is specified, consider the letter is at the right position.

 *)
let get_validity_from_element : El.t -> State.letter_validity =
 fun el ->
  if El.class' (Jstr.v "missing") el
  then State.Missing
  else if El.class' (Jstr.v "misplaced") el
  then State.Misplaced
  else State.Wellplaced


let get_rules : elements -> State.proposition =
 fun t ->
  List.map
    ~f:(fun input ->
      let value = El.prop El.Prop.value input in
      if Jstr.equal Jstr.empty value
      then None
      else
        let validity = get_validity_from_element input in
        Some (value, validity) )
    t


let get_class : State.letter_validity -> Jstr.t = function
  | Wellplaced -> Jstr.v "wellplaced"
  | Misplaced -> Jstr.v "misplaced"
  | _ -> Jstr.v "missing"


(** Create the field list modifiied by the user *)
let make : int -> (int * Jstr.t * State.letter_validity) E.send -> elements =
 fun len change_sender ->
  List.init ~len ~f:(fun i ->
      let input =
        El.input
          ~at:
            At.
              [ type' (Jstr.v "text")
              ; v (Jstr.v "maxLength") (Jstr.v "1")
              ; value Jstr.empty
              ; class' (Jstr.v "missing")
              ; v (Jstr.v "readonly") (Jstr.v "true")
              ]
          ()
      in

      Ev.listen
        Ev.change
        (fun _ ->
          let validity = get_validity_from_element input in
          change_sender (i, El.prop El.Prop.value input, validity) )
        (El.as_target input);
      Ev.listen
        Ev.click
        (fun _ ->
          let validity =
            match get_validity_from_element input with
            | State.Missing -> State.Misplaced
            | State.Misplaced -> State.Wellplaced
            | State.Wellplaced -> State.Missing
          in
          change_sender (i, El.prop El.Prop.value input, validity) )
        (El.as_target input);

      El.td [ input ] )


(** Set the element class depending of the proposition validity for each letter
 *)
let set_with_props :
    State.proposition -> elements -> Motus_lib.Criteria.t list -> unit =
 fun current_prop fields rules ->
  let i = ref 0 in
  List.iter2 current_prop fields ~f:(fun prop field ->
      (* Check if we have a rule for this letter *)
      let wellplaced =
        List.exists rules ~f:(function
            | Motus_lib.Criteria.Contain (_, Some i') when !i = i' -> true
            | _ -> false )
      in
      incr i;

      match (wellplaced, El.children field, prop) with
      | true, hd :: _, Some (letter, _) ->
          El.set_prop El.Prop.value letter hd;
          El.set_class (Jstr.v "wellplaced") true hd;
          El.set_class (Jstr.v "misplaced") false hd;
          El.set_class (Jstr.v "missing") false hd;
          El.set_at (Jstr.v "readonly") (Some (Jstr.v "true")) hd
      | _, hd :: _, None ->
          El.set_class (Jstr.v "wellplaced") false hd;
          El.set_class (Jstr.v "misplaced") false hd;
          El.set_class (Jstr.v "missing") false hd
      | false, hd :: _, Some (letter, validity) ->
          El.set_prop El.Prop.value letter hd;
          El.set_class (Jstr.v "wellplaced") false hd;
          El.set_class (Jstr.v "misplaced") false hd;
          El.set_class (Jstr.v "missing") false hd;
          El.set_class (get_class validity) true hd
      | _, [], _ -> () )


let build : El.t -> int S.t -> State.proposition S.t =
 fun container length ->
  (* Build the element list *)
  S.bind length (fun len ->
      let elements =
        List.init ~len ~f:(fun _ ->
            let input =
              El.input
                ~at:
                  At.
                    [ type' (Jstr.v "text")
                    ; v (Jstr.v "maxLength") (Jstr.v "1")
                    ; value Jstr.empty
                    ]
                ()
            in
            input )
      in
      let events =
        List.mapi
          ~f:(fun i input ->
            Evr.on_el
              Ev.input
              (fun _ ->
                let value = El.prop El.Prop.value input in
                if Jstr.equal Jstr.empty value
                then (i, None)
                else
                  let validity = State.Wellplaced in
                  (i, Some (Jstr.uppercased value, validity)) )
              input )
          elements
      (* As the state is in a list, we have no way to be sure that the list
         length is the same as the number of elements… except to rely on the
         compiler contract.

         But this would cause nasty bug if we had a difference here.
      *)
      and init_prop = List.init ~len ~f:(fun _ -> None) in

      (* Replace the children in the element *)
      El.set_children
        container
        [ El.table
            [ (* The table has only one row *)
              El.tr
                (List.map elements ~f:(fun el ->
                     El.td [ (* Each cell is the input element *) el ] ) )
            ]
        ];

      let change =
        E.select events
        |> E.map (fun (position, value) acc ->
               List.mapi acc ~f:(fun i prop ->
                   if i <> position then prop else value ) )
      in
      let initial_proposition = S.accum init_prop change in

      initial_proposition )