rlm@0: (ns coderloop.find-words
rlm@0:   (:use [clojure.contrib def
rlm@0: 	 [seq :only [indexed]]
rlm@0: 	 [duck-streams :only [read-lines file-str]]]
rlm@0: 	[clojure.java io]
rlm@0: 	[rlm shell-inspect]))
rlm@0: 
rlm@0: 
rlm@0: 
rlm@0: "I'm going to solve this using convolution because I like how the kernel
rlm@0:  looks for this problem.  For each word, we build up an asterisk kernel
rlm@0:  like so:
rlm@0: 
rlm@0:  {:word \"Robert\"}
rlm@0:  kernel:
rlm@0: 
rlm@0:               t    t    t
rlm@0:                r   r   r
rlm@0:                 e  e  e
rlm@0:                  b b b
rlm@0:                   ooo 
rlm@0:               treboRobert       
rlm@0:                   ooo           
rlm@0:                  b b b          
rlm@0:                 e  e  e         
rlm@0:                r   r   r   
rlm@0:               t    t    t
rlm@0: 
rlm@0: isn't it really cute-looking?
rlm@0: 
rlm@0: Anyways,  I'll drag these asterisks along the word-matrix via convolution
rlm@0: and use them to build up a transient structure that contains only the matches.
rlm@0: 
rlm@0: Then, I'll use that transitnt structure to remove all matches from the original
rlm@0: grid.
rlm@0: 
rlm@0: I need stuff to do convolutions, to make kernels given a word, to create the
rlm@0: transient structure, and to remove the entries in the transient structure
rlm@0: from the original word-grid.  I also need a way to represent a word grid."
rlm@0: 
rlm@0: (defvar strcat (partial apply str)
rlm@0:   "flattens a list by glomming everything together in a string.")
rlm@0: 
rlm@0: (defn word-grid
rlm@0:   "create a mapping from elements in R^2 to chars"
rlm@0:   [words]
rlm@0:   (reduce
rlm@0:    merge
rlm@0:    (map (fn [[idx s]]
rlm@0: 	  (zipmap 
rlm@0: 	   (map #(vector (first %) idx) (indexed s))
rlm@0: 	   (seq s)))
rlm@0: 	(indexed words))))
rlm@0: 
rlm@0: 
rlm@0: (defn bounding-square
rlm@0:   "finds the minimal square it takes to bound the grid. works for all
rlm@0:    geometries."
rlm@0:   [grid]
rlm@0:   (let [coords (keys grid)
rlm@0: 	xs (sort (map first coords))
rlm@0: 	ys (sort (map second coords))]
rlm@0:     [(first xs) (last xs) (first ys) (last ys)]))
rlm@0: 
rlm@0: ;;I have no compunctinos with using mutable state in printing
rlm@0: (defn print-grid* [grid]
rlm@0:   (let [[x-min x-max y-min y-max] (bounding-square grid)
rlm@0: 	canvas (atom
rlm@0: 		(vec  (for [y  (range  (inc (- y-max y-min)))]
rlm@0: 			(vec  (repeat (inc (- x-max x-min))  ".")))))]
rlm@0:     (dorun (map (fn [[[x y] c]]
rlm@0: 		  (swap! canvas #(assoc-in % [ (- y y-min) (- x x-min)] c))) grid))
rlm@0:     @canvas))
rlm@0: 	
rlm@0: (defn print-grid
rlm@0:   "nice for debugging but irrelevant for the rest of the problem"
rlm@0:   [grid]
rlm@0:   (dorun
rlm@0:    (for [line (print-grid* grid)]
rlm@0:      (do (dorun (map print line))
rlm@0: 	 (println)))))
rlm@0: 
rlm@0: (defn asterisk-kernel [word]
rlm@0:   (let [span (range (inc (count word)))]
rlm@0:     (vector
rlm@0:      (zipmap (map #(vector 0 %)     span) word)
rlm@0:      (zipmap (map #(vector 0 (- %)) span) word)
rlm@0:      (zipmap (map #(vector % %)     span) word)
rlm@0:      (zipmap (map #(vector % (- %)) span) word)
rlm@0:      (zipmap (map #(vector % 0)     span) word)
rlm@0:      (zipmap (map #(vector (- %) 0) span) word)
rlm@0:      (zipmap (map #(vector (- %) %)     span) word)
rlm@0:      (zipmap (map #(vector (- %)  (- %))     span) word))))
rlm@0: 
rlm@0: ;;this is not lazy :(
rlm@0: (defn search-grid-at-point [kernel grid [point-x point-y]]
rlm@0:   (let [shift-kernel
rlm@0: 	(zipmap 
rlm@0: 	 (map (fn [[x y]]
rlm@0: 		[(+ x point-x)
rlm@0: 		 (+ y point-y)])
rlm@0: 	      (keys kernel))
rlm@0: 	 (vals kernel))]
rlm@0:     (if (= (select-keys grid (keys shift-kernel))
rlm@0: 	   shift-kernel)
rlm@0:       shift-kernel nil)))
rlm@0:     
rlm@0: (defn search-word-kernel
rlm@0:   "search the grid for a particular kernel and store the reusult in the
rlm@0:    atom (matches)"
rlm@0:   [grid kernel]
rlm@0:   (reduce merge (map (fn [point]
rlm@0: 		       (search-grid-at-point kernel grid point))
rlm@0: 		     (keys grid))))
rlm@0: 
rlm@0: (defn search-word [grid word]
rlm@0:   (let [kernels (asterisk-kernel word)]
rlm@0:     (reduce merge (map #(search-word-kernel grid %) kernels))))
rlm@0: 
rlm@0: (defn search-words [grid words]
rlm@0:   (reduce merge (map #(search-word grid %) words)))
rlm@0: 
rlm@0: (defn remove-matches [grid matches]
rlm@0:   (apply (partial dissoc grid) (keys matches)))
rlm@0: 
rlm@0: (defn grid->str [grid]
rlm@0:   (strcat (vals (apply sorted-map
rlm@0: 		       (interleave (map (comp vec reverse) (keys grid)) (vals grid))))))
rlm@0: 
rlm@0: (defn read-wordsearch [#^java.io.File input]
rlm@0:   (let [[crossword words] (split-with (comp not (partial = "")) (read-lines input)) 
rlm@0: 	words (rest words)]
rlm@0:     [crossword words]))
rlm@0: 
rlm@0: (defn process-wordsearch [[crossword words]]
rlm@0:   (let [grid (word-grid crossword)]
rlm@0:     (grid->str (remove-matches grid (search-words grid words)))))
rlm@0: 
rlm@0: (defn doit [args]
rlm@0:   (println
rlm@0:    (process-wordsearch
rlm@0:     (read-wordsearch
rlm@0:      (file-str (first args))))))
rlm@0: 
rlm@0: ;;********************************************************************************
rlm@0: (if (command-line?)
rlm@0:   (doit *command-line-args*))
rlm@0: 
rlm@0: 
rlm@0: (def input (file-str "/home/r/coderloop-test/input.txt"))
rlm@0: (def a (file-str "/home/r/coderloop-test/findwords-a.in"))
rlm@0: (def d (file-str "/home/r/coderloop-test/findwords-d.in"))
rlm@0: (def c (file-str "/home/r/coderloop-test/findwords-c.in"))
rlm@0: (def e (file-str "/home/r/coderloop-test/findwords-e.in"))
rlm@0: 
rlm@0: (def test-grid
rlm@0:       ["ELGOOGWWW"
rlm@0:        "TIRXMAHIR"
rlm@0:        "BATMANZNC"
rlm@0:        "CMRVLTOLD"])
rlm@0: 
rlm@0: (def test-words
rlm@0:      ["MAIL"
rlm@0:       "WIN"
rlm@0:       "GOOGLE"
rlm@0:       "TAR"
rlm@0:       "BATMAN"
rlm@0:       "CAR"
rlm@0:       "WWW"
rlm@0:       "TOLD"
rlm@0:       "CD"])
rlm@0: 
rlm@0: 
rlm@0: