Attempt at the problem

core.clj

(ns timetable.core2
  (:refer-clojure :exclude [==])
  (:use [clojure.core.logic]
        [clojure.tools.macro]))

;;  --------------------------------------------------------
;;   Useful goals
(defne rembero 
  "Succeeds if out is the list l with the first instance of element x removed"
  [x l out]
  ([_ [] []])
  ([x [x . d] d])
  ([_ [a . d] [a . r]]
     (!= a x)
     (rembero x d r)))

(defne a-rembero
  "Succeed is l2 is a list with all elements of l1 removed."
  [l1 l2 q]
  ([[] l2 q] (== q l2))
  ([[a . d] l2 q]
     (fresh [x]
            (rembero a l2 x)
            (a-rembero d x q))))

(defne permo
  "Succeeds if x1 is a permutation of x2."
  [x1 x2]
  ([[] []])
  ([[a . r] x2]
     (fresh [rx2]
            (membero a x2)
            (rembero a x2 rx2)
            (permo r rx2))))

(defne subseto
  "Succeeds if x1 is a subset of x2.  x1 is distinct with elements of x2 but is shorter
than or equal to x2"
  [x1 x2]
  ([[] _])
  ([[a . r] x2]
     (fresh [rx2]
            (membero a x2)
            (rembero a x2 rx2)
            (subseto r rx2))))

(defne distincto
  "Succeeds if every element of x is unique"
  [x]
  ([[f . nil]])
  ([[f . r]]
     (rembero f r r)
     (distincto r)))

(defne partitiono [p o]
  ([[] []])
  ([[h . t] o]
     (fresh [rem]
            (subseto h o)
            (a-rembero h o rem)
            (!= h [])
            (partitiono t rem))))

;; --------------------------------
;; Abstract to our problem

(defne lectureso
  "Succeeds if the lecturer can lecture any of the courses in c"
  [l c q]
  ([l [?c1 . _] q] (membero [?c1 l (lvar)] q))
  ([l [_ . ?r] q] (lectureso l ?r q)))

;; Attends is the vector of streams attending a content
(defne attends
  "Succeeds if the vector of attends is EXACTLY (not a perm) a whenever the
 content is c"
  [c a q]
  ([c a []])
  ([c a [[c _ _ s] . t]]
     (== a s)
     (attends c a t))
  ([c a [[c1 _ _ _] . t]]
     (!= c1 c)
     (attends c a t)))

(defne can-lecture
  "Succeeds if whenever content c appears in q, the associated l is an element of l."
  [c l q]
  ([c l []])
  ([c l [[c l1 _ _] . r]]
     (membero l1 l)
     (can-lecture c l r))
  ([c l [[c1 _ _ _] . r]]
     (!= c1 c)
     (can-lecture c l r)))

;; no-concurrent-* should be abstracted over w/ macro
(defne no-concurrent-content
  "Succeeds if nothing is clashing in the periods.
  1. No content is being given twice"
  [conc tmp]
  ([[] tmp] (distincto tmp))
  ([[[h _ _ _] . t] tmp]
     (fresh [x]
            (conso h tmp x)
            (no-concurrent-content t x))))

(defne no-concurrent-lecturer
  "Succeed if during a concurrent the same lecturer does not appear twice."
  [conc tmp]
  ([[] tmp] (distincto tmp))
  ([[[_ l _ _] . t] tmp]
     (fresh [x]
            (conso l tmp x)
            (no-concurrent-lecturer t x))))

(defne no-concurrent-streams
  "Don't cross the streams, dude !  This seems horribly slow"
  [conc tmp streams]
  ([[] tmp streams ] (partitiono tmp streams))
  ([[[_ _ _ s] . t] tmp streams]
     (fresh [x]
            (conso s tmp x)
            (no-concurrent-streams t x))))

(defne concurrent 
  "Succeeds if all the constraints on a concurrent are met."
  [c]
  ([c]
     (no-concurrent-content c [])
     (no-concurrent-lecturer c [])))



;; ---------------------------------------------
;; Put it all together now.
;;
;; Timetable format [[period1] ... [periodN]]
;;
;;  Period format
;;     [period content lecturer venue [& stream]]
;;  period is just an identifier like :monday-1
;;  content is what is given, be it lecture, tut, prac
;;     its broken up this way to allow flexibility and
;;     oddness like enforced contiguous blocks
;;  lecturer is just who's giving it
;;  venue is the venue
;;  [& stream] is a vector of the streams taking the content
;;     so :me-1 is 1st year mecheng etc.

