;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; COOL solution for the n-queens problem
;;;   file: cool-nqueens-ka.lsp
;;;   created: mb
;;;   date:    nov 4, 94
;;;   ported to xlisp: feb, 20, 1995, mb
;;;   modified for testing ka: june 22, 95, mb
;;;

;;; assume 4 queens

;; 1. the 4 queens as agents
;;--------------------------

(def-agent 'q1 :continuation-control 'agent-control-ka) ; <--------
(def-agent 'q2 :continuation-control 'agent-control-ka) ; <--------
(def-agent 'q3 :continuation-control 'agent-control-ka) ; <--------
(def-agent 'q4 :continuation-control 'agent-control-ka) ; <--------

;; 2. the conversation manager
;;----------------------------

(def-conversation-manager 'm1)

;; 3. The three conversation classes
;;----------------------------------

;;
;; First,  the conversation for the leftmost queen
;;

(def-conversation-class 'qc-1
  :name 'first-queen-class
  :content-language 'list
  :speech-act-language 'kqml
  :initial-state 's0
  :final-states '(yes no)
  :control 'interactive-choice-control-ka              ; <-----------
)

;;
;; Second, the conversation for the middle queens (no matter how many)
;;

(def-conversation-class 'qc-2
  :name 'middle-queen-class
  :content-language 'list
  :speech-act-language 'kqml
  :initial-state 's0
  :final-states '(yes)
  :control 'interactive-choice-control-ka              ; <-----------
)

;;
;; Third, the conversation for the rightmost (last) queen
;;

(def-conversation-class 'qc-3
  :name 'last-queen-class
  :content-language 'list
  :speech-act-language 'kqml
  :initial-state 's0
  :final-states '(yes)
  :control 'interactive-choice-control-ka              ; <-----------
)

;; 4. rules for first-queen-class
;;-------------------------------

(def-conversation-rule 'r11
  :name 'r1
  :current-state 's0
  :next-state 's1
  :transmit '(propose :sender q1
                      :receiver q2
                      :content (?(choose-new-position ?agent nil))
                      :conversation c1)
  :incomplete t                                       ; <------------
) 

(def-conversation-rule 'r12
  :name 'r2
  :current-state 's1
  :received '(reject :sender q2
                     :content ?c)
  :such-that '(another-position-exists ?agent ?c)
  :next-state 's1
  :transmit '(propose
                :sender q1
                :receiver q2
                :content (?(choose-another-position ?agent ?c))
                :conversation c1)
)

(def-conversation-rule 'r13
  :name 'r3
  :current-state 's1
  :received '(reject :sender q2
                     :content ?c)
  :such-that '(not(another-position-exists ?agent ?c))
  :next-state 'no
  :do '(format t "~%;;; No solution possible")
)

(def-conversation-rule 'r14
  :name 'r4 
  :current-state 's1
  :received '(accept :sender q2
                     :content ?c)
  :next-state 'yes
  :do '(format t "~%;;; Solution found ~s" ?c)
)

;; 5. rules for middle-queen-class
;;--------------------------------

(def-conversation-rule 'r21
  :name 'r1
  :current-state 's0
  :received '(propose :sender ?s
                      :content ?c
                      :conversation ?conv)
  :such-that '(and (at-left ?s ?agent)        ; ?agent is a predefined variable
                   (not(new-position-exists ?agent ?c)))
  :next-state 's0
  :transmit '(reject :sender ?agent
                     :receiver ?s
                     :content ?c
                     :conversation ?conv)
) 

(def-conversation-rule 'r22
  :name 'r2
  :current-state 's0
  :received '(propose :sender ?s
                      :content ?c
                      :conversation ?conv)
  :such-that '(and(at-left ?s ?agent)
                  (new-position-exists ?agent ?c))
  :next-state 's1
  :transmit '(propose :sender ?agent
                      :receiver (?(right-of ?agent))
                      :content (?(choose-new-position ?agent ?c))
                      :conversation ?conv)
)

(def-conversation-rule 'r23
  :name 'r3
  :current-state 's1
  :received '(accept :sender ?s 
                     :content ?c
                     :conversation ?conv)
  :such-that '(at-right ?s ?agent)
  :next-state 'yes
  :transmit '(accept :sender ?agent
                     :content ?c 
                     :receiver (?(left-of ?agent))
                     :conversation ?conv)
)

