mentee-mentor-injective-mapping.clj

mentee-mentor-injective-mapping.clj

;; inspired by a Clojurians chat https://clojurians.slack.com/archives/CJ322KHNX/p1647192994651699
;; simplified version, without any persisted data:

(defn pairs [coll]
  (loop [[x & xs] coll
         result []]
    (if (nil? xs)
      result
      (recur xs (apply conj result (map #(vector x %) xs))))))

(defn all-different [coll]
  (mapv (fn [[a b]]
          (vector (list 'not= a b)))
        (pairs coll)))

(let [n (xt/start-node {}) ;; lightweight in-memory XTDB node, contains no data
      mentee-ids ["bob" "mary" "ricky"]
      mentor-preferences [#{"lucy" "fred" "ethel"}
                          #{"lucy" "ethel"}
                          #{"ethel" "fred"}]
      mentor-lvars (mapv #(gensym %) mentee-ids)]
  (->> (apply xt/q
              (xt/db n)
              {:find mentor-lvars
               :in (mapv #(vector % '...) mentor-lvars)
               :where (all-different mentor-lvars)}
              mentor-preferences)
       (map (fn [r] (map #(vector %1 %2) mentee-ids r)))))
;;=> ((["bob" "lucy"] ["mary" "ethel"] ["ricky" "fred"]) (["bob" "fred"] ["mary" "lucy"] ["ricky" "ethel"]) (["bob" "ethel"] ["mary" "lucy"] ["ricky" "fred"]))

;; Here XT's Datalog implementation is working as a general purpose backtracking constraint solver to find the mapping from a list of mentees to lists of mentors (i.e. an https://en.wikipedia.org/wiki/Injective_function).
;; The "alldifferent" constraint is naively implemented using a set of `!=` clauses.
;; It also works completely lazily, i.e. :limit 1 will halt the search after the first result is found.

;; The generated query looks like:
'{:find [bob35426 mary35427 ricky35428],
  :in [[bob35426 ...] [mary35427 ...] [ricky35428 ...]],
  :where [[(not= bob35426 mary35427)] [(not= bob35426 ricky35428)] [(not= mary35427 ricky35428)]]}





;; Original notes + solution that can work on persisted indexes...

;; Given a set of mentors and mentees
;; Each mentee can have a list of mentor preferences
;; I want to find all solutions to matching mentees with their mentor preferences.
;; Each mentor can only be a mentor for one mentee

;; (def mentor-match-schema [{:db/ident :mentee/name
;;                            :db/valuetype :db.type/string
;;                            :db/unique :db.unique/identity
;;                            :db/cardinality :db.cardinality/one
;;                            :db/doc "name of a mentee"}
;; 
;;                           {:db/ident :mentor/handle
;;                            :db/valuetype :db.type/string
;;                            :db/unique :db.unique/identity
;;                            :db/cardinality :db.cardinality/one
;;                            :db/doc "handle of a mentor"}
;; 
;;                           {:db/ident :mentee/mentor-preference
;;                            :db/valuetype :db.type/ref
;;                            :db/cardinality :db.cardinality/many}])

(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"]}
   ])

(def mentors-data (mapcat
              (fn [{:keys [mentor-preferences]}]
                (map
                 #(hash-map :mentor/handle %)
                 mentor-preferences))

              mentee-preferences))

(def mentees-data
  (map
   (fn [x]
     (let [{:keys [mentee mentor-preferences]} x]
       {:mentee/name mentee
        :mentee/mentor-preference
        (map #(hash-map :mentor/handle %)
             mentor-preferences)}))

   mentee-preferences))

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

(let [n (xt/start-node {})]
  (->> (xt/submit-tx n (mapv
                        (fn [m] [::xt/put m])
                        (concat (for [m mentors-data]
                                  (assoc m :xt/id (:mentor/handle m)))
                                (for [m mentees-data]
                                  (-> (assoc m :xt/id (:mentee/name m))
                                      (update :mentee/mentor-preference (fn [hs]
                                                                          (mapv :mentor/handle hs))))))))
       (xt/await-tx n))
  (let [mentee-ids (mapv :mentee/name mentees-data)
        mentor-lvars (mapv #(gensym %) mentee-ids)]
    (->> (xt/q (xt/db n)
               {:find mentor-lvars
                :where (vec (concat (mapv #(vector %1 :mentee/mentor-preference %2) mentee-ids mentor-lvars)
                                    (all-different mentor-lvars)))})
         (map (fn [r] (map #(vector %1 %2) mentee-ids r))))))