(ns schejule.analyser
  (:require [schejule.generator :as gen]))

(defn subseq?
  [s coll]
  (loop [v1 s
         v2 coll]
    (cond
      (nil? v1)                 true
      (nil? v2)                 false
      (= (first v1) (first v2)) (recur (next v1) (next v2))
      :else                     (recur v1 (next v2)))))

(defn get-workspan
  [solution]
  (if (empty? solution)
    nil
    (->> solution :machines (map second) (apply max))))

(defn simulate-schedule*
  [tasks constraints]
  (map (fn [tasks]
         (reduce (fn [solution task]
                   (let [{:keys [machine duration job id endby]} task
                         end-time (+ duration (max
                                               (or (get-in solution [:machines machine]) 0)
                                               (or (get-in solution [:jobs job]) 0)))]
                      ;; Check if `:endby` constraint has been violated.
                     (let [new-sol (-> solution
                                       (assoc-in [:machines machine] end-time)
                                       (assoc-in [:jobs job] end-time)
                                       (update :tasks #(conj % (assoc task :end-time end-time))))]
                       (if (and endby (< endby end-time))
                         (reduced (assoc new-sol :failure id))
                         new-sol))))
                 {}
                 tasks))
       (gen/gen-schedule* tasks constraints)))

(defn distil-rule
  [bad-schedule]
  (loop [current       (first (bad-schedule :tasks))
         [head & tail] (next (bad-schedule :tasks))
         bottleneck    [(:id current)]
         start         (- (current :end-time) (current :duration))]
    (cond
      (nil? head)
      bottleneck
      (and (= start (head :end-time))
           (or (= (current :job) (head :job))
               (= (current :machine) (head :machine))))
      (recur head tail (cons (:id head) bottleneck) (- start (head :duration)))
      :else
      (recur current tail bottleneck start))))

(defn disjunctive-pairs
  [job-lookup bad-schedule]
  (partition 2 (rest (mapcat (fn [tasks] [(first tasks) (last tasks)])
                             (partition-by job-lookup bad-schedule)))))

(defn accrete-rules
  [job-lookup rules failure]
  (let [new-rule (disjunctive-pairs job-lookup (distil-rule failure))]
    (if (some #(subseq? (apply concat %) (apply concat new-rule)) rules)
      rules
      (conj (remove #(subseq? (apply concat new-rule) (apply concat %)) rules)
            new-rule))))

(ns schejule.generator
  (:refer-clojure :exclude [==])
  (:require [clojure.core.logic :refer [== all defne everyg lvar run* succeed] :as l]
            [clojure.core.logic.fd :as fd]))

(defn bind-intra-job-ordero
  [vars lengths]
  (if (seq lengths)
    (let [l (first lengths)]
      (all
       (everyg (fn [[x y]] (fd/< x y)) (partition 2 1 (take l vars)))
       (bind-intra-job-ordero (drop l vars) (next lengths))))
    succeed))

(defn select-nths
  [from ks]
  (reduce (fn [result s] (conj result (nth from s)))
          []
          ks))

(defne not-ordered-pairso [l]
  ([[[a b] . _]] (fd/> a b))
  ([[[a b] . tail]] (fd/< a b) (not-ordered-pairso tail)))

(defn gen-sequence*
  [tasks constraints]
  (let [n       (count tasks)
        dom     (dec n)
        lengths (->> tasks (partition-by :job) (map count))
        vars    (repeatedly n lvar)
        rules   (map (fn [c]
                       (map (partial select-nths vars) c))
                     constraints)]
    (run* [q]
          (== q vars)
          (fd/distinct vars)
          (everyg #(fd/in % (fd/interval dom)) vars)
          (bind-intra-job-ordero vars lengths)
          (everyg #(not-ordered-pairso %) rules))))

(defn gen-schedule*
  [tasks constraints]
  (let [feasible* (gen-sequence* tasks constraints)]
    (map (fn [tasks ords]
           (sort-by :ord (map (fn [t ord] (assoc t :ord ord))
                              tasks
                              ords)))
         (repeat tasks)
         feasible*)))

(ns schejule
  (:require [schejule.analyser :as z]))

(defn sort-tasks
  [tasks]
  (sort (fn [a b] (if-not (= (a :job) (b :job))
                    (compare (a :job) (b :job))
                    (compare (a :id) (b :id))))
        tasks))

(defn clean-tasks
  [tasks]
  (let [sorted (sort-tasks tasks)]
    (loop [clean         []
           [head & tail] sorted
           id            0]
      (if (empty? head)
        clean
        (recur (conj clean (assoc head :id id)) tail (inc id))))))

(defn by-job [tasks]
  (into {} (map (fn [task] [(:id task) (:job task)])
                tasks)))

(defn by-machine [tasks]
  (into {} (map (fn [task] [(:id task) (:machine task)])
                tasks)))

(defn solution-search
  [tasks sols failures]
  (let [job-lookup (by-job tasks)]
    (loop [anti-patterns []
           [s & others]  (z/simulate-schedule* tasks [])]
      (cond
        (Thread/interrupted) nil
        (:failure s)
        (let [anti-patterns' (z/accrete-rules job-lookup anti-patterns s)]
          (prn (str "Failure: " (s :failure)))
          (prn "Anti-Patterns")
          (prn anti-patterns')
          ;; (prn "Constraints")
          ;; (prn constraints)
          (send failures (fn [old] (update old (s :failure) #(inc (or % 0)))))
          (recur anti-patterns' (z/simulate-schedule* tasks anti-patterns')))
        :else
        (let [current (z/get-workspan s)]
          (prn (str "Success: " current))
          (send sols (fn [b] (if (or (nil? b)
                                     (< current (:workspan b)))
                               (assoc s :workspan current)
                               b)))
          (recur anti-patterns others))))))

(defn adequate-schedule
  [tasks millis]
  (let [ts       (clean-tasks tasks)
        failures (agent nil)
        sols     (agent nil)
        f        (future (solution-search ts sols failures))]
    (doall (map prn ts))
    (Thread/sleep millis)
    (future-cancel f)
    (assoc @sols :failures @failures)))