(def-conversation-rule 'r24
  :name 'r4
  :current-state 's1
  :received '(reject :sender ?s 
                     :content ?c
                     :conversation ?conv)
  :such-that '(and(at-right ?s ?agent)
                  (another-position-exists ?agent ?c))  
  :next-state 's1
  :transmit '(propose :sender ?agent
                      :receiver (?(right-of ?agent))
                      :content (?(choose-another-position ?agent ?c))
                      :conversation ?conv)
)

(def-conversation-rule 'r25
  :name 'r5
  :current-state 's1
  :received '(reject :sender ?s
                     :content ?c
                     :conversation ?conv)
  :such-that '(and(at-right ?s ?agent)
                  (not(another-position-exists ?agent ?c)))
  :next-state 's0
  :transmit '(reject :sender ?agent
                     :receiver (?(left-of ?agent)) 
                     :content (?(remove-last ?c))
                     :conversation ?conv)
)

;; 6. rules for last-queen-class
;;------------------------------

(def-conversation-rule 'r31
  :name 'r1
  :current-state 's0
  :received '(propose :sender ?s
                      :content ?c
                      :conversation ?conv)
  :such-that '(and (at-left ?s ?agent)
                   (new-position-exists ?agent ?c))
  :next-state 'yes
  :transmit '(accept :sender ?agent
                     :receiver (?(left-of ?agent))
                     :content (?(choose-new-position ?agent ?c))
                     :conversation ?conv)
  :do '(format t "~%;;; Solution found ~s" ?c)
)

(def-conversation-rule 'r32
  :name 'r2
  :current-state 's0
  :received '(propose :sender ?s
                      :content ?c 
                      :conversation ?conv)
  :such-that '(and(at-left ?s ?agent)
                  (not(new-position-exists ?agent ?c)))
  :next-state 's0
  :transmit '(reject :sender ?agent
                     :receiver (?(left-of ?agent))
                     :content ?c
                     :conversation ?conv)
)             
                     
                     
;; 7. Functions
;;-------------

(defun make-list (n &key (initial-element nil) 
                    &aux aux)
 (when (or (not(numberp n))
           (<= n 0))
   (error "make-list, arg must be positive number" n))
 (dotimes (i n aux)
   (setq aux (cons initial-element aux)))) 

(defun remove-last(l)
  (reverse(cdr(reverse l))))

;;
;;

(defun at-left(a1 a2 
               &aux
              )
 " is a1 at left of a2?"

 (string< (symbol-name a1) (symbol-name a2)))

;;
;;

(defun at-right(a1 a2
                &aux
               )
 " is a1 at the right of a2 "

 (string< (symbol-name a2)(symbol-name a1)))

;;
;;

