Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
Attempt at the problem
(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)
))
)
@ejackson

This comment has been minimized.

Copy link
Owner Author

ejackson commented Feb 3, 2012

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)

           ))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.