Clojure code to create a balanced draw for ~30 schools each competing sequentially in (up to) 9 events. "Balanced" in the sense that schools each receive allotted positions throughout the day; no school has all their events clustered at any particular time. Contains rough test code throughout. If run, will output some test results, and write to …

gistfile1.clj

; Ways in which I want to improve this code:
;  * less explicit looping; more higher-order functions
;  * use records or types as appropriate to capture the structure of the data
;    that flows through the functions
;  * break a couple of functions into smaller ones
;  * extract a general data type for a 2D table that is iterable by rows or columns
;  * implement organised unit tests instead of the ad-hoc ones spread throughout
;  * use namespaces and private/public functions idiomatically

(ns gs.ahigs.draw
  (:use [clojure.math.numeric-tower :only [round]]
        [clojure.repl]
        [clojure.string :only [split trim split-lines join]]
        [clojure.pprint :only [pprint]]
        [clojure.set :only [difference]]
        ))

(defn- balanced-partition*
  [number nslots]
  (if (= nslots 1)
    (list number)
    (let [x (round (/ number nslots))]
      (cons x (balanced-partition* (- number x) (dec nslots))))))

(defn balanced-partition
  "Partition _number_ into _nslots_ integers as balanced as possible.
   Examples:
     [10 4]   ->  [3 2 3 2]
     [11 4]   ->  [3 3 3 2]
     [12 4]   ->  [3 3 3 3]
     [27 10]  ->  [3 3 3 3 3 2 3 2 3 2]
   The return vector is not sorted."
  [number nslots]
  (map int (balanced-partition* number nslots)))

(balanced-partition 17 1)
(balanced-partition 17 2)
(balanced-partition 11 4)
(= 27 (apply + (balanced-partition 27 10)))