(defun left-of(a
               &aux(queens '(q4 q3 q2 q1))
                   aux
              )
 " returns the agent at the left of a"

 (when(setq aux(member a queens)) 
   (cadr aux)))

;;
;;

(defun right-of(a
               &aux(queens '(q1 q2 q3 q4))
                   aux
              )
 " returns the agent at the right of a "

 (when(setq aux(member  a queens))
   (cadr aux)))

;;
;;

(defparameter *queens-no* 3) ; 0, 1, 2, 3, - 4 queens

;;
;;

(defun new-position-exists(queen table
                       &aux (column 0)
                            (this-column (length table))
                      )
 " checks if a new position exists for extending the partial solution in table "

 (cond((null table) t)
      (t(dotimes (i (1+ *queens-no*) nil) 
          (dolist (pos table 
                   (return-from new-position-exists t)) ; pos = number, 0 .. 3
            (if(conflicts pos column i this-column) 
               (progn
                    (setq column 0)
                    (return nil))
               (incf column)))))))

;;
;;
 
(defparameter *tried-positions* (make-list (1+ *queens-no*)))
     ;;  has form ((pos1 pos2 ...) (pos1 pos2 ...) ...)

;;
;;

(defun another-position-exists(queen table
                       &aux (column 0)
                            (this-column (1- (length table)))
                            (old-column (car (last table)))
                            prev-table
                      )
 " checks if another position exists for the last queen in table "

 (rplaca (nthcdr this-column *tried-positions*)
         (nconc (nth this-column *tried-positions*) (list old-column)))

 (cond((null table) t)
      (t(setq prev-table (reverse(cdr(reverse table))))
        (dotimes (i (1+ *queens-no*) nil)
         (unless(member i (nth this-column *tried-positions*))
          (dolist (pos prev-table
                   (return-from another-position-exists t)) ;pos=number, 0 .. 3
            (if(conflicts pos column i this-column)
               (progn
                    (setq column 0)
                    (return nil))
               (incf column))))))))
 
;;
;;
 
(defun choose-new-position(queen table
                       &aux (column 0)
                            (this-column (length table))
                      )
 " chooses a new position,  extending the partial solution in table "

 (cond((null table) (list 0))
      (t(dotimes (i (1+ *queens-no*) 
                  (error "CHOOSE-NEW-POSITION error"))
          (dolist (pos table
                   (return-from choose-new-position 
                                (nconc table (list i)))) ; pos = number, 0 .. 3
            (if(conflicts pos column i this-column)
               (progn
                    (setq column 0)
                    (return nil))
               (incf column)))))))

;;
;;

(defun choose-another-position(queen table
                       &aux (column 0)
                            (this-column (1- (length table)))
                            (old-column (car (last table)))
                            prev-table
                      )
 " chooses another position for the last queen in table "

 (dotimes(i (- *queens-no* this-column))
   (rplaca(nthcdr (+ i (length table)) *tried-positions*) nil))

 (cond((null table) t)
      (t(setq prev-table (reverse(cdr(reverse table))))
        (dotimes (i (1+ *queens-no*) 
                  (error "CHOOSE-ANOTHER-POSITION error"))
         (unless(member i (nth this-column *tried-positions*))
          (dolist (pos prev-table
                   (return-from choose-another-position 
                     (progn (rplaca (last table) i)
                            table))) ; pos = number, 0 .. 3
            (if(conflicts pos column i this-column)
               (progn
                    (setq column 0)
                    (return nil))
               (incf column))))))))

;;
;;

(defun conflicts (l1 c1 l2 c2)
  (or(= l1 l2)
     (= c1 c2)
     (= (abs (- l1 l2))
        (abs (- c1 c2)))))

;;
;;

;; 8. Continuation rules
;;----------------------

;; ---------- ! modified to test ka ! ------------------------

(def-continuation-rule 'cont-0
  :name 'cont-0
  :conversations-test 'cvt-0
  :incomplete nil)               ; <------------------------------------

(defun cvt-0(conversations &aux aux)
  (if conversations
      (if (setq aux(exists-conv-runnable-or-waiting conversations))
          aux
          nil)
      nil))

(defun exists-conv-runnable-or-waiting (conversations &aux aux)
  (dolist(c conversations nil)
    (when(or(and (eq (send c :status) 'waiting-for-input) 
                 (send c :input-queue))
            (eq (send c :status) 'runnable))
      (return c))))

(def-continuation-rule 'cont-1
  :name 'cont-1
  :input-queue-test 'iqt-1
  :incomplete nil)               ; <------------------------------------

(defun iqt-1 (queue)
  (if queue
      (exists-conv-class-initially-accepting (car queue))
      nil))

(def-continuation-rule 'cont-2
  :name 'cont-2
  :conversations-test 'cvt-1
  :incomplete nil)                ; <------------------------------------

(defun cvt-1(conversations &aux aux)
  (if conversations
      (if (and(setq aux(exists-conv-not-receiving-input conversations))
              (not(eq(send aux :status) 'waits-for-conversations)))
          aux
          nil)
      nil))

;; 9. the associations table
;;--------------------------

(def-association
  :conv-rule '(r11 r12 r13 r14)     :conv-class qc-1
  :conv-rule '(r21 r22 r23 r24 r25) :conv-class qc-2
  :conv-rule '(r31 r32)             :conv-class qc-3
  :cont-rule '(cont-0 cont-1 cont-2)       :agent q1
  :cont-rule '(cont-0 cont-1 cont-2)       :agent q2
  :cont-rule '(cont-0 cont-1 cont-2)       :agent q3
  :cont-rule '(cont-0 cont-1 cont-2)       :agent q4
  :agent     '(q1 q2 q3 q4)         :manager m1
  :conv-class qc-1                  :agent q1
  :conv-class qc-2                  :agent q2
  :conv-class qc-2                  :agent q3
  :conv-class qc-3                  :agent q4
  :conv      '(qc-1 c1)             :agent q1
)

;; 10. Traces
;;-----------

;(trace-agent m1 q1 q2 q3 q4)
(trace-conv m1 `((,q1 c1 first-queen-class)
                 (,q2 c1 middle-queen-class)
                 (,q3 c1 middle-queen-class)
                 (,q4 c1 last-queen-class)))
;(trace-conv m1 q2)
;(trace-conv m1 q3)
;(trace-conv m1 q4) 
(trace-message m1 q1 q2 q3 q4)