summaryrefslogtreecommitdiff
path: root/src/wall.ml
blob: fd3f69d91ed4733ca82028d3cee9593fad7513b6 (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
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


(* Programmed by Jedidiah Barber *)
(* Licensed under the Sunset License v1.0 *)


module type Algebra =
  sig
    type t
    val zero : t
    val one : t
    val add : t -> t -> t
    val sub : t -> t -> t
    val mul : t -> t -> t
    val div : t -> t -> t
    val to_string : t -> string
  end



module type S =
  sig
    type element
    type wall
    val empty : wall
    val create : dimx:int -> dimy:int -> init:element array -> wall
    val x_length : wall -> int
    val y_length : wall -> int
    val has_value : wall -> x:int -> y:int -> bool
    val get : wall -> x:int -> y:int -> element
    val get_opt : wall -> x:int -> y:int -> element option
    val last_nonzero_row : wall -> int
    val to_string : wall -> string
    val print : wall -> unit
    val output : Stdlib.out_channel -> wall -> unit
    val pp_print : Stdlib.Format.formatter -> wall -> unit
  end



let (let*?) = Option.bind



module Make (A : Algebra) =
  struct

    type element = A.t
    type wall = element option array array

    let x_length wall =
      Array.length wall

    let y_length wall =
      Array.length wall.(0)

    let has_value wall ~x ~y =
      if x >= 0 && x < x_length wall &&
         y >= 0 && y < y_length wall
      then
        match wall.(x).(y) with
            None -> false
          | Some _ -> true
      else
        false

    let get_opt wall ~x ~y =
      if x >= 0 && x < x_length wall &&
         y >= 0 && y < y_length wall
      then
        wall.(x).(y)
      else
        None



    let next_nonzero_up wall ~x ~y =
      let rec walker y1 =
        let*? v = get_opt wall ~x ~y:y1 in
        if v <> A.zero then Some y1 else walker (y1-1)
      in walker y

    let next_nonzero_left wall ~x ~y =
      let rec walker x1 =
        let*? v = get_opt wall ~x:x1 ~y in
        if v <> A.zero then Some x1 else walker (x1-1)
      in walker x

    let next_nonzero_right wall ~x ~y =
      let rec walker x1 =
        let*? v = get_opt wall ~x:x1 ~y in
        if v <> A.zero then Some x1 else walker (x1+1)
      in walker x



    let next_valid_left wall ~x ~y =
      let rec walker x1 =
        if x1 < 0 then
          None
        else
          if Option.is_some (get_opt wall ~x:x1 ~y) then
            Some x1
          else
            walker (x1-1) in
      walker x



    let safe_div a b =
      if b = A.zero then None else Some (A.div a b)

    let multi_mul items =
      let f a b = A.mul a b in
      List.fold_left f A.one items

    let square a =
      A.mul a a

    let rec power ~base ~num ~denom ~times =
      if times <= 0 then
        Some base
      else
        let*? new_base = safe_div (A.mul base num) denom in
        power ~base:new_base ~num ~denom ~times:(times-1)



    (* red x red + green x green = blue squared *)
    (* target to calculate is red on the bottom of the cross *)
    (* current cell x two up + one diag up left x one diag up right = one up squared *)
    let cross_rule wall ~x ~y =
      let*? green_left = get_opt wall ~x:(x-1) ~y:(y-1) in
      let*? green_right = get_opt wall ~x:(x+1) ~y:(y-1) in
      let*? blue = get_opt wall ~x ~y:(y-1) in
      let*? red_top = get_opt wall ~x ~y:(y-2) in
      safe_div (A.sub (square blue) (A.mul green_left green_right)) red_top



    (* outer yellow x inner yellow squared + outer blue x inner blue squared *)
    (* equals outer grey x inner grey squared + outer red x inner red squared *)
    (* inner yellow is up, outer yellow is down *)
    (* inner blue is down, outer blue is up *)
    (* inner grey is left, outer grey is right *)
    (* inner red is right, outer red is left *)
    (* target to calculate is outer yellow *)
    let long_cross_rule wall ~x ~y =
      let*? outer_red = get_opt wall ~x:(x-2) ~y:(y-2) in
      let*? inner_red = get_opt wall ~x:(x+1) ~y:(y-2) in
      let*? red_product = Some (A.mul outer_red (square inner_red)) in
      let*? outer_grey = get_opt wall ~x:(x+2) ~y:(y-2) in
      let*? inner_grey = get_opt wall ~x:(x-1) ~y:(y-2) in
      let*? grey_product = Some (A.mul outer_grey (square inner_grey)) in
      let*? grey_red_sum = Some (A.add grey_product red_product) in
      let*? outer_blue = if y - 4 = -1 then Some A.zero else get_opt wall ~x ~y:(y-4) in
      let*? inner_blue = get_opt wall ~x ~y:(y-1) in
      let*? blue_product = Some (A.mul outer_blue (square inner_blue)) in
      let*? greyred_blue_diff = Some (A.sub grey_red_sum blue_product) in
      let*? inner_yellow = get_opt wall ~x ~y:(y-3) in
      safe_div greyred_blue_diff (square inner_yellow)



    (* All blocks of zeros in the wall come in squares. *)
    let zero_window wall ~x ~y =
      let*? top = next_nonzero_up wall ~x ~y:(y-1) in
      let*? left = next_nonzero_left wall ~x ~y:(top+1) in
      let*? right = next_nonzero_right wall ~x ~y:(top+1) in
      if y - 1 > top && right - left > 0 &&
         right - left + 1 > y - 1 - top
      then
        Some A.zero
      else
        None



    (* denote ratio of top sequence from left to right as a/b *)
    (* denote ratio of bottom sequence from right to left as c/d *)
    (* denote ratio of left sequence from top to bottom as e/f *)
    (* denote ratio of right sequence from bottom to top as g/h *)
    (* denote rhs as s *)
    (* s is 1 when even sized window and -1 when odd sized window *)
    (* goal is to calculate c/d *)
    (* then *)
    (* ((a/b)(c/d))/((e/f)(g/h)) = s *)
    (* (a/b)(c/d) = s(e/f)(g/h) *)
    (* (a/b)(c/d) = (seg)/(fh) *)
    (* c/d = ((seg)/(fh))(b/a) *)
    (* c/d = (begs)/(afh) *)
    (* and since that ratio is going from right to left, invert to go left to right *)
    (* thus to transform bottom left corner number into next number... *)
    (* multiply by afh then divide by begs *)
    let horseshoe_rule wall ~x ~y =
      let*? top = next_nonzero_up wall ~x ~y:(y-1) in
      let*? left = next_nonzero_left wall ~x ~y:(top+1) in
      let*? right = next_nonzero_right wall ~x ~y:(top+1) in
      let*? _ = if y - top <> right - left || right - left <= 2 then None else Some 1 in
      let*? a = get_opt wall ~x:(left+1) ~y:top in
      let*? b = get_opt wall ~x:left     ~y:top in
      let*? e = get_opt wall ~x:left     ~y:(top+1) in
      let*? f = get_opt wall ~x:left     ~y:top in
      let*? g = get_opt wall ~x:right    ~y:top in
      let*? h = get_opt wall ~x:right    ~y:(top+1) in
      let*? s = if (right - left - 1) mod 2 = 0 then Some A.one else Some (A.sub A.zero A.one) in
      let*? prev = next_valid_left wall ~x ~y in
      power
        ~base:(Option.get wall.(prev).(y))
        ~num:(A.mul (A.mul a f) h)
        ~denom:(A.mul (A.mul (A.mul b e) g) s)
        ~times:(x - prev)



    (* denote ratio of top sequence from left to right as a/b *)
    (* denote ratio of bottom sequence from right to left as c/d *)
    (* denote ratio of left sequence from top to bottom as e/f *)
    (* denote ratio of right sequence from bottom to top as g/h *)
    (* denote sign of grey/red terms as s *)
    (* goal is to calculate outer yellow *)
    (* and also to put off division until the very end to ensure integer intermediate results *)
    (* then *)
    (* (e/f)(o_bl/i_bl) + s(a/b)(o_gr/i_gr) = (g/h)(o_ye/i_ye) + s(c/d)(o_re/i_re) *)
    (* (e/f)(o_bl/i_bl) + s(a/b)(o_gr/i_gr) - s(c/d)(o_re/i_re) = (g/h)(o_ye/i_ye) *)
    (* i_ye((e/f)(o_bl/i_bl) + s(a/b)(o_gr/i_gr) - s(c/d)(o_re/i_re)) = (g/h)o_ye *)
    (* o_ye = i_ye(h/g)((e/f)(o_bl/i_bl) + s(a/b)(o_gr/i_gr) - s(c/d)(o_re/i_re)) *)
    (* o_ye = i_ye(h/g)((e*o_bl)/(f*i_bl) + s(a*o_gr)/(b*i_gr) - s(c*o_re)/(d*i_re)) *)
    (* o_ye = h*i_ye*(e*o_bl*b*i_gr*d*i_re + s*a*o_gr*f*i_bl*d*i_re - s*c*o_re*f*i_bl*b*i_gr) / *)
    (*        (g*f*i_bl*b*i_gr*d*i_re) *)
    let broken_cross_rule wall ~x ~y =
      let*? top = next_nonzero_up wall ~x ~y:(y-2) in
      let*? left = next_nonzero_left wall ~x ~y:(top+1) in
      let*? right = next_nonzero_right wall ~x ~y:(top+1) in
      let*? bottom = Some (y - 1) in
      let*? _ = if bottom - top <> right - left || right - left <= 2 then None else Some 1 in
      let*? a = get_opt wall ~x:(left+1) ~y:top in
      let*? b = get_opt wall ~x:left     ~y:top in
      let*? c = get_opt wall ~x:left     ~y:bottom in
      let*? d = get_opt wall ~x:(left+1) ~y:bottom in
      let*? e = get_opt wall ~x:left     ~y:(top+1) in
      let*? f = get_opt wall ~x:left     ~y:top in
      let*? g = get_opt wall ~x:right    ~y:top in
      let*? h = get_opt wall ~x:right    ~y:(top+1) in
      let*? s = if (right - x) mod 2 = 0 then Some A.one else Some (A.sub A.zero A.one) in
      let*? inner_yellow = get_opt wall ~x                ~y:bottom in
      let*? inner_blue   = get_opt wall ~x:(right-x+left) ~y:top in
      let*? inner_red    = get_opt wall ~x:right          ~y:(bottom-right-x) in
      let*? inner_grey   = get_opt wall ~x:left           ~y:(right-x+top) in
      let*? outer_blue   = get_opt wall ~x:(right-x+left) ~y:(top-1) in
      let*? outer_red    = get_opt wall ~x:(right+1)      ~y:(bottom-right-x) in
      let*? outer_grey   = get_opt wall ~x:(left-1)       ~y:(right-x+top) in
      let*? term_1 = Some (multi_mul [   e; outer_blue; b; inner_grey; d; inner_red]) in
      let*? term_2 = Some (multi_mul [s; a; outer_grey; f; inner_blue; d; inner_red]) in
      let*? term_3 = Some (multi_mul [s; c; outer_red;  f; inner_blue; b; inner_grey]) in
      let*? term_sum = Some (A.sub (A.add term_1 term_2) term_3) in
      let*? numerator = Some (multi_mul [h; inner_yellow; term_sum]) in
      let*? denominator = Some (multi_mul [g; f; inner_blue; b; inner_grey; d; inner_red]) in
      safe_div numerator denominator



    let rec attempt_order wall ~x ~y funcs =
      if funcs = [] then
        None
      else
        let r = (List.hd funcs) wall ~x ~y in
        if Option.is_some r then
          r
        else
          attempt_order wall ~x ~y (List.tl funcs)

    let create ~dimx ~dimy ~init =
      let result = Array.make_matrix dimx dimy None in
      for i = 0 to dimx - 1 do
        result.(i).(0) <- Some A.one
      done;
      for i = 0 to min (dimx - 1) ((Array.length init) - 1) do
        result.(i).(1) <- Some init.(i)
      done;
      try
        for j = 2 to dimy - 1 do
          let do_exit = ref true in
          for i = 0 to dimx - 1 do
            let v = attempt_order result ~x:i ~y:j
              [cross_rule; long_cross_rule; zero_window; horseshoe_rule; broken_cross_rule] in
            result.(i).(j) <- v;
            if Option.is_some v &&
               Option.get v <> A.zero
            then
              do_exit := false
          done;
          if !do_exit then raise Exit
        done;
        result
      with Exit ->
        result

    (* The empty wall isn't truly empty because every wall has *)
    (* a row of ones at the very top, regardless of the input sequence. *)
    let empty =
      Array.make_matrix 1 1 (Some A.one)



    let get wall ~x ~y =
      if x >= 0 && x < x_length wall &&
         y >= 0 && y < y_length wall
      then
        match wall.(x).(y) with
            None -> raise Not_found
          | Some v -> v
      else
        raise Not_found

    let last_nonzero_row wall =
      let rec checker x y =
        if wall.(x).(y) <> Some A.zero &&
           wall.(x).(y) <> None
        then
         (if y + 1 = y_length wall then y else checker 0 (y + 1))
        else
         (if x + 1 = x_length wall then y - 1 else checker (x + 1) y)
      in checker 0 0



    let row_string wall ~y =
      let result = ref "" in
      for i = 0 to (x_length wall) - 2 do
        let v = wall.(i).(y) in
        if Option.is_some v then
          result := !result ^ (A.to_string (Option.get v)) ^ ","
        else
          result := !result ^ ","
      done;
      let v = wall.(x_length wall - 1).(y) in
      if Option.is_some v then
        result := !result ^ (A.to_string (Option.get v));
      !result

    let to_string wall =
      let result = ref "" in
      for j = 0 to (y_length wall) - 1 do
        result := !result ^ (row_string wall ~y:j) ^ (String.make 1 (char_of_int 10))
      done;
      !result

    let print wall =
      print_string (to_string wall)

    let output channel wall =
      output_string channel (to_string wall)

    let pp_print format wall =
      for j = 0 to (y_length wall) - 1 do
        Format.pp_print_string format (row_string wall ~y:j);
        Format.pp_print_break format 8 0
      done

  end