我正在努力阅读人工智能：一种现代方法，以减轻我天生的愚蠢。在尝试解决一些练习时，我遇到了“谁拥有斑马”问题，即第 5 章中的练习 5.13。这曾经是SO 上的一个话题，但回复主要针对的是“如果可以自由选择可用的问题解决软件，你将如何解决这个问题？”

我接受 Prolog 是一种非常适合解决此类问题的编程语言，并且有一些不错的软件包可用，例如 Python 中的，如排名最高的答案所示，以及独立的。唉，这些都无法帮助我按照书中所述的方式“坚持下去”。

这本书似乎建议构建一组双重或全局约束，然后实现一些提到的算法来找到解决方案。我在提出一套适合建模问题的约束条件时遇到了很多麻烦。我正在自学，因此无法获得教授或助教的帮助来克服困难 – 这就是我寻求你们帮助的地方。

我发现它与本章中的示例几乎没有相似之处。

我渴望构建双重约束，并首先创建（逻辑等价于）25 个变量：nationality1、nationality2、nationality3、… nationality5、pet1、pet2、pet3、… pet5、drink1 … drink5 等等，其中数字表示房屋的位置。

这对于构建一元约束很好，例如：

挪威人住在第一栋房子里：

nationality1 = { :norway }.

但是，大多数约束是通过一个共同的房屋编号将两个这样的变量组合在一起，例如：

瑞典人养了一只狗：

nationality[n] = { :sweden } AND pet[n] = { :dog }

其中 n 的范围显然可以从 1 到 5。或者用另一种方式表示：

    nationality1 = { :sweden } AND pet1 = { :dog } 
XOR nationality2 = { :sweden } AND pet2 = { :dog } 
XOR nationality3 = { :sweden } AND pet3 = { :dog } 
XOR nationality4 = { :sweden } AND pet4 = { :dog } 
XOR nationality5 = { :sweden } AND pet5 = { :dog } 

…这与书中提倡的“元组列表”的感觉截然不同：

( X1, X2, X3 = { val1, val2, val3 }, { val4, val5, val6 }, ... )

我不是在寻找解决方案本身；我正在寻找一种以与本书方法兼容的方式对这个问题进行建模的起点。 任何帮助将不胜感激。

回答：

感谢大家的有益信息！

我在交通堵塞中突然得到了我真正需要的提示。我需要做的是将房屋分配给域的元素，而不是将国籍、宠物等分配给房屋（变量名为 country1、country2、pet1、pet2）！ 示例：

(9) norway = 1        ; 一元约束：挪威人住在第一栋房子里
(2) britain = dog     ; 二元约束：狗和英国人在同一栋房子里
(4) green - ivory = 1 ; 相对位置

这让我能够为我的约束找到简单的公式，例如：

(def constraints
  #{
   [:con-eq :england :red]
   [:con-eq :spain :dog]
   [:abs-pos :norway 1]
   [:con-eq :kools :yellow]
   [:next-to :chesterfields :fox]
   [:next-to :norway :blue]
   [:con-eq :winston :snails]
   [:con-eq :lucky :oj]
   [:con-eq :ukraine :tea]
   [:con-eq :japan :parliaments]
   [:next-to :kools :horse]
   [:con-eq :coffee :green]
   [:right-of :green :ivory]
   [:abs-pos :milk 3]
   })

我还没有完成（只是兼职处理这件事），但我会在解决后发布完整的解决方案。

更新：大约 2 周后，我想出了一个用 Clojure 编写的有效解决方案：

(ns houses
  [:use [htmllog] clojure.set]  
  )

(comment
  [ 1] 英国人住在红色的房子里。
  [ 2] 西班牙人养狗。
  [ 3] 挪威人住在最左边的第一栋房子里。
  [ 4] Kools 牌香烟在黄色的房子里抽。
  [ 5] 抽 Chesterfields 牌香烟的人住在养狐狸的人的隔壁。
  [ 6] 挪威人住在蓝色房子的隔壁。
  [ 7] Winston 牌香烟的吸烟者养蜗牛。
  [ 8] Lucky Strike 牌香烟的吸烟者喝橙汁。
  [ 9] 乌克兰人喝茶。
  [10] 日本人抽 Parliaments 牌香烟。
  [11] Kools 牌香烟在养马的房子的隔壁抽。
  [12] 咖啡在绿色的房子里喝。
  [13] 绿色的房子就在象牙色房子的右边（你的右边）。
  [14] 牛奶在中间的房子里喝。

  “斑马住在哪里，他们在哪栋房子里喝水？”
)

