;;;;
;;;; 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
;;;;
;;XXX utility function during development, remove later
(defun dt (&optional (n 0))
(bt:destroy-thread (nth n (bt:all-threads))))
(in-package :naledi-ya-africa)
;; TODO save and load functions
;; XXX Will probably require `make-load-form-saving-slots'
;;; PLAYER LIST
(let ((players NIL))
(defun reset-players () (setf players NIL))
(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 save-players (file-name)
;;TODO
))
(defun online-p (name)
(let ((p (get-player name)))
(when p (player-online p))))
;;; WORLD OBJECT
(let ((world NIL))
(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"
(debugging "~&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"))
(logging "SERVER: initialized")))
(defun terminate ()
;;TODO do some error catching if the threads no longer exist
(logging "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 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))
;;TODO remove threads named `terminated'
(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)
(logging "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
;;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)
(let ((thread (bt:make-thread
#'(lambda ()
(handle-connection socket))
:name "anonymous")))
(setf player-threads
(cons thread 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))
(logging "~&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)))))
(defparameter *API*
;; An alist of API commands and their corresponding functions
'((login #'login)
(map #'get-map)
(signup #'create-player)
(describe-patch #'describe-patch)
(move #'move-player)))
(defun answer (request)
"Dispatch on the functions registerd in `api'"
(let* ((reqelts (extract-elements request))
(cmd (car reqelts))
(args (cdr reqelts)))
(logging "SERVER: received request ~S" reqelts)
(when (member cmd (keys *API*) :test #'eq)
(if (and (equalp (bt:thread-name (bt:current-thread)) "anonymous")
(not (member cmd '(login signup) :test #'eq)))
"ERROR: not logged in"
(progn
(logging "SERVER: calling function ~S with args ~S"
(cassoc cmd *API* :test #'eq) args)
(apply (cassoc cmd *API* :test #'eq) args))))))
;;; COMMUNICATION FUNCTIONS
(defun login (name passwd)
"Log this player in"
;;XXX name and passwd are converted to symbols by `answer'!
(logging "SERVER: ~A is trying to log in")
(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))
(setf (bt:thread-name (bt:current-thread)) name)
(logging "SERVER: player ~A logged in" player)
name))))
(defun logout ()
"Log the player out again"
(let ((p (get-player (bt:thread-name (bt:current-thread)))))
(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>"
(logging "SERVER: player ~A logged out" player)
(setf (bt:thread-name (bt:current-thread)) "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 (width height)
"Return a 3d array (x-coord, y-coord, character/colour) of the visible map"
(let* ((plr (player-human
(get-player (bt:thread-name (bt:current-thread)))))
(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))))
submap))
(defun describe-patch (coords)
"Return a list of lines describing the patch at these coordinates."
(let ((p (coord (first coords) (second coords))))
(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"
;;TODO
)
