;;;;
;;;; 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 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")
					;;FIXME throws an error when i==0
					(bt:join-thread (first pt))
					(if (zerop i)
						(setf player-threads (cdr player-threads))
						(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 100)) (cleanup-player-threads))
		;;Save the world and start over
		(save-world) ;XXX not yet implemented
		(incf uptime)
		(sleep (/ *framerate* 1000))
		;;CAVE requires Tail-Call Optimization (not provided by ABCL, otherwise no problem)
		(when running (update-loop)))

	(defun run-server ()
		"Start a server, listening for connections"
		;;TODO wrap in an `unwind-protect' clause
		;; (or is that implicit in `with-socket-listener'?
		(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)
		;; Make sure the request is valid
		(cond ((not (member cmd (keys *API*) :test #'equalp))
				  "ERROR: unknown command")
			((and (equalp (thread-player) "anon")
				 (not (or (equalp cmd "login") (equalp cmd "signup"))))
				"ERROR: not logged in")
			((eq (third (assoc cmd *API* :test #'equalp)) 'ACTION)
				;; Make sure each player only executes one action per turn
				;;XXX This needs some more thinking about
				(symbol-macrolet ((age (age-of-the-world))
									 (am (player-last-move
											 (get-player (thread-player)))))
					(if (< am age)
						(progn (setf am age)
							(apply (cassoc cmd *API* :test #'equalp) args))
						(progn (logf 4 "SERVER: dropped request") ""))))
			(T (apply (cassoc cmd *API* :test #'equalp) args)))))

;;; 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 a "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))
					;;FIXME crashes if occupant moves away between the next
					;; two calls...
					(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~%~%INVENTORY~%~%Holding: ~A~%"
				(.hunger p)
				(if (.tool p) (.name (.tool p)) ""))
			(string-from-list
				(loop for i in (.inventory p)
					count i into n
					collect (format NIL "~%~S) ~A (~S)"
								n (if (first i) (.name (first i)) " - ")
								(second i)))))))

(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));; (error "random error")) ;(test error)
				  ((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
	;; The third symbol designates the request type
	;;XXX move all listed functions to another file?
	(list (list "login" #'login 'CONNECTION)
		(list "signup" #'create-player 'CONNECTION)
		(list "map" #'get-map 'INFORMATION)
		(list "describe-patch" #'describe-patch 'INFORMATION)
		(list "describe-player" #'describe-player 'INFORMATION)
		(list "move" #'move-player 'ACTION)
		(list "messages"
			#'(lambda () (collect-messages (get-player (thread-player))))
			 'INFORMATION)))