1  import "trilogy:io" use readall
 2  import "trilogy:debug" use dbg
 3  import "trilogy:bits" as bits use pop_count, concat
 4  import "trilogy:parsec" as p use parse, run_parser, apply, followed_by, string, integer, char_of, per_line, many_1, sep_by, char
 5  import "trilogy:array" use length, filter, flatten, reduce, zip, map, rotate_cw, collect
 6  import "trilogy:string" use split, chomp
 7  import "trilogy:iterator" as it
 8  
 9  proc point!() {
10    return '#' == apply <| char_of "#."
11  }
12  
13  proc present!() {
14    apply <| followed_by (string ":\n") integer
15    return apply <| per_line <| many_1 point
16  }
17  
18  proc tree!() {
19    let w = apply integer
20    apply <| char 'x'
21    let h = apply integer
22    apply <| string ": "
23    let req = apply <| sep_by (char ' ') integer
24    return w:h:req
25  }
26  
27  func id x = x
28  
29  func area present = flatten present |> filter id |> length
30  
31  func spread _ [bb] = bb
32  func spread width [bb, ..rest] = bb | (spread width rest ~~> width)
33  func expand size bb = bb | bits::init_zero size
34  
35  func possible areas w:h:requirements =
36    let total = areas
37    |> zip requirements
38    |> map (fn a:r. a * r)
39    |> reduce (+),
40    total <= w * h
41  
42  func trivial w:h:requirements =
43    let total = requirements
44    |> map ((*) 9)
45    |> reduce (+),
46    total <= w * h 
47  
48  func rotations arr =
49    let brr = rotate_cw arr,
50    let crr = rotate_cw brr,
51    let drr = rotate_cw crr,
52    [arr, brr, crr, drr]
53  
54  func place_all _ _ _ [] = true
55  func place_all w h state [present, ..rest] =
56    it::range 0 (h - 3)
57    |> it::map ((*) w)
58    |> it::flat_map (fn y. it::range 0 (w - 3) |> it::map ((+) y))
59    |> it::flat_map (fn offset. it::from present |> it::map (fn p. p ~> offset))
60    |> it::filter (fn p. pop_count (state & p) == 0)
61    |> it::map ((|) state)
62    |> it::any (fn st. place_all w h st rest)
63  
64  func solve presents w:h:requirements =
65    presents
66    |> map (rotations >> map (map (bits::from_array) >> spread w >> expand (w * h)))
67    |> zip requirements
68    |> it::from
69    |> it::flat_map (fn n:arr. it::repeat n arr)
70    |> collect
71    |> place_all w h (bits::init_zero <| w * h)
72  
73  proc main!() {
74    let presents:rest = run_parser (per_line present) <| chomp readall!()
75    rest
76    |> split "\n"
77    |> it::from
78    |> it::map (parse tree)
79    |> it::filter (possible <| map area presents)
80    |> it::filter (fn tree. trivial tree || solve presents tree)
81    |> it::count
82    |> dbg
83  }