(def SCHOOLS
  (split 
    "Abbotsleigh, Ascham School, Brigidine College, Canberra Grammar, Danebank,
    Frensham, Kambala, Kincoppal Rose Bay, Loreto Kirribilli, Loreto Normanhurst,
    Meriden, MLC Sydney, Monte Sant' Angelo, OLMC, PLC Armidale, PLC Sydney,
    Pymble Ladies' College, Queenwood, Ravenswood, Roseville, Santa Sabina, SCEGGS,
    St Catherine's School, St Patrick's College, St Vincent's College, Tangara,
    Tara, Wenona"
    #",\s+"))

(def SECTIONS
  (split 
    "Current Affairs, Drama, Poetry Junior, Poetry Senior, Public Speaking Junior,
    Public Speaking Senior, Readings Senior, Readings Junior, Religious & Ethical Questions"
    #",\s+"))

(def participation-string
  "Current Affairs,Debating Junior,Debating Senior,Drama,Poetry Junior,Poetry Senior,Public Speaking Junior,Public Speaking Senior,Readings Senior,Readings Junior,Religious & Ethical Questions
  Abbotsleigh,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Ascham School,NO,Yes,Yes,NO,Yes,Yes,Yes,NO,Yes,Yes,NO
  Brigidine College,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Canberra Grammar,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Danebank,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Frensham,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Kambala,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Kincoppal Rose Bay,NO,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Loreto Kirribilli,Yes,Yes,Yes,NO,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Loreto Normanhurst,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Meriden,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  MLC Sydney,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Monte Sant' Angelo,Yes,Yes,Yes,TBC,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  NEGS,NO,NO,NO,NO,NO,NO,NO,NO,NO,NO,NO
  OLMC,NO,Yes,Yes,Yes,NO,NO,Yes,Yes,NO,NO,NO
  PLC Armidale,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  PLC Sydney,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Pymble Ladies' College,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Queenwood,NO,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,NO
  Ravenswood,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Roseville,YES,YES,YES,NO,YES,YES,YES,YES,NO,NO,YES
  Santa Sabina,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  SCEGGS,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  St Catherine's School,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  St Patrick's College,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  St Vincent's College,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Tangara,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Tara,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes
  Wenona,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes,Yes"
)

; Input: ["OLMC" "NO" "Yes" "Yes" "yes" "no"]
; Output: [false true true true false]   (ignore the first element)
(defn- true-false [data]
  (let [yes-no-bool (fn [str] (->> str (re-find #"(?i)yes") nil? not))]
    (map yes-no-bool (rest data))))
  
(defn participating? [db school section]
  ((db school) section))

; { "Tara"    {"Readings Junior" true,   "Drama" true, "Debating Senior" false, ...}
;   "Meriden" {"Readings Junior" false", "Drama" true, "Debating Senior" true, ...}
;   ... }
(def PARTICIPATION-RECORDS
  (let [lines        (->> participation-string trim split-lines (map trim))
        sections     (split (first lines) #",")           ; ["Drama" "Debating Junior" ...]
        school-data  (map #(split % #",") (rest lines))   ; [ ["OLMC", "NO", "Yes", ...] ["Tara", "Yes", "Yes", ...] [...] ] 
        process-data (fn [acc-map datum]
                       (assoc acc-map (first datum)
                                      (zipmap sections (true-false datum))))
        ]
    (reduce process-data {} school-data)))

(defn check-participation-data [schools p-records]
  (println (count schools) (count p-records))
  (let [set1 (set schools) set2 (set (keys p-records))]
    (difference set2 set1)
    )
  )

(check-participation-data SCHOOLS PARTICIPATION-RECORDS)

; The initial hash containing the number of tickets each school has for each
; group.
;   { "Abbotsleigh" [2 2 2 1], "Ascham School" [2 2 2 1], ... }
(defn schools-tickets-init [schools sections nslots]
  (let [ntickets-seq (balanced-partition (count sections) nslots)
        ntickets-vec ((comp vec clojure.core/reverse sort) ntickets-seq)]
    (zipmap schools (repeat ntickets-vec))
    ))

; tickets: the number of tickets a particular school has for each slot
;   [2 1 0 1]
;
; For example, given the input above, there are no tickets left for
; slot #2, so we can only return 0, 1 or 3.
;
; Return the chosen slot number (e.g. 1) and a new tickets list ([2 0 0 1]).
;
; If there are no tickets left at all, we raise an exception.
(defn select-slot-number [tickets]                   ; [7 3 0 8]
  (let [indices (range (count tickets))              ; [0 1 2 3]
        index-gt-0? (fn [idx] (> (tickets idx) 0))
        valid-indices (filter index-gt-0? indices)   ; [0 1 3]
        chosen-slot
          (if (empty? valid-indices)
            nil
            (rand-nth valid-indices))                ; 1  (random)
        tickets* (update-in tickets [chosen-slot] dec)]
    [chosen-slot tickets*]))                         ; [1 [7 2 0 8]

(select-slot-number [2 1 0 1])  ; -> '(1 [2 0 0 1]) for example (it's random)

; (generate-groups-for-section schools-tickets 4)    [4 is the #slots]
;  * schools = [PLC Tara Wenona ...]
;  * groups  = [ [] [] [] [] ]    { 4 slots }
;  * loop (schools, groups, s-tix)
;    * school = PLC
;    * tickets = [3 1 0 1]
;    * slot = 1; tickets = [2 1 0 1]     { call to select-slot-number }
;    * s-tix* = { ... "PLC" [2 1 0 1] ... }
;    * groups* = [ [] [PLC] [] [] ]      { call to a rewritten assign-school }
;    * recur ((rest schools) groups* s-tix*)
;  * return a map (when schools is empty) with two values:
;      groups: [ [Tara Meriden...] [PLC Roseville...] [...] [...] ] 
;      schools-tickets*: (modified schools-tickets)
;
(defn generate-groups-for-section [schools-tickets nslots]
  (let [groups-init (vec (repeat nslots []))]
    (loop [schools (keys schools-tickets)
           groups groups-init
           s-tix schools-tickets]
      (if (seq schools)
        (let [school (first schools)
              tix (s-tix school)
              [slot# tix*] (select-slot-number tix)
              s-tix* (assoc s-tix school tix*)
              groups* (update-in groups [slot#] conj school)]
          (recur (rest schools) groups* s-tix*))
        ; when we run out of schools, return the groups and the modified schools-tickets
        {:groups groups, :schools-tickets s-tix})
      )))

; test create-groups-for-section
; schools-tickets = (initialise)
; nslots = 4
(let [nslots 4
      s-tix (schools-tickets-init (take 15 SCHOOLS) SECTIONS nslots)]
  (generate-groups-for-section
    s-tix
    nslots))

; (school-list-for-section schools-tickets 4)
;  * groups = [ [Tara Meriden...] [PLC Roseville...] [...] [...] ] 
;  * schools-tickets* = (updated schools-tickets)
;      { the two values above come back from create-groups-for-section }
;  * draw = (shuffle-and-flatten groups)
;  * return list of schools, and schools-tickets*
;
; This function returns a list of _all_ schools; it does not take account
; of participation.
;
(defn school-list-for-section [schools-tickets nslots]
  (let [result (generate-groups-for-section schools-tickets nslots)
        { groups :groups schools-tickets* :schools-tickets } result
        s-list (mapcat shuffle groups)]
    {:list s-list, :schools-tickets schools-tickets*}))

; test school-list-for-section
; section = "Drama"
; schools-tickets = (initialise)
; nslots = 4
; participating = (always true)
(let [nslots 4]
  (pprint
    (school-list-for-section
      (schools-tickets-init (take 50 SCHOOLS) SECTIONS nslots)
      nslots)))

; (create-full-draw sections schools nslots)
;   * schools-tickets = (schools-tickets-init schools ngroups)
;   * draw = {}
;   * loop(sections, draw, s-tix)
;     * if sections is empty, return the draw
;     * draw[section] = (create-draw-for-section ...)
;     * s-tix* = updated s-tix from create-draw-for-section
;     * recur((rest sections), draw*, s-tix*)
;
; Returns a hash:
;   { "Drama" ["MLC" "Tara" ...]
;     "REQ"   ["Meriden" "Wenona" ...]
;     ... }
;
; This function creates a draw for _all_ schools. Filtering for participation
; must be handled separately.
; 
(defn create-full-draw [sections schools nslots]
  (loop [sections sections
         draw {}
         s-tix (schools-tickets-init schools sections nslots)]
    (if (empty? sections)
      draw
      ; else
      (let [section (first sections)
            {s-list :list, s-tix* :schools-tickets}
                               (school-list-for-section s-tix nslots)
            draw*   (assoc draw section s-list)]
        (recur (rest sections) draw* s-tix*)))
    ))

; Test create-full-draw
(let [nslots 4]
  (pprint
    (create-full-draw (take 3 SECTIONS)
                      (take 10 SCHOOLS)
                      nslots)))

(let [nslots 4]
  (pprint
    (create-full-draw SECTIONS
                      SCHOOLS
                      nslots)))

; (evaluate-full-draw sections schools nslots)
;  * creates a full draw
;  * for each school, prints a list of the positions the school is placed
;    in each section (plus the sum), so I can see that it looks fair
(defn evaluate-full-draw [sections schools nslots]
  (let [draw (create-full-draw sections schools nslots)]
    (doseq [sch schools]
      (println sch)
      (let [indices (map #(.indexOf (get draw %) sch) sections)
            sum     (reduce + indices)]
        (println indices "   | " sum)))))

(let [nslots 20]
  (pprint
    (evaluate-full-draw SECTIONS
                        SCHOOLS
                        nslots)))

(def DRAW (create-full-draw SECTIONS SCHOOLS NSLOTS))

(defn remap [map_ f]
  (into {} (for [[k v] map_] [k (f k v)])))

; (filter-draw draw participating?)
;  * return a draw where each section only contains the schools that are
;    participating in that section
(defn filter-draw [draw participating?]
  (remap draw
         (fn [section schools]
           (filter #(participating? %1 section) schools))))

(defn create-draw [sections schools nslots participating?] 
  (-> (create-full-draw sections schools nslots)
      (filter-draw participating?)))

(let [p? (partial participating? PARTICIPATION-RECORDS)]
  (def DRAW (create-draw SECTIONS SCHOOLS 10 p?))
  (pprint DRAW))

; This would work with any hash whose keys are scalars and whose values
; are lists. In fact, I could extract a function (iterate-rows [columns f])
; or similar. In double fact, this functionality could be part of my 2D-table
; type.
(defn draw-csv* [draw]
  (let [columns (map (fn [[k v]] (cons k v)) draw)
        to-csv  (fn [row] (apply str (interpose "," row)))]
    (loop [acc []
           columns columns]
      (if (every? empty? columns) 
        acc
        (let [row  (map first columns)
              acc* (conj acc (to-csv row))]
          (recur acc* (map rest columns)))))))

(defn draw-csv [draw]
  (join "\n" (draw-csv* draw)))

(spit "draw.csv" (draw-csv DRAW))