;;;; -*- Mode: LISP; Syntax: COMMON-LISP -*-
;;;;
;;;; cl-unreal-gamebot.lisp
;;;;
;;;;  author: Erik Winkels (aerique@xs4all.nl)
;;;; created: 2010-03-01

;;; Packages

(asdf:oos 'asdf:load-op :parse-number)
(use-package :parse-number)

(asdf:oos 'asdf:load-op :usocket)
(use-package :usocket)


;;; Parameters

(defvar *gb* nil)
(defparameter *gb-state* :default)

(defparameter *booleans* '("BotsPaused" "ForceDoubleJump" "GamePaused"))
(defparameter *coordinates* '("Location" "NeededJump"))
(defparameter *numbers* '("CollisionH" "CollisionR" "Flags" "FragLimit"
                          "TimeLimit"))

(defparameter *iinvs* nil)
(defparameter *inavs* nil)
(defparameter *iplrs* nil)


;;; Common Functions

;; Paul Graham, On Lisp
(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))


(defun mktag (string)
  (intern (string-upcase string) :keyword))


(defun starts-with (sequence subsequence)
  (let ((sublen (length subsequence)))
    (when (and (> sublen 0)
               (<= sublen (length sequence)))
      (equal (subseq sequence 0 sublen) subsequence))))


;(defun quit (&optional (unix-status 0))
;  (cl-user::quit :unix-status unix-status))


;;; Predicates

(defun names-boolean-p (name)
  (member name *booleans* :test #'equal))


(defun names-coordinates-p (name)
  (member name *coordinates* :test #'equal))


(defun names-number-p (name)
  (member name *numbers* :test #'equal))


;;; Parsers

(defun skip-space (string)
  (when (>= (length string) 1)
    (if (starts-with string " ")
        (subseq string 1)
        string)))


(defun parse-coords (coords-string)
  (loop with x = nil
        with y = nil
        with z = nil
        with n = :x
        for c across coords-string
        do (cond ((and (char= c #\comma) (equal n :x)) (setf n :y))
                 ((and (char= c #\comma) (equal n :y)) (setf n :z))
                 ((equal n :x) (push c x))
                 ((equal n :y) (push c y))
                 ((equal n :z) (push c z))
                 (t (error "[parse-coords] Unknown n (~S) and c (~S)" n c)))
        finally (return (list (parse-number (coerce (reverse x) 'string))
                              (parse-number (coerce (reverse y) 'string))
                              (parse-number (coerce (reverse z) 'string))))))


(defun parse-value (string name)
  (if (char/= #\{ (elt string 0))
      ;; normal value
      (let* ((end (position #\} string))
             (value (subseq string 0 end)))
        (list (cond ((names-boolean-p name)
                     (cond ((equal value "False") nil)
                           ((equal value "True") t)
                           (t (error "[parse-value] Not boolean: ~S" value))))
                    ((names-coordinates-p name) (parse-coords value))
                    ((names-number-p name) (parse-number value))
                    (t value))
              (subseq string (+ end 1))))
      ;; nested pair(s)
      (loop with result = nil
            with pairs = string
            do (when (char= #\} (elt pairs 0))
                 (loop-finish))
               (let ((parse-result (parse-pair pairs)))
                 (push (list (first parse-result) (second parse-result))
                       result)
                 (setf pairs (skip-space (third parse-result))))
            finally (return (list (reverse result) (subseq pairs 1))))))


(defun parse-pair (string)
  (unless (starts-with string "{")
    (format t "[parse-pair] Not a {name value} pair: ~S~%" string)
    (return-from parse-pair))
  (let* ((space (position #\space string))
         (name (subseq string 1 space))
         (parse-result (parse-value (subseq string (+ space 1)) name)))
    (list (mktag name) (first parse-result) (second parse-result))))


(defun parse-pairs (string)
  (loop with result = nil
        with pairs = (subseq string (+ (position #\space string) 1))
        while pairs
        for parse-result = (parse-pair pairs)
        do (push (first parse-result) result)
           (push (second parse-result) result)
           (setf pairs (skip-space (third parse-result)))
        finally (return (reverse result))))


;;; Functions

(defun gb-connect (&key (host "127.0.0.1") (port 3000))
  (setf *gb* (socket-connect host port)))


(defun gb-disconnect ()
  (when *gb*
    (socket-close *gb*))
  (setf *gb* nil))


(defun gb-listen ()
  (listen (socket-stream *gb*)))


(defun gb-receive ()
  (loop for c = (read-char (socket-stream *gb*))
        until (char= c #\newline)
        unless (char= c #\return)
          collect c into result
        finally (return (coerce result 'string))))


(defun gb-send (command)
  (princ command (socket-stream *gb*))
  (write-char #\Return (socket-stream *gb*))
  (write-char #\Newline (socket-stream *gb*))
  (force-output (socket-stream *gb*)))


(defun gb-wait-for-input (&optional (sleep-time 0))
  (loop until (gb-listen)
        do (sleep sleep-time)))


;;; Commands

(defun gb-init (&key (name "cl-bot"))
  (gb-send (mkstr "INIT {Name " name "}")))


(defun gb-ready ()
  (gb-send "READY"))


;;; Main Program

(defun gb-start (&key (host "127.0.0.1") (port 3000))
  (gb-connect :host host :port port)
  (if *gb*
      (format t "~&Connected to GameBots server at ~A port ~A.~%" host port)
      (progn (format t "Failed to connect to GameBots server at ~A port ~A.~%"
                     host port)
             (quit :unix-status 1)))
  (format t "Waiting for \"HELLO BOT\"... ")
  (force-output)
  (gb-wait-for-input)
  (let ((hello-bot (gb-receive)))
    (if (equal hello-bot "HELLO BOT")
        (format t "Received.~%")
        (format t "Error, received: ~S~%" hello-bot)))
  (format t "Sending \"READY\"... ")
  (force-output)
  (gb-ready)
  (format t "Sent.~%Waiting NFO message... ")
  (force-output)
  (gb-wait-for-input)
  (let ((nfo (gb-receive)))
    (if (starts-with nfo "NFO ")
        (format t "Received.~%")
        (format t "Error, received: ~S~%" nfo))
    (format t "NFO: ~S~%" (parse-pairs nfo)))
  (gb-wait-for-input)
  (setf *iinvs* nil  *inavs* nil  *iplrs* nil)
  (loop with init-blocks = '("SINV" "SNAV" "SPLR")
        while init-blocks
        for init-block = (gb-receive)
        do (setf init-blocks (remove init-block init-blocks :test #'equal))
           (cond ((equal init-block "SINV")
                  (loop for iinv = (gb-receive)
                        until (equal iinv "EINV")
                        do (push (parse-pairs iinv) *iinvs*)))
                 ((equal init-block "SNAV")
                  (loop for inav = (gb-receive)
                        until (equal inav "ENAV")
                        do (push (parse-pairs inav) *inavs*)))
                 ((equal init-block "SPLR")
                  (loop for iplr = (gb-receive)
                        until (equal iplr "EPLR")
                        do (push (parse-pairs iplr) *iplrs*)))
                 (t (error "[gb-start] Unknown init-block: ~S" init-block))))
  (format t "Sending \"INIT\"... ")
  (force-output)
  (gb-init :name "aerique-bot")
  (format t "Sent.~%Waiting CONFCH message... ")
  (force-output)
  (gb-wait-for-input)
  (let ((confch (gb-receive)))
    (if (starts-with confch "CONFCH ")
        (format t "Received.~%")
        (format t "Error, received: ~S~%" confch))
    (format t "CONFCH: ~S~%" (parse-pairs confch)))
  (sleep 2)
  (format t "Disconnecting...~%")
  (gb-disconnect))