Match mentor prefs with core.logic finite domain constraints

mentor-match.clj

(ns krukow.example
  (:refer-clojure :exclude [==])
  (:use clojure.core.logic)
  (:require [clojure.core.logic.pldb :as pldb]
            [clojure.core.logic.fd :as fd]))

(pldb/db-rel mentor p)
(pldb/db-rel mentee p)
(pldb/db-rel preferences p ps)

(def mentors
  {0 :fred
   1 :lucy
   2 :ethel})


(def mentees
  {0 :bob
   1 :mary
   2 :ricky})


(def mentee-preferences
  [{:mentee :bob
    :mentor-preferences [:lucy :fred :ethel]}
   {:mentee :mary
    :mentor-preferences [:lucy :ethel]}
   {:mentee :ricky
    :mentor-preferences [:ethel :fred]}
   ])

;; solutions
;; (([:bob :fred] [:mary :lucy] [:ricky :ethel])
;;  ([:bob :lucy] [:mary :ethel] [:ricky :fred])
;;  ([:bob :ethel] [:mary :lucy] [:ricky :fred]))

(def menteesT ;; map from name to finite domain id
  (zipmap (vals mentees) (keys mentees)))

(def mentorsT ;; map from name to finite domain id
  (zipmap (vals mentors) (keys mentors)))


(defn to-fact [x]
  (let [tee (menteesT (:mentee x))
        tors (map mentorsT (:mentor-preferences x))]
    (concat
     (list
      [mentee tee]
      [preferences tee tors])
     (map #(vector mentor %) tors))))

(def db (apply pldb/db-facts
               pldb/empty-db
               (mapcat to-fact mentee-preferences)))

(def mentor-domain
  (fd/sorted-set->domain (apply sorted-set (keys mentors))))

(defn keyword-solution
  [solution]
  (map
   (juxt (comp mentees first)
         (comp mentors second))
   solution))

(let [lmentors (repeatedly (count mentees) lvar)
      solutions (pldb/with-db db
                  (run 1 [q]
                    (== q (vec
                           (map
                            (fn [tee tor]
                              [tee tor])
                            (keys mentees)
                            lmentors)))
                    (everyg #(fd/in % mentor-domain) lmentors)
                    (fd/distinct (vec lmentors))
                    (and*
                     (map
                      (fn [tee tor]
                        (fresh [tors]
                          (mentee tee)
                          (mentor tor)
                          (preferences tee tors)
                          (membero tor tors)))
                      (keys mentees)
                      lmentors))))]


  (map keyword-solution solutions))