(in-package :cs325-user)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :s-xml-rpc #.(get-code-file "s-xml-rpc"))
  (require :xml-rpc-utils #.(get-code-file "xml-rpc-utils"))
  (use-package :s-xml-rpc)
  )

;;; Change Log
;;; 11-06-2009 CKR changed REQUIRE to use GET-CODE-FILE
;;; 11-06-2009 CKR changed default port so client/server can run on same machine
;;; 11-04-2009 CKR added debugging output to CAN-CONTACT-P, WITH-TIMEOUT
;;;    to CALL-PLAYER
;;; 11-04-2009 CKR fixed REQUIRE calls to compile in Allegro and Lispworks


(defparameter *template*
  '(
"Ladies and gentlemen, on this ~(~A~) occasion, it is a privilege to address
such a/an ~(~A~)-looking group of ~(~A~). I can tell from your
smiling ~(~A~) that you will support my ~(~A~) program in the
coming election. I promise that, if elected, there will be a/an ~(~A~) in every
~(~A~) and two ~(~A~) in every garage. I want to warn you
against my ~(~A~) opponent, Mr. ~A This man is nothing
but a/an ~(~A~) ~(~A~). He has a/an ~(~A~) character and is working
~(~A~) in glove with the criminal element. If elected, I promise to
eliminate vice. I will keep the ~(~A~) in the public till. I promise you
~(~A~) government, ~(~A~) taxes, and ~(~A~) schools."
       
   (adjective adjective plural-noun plural-noun adjective noun noun plural-noun
              adjective name adjective noun adjective noun
              plural-noun adjective adjective adjective)
   ))


;;; SERVER SIDE

(defvar *madlibs-server* nil)
(defvar *story* nil)

;;; (reset to the value of *standard-output* by START-MADLIBS)
(defvar *madlibs-host-output* *terminal-io*)


;;; Register players

(defvar *madlibs-players* (make-hash-table :test 'equal))

;;; respond to player registering
(defun s-xml-rpc-exports::|madlibs.register| (port)
  (let* ((dotted-ip (get-remote-ip))
         (player (list dotted-ip port)))
    (format *madlibs-host-output* "~&Registering:~{ ~A~}~%" player)
    (setf (gethash dotted-ip *madlibs-players*) player)))

;;; respond to player quitting
(defun s-xml-rpc-exports::|madlibs.quit| ()
  (let ((ip (get-remote-ip)))
    (format *madlibs-host-output* "~&Unregistering: ~A~%" ip)
    (remhash ip *madlibs-players*)))
               
;;; respond to player request for result
(defun s-xml-rpc-exports::|madlibs.getStory| ()
  *story*)

(defun get-remote-ip ()
  (let* ((conn s-xml-rpc::*xml-rpc-connection*)
         (host-ip (socket:remote-host conn)))
    (socket:ipaddr-to-dotted host-ip)))

(defun start-madlibs (&optional (port 8000))
  ;; capture the output stream for the window where this is called
  (setq *madlibs-host-output* *standard-output*)
  
  (unless *madlibs-server*
    (setq *madlibs-server* (start-xml-rpc-server :port port))))

(defun stop-madlibs ()
  (when *madlibs-server*
    (stop-server *madlibs-server*)
    (setq *madlibs-server* nil)))

(defun clear-players ()
  (clrhash *madlibs-players*))


;;; CLIENT SIDE

(defun call-player (player method &rest args)
  (format *madlibs-host-output* "~&~A ~A" player method)
  (let ((result
         (with-timeout (3 :timeout)
           (xml-rpc-call (apply #'encode-xml-rpc-call method args)
                         :host (car player)
                         :port (cadr player)))))
    (format *madlibs-host-output* " -> ~A~%" result)
    result))    

;;; confirm a player is available
(defun can-contact-p (player)
  (not (eql :timeout (call-player player "madlibs.acknowledge"))))

;;; ask a player for a word type
(defun ask-for-word (part player)
  (with-timeout (5 nil)
    (call-player player "madlibs.getWord" part)))

;;; send story to player
(defun send-story (&optional (story *story*) (players (get-players)))
  (format *madlibs-host-output* "~%Sending story:~%~A~%" story)
  (dolist (player players)
    (call-player player "madlibs.showStory" story)))


;;; Story generator

;;; generate story by getting available players and asking them for words
(defun run-madlibs ()
  (let ((players (get-players)))
    (if (null players)
        (format *madlibs-host-output* "No one wanted to play!")
      (send-story (get-story (car *template*) (cadr *template*) players)
                  players))))

(defun get-story (text parts players)
  (format *madlibs-host-output* "~&Getting words from~{ ~A~}~%" players)
  (get-text text (get-words parts (shuffle players))))

(defun get-players ()
  (let ((players nil))
    (maphash #'(lambda (ip player)
                 (declare (ignore ip))
                 (when (can-contact-p player) (push player players)))
             *madlibs-players*)
    players))

(defun get-words (parts players)
  (do ((l players (if (null (cdr l)) players (cdr l)))
       (parts parts (cdr parts))
       (words nil (cons-if (ask-for-word (car parts) (car l))
                           words)))
      ((null parts) (nreverse words))))

(defun cons-if (x l)
  (if (null x) l (cons x l)))

(defun get-text (template words)
  (setq *story*
        (format nil "~?" template words)))

(defun shuffle (l)
  (let ((n (length l)))
    (dotimes (i n)
      (rotatef (nth i l) (nth (random n) l)))
    l))