Seven sins

From New Scientist #1033, 6th January 1977
 
An air of rare humility pervades the Common Room at St.
Aletheia's tonight. The seven inmates overdid the
post-prandial gin and rashly confessed their sins to one
another. Each owned to a different pair of the deadly ones and
each sin turned out to have claimed a different pair of
victims.
 
Constance, Emily, and Flavia have no sin in common to any two
of them. Beatrice, Deborah, Emily, and Gertrude confessed to
all seven among them. Alice and Gertrude admitted to sloth;
Deborah and Emily to lust. Alice is not given to pride nor
Beatrice to avarice nor Flavia to either pride or
intemperance. Constance, who owned to anger, has a sin in
common with Deborah, who did not.
 
Which pair has fallen prey to intemperance and which pair to envy?

newLISP


(define (cartesian-multiply cartesian.lists cartesian.func
          (cartesian.built '()))
  (if (null? cartesian.lists)
    (cartesian.func (reverse cartesian.built))
    (dolist (x (first cartesian.lists))
      (cartesian-multiply (rest cartesian.lists) cartesian.func
        (cons x cartesian.built)))))

;; Iterate over all combinations from a list, and
;; call a function on each.
(define (combine-n combine.size combine.seq combine.func (combine.built '()))
  (if (or (zero? combine.size) (null? combine.seq))
    (combine.func combine.built)
    (for (i 0 (- (length combine.seq) combine.size))
      (combine-n
        (- combine.size 1)
        (slice combine.seq (+ 1 i))
        combine.func
        (cons (nth i combine.seq) combine.built)))))

(define (combinations size seq)
  (let (result '())
    (combine-n size seq (fn(x) (push x result)))
    result))

;; Reverse association table lookup.
;; Returns a list of all keys.
(define (rev-lookup* val tbl)
  (map
    (fn (indices) (nth (list (first indices) 0) tbl))
    (ref-all val tbl)))

(setf sins '(intemperance envy sloth lust pride avarice anger))
(setf sin-combos (combinations 2 sins))
(define names '(Constance Emily Flavia Beatrice Deborah Gertrude Alice))
(define table (map (fn (nun) (list nun sin-combos)) names))

(define (update-table nun the-sin must-have)
  (let (sin-list (lookup nun table))
    (setf (lookup nun table)
      ((if must-have filter clean)
        (fn (pair) (member the-sin pair))
        sin-list))))

(update-table 'Alice 'sloth true)
(update-table 'Gertrude 'sloth true)
(update-table 'Deborah 'lust true)
(update-table 'Emily 'lust true)
(update-table 'Alice 'pride nil)
(update-table 'Beatrice 'avarice nil)
(update-table 'Flavia 'pride nil)
(update-table 'Flavia 'intemperance nil)
(update-table 'Constance 'anger true)
(update-table 'Deborah 'anger nil)

(define (check sin-pairs)
  (local (Constance Emily Flavia Beatrice Deborah Gertrude Alice)
    (let (tbl (unify '(Constance Emily Flavia Beatrice Deborah Gertrude Alice)
                sin-pairs))
      (bind tbl)
      (and
        (= 7 (length (unique sin-pairs)))
        (= 7 (length (union Beatrice Deborah Emily Gertrude)))
        (intersect Constance Deborah)
        (not (intersect Constance Emily))
        (not (intersect Constance Flavia))
        (not (intersect Emily Flavia))
        (let (nuns-per-sin
                (map
                  (fn (s)
                    (filter (fn (nun) (member s (lookup nun tbl)))
                            names))
                  sins))
          (and
            (= 7 (length (unique nuns-per-sin)))
            (for-all (fn(xs) (= 2 (length xs))) nuns-per-sin)))
        (println sin-pairs)
        (dolist (s '(intemperance envy))
          (println s ": " (rev-lookup* s tbl)))))))


(cartesian-multiply (map (fn (nun) (lookup nun table)) names) check)

intemperance: (Emily Alice)
envy: (Flavia Beatrice)