We use cookies to ensure you have the best browsing experience on our website. Please read our cookie policy for more information about how we use cookies.
  1. Prepare
  2. Functional Programming
  3. Recursion
  4. Crosswords-101
  5. Discussions

Crosswords-101

Sort by

recency

|

20 Discussions

|

  • apramesh2014
     + 0 comments
    import Data.Array
import Data.List (sort)


getWord :: String -> (Int, String)
getWord ('-':cs) = (l+1, remainingCS)
 where (l, remainingCS) = getWord cs
getWord (_:cs) = (1, cs)
getWord "" = (1, "")

wordsInLine :: Int -> String -> [(Int, Int)]
wordsInLine _ "" = []
wordsInLine pos ('+':cs) = wordsInLine (pos+1) cs
wordsInLine pos ('-':cs) = if firstWordLength > 1 then (pos, firstWordLength):otherWords else otherWords
 where (firstWordLength, remainingCS) = getWord cs
       otherWords = wordsInLine (pos+firstWordLength+1) remainingCS

addY :: Int -> (Int, Int) -> (Int, Int, Int)
addY y (x, l) = (x, y, l)

wordsInLineWithY :: Int -> String -> [(Int, Int, Int)]
wordsInLineWithY y line = map (addY y) (wordsInLine 0 line)

addX :: Int -> (Int, Int) -> (Int, Int, Int)
addX x (y, l) = (x, y, l)

wordsInLineWithX :: Int -> String -> [(Int, Int, Int)]
wordsInLineWithX x line = map (addX x) (wordsInLine 0 line)

horizontalWords :: Int -> [String] -> [(Int, Int, Int)]
horizontalWords _ [] = []
horizontalWords y (line:lines) = (wordsInLineWithY y line) ++ (horizontalWords (y+1) lines)

verticalWords :: Int -> [String] -> [(Int, Int, Int)]
verticalWords _ ([]:_) = []
verticalWords x linesIn = (wordsInLineWithX x line) ++ (verticalWords (x+1) lines)
 where line = map head linesIn
       lines = map tail linesIn


letterLocations :: (Int,Int) -> Int -> Int -> Int -> [Int]
letterLocations dir x y 0 = []
letterLocations dir@(dirX,dirY) x y l = (y*10+x):(letterLocations dir (x+dirX) (y+dirY) (l-1))

allLetterLocations :: (Int,Int) -> Int -> [(Int, Int, Int)] -> [(Int, (Int, Int))]
allLetterLocations _ _ [] = []
allLetterLocations dir i ((x,y,l):ws) = wordLocsWithWordIndex ++ (allLetterLocations dir (i+1) ws)
 where wordLocs = zip (letterLocations dir x y l) [0..]
       f (arrayI, pos) = (arrayI, (i, pos))
       wordLocsWithWordIndex = map f wordLocs

mixInEmpty :: Int -> Int -> [(Int, (Int, Int))] -> [(Int, (Int, Int))]
mixInEmpty i endI _ | i == endI = []
mixInEmpty i endI [] = (i,((-1),0)):(mixInEmpty (i+1) endI [])
mixInEmpty i endI allE@((k,v):es) | k == i = (k,v):(mixInEmpty (i+1) endI es)
                             | otherwise = (i,((-1),0)):(mixInEmpty (i+1) endI allE)

intersectLookup :: [(Int, Int, Int)] -> Array Int (Int, Int)
intersectLookup words = array (0,99) (mixInEmpty 0 100 (allLetterLocations (1,0) 0 words))

addToFront :: [a] -> Int -> a -> [a]
addToFront l 0 _ = l
addToFront l n e = e:(addToFront l (n-1) e)

refsForWord :: Array Int (Int, Int) -> Int -> [Int] -> [(Int, Int, Int)]
refsForWord _ _ [] = []
refsForWord lookup i (arrayI:vs) = if w == (-1) then rest else (i,w,c):rest
 where (w, c) = lookup!arrayI
       rest = refsForWord lookup (i+1) vs

refs :: Array Int (Int, Int) -> [(Int, Int, Int)] -> [[(Int, Int, Int)]]
refs _ [] = []
refs lookup ((x,y,l):vs) = lookupForThis:lookupForRest
 where locs = letterLocations (0,1) x y l
       lookupForThis = refsForWord lookup 0 locs
       lookupForRest = refs lookup vs

getIntersects :: [(Int, Int, Int)] -> [(Int, Int, Int)] -> [[(Int, Int, Int)]]
getIntersects hs vs = addToFront vrefs (length hs) []
 where lookup = intersectLookup hs
       vrefs = refs lookup vs


intersectsOK :: [(Int, Int, Int)] -> String -> [String] -> Bool
intersectsOK [] _ _ = True
intersectsOK ((charInThis,wordRef,charInWord):intersects) word resultSoFar =
    if resultSoFar!!wordRef!!charInWord  == word!!charInThis
    then intersectsOK intersects word resultSoFar
    else False

