;;;;
;;;; Naledi ya Africa ("Star of Africa") is an ncurses-based survival game
;;;; set in Africa.
;;;;
;;;; This file stores all game data and handles the server.
;;;;
;;;; (c) 2018 Daniel Vedder, MIT license
;;;;

(in-package :naledi-ya-africa)

;; TODO save and load functions
;; XXX Will probably require `make-load-form-saving-slots'

;; TODO split this file up? remove the networking code...

;;; PLAYER LIST

(let ((players NIL))
	(defun reset-players () (setf players NIL)) ;;TODO logout first
	
	(defun get-player (name)
		(first (member name players
				   :test #'(lambda (s p) (equalp (player-name p) s)))))

	(defun add-player (name passwd)
		(let ((np (make-player :name name :password passwd :online NIL
					  :human (make-instance 'human
								 :x (random *world-size*)
								 :y (random *world-size*)))))
			(setf players (cons np players))))

	(defun online-players ()
		"Return a list of names of players who are online"
		(loop for p in players
			if (player-online p)
			collect (player-name p)))
	
	(defun save-players (file-name)
		;;TODO
		))

(defun online-p (name)
	(let ((p (get-player name)))
		(when p (player-online p))))

;;; WORLD OBJECT

(let ((world NIL))
	;;TODO we need to keep track of the current world map (i.e. patch chars and colours),
	;; otherwise player map requests will take way too long to serve
	(defun set-world (w) (setf world w))

	(defun world-size () (length world))

	(defun save-topography (file-name) ;XXX (re)move this?
		"Save the world topography as a text file"
		(logf 3 "~&Saving world to file ~A" file-name) ;debug
		(with-open-file (tf file-name :direction :output)
			(dolist (row world)
				(format stream "~&~A~%"
					(string-from-list
						(mapcar #'(lambda (p)
									  (biome-char (patch-biome p)))
							row) "")))))

	(defun save-world (&optional (file-name "naledi.save"))
		;;TODO
		(save-players file-name))
	
	(defun coord (x y)
		"Return the patch at the given coordinates or NIL if out of bounds"
		(unless (or (< x 0) (< y 0) (> x (length world)) (> y (length world)))
			(nth x (nth y world)))))

;;; WORLD THREADS

(let ((uptime 0) (world-thread NIL) (server-thread NIL)
		 (player-threads NIL) (running NIL))

	(defun start-server (&optional (force T))
		"Start the game server"
		;;FIXME cannot restart -> ADDRESS-IN-USE ERROR
		;; -> comes from not closing connections properly?
		;;XXX change force back to NIL?
		(when force 
			(reset-server-threads)
			(reset-world-age))
		(unless (or world-thread server-thread)
			(init-world)
			(setf running T)
			(setf world-thread
				(bt:make-thread #'update-loop :name "world-thread"))
			(setf server-thread
				(bt:make-thread #'run-server :name "server-thread"))
			(logf 2 "SERVER: initialized")))

	(defun terminate ()
		;;TODO do some error catching if the threads no longer exist
		(logf 2 "SERVER: terminating the world.")
	    (setf running NIL)
		;;XXX have to use destroy-thread because the server mostly idles,
		;; waiting for connections - only checks 'running' when connecting
		(bt:destroy-thread server-thread)
		(bt:join-thread world-thread)
		(dolist (pt player-threads)
			(bt:join-thread (first pt)))
		(reset-server-threads)
		(save-world)) ;XXX not yet implemented
	
	(defun age-of-the-world () uptime)

	(defun reset-world-age () (setf uptime 0))

	(defun runningp () running)

	(defun reset-server-threads ()
		(set-list NIL server-thread world-thread player-threads))

	(defun thread-player (&optional (th (bt:current-thread)))
		"Return the player name associated with this thread"
		(cassoc th player-threads))

	(defun set-thread-player (name &optional (th (bt:current-thread)))
		"Set the player name associated with this thread"
		;;XXX somewhat ugly...
		(setf (cassoc th player-threads) name))

	(defun cleanup-player-threads ()
		"Remove threads of disconnected players"
		(dotimes (i (length player-threads))
			(let ((pt (nth i player-threads)))
				(when (equalp (second pt) "terminated")
					(bt:join-thread (first pt))
					(setf (cdr (nth (1- i) player-threads))
						(nth (1+ i) player-threads))))))
	
	(defun update-loop ()
		"The main loop, updating the world in the background"
		;;XXX split this up into two or more functions, to be run by
		;; different threads? (e.g. player- & world-update threads)
		(logf 3 "UPDATE ~S" uptime)
		;;Update all items and occupants in each patch
		(dotimes (y (world-size))
			(dotimes (x (world-size))
				(unless running (return-from update-loop))
				(when (patch-occupant (coord x y))
					(update (patch-occupant (coord x y))))
				(dolist (i (patch-items (coord x y)))
					(update i))))
		;;Update all items each player has
		;;TODO
		;;Update the world map
		;;FIXME
		;;Do cleanup work
		(when (zerop (rem uptime 20)) (cleanup-player-threads))
		;;Save the world and start over
		(save-world) ;XXX not yet implemented
		(incf uptime)
		(sleep (/ *framerate* 1000))
		(when running (update-loop))) ;;requires Tail-Call Optimization

	(defun run-server ()
		"Start a server, listening for connections"
		(usocket:with-socket-listener (socket "127.0.0.1" *port*)
			(while running
				(usocket:wait-for-input socket)
				(when (eq (usocket:socket-state socket) ':read)
					;;XXX give player threads unique names again?
					(let ((thread (bt:make-thread
									  #'(lambda ()
											(handle-connection socket))
									  :name "player-thread")))
						(setf player-threads
							(cons (list thread "anon") player-threads))
						(sleep 1)))))) ;;give the socket a chance to connect

	(defun handle-connection (socket)
		"Answer requests until the player disconnects"
		(usocket:with-connected-socket (conn (usocket:socket-accept socket))
			(logf 3 "~&SERVER: received a connection") ; cf. `get-peer-name'
			(do* ((sockstr (usocket:socket-stream conn))
					 (request (read-line sockstr NIL) (read-line sockstr NIL)))
				((or (not running) (null request)) (logout))
				(format sockstr "~S~%" (to-string (answer request)))
				(finish-output sockstr)))))