(def content   [:maths1a :phys1a :draw1a :mech1a :comps1a :free])
(def lecturers [:jones :smith :brown :peplow :jarvis :free])
(def venues    [:S19 :S18 :free])
(def streams   [:ec-1 :el-1 :cv-1])  

(comment
  (run 1 [q]
       ;; There need to be periods * venues of pi .. si
       (fresh [c1 l1 v1 s1
               c2 l2 v2 s2
               c3 l3 v3 s3
               c4 l4 v4 s4
               c5 l5 v5 s5
               c6 l6 v6 s6
               ;; Concurrents are periods that accur concurrently
               conc1 conc2
               ;; Raw is the unstructured list of periods
               raw]
              ;; Structure the output for us
              (== q [conc1 conc2])

              ;; Raw data
              (== raw [[c1 l1 v1 s1]
                       [c2 l2 v2 s2]
                       [c3 l3 v3 s3]
                       [c4 l4 v4 s4]
                       [c5 l5 v5 s5]
                       [c6 l6 v6 s6]])

              ;; Concurrents are periods that accur concurrently
              (== conc1 [[c1 l1 v1 s1]
                         [c2 l2 v2 s2]
                         [c3 l3 v3 s3]])
              (== conc2 [[c4 l4 v4 s4]
                         [c5 l5 v5 s5]
                         [c6 l6 v6 s6]])

              ;; Putting these first seems to speed things up
              (membero c1 content)
              (membero c2 content)
              (membero c4 content)
              (membero c5 content)

              (membero l1 lecturers)
              (membero l2 lecturers)
              (membero l4 lecturers)
              (membero l5 lecturers)
              
              ;; Setup the frees
              (== c3 :free)
              (== l3 :free)
              (== v3 :free)

              (== c6 :free)
              (== l6 :free)
              (== v6 :free)

              ;;(attends :maths1a [:ec-1] raw)
              ;;(attends :phys1a  [:el-1] raw)
              ;;(attends :draw1a  [:me-1 :cv-1] raw)
              
              ;; List what each lecturer can teach
              ;;(can-lecture :chem1a [:smith :brown :smith] raw)
              ;;(can-lecture :maths1a [:jarvis] raw)
              ;;(can-lecture :phys1a [:smith :brown] raw)
              ;;(can-lecture :draw1a [:peplow :jarvis :gershin] raw)
              
              ;; Ensure each concurrent is valid
              (concurrent conc1)
              ;;(partitiono [s1 s2 s3] [streams])
              
              (concurrent conc2)

              
              ))

  )

Yet this is speedy...

 (run 1 [q]
    (fresh [c1 l1 v1 s1
            c2 l2 v2 s2
            c3 l3 v3 s3
            c4 l4 v4 s4
            c5 l5 v5 s5
            c6 l6 v6 s6
            conc1 conc2
            raw]
           (== raw [[c1 l1 v1 s1] [c2 l2 v2 s2] [c3 l3 v3 s3]
                    [c4 l4 v4 s4] [c5 l5 v5 s5] [c6 l6 v6 s6]])
           (== conc1 [[c1 l1 v1 s1] [c2 l2 v2 s2] [c3 l3 v3 s3]])
           (== conc2 [[c4 l4 v4 s4] [c5 l5 v5 s5] [c6 l6 v6 s6]])
           (== q [conc1 conc2])

           ;; --------------------------
           ;; First concurrent
           ;; Fixed content
           (membero c1 content)
           (membero c2 content)
           (membero l1 lecturers)
           (membero l2 lecturers)
           ;; Free to mop up
           (== c3 :free)
           (== l3 :free)
           (== v3 :free)

           ;; --------------------------
           ;; Second concurrent
           (membero c4 content)
           (membero c5 content)
           (membero l4 lecturers)
           (membero l5 lecturers)
           ;; Free to mop up
           (== c6 :free)
           (== l6 :free)
           (== v6 :free)

           (attends :maths1a [:ec-1] raw)
           (can-lecture :maths1a [:jarvis :brown] raw)

           (attends :draw1a [:ec-1 :el-1] raw)
           (can-lecture :draw1a [:peplow] raw)

           (concurrent conc1)
           (partitiono [s1 s2 s3] streams)

           ))