wordPossibilities :: Int -> [(Int, Int, Int)] -> [String] -> [String] -> [String] -> [([String], String)]
wordPossibilities _ _ [] _ _ = []
wordPossibilities l intersects (word:wordsLeft) otherWordsLeft resultSoFar =
        if length(word) == l && intersectsOK intersects word resultSoFar
        then (otherWordsLeft++wordsLeft,word):otherPossibilities
        else otherPossibilities
 where otherPossibilities = wordPossibilities l intersects wordsLeft (word:otherWordsLeft) resultSoFar

firstSolution :: [Int] -> [[(Int, Int, Int)]] -> [String] -> [([String], String)] -> [String]
firstSolution _ _ _ [] = []
firstSolution ls intersects resultSoFar ((wordsLeft,word):ps) =
  if solution == [] then firstSolution ls intersects resultSoFar ps else solution
 where solution = solve' ls intersects wordsLeft (resultSoFar++[word])

solve' :: [Int] -> [[(Int, Int, Int)]] -> [String] -> [String] -> [String]
solve' [] _ _ resultSoFar = resultSoFar
solve' (l:ls) (intersect:intersects) words resultSoFar =
  firstSolution ls intersects resultSoFar ps
 where ps = wordPossibilities l intersect words [] resultSoFar

solve :: [Int] -> [[(Int, Int, Int)]] -> [String] -> [String]
solve wordLengths intersects words = solve' wordLengths intersects words []



renderChars :: [(Int,Int)] -> [(Int, Int, Int)] -> [String] -> [(Int, Char)]
renderChars _ [] _ = []
renderChars (dir:dirs) ((x,y,l):spaces) (word:words) = forWord ++ rest
 where locs = letterLocations dir x y l
       forWord = zip locs word
       rest = renderChars dirs spaces words

renderLine :: Int -> Int -> [(Int, Char)] -> String
renderLine i endI cs | i == endI = ""
renderLine i endI [] = '+':(renderLine (i+1) endI [])
renderLine i endI allCS@((ci,c):cs) | ci < i = renderLine i endI cs
                                    | ci == i = c:(renderLine (i+1) endI cs)
                                    | otherwise = '+':(renderLine (i+1) endI allCS)

renderLines :: Int -> [(Int, Char)] -> [String]
renderLines 100 _ = []
renderLines startI cs = (renderLine startI endI cs):(renderLines endI cs)
 where endI = startI + 10

render :: [(Int,Int)] -> [(Int, Int, Int)] -> [String] -> [String]
render dirs spaces words = renderLines 0 cs
 where cs = sort $ renderChars dirs spaces words

wordsWhen :: (Char -> Bool) -> String -> [String]
wordsWhen p s =  case dropWhile p s of
                      "" -> []
                      s' -> w : wordsWhen p s''
                            where (w, s'') = break p s'

doit strIn = unlines resultLines
 where ls = lines strIn
       templateLines = take 10 ls
       [wordsToFitLine] = drop 10 ls
       wordsToFit = wordsWhen (==';') wordsToFitLine
       hs = horizontalWords 0 templateLines
       vs = verticalWords 0 templateLines
       intersects = getIntersects hs vs
       extractL (_,_,l) = l
       lengths = (map extractL hs) ++ (map extractL vs)
       solution = solve lengths intersects wordsToFit
       takeN n a = take n $ repeat a
       dirs = (takeN (length hs) (1,0)) ++ (takeN (length vs) (0,1))
       resultLines = render dirs (hs++vs) solution

main = interact doit

    pls follow me and use this code with haskell

  • iamhere2
     + 0 comments

    Such a brilliant puzzle! I like that kind. My solution with F# is not concise at all. Full text is about 100 lines. Here is the heart without I/O:

    Parsing placeholders:

    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)

    Finding a solution (just a consequent recoursive "trying" of each word for each next placeholder with checking letters in "joint" points):

    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

  • iamhere2
     + 0 comments

    Such a brilliant puzzle! I like that kind. My solution with F# is not concise at all. Full text is about 108 lines. Here is the heart without I/O:

    Parsing placeholders:

    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)

    Finding a solution (just a consequent recoursive "trying" of each word for each next placeholder with checking letters in "joint" points):

    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

  • ams200140
     + 0 comments

    Nice problem for list-monad in Haskell

  • rre0520
     + 0 comments

    Wow I actually did it!

    How my algorithm works: Try putting the word at the front of your list in the board at all possible positions. (No, actually. i <- [0..9]; j <- [0..9]) For each successful placement, continue with the rest of the list of words. I ended up using do notation on lists and maybeToListing some information.

    I'm super proud of it! On the other hand, I'm really glad we don't have hacking on ... uh, on HackerRank ... unlike some other platforms, like CodeForces ... hm.

    Here it is! Sorry for the hiding, I'm lazier than Haskell.