;;;;
;;;; 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 :name name
								 :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))
	;;XXX do we need to keep track of the current world map (i.e. patch chars
	;; and colours),or 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)) ;;XXX right place?
				(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))) ;;CAVE 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))
				;;FIXME Errors must be wrapped in double quotation marks
				;; (client uses `read')
				(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? -> XXX Is this indeed the case?
	;;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 submap)
			(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))))))

(defun describe-patch (&optional (x 0) (y 0))
	"Return a multi-line string describing the patch at these coordinates."
    (let* ((plr (player-human (get-player (thread-player))))
			  (p (coord (+ x (.x plr)) (+ y (.y plr)))))
		(format NIL "~A~%~%~A / ~A~%~%The ground here is ~A.~A~A"
			(string-upcase (biome-name (patch-biome p)))
			(first (patch-pos p)) (second (patch-pos p))
			(biome-ground (patch-biome p))
			(if (and (patch-occupant p) (not (typep (patch-occupant p) 'human)))
				;;XXX At the moment, this is never called - the player cannot
				;; enter an occupied patch... -> requires "look mode"
				;;TODO players -> "$name is here."
				(format NIL "~%~%There is ~A here."
					(leading-vowel (.name (patch-occupant p))))
				"" )
			(if (null (patch-items p)) ""
				(format NIL "~%~%The following items are here:~% *~A"
					(string-from-list (mapcar #'.name (patch-items p))
						(format NIL "~%  *")))))))

(defun describe-player ()
	"Return a multi-line string describing the current player."
	(let ((p (player-human (get-player (thread-player)))))
		(sconc
			(format NIL "~A~%~%Health: ~S / ~S~%Experience: ~S (Level ~S)"
				(string-upcase (.name p)) (.health p) (.max-health p)
				(.xp p) (.level p))
			(format NIL "~%~%Strength: ~S Dexterity: ~S~%Intelligence: ~S"
				(.strength p) (.dex p) (.int p))
			(format NIL "~%~%Hunger: ~S~%Carried items: ~S~%Holding: ~A"
				(.hunger p)
				(length (remove-if #'(lambda (x) (or (null (first x))
													 (zerop (second x))))
							(.inventory p))) ;;XXX Show all slots?
				(if (.tool p) (.name (.tool p)) "")))))

(defun move-player (dir)
	"Move a player in the given direction"
	(let ((plr (player-human (get-player (thread-player)))))
		;;TODO If path is blocked, show a message
		;;XXX replace cond with read-from-string?
		(cond ((equalp dir "n") (move plr 'n))
				  ((equalp dir "ne") (move plr 'ne))
				  ((equalp dir "e") (move plr 'e))
				  ((equalp dir "se") (move plr 'se))
				  ((equalp dir "s") (move plr 's))
				  ((equalp dir "sw") (move plr 'sw))
				  ((equalp dir "w") (move plr 'w))
				  ((equalp dir "nw") (move plr 'nw))
				  (T (format NIL "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 "describe-player" #'describe-player)
		(list "move" #'move-player)
		(list "messages"
			#'(lambda () (collect-messages (get-player (thread-player)))))))