Ward Number In Lisp

See WardNumber for the problem description.

See WardNumberInManyProgrammingLanguages for many other implementations.

Guess the language my version is in. It correctly gives Ward a WardNumber of zero. -- DanielKnapp

    (defstruct (person)
      (distance -1)
      (links nil))

    (defun read-links (&optional (filename "data.txt"))
      (with-open-file (data filename :direction :input)
        (do ((hash (make-hash-table :test #'equal))
             (line (read-line data nil nil) (read-line data nil nil))
             space name-a name-b)
            ((not line) hash)
          (setq space (position #\Space line)
                name-a (subseq line 0 space)
                name-b (subseq line (+ space 1)))
          (unless (gethash name-a hash)
            (setf (gethash name-a hash) (make-person)))
          (unless (gethash name-b hash)
            (setf (gethash name-b hash) (make-person)))
          (push (gethash name-b hash) (person-links (gethash name-a hash)))
          (push (gethash name-a hash) (person-links (gethash name-b hash))))))

    (defun calculate-distances (hash)
      (labels ((calculate-distances-h (person distance)
                 (setf (person-distance person) distance)
                 (incf distance)
                 (mapc (lambda (person)
                         (when (or (= -1 (person-distance person))
                                   (< distance (person-distance person)))
                           (calculate-distances-h person distance)))
                       (person-links person))))
        (calculate-distances-h (gethash "Ward" hash) 0)
        hash))

    (defun print-distances (hash)
      (maphash (lambda (name person)
                 (if (= -1 (person-distance person))
                     (format t "~A undefined~%" name)
                   (format t "~A ~D~%" name (person-distance person))))
               hash))

    (print-distances (calculate-distances (read-links)))

EmacsLisp

In the name of convenience, an EmacsLisp version. Doesn't actually parse the input, which is fun and/or stupid.

 ;; marker positions for where "data.txt" is; set in ward-number
 (defvar ward-start  (make-marker))     ; start of data
 (defvar ward-end    (make-marker))     ; end of data
 (defvar ward-output (make-marker))     ; where to write output
 (set-marker-insertion-type ward-end nil)
 (set-marker-insertion-type ward-output t)

 (defun ward-number ()
   "Find a set of pairing data at the top of the buffer, and insert an
 analysis below it. Assumes the existence of Mr Cunningham with number 0."
   (interactive)
   (goto-char (point-min))
   (set-marker ward-start (point-min))
   (set-marker ward-end   (search-forward-regexp "^$" (point-max) t))
   (goto-char ward-end)
   (set-marker ward-output (point))
   (insert "\n")
   ;; the business part
   (ward-insert-results (ward-find-groups '(ward) '(ward)))
   (goto-char ward-output))

 (defun ward-insert-results (list &optional n)
   (unless n (setq n 0))
   (unless (null list)
     (goto-char ward-output)
     (insert (format "%d: %s\n"
                     n
                     (reduce (lambda (acc x) (format "%s, %s" x acc))
                             (car list)
                             :from-end t)))
     (ward-insert-results (cdr list) (+ n 1))))

 (defun ward-find-groups (found group)
   (goto-char ward-start)
   (let* ((next-found (ward-next group))
          (next-group (remove-if (lambda (x) (member x found)) next-found)))
     (if next-group
         (cons group (ward-find-groups (union next-found found) next-group))
       (list group))))

 (defun ward-next (group)
   (let ((found '())
         (regexp (ward-regexp group)))
     (reduce (lambda (acc name)
               (union acc (ward-collect-matches name)))
             group
             :initial-value nil)))

 (defun ward-collect-matches (name)
   (let ((regexp (ward-regexp name))
         (found '()))
     (goto-char ward-start)
     (while (search-forward-regexp regexp ward-end t)
       (let ((a (match-string 2))
             (b (match-string 4)))
         (add-to-list 'found (intern (if a a b)))))
     found))

 (defun ward-regexp (name)
   (format "\\(%s \\(.*\\)\\)\\|\\(\\(.*\\) %s\\)$" name name))

SchemeLanguage

The following is not Lisp ;-) (It is written in a Lisp-dialect called Scheme)

 (define pairings
  '((al . bob)
    (bob . cal)
    (cal . dave)
    (dave . ed)
    (cal . fred)
    (al . ward)
    (dave . ward)))

 (define (get-partners name)
  (do ((pairs pairings (cdr pairs))
       (partners '()
                 (let* ((pair (car pairs))
                        (first (car pair))
                        (second (cdr pair)))
                   (cond 
                     ((and (eq? first name)
                           (not (memq second partners)))
                      (cons second partners))
                     ((and (eq? second name)
                           (not (memq first partners)))
                      (cons first partners))
                     (else
                      partners)))))
    ((null? pairs) partners)))

 (define ward-numbers '())

 (define (assign-ward-number name number)
  (cond
    ((assq name ward-numbers)
     =>
     (lambda (p)
       (let ((old-number (cdr p)))
         (if (< number old-number)
             (begin
               (set-cdr! p number)
               (for-each (lambda (partner)
                           (assign-ward-number partner (+ number 1)))
                         (get-partners name)))))))
    (else
     (set! ward-numbers (cons (cons name number) ward-numbers))
     (for-each (lambda (partner)
                 (assign-ward-number partner (+ number 1)))
                 (get-partners name)))))

 (assign-ward-number 'ward 0)
 (display ward-numbers)
 (newline)

another approach (similar to the python version, if i understand it):

 (define pairings
  '((al . bob)
    (bob . cal)
    (cal . dave)
    (dave . ed)
    (cal . fred)
    (al . ward)
    (dave . ward)))
 (define ward-numbers '())
 (define work-queue '(queue))
 (define end-of-queue work-queue)

 (define (get-partners name)
   (let loop ((p pairings) (partners '()))
     (cond ((null? p) partners)
           ((eq? name (caar p)) (loop (cdr p) (cons (cdar p) partners)))
           ((eq? name (cdar p)) (loop (cdr p) (cons (caar p) partners)))
           (else (loop (cdr p) partners)))))

 (define (add-partners name value)
   (for-each (lambda (partner)
               (if (not (assq partner ward-numbers))
                   (assign-ward-number partner value)))
             (get-partners name)))

 (define (add-task task)
   (set-cdr! end-of-queue (list task))
   (set! end-of-queue (cdr end-of-queue)))

 (define (run)
   (cond ((not (eq? work-queue end-of-queue))
          (force (cadr work-queue))
          (set! work-queue (cdr work-queue))
          (run))))

 (define (assign-ward-number name value)
   (set! ward-numbers (cons (cons name value) ward-numbers))
   (display (car ward-numbers))
   (newline)
   (add-task (delay (add-partners name (+ value 1)))))

 (cond (accurate (add-partners 'ward 1))
       (correct (assign-ward-number 'ward 0)))
 (run)

Yet another SchemeLanguage implementation. I have not bothered with efficiency:

  (define pairings
    '((al . bob)
      (bob . cal)
      (cal . dave)
      (dave . ed)
      (cal . fred)
      (al . ward)
      (dave . ward)))

  (define (partners name)
    (foldl (lambda (pair base) 
             (cond [(eq? name (car pair)) (cons (cdr pair) base)]
                   [(eq? name (cdr pair)) (cons (car pair) base)]
                   [else base])) 
           '()
           pairings))

  (define (distance name group)
    (cond [(memq name group) 0]
          [else (+ 1 (distance name 
                               (apply append (map partners group))))]))

Use it as follows:

  (distance 'bob '(ward))     ----> 2        

  (distance 'al '(fred))      ----> 3