(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :iterate))

(defpackage :wb1
  (:use :cl :iterate)
  (:export #:report-chaton-activity #:*chat1*
           #:define-chaton-relations))

(in-package :wb1)

;;; The basic chaton direct "likes" relationship data structure.

(defun make-chaton-table ()
  "Returns a new chaton relationship data structure."
  (make-hash-table :test 'eql))

(defun chaton-likes-chaton (table A B &key (remove-relation nil))
  "Set in TABLE that chaton A likes chaton B.
If REMOVE-RELATION is T, set that A no longer likes B."
  (if (not remove-relation)
      (pushnew B (gethash A table))
      (setf (gethash A table) (delete B (gethash A table)))))

(defun chaton-name-sort (names)
  "Sort the sequence of chaton names NAMES and return the sorted
result."
  (sort names #'string<))

(defun all-chatons (table)
  "Return all chatons in the table TABLE."
  (chaton-name-sort (iterate (for (key value) in-hashtable table)
                             (collect key))))

(defun liked-chatons (table chaton)
  "Return the chatons in TABLE that CHATON has a direct 'likes'
relationship with."
  (nth-value 0 (gethash chaton table)))

(defmacro define-chaton-relations (name (&body relations))
  "Define a chaton relation table NAME with RELATIONS.
RELATIONS is a list of relations.

Each relation is a list of the form (chaton ([likes-chatons ...]))."
  `(progn
     (defparameter ,name (make-chaton-table))
     ,@(iterate outer
                (for (chaton . (liked-chatons)) in relations)
                (iterate (for liked-chaton in liked-chatons)
                         (in outer (collect `(chaton-likes-chaton ,name ',chaton ',liked-chaton)))))
     ,name))


;;; Examples

(define-chaton-relations *chat1*
    ((A (B E))
     (B (C))
     (C (D G))
     (D (C))
     (E (F))
     (F (B E G))
     (G (H))
     (H (D))))

(define-chaton-relations *chat2*
    ((A (B D))
     (B (A))
     (C (D G))
     (D (A E))
     (E (H))
     (F (E))
     (G (H))
     (H (C D))
     (I (D))))

;;; Like / Dislike Lookups

;; A simple cache (slightly tacky. should be a structure) for
;; like/dislike status of chatons.
(defvar *cache-for-table* nil)
(defvar *chaton-likes-chaton-cache* nil)

(defmacro with-initialized-cache (table &body body)
  "Execute body with an initialized chaton like/dislike relation cache."
  `(let ((*chaton-likes-chaton-cache* (if (or (null *chaton-likes-chaton-cache*)
                                              (not (eql *cache-for-table* ,table)))
                                          (make-hash-table :test 'equal)
                                          *chaton-likes-chaton-cache*))
         (*cache-for-table* ,table))
     ,@body))

(defun cached-relation (a b)
  "Return a cached relation between A and B if it exists.
If there is a relation, the returned values are RELATIONSHIP-STATUS, T.
If there is no relation, the returned values are NIL, NIL."
  (gethash (cons a b) *chaton-likes-chaton-cache*))

(defun (setf cached-relation) (new a b)
  (setf (gethash (cons a b) *chaton-likes-chaton-cache*)
        new))

(defun relation-cached-p (a b)
  (nth-value 1 (cached-relation a b)))

(defun (setf visiting-relation-p) (new a b)
  (when new
    (setf (cached-relation a b) :visiting)))

(defun visiting-relation-p (a b)
  (eql (cached-relation a b) :visiting))

(defun chaton-likes-chaton-p (table A B)
  ")) Return T if A has a (possibly indirect) 'likes' relationship
to B, NIL otherwise."
  (with-initialized-cache table
    (cond
      ((visiting-relation-p a b)
       nil)
      ((relation-cached-p a b)
       (cached-relation a b))
      (t
       (setf (visiting-relation-p A B) t)
       (iterate (for liked-chaton in (liked-chatons table A))
                (for liked-chaton-likes-B =
                     (setf (cached-relation a b)
                           (or
                            (eql B liked-chaton)
                            (chaton-likes-chaton-p table liked-chaton B))))
                (when liked-chaton-likes-B
                  (setf (visiting-relation-p A B) nil)
                  (return liked-chaton-likes-B)))))))

(defun chaton-network-from (table a)
  "Return as the first value the liked chatons of A on TABLE, and
as the second value the disliked chatons of A on TABLE."
  (with-initialized-cache table
    (iterate (for b in (remove a (all-chatons table)))
             (if (chaton-likes-chaton-p table a b)
                 (collect b into liked)
                 (collect b into disliked))
             (finally (return (values liked disliked))))))

;;; Sender relationship checks

(defun chaton-can-send-to-chaton-about (table a b)
  "Return the chatons about which A can gossip to B."
  (with-initialized-cache table
    (if (not (chaton-likes-chaton-p table a b))
        nil
        (multiple-value-bind (a-likes a-dislikes) (chaton-network-from table a)
          (declare (ignore a-likes))
          (multiple-value-bind (b-likes b-dislikes) (chaton-network-from table b)
            (declare (ignore b-likes))
            (nintersection a-dislikes b-dislikes))))))

;;; Reporting the chaton network

(defun chaton-flames-chatons-for (table A)
  "Return a list of (victims receivers) pairs."
  (iterate (for victims in (all-flame-victims table a))
           (collect (list victims (flame-receivers-for table a victims)))))

(defun report-chaton-activity (table)
  "Write to *standard-output* the status of the chaton world."
  (with-initialized-cache table
    (let ((flame-table (make-chaton-flame-relation-table)))
      (iterate (for a in (all-chatons table))
               (iterate (for b in (remove a (all-chatons table)))
                        (for victims = (chaton-can-send-to-chaton-about table a b))
                        (when victims
                          (setf (chaton-flames-chatons flame-table a b) victims)))
               (iterate (for (victims receivers) in (chaton-flames-chatons-for flame-table a))
                        (format t "Chatone ~A jammert bei ~{~A~^, ~} ueber den/die Chatonen ~{~A~^, ~}~%" a
                                (chaton-name-sort receivers) (chaton-name-sort victims)))))))

;;; Output minimization.

(defun make-chaton-flame-relation-table ()
  (make-hash-table :test 'eql))

(defun (setf chaton-flames-chatons) (victims table A B)
  (when (null (gethash A table))
    (setf (gethash A table) (make-hash-table :test 'equal)))
  (pushnew B (gethash victims (gethash A table))))

(defun all-flame-victims (table A)
  (unless (null (gethash a table))
    (iterate (for (key val) in-hashtable (gethash a table))
             (collect key))))

(defun flame-receivers-for (table A victims)
  (gethash victims (gethash A table)))