let (|=>|) x (a, len) = x >= a && x <= a + len - 1
type Dir = H | V
let dirShift dir = if dir = H then (1, 0) else (0, 1)
let (|->) (x, y) (dx, dy) = (x + dx, y + dy)
let (*) (dx, dy) n = (dx * n, dy * n)
let len (s : string) = s.Length
let makeTuple a b = (a, b)

type Placeholder = { P : int * int; Dir : Dir; Len : int } with
    member p.IndexOf (x, y) =
        let (px, py) = p.P
        if p.Dir = H && y = py && x |=>| (px, p.Len) then Some (x - px)
        elif p.Dir = V && x = px && y |=>| (py, p.Len) then Some (y - py)
        else None
    member p.Cells =
        let shift = dirShift p.Dir
        [ for i in [0 .. p.Len - 1] -> p.P |-> (shift * i)]

let parsePlaceholders lines =
    let parseCells =
        Seq.mapi (fun y s ->
            s |> Seq.indexed |> Seq.filter (snd >> (=) '-')
            |> Seq.map (fun (x, _) -> (x, y)) 
        ) >> Seq.concat >> Set.ofSeq
    let cells = parseCells lines
    let rec extend p shift cells =
        let next = p |-> shift
        if Set.contains next <| cells then p :: extend next shift cells
        else [p]
    let dirPlaceholders dir cells =
        let shift = dirShift dir
        cells
        |> Set.fold
            (fun (chains, rest) cell ->
                match extend cell shift rest with
                | [_] -> (chains, rest)
                | chain -> (chain :: chains, Set.difference rest (Set.ofList chain)))
            ([], cells)
        |> fst |> List.map (fun chain ->
            { P = List.min chain; Dir = dir; Len = List.length chain })
    (dirPlaceholders H cells) @ (dirPlaceholders V cells)

type Joint = { H : Placeholder; V : Placeholder; Cell : int * int }

let solveCrossword placeholders words =
    let findJoints placeholders =
        List.allPairs placeholders placeholders
        |> List.filter (fun (a, b) -> a.P < b.P && a.Dir <> b.Dir)
        |> List.fold
            (fun joints (a, b) ->
                let (h, v) = if a.Dir = H then (a, b) else (b, a)
                let ((hX, hY), hLen) = (h.P, h.Len)
                let ((vX, vY), vLen) = (v.P, v.Len)
                if hY |=>| (vY, vLen) && vX |=>| (hX, hLen) 
                    then { H = h; V = v; Cell = (vX, hY)} :: joints
                    else joints)
            ([])
    let joints = findJoints placeholders
    let rec findDecision alreadyPlaced placeholders words =
        match placeholders with
        | [] -> Some alreadyPlaced
        | ph :: restPlaceholders -> 
            let fitJoints ph (w : string) =
                joints
                |> List.filter (fun j -> j.H = ph || j.V = ph)
                |> List.forall (fun j ->
                    let c = w.[(ph.IndexOf j.Cell).Value]
                    not (List.exists (fun (oPh : Placeholder, oW : string) -> 
                            match oPh.IndexOf j.Cell with
                            | None -> false
                            | Some i -> oW.[i] <> c)
                        alreadyPlaced))
            let validWords = words |> List.filter (fun w -> len w = ph.Len && fitJoints ph w)
            match validWords with
                | [] -> None
                | _ -> validWords
                    |> List.choose (fun w ->
                        let restWords = List.except [w] words
                        findDecision ((ph, w) :: alreadyPlaced) restPlaceholders restWords)
                    |> List.tryHead
    findDecision [] placeholders words