Solver for a Sokoban like game

core.clj

(ns sokoban.core
  (:require [clojure.data.priority-map :refer [priority-map-keyfn-by]]))

(def test-plan "########\n#@  # a#\n# A #  #\n#      #\n#      #\n########")
(def test-tricky "#######\n##bac #\n#@A   #\n###BC #\n###   #\n#######")

(def barrels (set "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
(def targets (set "abcdefghijklmnopqrstuvwxyz"))
(def player \@)
(def wall \#)
(def space \space)

(def valid-directions #{:up :down :left :right})

(defn valid-position?
  [pos]
  (and
   (seq pos)
   (= 2 (count pos))
   (every? #(instance? Number %) pos)))

(defn valid-chart?
  [chart]
  (and
   (seq chart)
   (every? seq chart)))

(defn has-keys? [m keys]
  (apply = (map count [keys (select-keys m keys)])))

(defn valid-game?
  [game]
  (and
   (has-keys? game [:width :height :player-pos :chart])
   (instance? Number (:width game))
   (instance? Number (:height game))
   (valid-position? (:player-pos game))
   (valid-chart? (:chart game))))

(defn contents-order
  [{l :element} {r :element}]
  (let [ordering {:wall 10
                  :player 9
                  :barrel 8
                  :target 7
                  :space 0}]
    (> (ordering l) (ordering r))))

(defn render-contents
  [contents]
  {:pre [(set? contents)]
   :post [(instance? Character %)]}

  (letfn [(render [{:keys [element value]}] (condp = element
                                              :wall \#
                                              :player \@
                                              :space \space
                                              :barrel (Character/toUpperCase value)
                                              :target value
                                              \space))]

    (render (first (apply sorted-set-by contents-order contents)))))

(defn show-game
  [game]
  {:pre [(valid-game? game)]}
  (->> (:chart game)
       (map #(map render-contents %))
       (map #(apply str %))
       (clojure.string/join "\n")))

(defn get-in-cell-by-type
  [cell e-type]
  {:pre [(set? cell)]
   :post [(or (map? %) (nil? %))]}
  (first (clojure.set/select #(= (:element %) e-type) cell)))

(defn map-chart
  [f chart]
  (for [row chart]
    (for [element row] (f element))))

(defn map-indexed-chart
  [f chart]
  (let [col-f (fn [y x e] (f x y e))
        row-f (fn [y row] (map-indexed (partial col-f y) row))]
       (map-indexed row-f chart)))

(defn update-in-chart
  [chart pos f & args]
  {:pre [(seq chart)
         (valid-position? pos)]
   :post [(valid-chart? %)]}
  (let [[x y] pos
        col-update (fn [index e] (if (= index x) (apply f e args) e))
        row-update (fn [index row] (if (= index y) (map-indexed col-update row) row))]
    (map-indexed row-update chart)))

(defn find-player-position
  [chart]
  {:pre [(seq chart)]
   :post [(valid-position? %)]}
  (let [positions (map-chart #(get-in-cell-by-type % :player) chart)
        not-nil-index #(first (keep-indexed (fn [i v] (if v i)) %))
        y-pos (not-nil-index (map #(some (comp not nil?) %) positions))
        x-pos (not-nil-index (first (drop y-pos positions)))]
    [x-pos y-pos]))

(defn move-position
  [position direction]
  {:pre [(valid-directions direction)
         (valid-position? position)]
   :post [(valid-position? %)]}

  (let [movement {:up [0 -1]
                  :down [0 1]
                  :left [-1 0]
                  :right [1 0]}]
    (map + (movement direction) position)))

(defn get-game-at
  [game position]

  {:pre [(valid-game? game)
         (valid-position? position)]
   :post [(set? %)]}

  (let [chart (:chart game)
        [x y] position]

    (first (drop x (first (drop y chart))))))

(defn can-enter?
  [game position]
  {:pre [(valid-game? game)
         (valid-position? position)]
   :post [(instance? Boolean %)]}

  (let [elements (get-game-at game position)]
    (not (or (get-in-cell-by-type elements :wall)
             (get-in-cell-by-type elements :barrel)))))

(defn can-move?
  [game direction]
  {:pre [(valid-directions direction)
         (valid-game? game)]
   :post [(instance? Boolean %)]}

  (let [new-position (move-position (:player-pos game) direction)
        element (get-game-at game new-position)]
    (or (can-enter? game new-position)
        (and (not (nil? (get-in-cell-by-type element :barrel)))
             (can-enter? game (move-position new-position direction))))))

(defn move-thing
  [game thing pos direction]
  {:pre [(valid-game? game)
         (valid-directions direction)
         (#{:player :barrel} thing)
         (valid-position? pos)]
   :post [(valid-game? %)]}
  (if-let [element (get-in-cell-by-type (get-game-at game pos) thing)]
    (let [new-pos (move-position pos direction)]
      (assoc
          game :chart
          (->
           (:chart game)
           (update-in-chart pos (fn [e] (set (remove #(= element %) e))))
           (update-in-chart new-pos (fn [e] (conj e element))))))
    game))

(defn move
  [game direction]
  {:pre [(valid-game? game)
         (valid-directions direction)]
   :post [(valid-game? %)]}
  (if (can-move? game direction)

    (let [new-player-pos (move-position (:player-pos game) direction)]
      (-> game
          (move-thing :player (:player-pos game) direction)
          (move-thing :barrel new-player-pos direction)
          (assoc :player-pos new-player-pos)
          (assoc :moves (conj (:moves game) direction))))
    game))

(defn tokenise
  [c]
  {:pre [(instance? Character c)]}
  (condp contains? c
    #{wall} #{{:element :wall}}
    #{space} #{}
    #{player} #{{:element :player}}
    barrels #{{:element :barrel :value (Character/toLowerCase c)}}
    targets #{{:element :target :value c}}))

(defn parse
  [floor-plan-description]
  (let [lines (clojure.string/split-lines floor-plan-description)
        chart (map #(map tokenise %) lines)
        width (apply max (map count chart))
        height (count chart)
        player-position (find-player-position chart)]
    {:chart chart
     :width width
     :height height
     :player-pos player-position
     :moves ()}))

(defn move-sequence
  [game directions]
  (if (seq directions)
    (recur (move game (first directions)) (rest directions))
    game))

(defn get-barrels
  [game]
  (let [barrel-positions (map-indexed-chart
                           (fn [x y cell] (when-let [barrel (get-in-cell-by-type cell :barrel)] [x y (:value barrel)]))
                           (:chart game))]
    (into {} (map (fn [[x y e]] [e [x y]]) (remove nil? (apply concat barrel-positions))))))

(defn get-targets
  [game]
  (let [barrel-positions (map-indexed-chart
                           (fn [x y cell] (when-let [barrel (get-in-cell-by-type cell :target)] [x y (:value barrel)]))
                           (:chart game))]
    (into {} (map (fn [[x y e]] [e [x y]]) (remove nil? (apply concat barrel-positions))))))

(defn solved?
  [game]
  (= (get-barrels game) (get-targets game)))

(def print-game (comp println show-game))

(defn abs [n] (if (neg? n) (- n) n))

(defn q
  "Calculate estimate for distance from game to terminal condition."
  [game]
  (if (solved? game)
    0
    (let [barrels (get-barrels game)
          targets (get-targets game)
          manhattan (fn [[x1 y1] [x2 y2]] (+ (abs (- x1 x2)) (abs (- y1 y2))))]
      (reduce
       (fn [v [_ c]] (+ v c))
       0
       (merge-with manhattan barrels targets)))))

(def f (comp count :moves))

(defn a*-cost [game] (+ (f game) (q game)))

(defn solve*
  [games seen]

  (when-let [[game _] (first games)]
    (if (solved? game)
      game
      (let [valid-moves (filter (partial can-move? game) [:up :down :left :right])
            next-states (map #(move game %) valid-moves)
            unseen      (remove (fn [game] (seen (:chart game))) next-states)]
        (recur
         (into
          (pop games)
          (map (fn [g] [g g]) unseen))
         (into seen (map :chart unseen)))))))

(defn solve
  [game]
  (solve*
   (priority-map-keyfn-by a*-cost < game game)
   #{}))