;;;;
;;;; An implementation of the diamond landscape generation algorithm.
;;;; Daniel Vedder, 14/9/2018
;;;;

(defvar *world-size* 7)
(defvar *size* (1+ (expt 2 *world-size*)))
(defvar *base-height* 50)

(defvar *world* NIL)

;;; WORLD RELATED FUNCTIONS

(defun init-matrix (&optional (size *size*))
	(unless (integerp (log (1- size) 2)) (error "~&Unusable size"))
	(format t "~&Creating a ~Sx~S world matrix." size size)
	(do ((y 0 (1+ y)) (world NIL) (row NIL NIL))
		((= y size) world)
		(dotimes (x size)
			(setf row (cons NIL row)))
		(setf world (append world (list row)))))

(defun getv (x y &optional (world *world*))
	"Return the height value 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))))

(defun setv (x y value &optional (world *world*))
	"Set the height value at the given coordinates if possible"
	(unless (or (< x 0) (< y 0) (> x (length world)) (> y (length world)))
		(setf (nth x (nth y world)) value)))

(defun dist (x1 y1 x2 y2)
	"Calculate the distance between these two points"
	(max (abs (- x1 x2)) (abs (- y1 y2))))

(defun print-world (&optional (world *world*) (stream t))
	(dolist (row world)
		;; XXX This would be quicker with (string-from-list), but I
		;; don't want to use util.lisp just yet
		(do ((x 0 (1+ x)) (xstr ""))
			((= x (length world)) (format stream "~&~A~%" xstr))
			(setf xstr (concatenate 'string xstr (unless (= x 0) ",")
						   (format NIL "~S" (nth x row)))))))

(defun save-topography (file-name &optional (world *world*))
	"Save the world topography as a csv file"
	(with-open-file (tf file-name :direction :output)
		(print-world world tf)))

;;; DIAMOND ALGORITHM FUNCTIONS

(defun avg (&rest values)
	"Calculate the average"
	(/ (reduce #'+ values) (length values)))

(defun displace (n &optional (maxpercent 20))
	"Displace a number by a random percentage"
	(let ((displacement (round (* n (/ maxpercent 100)))))
		(+ n (if (zerop displacement) 0
				 (- displacement (* 2 (random displacement)))))))

(defun midpoint (x1 y1 x2 y2)
	"Calculate the midpoint displacement"
	(let ((m (displace (round (avg (getv x1 y1) (getv x2 y2)))
				 (* 10 (dist x1 y1 x2 y2)))))
		(if (minusp m) 0 m)))

(defun diamond-step (&optional (world *world*) (minx 0) (miny 0)
				   (maxx (1- (length world))) (maxy (1- (length world))))
	"Carry out one step of the diamond algorithm"
	(let ((xm (avg minx maxx)) (ym (avg miny maxy)))
		(setv xm miny (midpoint minx miny maxx miny) world)
		(setv minx ym (midpoint minx miny minx maxy) world)
		(setv maxx ym (midpoint maxx miny maxx maxy) world)
		(setv xm maxy (midpoint minx maxy maxx maxy) world)
		(setv xm ym (round (avg (midpoint xm miny xm maxy)
							   (midpoint minx ym maxx ym)))
			world)
		(unless (= 1 (dist minx miny xm ym))
			(diamond-step world minx miny xm ym)
			(diamond-step world xm miny maxx ym)
			(diamond-step world minx ym xm maxy)
			(diamond-step world xm ym maxx maxy))))

(defun diamond (&optional (world *world*) (base-height *base-height*))
	"Initialise and begin the diamond algorithm"
	(setv 0 0 (displace base-height))
	(setv 0 (1- (length world)) (displace base-height))
	(setv (1- (length world)) 0 (displace base-height))
	(setv (1- (length world)) (1- (length world)) (displace base-height))
	(diamond-step world))


(defun create-world (worldname &optional (world-size *world-size*))
	(setf *size* (1+ (expt 2 world-size)))
	(setf *world* (init-matrix *size*))
	(diamond)
	(save-topography (concatenate 'string "worlds/" worldname ".csv")))

;; Initialize the random state (which would otherwise not be very random...)
(setf *random-state* (make-random-state t))