(def positions #{1 2 3 4 5})

(def categories {
          :country #{:england :spain :norway :ukraine :japan}
          :color #{:red :yellow :blue :green :ivory}
          :pet #{:dog :fox :snails :horse :zebra}
          :smoke #{:chesterfield :winston :lucky :parliament :kool}
          :drink #{:orange-juice :tea :coffee :milk :water}
})

(def constraints #{
                    ; -- unary
          '(at :norway 1) ; 3
          '(at :milk 3) ; 14
                    ; -- simple binary
          '(coloc :england :red) ; 1
          '(coloc :spain :dog) ; 2
          '(coloc :kool :yellow) ; 4
          '(coloc :winston :snails) ; 7
          '(coloc :lucky :orange-juice) ; 8
          '(coloc :ukraine :tea) ; 9
          '(coloc :japan :parliament) ; 10
          '(coloc :coffee :green) ; 12
                    ; -- interesting binary
          '(next-to :chesterfield :fox) ; 5
          '(next-to :norway :blue) ; 6
          '(next-to :kool :horse) ; 11
          '(relative :green :ivory 1) ; 13
})

; ========== Setup ==========

(doseq [x (range 3)] (println))

(def var-cat    ; variable -> group 的映射
      ; {:kool :smoke, :water :drink, :ivory :color, ... 
    (apply hash-map (apply concat 
        (for [cat categories vari (second cat)] 
      [vari (first cat)]))))

(prn "var-cat:" var-cat)

(def initial-vars    ; variable -> position 的映射
      ; {:kool #{1 2 3 4 5}, :water #{1 2 3 4 5}, :ivory #{1 2 3 4 5}, ...
    (apply hash-map (apply concat 
        (for [v (keys var-cat)] [v positions]))))

(prn "initial-vars:" initial-vars)

(defn apply-unary-constraints
   "这会应用 'at' 约束。单独应用，因为它只需要执行一次。" 
   [vars]
   (let [update (apply concat
      (for [c constraints :when (= (first c) 'at) :let [[v d] (rest c)]]
   [v #{d}]))]
      (apply assoc vars update)))

(def after-unary (apply-unary-constraints initial-vars))

(prn "after-unary:" after-unary)

(def binary-constraints (remove #(= 'at (first %)) constraints))

(prn "binary-constraints:" binary-constraints)

; ========== Utilities ==========

(defn dump-vars
   "将映射 `vars` 作为 HTML 表格转储到日志中，带有 `title`。" 
   [vars title]
  (letfn [
        (vars-for-cat-pos [vars var-list pos]
          (apply str (interpose "<br/>" (map name (filter #((vars %) pos) var-list)))))]
      (log-tag "h2" title)
    (log "<table border='1'>")
    (log "<tr>")
    (doall (map #(log-tag "th" %) (cons "house" positions)))
    (log "</tr>")
    (doseq [cat categories]
      (log "<tr>")
          (log-tag "th" (name (first cat)))
          (doseq [pos positions]
          (log-tag "td" (vars-for-cat-pos vars (second cat) pos)))
      (log "</tr>")
      )
    (log "</table>")))

(defn remove-values
   "给定键/值对的列表，从键命名的变量中删除值。" 
   [vars kvs]
   (let [names (distinct (map first kvs))
      delta (for [n names]
      [n (set (map second (filter #(= n (first %)) kvs)))])
      update (for [kv delta
         :let [[cname negative] kv]]
      [cname (difference (vars cname) negative)])]
      (let [vars (apply assoc vars (apply concat update))]
   vars)))

(defn siblings
   "给定一个变量名，返回同一类别中变量的名称列表。"
   [vname]
   (disj (categories (var-cat vname)) vname))

(defn contradictory?
   "检查 vars 中是否存在矛盾，表现为一个变量具有空域。" 
   [vars]
   (some #(empty? (vars %)) (keys vars)))

(defn solved?
   "检查 'vars' 中的所有变量是否都具有单值域。"
   [vars]
   (every? #(= 1 (count (vars %))) (keys vars)))

(defn first-most-constrained
   "查找具有最小域大小 > 1 的变量。"
   [vars]
   (let [best-pair (first (sort (for [v (keys vars) :let [n (count (vars v))] :when (> n 1)] [n v])))]
      (prn "best-pair:" best-pair)
      (second best-pair)))   

;========== Constraint functions ==========

   (comment
      这些函数对映射 'bvars' 中的域进行断言，
      并从中删除那些断言不成立的任何位置。
      它们都返回（希望已修改的）域空间 'bvars'。）

   (declare bvars coloc next-to relative alldiff solitary)

   (defn coloc
      "两个变量共享相同的位置。" 
      [vname1 vname2]
      (if (= (bvars vname1) (bvars vname2)) bvars
   (do
      (let [inter (intersection (bvars vname1) (bvars vname2))]
         (apply assoc bvars [vname1 inter vname2 inter])))))

   (defn next-to 
      "两个变量具有相邻的位置"
      [vname1 vname2]
      ; (prn "doing next-to" vname1 vname2)
      (let [v1 (bvars vname1) v2 (bvars vname2)
            bad1 (for [j1 v1 :when (not (or (v2 (dec j1)) (v2 (inc j1))))] [vname1 j1])
        bad2 (for [j2 v2 :when (not (or (v1 (dec j2)) (v1 (inc j2))))] [vname2 j2])
         allbad (concat bad1 bad2)]
   (if (empty? allbad) bvars 
      (do
         (remove-values bvars allbad)))))

   (defn relative
      "(position vname1) - (position vname2) = diff"  
      [vname1 vname2 diff]
      (let [v1 (bvars vname1) v2 (bvars vname2)
       bad1 (for [j1 v1 :when (not (v2 (- j1 diff)))] [vname1 j1])
         bad2 (for [j2 v2 :when (not (v1 (+ j2 diff)))] [vname2 j2])
         allbad (concat bad1 bad2)]
   (if (empty? allbad) bvars
      (do
         (remove-values bvars allbad)))))

   (defn alldiff
      "如果一个类别的某个变量只有一个位置，则该类别的其他变量都没有该位置。"
      []
      (let [update (apply concat
   (for [c categories v (val c) :when (= (count (bvars v)) 1) :let [x (first (bvars v))]]
      (for [s (siblings v)]
         [s x])))]
   (remove-values bvars update)))

   (defn solitary
      "如果一个类别的某个位置只有一个变量，则该变量没有其他位置。"
      []
      (let [loners (apply concat
   (for [c categories p positions v (val c) 
      :when (and 
         ((bvars v) p)
         (> (count (bvars v)) 1)
         (not-any? #((bvars %) p) (siblings v)))]
      [v #{p}]))]
      (if (empty? loners) bvars
   (do
      ; (prn "loners:" loners)
      (apply assoc bvars loners)))))

;========== Solving "engine" ==========

(open)

(dump-vars initial-vars "Initial vars")

(dump-vars after-unary "After unary")

(def rules-list (concat (list '(alldiff)) binary-constraints (list '(solitary))))

(defn apply-rule
   "将规则应用于域空间并检查结果。" 
   [vars rule]
   (cond
      (nil? vars) nil
      (contradictory? vars) nil
      :else 
   (binding [bvars vars]
   (let [new-vars (eval rule)]
      (cond
         (contradictory new-vars) (do 
      (prn "contradiction after rule:" rule) 
      nil)
         (= new-vars vars) vars  ; 没有变化
         :else (do 
      (prn "applied:" rule)
      (log-tag "p" (str "applied: " (pr-str rule))) 
      (prn "result: " new-vars) 
      new-vars))))))

(defn apply-rules 
   "使用 'reduce' 将 'rules-list' 中的所有规则按顺序应用于 'vars'。"
   [vars]
   (reduce apply-rule vars rules-list))

(defn infer
   "重复应用所有规则，直到变量域不再更改。" 
   [vars]
   (loop [vars vars]
      (let [new-vars(apply-rules vars)]
      (if (= new-vars vars) (do 
         (prn "no change")
         vars)
      (do (recur new-vars))))))

(def after-inference (infer after-unary))

(dump-vars after-inference "Inferred")

(prn "solved?" (solved? after-inference))

(defn backtrack
   "通过回溯解决。"
   [vars]
   (cond
      (nil? vars) nil
      (solved? vars) vars
      :else
      (let [fmc (first-most-constrained vars)]
   (loop [hypotheses (seq (vars fmc))]
      (if (empty? hypotheses) (do
         (prn "dead end.")
         (log-tag "p" "dead end.")
         nil)
         (let [hyp (first hypotheses) hyp-vars (assoc vars fmc #{hyp})]
      (prn "hypothesis:" fmc hyp)
      (log-tag "p" (str "hypothesis: " hyp))
      (dump-vars hyp-vars (str "Hypothesis: " fmc " = " hyp))
      (let [bt (backtrack (infer hyp-vars))]
         (if bt (do
      (prn "success!")
         (dump-vars bt "Solved")
         bt)
      (recur (rest hypotheses))))))))))

(prn "first-most-constrained:" (first-most-constrained after-inference))

(def solution (backtrack after-inference))

(prn "solution:" solution)

(close)

(println "houses loaded.")

这是 292 行代码，但其中有很多调试/诊断代码。 总而言之，我很高兴能够用 Clojure 编写一个相当简短的解决方案。 函数式编程带来了一些挑战，但我设法保持了一种相当一致的函数式风格。

不过，欢迎提出批评意见！

对于任何关心的人，这是解决方案：

house       1       2               3       4             5
country     norway  ukraine         england spain         japan
color       yellow  blue            red     ivory         green
pet         fox     horse           snails  dog           zebra
smoke       kool    chesterfield    winston lucky         parliament
drink       water   tea             milk    orange-juice  coffee