(defun answer (request)
	"Dispatch on the functions registerd in `*API*'"
	;;XXX potential problem with reading all user-received symbols into memory
	(let* ((reqelts (split-string request #\space))
			  (cmd (car reqelts))
			  (args (cdr reqelts)))
		(logf 4 "SERVER: received request ~S" reqelts)
		(if (member cmd (keys *API*) :test #'equalp)
			;;XXX Surely there must be a way to simplify the next few lines?!
			(if (and (equalp (thread-player) "anon")
					(not (or (equalp cmd "login") (equalp cmd "signup"))))
				"ERROR: not logged in"
				(apply (cassoc cmd *API* :test #'equalp) args))
			"ERROR: unknown command")))

;;; COMMUNICATION FUNCTIONS

;;NOTE: all following functions receive string arguments and must convert
;; them as needed

(defun login (name passwd)
	"Log this player in"
	;;XXX name and passwd are converted to symbols by `answer'! - not currently
	(logf 3 "SERVER: ~A is trying to log in" name)
	(let ((p (get-player name)))
		(cond ((not p) "ERROR: nonexistent player")
			((not (equalp passwd (player-password p))) "ERROR: bad password")
			(T (setf (player-online p) T)
				(setf (patch-occupant ;;TODO check for previous occupants
						  (coord (.x (player-human p)) (.y (player-human p))))
					(player-human p))
				(set-thread-player name)
				(logf 2 "SERVER: player ~A logged in" name)
				name))))

(defun logout ()
	"Log the player out again"
	(let ((p (get-player (thread-player))))
		(when p
			(setf (player-online p) NIL)
			(setf (patch-occupant
					  (coord (.x (player-human p)) (.y (player-human p))))
				NIL) ;;TODO set to "statue of <player>"
			(logf 2 "SERVER: player ~A logged out" (thread-player))
			(set-thread-player "terminated"))))

(defun create-player (name passwd)
	"Create and log in a new player"
	(if (get-player name) "ERROR: player exists"
		(progn
			(add-player name passwd)
			(login name passwd))))

(defun get-map (swidth sheight)
	"Return a 3d array (x-coord, y-coord, character/colour) of the visible map"
	;;TODO It's too inefficient to compile a new map for every player at every
	;; request. Keep a central map?
	;;FIXME exhausts the heap?! -> only return one patch char at a time
	;;XXX implement of "field of view" for each player?
	(let* ((plr (player-human (get-player (thread-player))))
			  (width (read-from-string swidth))
			  (height (read-from-string sheight))
			  (x0 (- (.x plr) (halve width)))
			  (y0 (- (.y plr) (halve height)))
			  (submap (make-array (list width height 2))))
		(dotimes (h height)
			(dotimes (w width)
				(let ((p (coord (+ w x0 1) (+ h y0 1)))
						 (next-char #\space) (next-col ':black))
					(if (and p (patch-occupant p))
						(setf next-char (.char (patch-occupant p))
							next-col (.color (patch-occupant p)))
						(when p (setf next-char (biome-char (patch-biome p))
									next-col (biome-col (patch-biome p)))))
					(setf (aref submap w h 0) next-char
						(aref submap w h 1) next-col))))
		;;XXX Arrays are pretty-printed with linebreaks, this causes a
		;; client-side error (as the client only expects one line).
		;; The following code takes apart such a pretty print and puts it
		;; back together without linebreaks. However, this means that the
		;; server returns a map string enclosed in _two_ quotation marks,
		;; so the client has to perform an additional call to `read-from-string`
		(string-from-list (split-string (to-string submap) #\newline) "")))

(defun describe-patch (&optional (x 0) (y 0))
	"Return a list of lines describing the patch at these coordinates."
	;;FIXME throws an out of bounds error somewhere on a string
    (let* ((plr (player-human (get-player (thread-player))))
			  (p (coord (+ x (.x plr)) (+ y (.y plr)))))
		(list (string-upcase (biome-name (patch-biome p))) ""
			(format NIL "~A / ~A" (first (patch-pos p)) (second (patch-pos p)))	""
			(format NIL "The ground here is ~A." (biome-ground (patch-biome p)))
			(when (patch-occupant p) ;TODO players -> "$name is here."
				(format NIL "There is ~A here."
					(leading-vowel (.name (patch-occupant p)))))
			(when (patch-items p)
				(format NIL "The following items are here:~A *~A" #\newline
					(string-from-list (mapcar #'.name (patch-items p)))
					(format NIL "~%  *"))))))

(defun move-player (dir)
	"Move a player in the given direction"
	(let ((plr (player-human (get-player (thread-player)))))
		(cond ((equalp d "n") (move plr 'n))
				  ((equalp d "ne") (move plr 'ne))
				  ((equalp d "e") (move plr 'e))
				  ((equalp d "se") (move plr 'se))
				  ((equalp d "s") (move plr 's))
				  ((equalp d "sw") (move plr 'sw))
				  ((equalp d "w") (move plr 'w))
				  ((equalp d "nw") (move plr 'nw))
				  (T "ERROR: Invalid move direction ~S" dir))))

(defparameter *API*
	;; An alist of API commands and their corresponding functions
	;;XXX move all listed functions to another file?
	(list (list "login" #'login)
		(list "signup" #'create-player)
		(list "map" #'get-map)
		(list "describe-patch" #'describe-patch)
		(list "move" #'move-player)))