;;;
;;; This is a personal utility module that I use in most of my Common Lisp
;;; projects. It originated in the Atlantis project, but has been used many
;;; times since and evolved accordingly.
;;;
;;; Licensed under the terms of the MIT license.
;;; author: Daniel Vedder
;;; date: 09/05/2015
;;;

;;; MACROS

(defmacro debugging (str &rest format-args)
	"If *debugging* is true, print str"
	`(when *debugging* (format t ,str ,@format-args)))

(defmacro logging (str &rest format-args)
	"Write an entry to *logfile*"
	`(write-to-file (format NIL ,str ,@format-args) *logfile* T))

(defmacro set-list (value &rest var-list)
	"Set each symbol in var-list to value"
	(do* ((expr (list 'setf)) (vl var-list (cdr vl)) (var (car vl) (car vl)))
		((null vl) expr)
		(setf (cdr (last expr)) (list var))
		(setf (cdr (last expr)) (list value))))
		
(defmacro input (&rest vars)
	"Take input from terminal and store each element in a passed variable"
	;; XXX Add a prompt parameter again?
	`(progn
		 (format t "~&>>> ")
		 (set-list (read) ,@vars)
		 (first (list ,@vars))))

(defmacro input-string (&optional (var (gensym)))
	"Read a string input line"
	`(progn
		 (format t "~&>>> ")
		 (setf ,var (read-line))
		 ,var))

(defmacro while (condition &body body)
	"An implementation of a while loop as found in other languages"
	`(do ()
		 ((not ,condition) NIL)
		 ,@body))

(defmacro != (object1 object2 &key (test 'eql))
	"A not-equals macro to save some typing"
	`(not (,test ,object1 ,object2)))

(defmacro cassoc (entry table &key (test #'eql))
	"Returns (car (cdr (assoc entry table)))"
	`(car (cdr (assoc ,entry ,table :test ,test))))

(defmacro safe-nth (index lst)
	"Return (nth index lst), or NIL if index is out of range"
	`(if (> ,index (1- (length ,lst)))
		 NIL (nth ,index ,lst)))

(defmacro safe-aref (vector index)
	"Return (aref vector index), but return NIL if out of range"
	`(if (> ,index (1- (length ,vector)))
		 NIL (aref ,vector ,index)))

(defmacro dovector ((element vector &optional (return-variable NIL)) &body body)
	"A macro analogous to dolist"
	(let-gensyms (index)
		`(do* ((,index 0 (1+ ,index))
				  (,element (safe-aref ,vector ,index)
					  (safe-aref ,vector ,index)))
			 ((= ,index (length ,vector)) ,return-variable)
			 ,@body)))

;;; FUNCTIONS

;; Some of these functions are probably quite inefficient (lots of consing)

(defun remove-first-if (fn lst)
	;;FIXME isn't this identical to `remove-if'?
	"Remove the first element in a list that satisfies the given predicate"
    (cond ((null lst) NIL)
		((funcall fn (car lst))	(cdr lst))
		(T (cons (car lst) (remove-first-if fn (cdr lst))))))

(defun average (&rest numbers)
	"Compute the average of the given numbers"
	(/ (reduce #'+ numbers) (length numbers)))

(defun halve (n &optional (round-fn 'round))
	"Halve a given number and round it to an integer."
	(let ((half (/ n 2)))
		(cond ((eq round-fn 'up) (ceiling half))
			((eq round-fn 'down) (floor half))
			(T (round half)))))

(defun keys (assoc-list)
	"Return a list of the keys in an association list"
	(if (null assoc-list) NIL
		(cons (car (car assoc-list)) (keys (cdr assoc-list)))))

(defun build-symbol (&rest components)
	"Concatenate the passed components into a single symbol"
	(read-from-string (string-from-list components :sep "")))

(defun symbol-to-string (sym)
	"Convert a symbol to a string, exchanging dashes for spaces"
	(string-from-list
		(split-string (string-downcase (string sym)) #\-) #\space))		

(defun letter-in-string (letter str)
	"Is this letter in this string?"
	(dotimes (i (length str) NIL)
		(when (equalp (aref str i) letter) (return T))))

;; TODO change &optional to &key (and figure out why the heck that doesn't
;; work - clisp bug?), add null-filler keyword
(defun string-from-list (lst &optional (separator #\space))
	"Put all elements of lst into a single string, separated by the separator"
	(cond ((null lst) "")
		((= (length lst) 1) (to-string (car lst)))
		(T (concatenate 'string (to-string (first lst)) (to-string separator)
			(string-from-list (cdr lst) separator)))))

(defun split-string (str separator)
	"Split the string up into a list of strings along the separator character"
	(cond ((equalp str (to-string separator)) NIL)
		((zerop (count-instances separator str)) (list str))
		(T (let ((split-elt (cut-string str (position separator str))))
			   (cons (first split-elt)
				   (split-string (second (cut-string (second split-elt) 1))
					   separator))))))

(defun cut-string (s i)
	"Cut string s in two at index i and return the two substrings in a list"
	(if (or (minusp i) (> i (length s))) s
		(let ((s1 (make-string i)) (s2 (make-string (- (length s) i))))
			(dotimes (c (length s) (list s1 s2))
				(if (> i c)
					(setf (aref s1 c) (aref s c))
					(setf (aref s2 (- c i)) (aref s c)))))))

(defun char-list-to-string (char-list)
	"Convert a character list to a string"
	(let ((s (make-string (length char-list) :initial-element #\SPACE)))
		(dotimes (i (length char-list) s)
			(setf (aref s i) (nth i char-list)))))

(defun trim-whitespace (s)
	"Trim off spaces and tabs before and after string s"
	(string-trim '(#\space #\tab) s))

(defun to-string (x)
	"Whatever x is, convert it into a string"
	(cond ((stringp x) x)
		((or (symbolp x) (characterp x)) (string x))
		(t (format NIL "~S" x))))

(defun leading-vowel (noun)
	"Return noun prepended with 'a' or 'an', depending on its first letter."
	(format NIL "~A ~A"
		(if (member (char noun 0) '(#\a #\e #\i #\o #\u)) "an" "a")
		noun))

(defun break-lines (lines width &optional (indent ""))
	"Take a list of lines and break any that are too long."
	(do* ((ls lines (cdr ls)) (l (car ls) (car ls)) (result NIL))
		((null ls) result)
		(if (<= (length l) width)
			(setf result (append result (list l)))
			(setf ls (append (list nil (first (cut-string l width))
								 (concatenate 'string (to-string indent)
									 (second (cut-string l width))))
									 (cdr ls))))))

(defun extract-elements (str)
	"Extract all Lisp elements (strings, symbols, numbers, etc.) from str"
	(multiple-value-bind (next-element i) (read-from-string str nil)
		(if (null next-element) NIL
			(cons next-element
				(extract-elements (second (cut-string str i)))))))

(defun count-instances (search-term search-sequence &key (test #'eql))
	"Count the number of instances of search-term in search-sequence"
	(let ((count 0))
		(dotimes (i (length search-sequence) count)
			(when (funcall test search-term (elt search-sequence i))
				(incf count)))))

(defun most-common-element (lst &key (test #'eql))
	"Return the most common element in this list and how often it appears"
	;;This function has multiple return values!
	;;In case of multiple mces, return the one that appears first
	(let ((elements-counted NIL) (max 0) (mce NIL))
		(dolist (e lst (values mce max))
			(unless (member e elements-counted :test test)
				(let ((count (count-instances e lst :test test)))
					(when (> count max)
						(setf max count)
						(setf mce e)))
				(setf elements-counted (append elements-counted (list e)))))))

(defun nths (n lst)
	"Take in a list of lists and return the nth element of each"
	(when (and lst (listp (car lst)))
		(cons (nth n (car lst)) (nths n (cdr lst)))))

(defun set-p (lst)
	"Is lst a set (i.e. no elements occur more than once)?"
	(cond ((null lst) T)
		((member (car lst) (cdr lst)) NIL)
		(T (set-p (cdr lst)))))

(defun range (stop &key (start 0) (step 1))
	"Return a list of numbers from start to stop"
	;;XXX Surely this must exist as a function in Common Lisp already,
	;; I just don't know what it's called...
	(unless (>= start stop)
		(cons start (range stop :start (+ start step) :step step))))

(defun to-list (vector &optional (next-elt 0))
	"Turn the vector into a list"
	(if (= next-elt (1- (length vector))) NIL
		(cons (aref vector next-elt) (to-list vector (1+ next-elt)))))

(defun cut-list (l i)
	"Cut list l in two at index i and return the two sublists in a list"
	(if (or (< i 1) (> i (length l))) l
		(do* ((lst2 l (cdr lst2))
				 (lst1 (list (car lst2)) (append lst1 (list (car lst2)))))
			((= i (length lst1)) (list lst1 (cdr lst2))))))

(defun random-elt (seq)
	"Return a random element of this sequence"
	(elt seq (random (length seq))))

(defun random-offset (n max-offset)
	"Return n plus a random offset"
	(+ n (- (random (* 2 max-offset)) max-offset)))

(defun chancep (p)
	"Do a random test with 1/p probability of success."
	(= 1 (random p)))

(defun probabilityp (percent)
	"Do a random test, with the percentage giving the success probability"
	;;Accuracy: 0.1
	(> percent (/ (random 1000) 10)))

(defun load-text-file (file-name)
	"Load a text file into a list of strings (representing the lines)"
	(with-open-file (f file-name)
		(do* ((line (read-line f nil nil)
				  (read-line f nil nil))
				 (file-lines (list line) (append file-lines (list line))))
			((null line) file-lines))))

(defun print-text-file (file-name)
	"Print out the contents of this text file"
	(dolist (line (load-text-file file-name))
		(unless (null line) (format t "~%~A" line))))

(defun write-to-file (text filename &optional (append NIL))
	"Write text (a string or list of strings) to the specified file"
	(let ((text-list (if (listp text) text (list text)))
			 (f (if append
					(open filename :direction :output
						:if-exists :append :if-does-not-exist :create)
					(open filename :direction :output :if-exists :supersede))))
		(dolist (line text-list)
			(format f "~&~A~&" line))
		(close f)))

(defun write-list (lst filename)
	"Write a list to file, one entry per line."
	(let ((f (open filename :direction :output)))
		(dolist (i lst) (format f "~&~S" i))
		(close f)))

(defun time-stamp (&optional (time-t (get-universal-time)))
	(let ((time (multiple-value-list (decode-universal-time time-t))))
		(format NIL "~S/~S/~S ~S:~S"
			(nth 3 time) (nth 4 time) (nth 5 time) (nth 2 time) (nth 1 time))))

(defun build-symbol (&rest components)
	"Concatenate the passed components into a single symbol"
	(read-from-string (string-from-list components "")))

(defun make-list-function (container-type &optional (add-s t))
	"Return a function to return a list of the names of all objects of the
specified type in the container struct"
	#'(lambda (object-type container)
		  (let* ((get-objects (symbol-function
								  (build-symbol container-type "-"
									  object-type (if add-s "s" ""))))
					(get-object-name (symbol-function
										 (build-symbol object-type "-name")))
					(objects (funcall get-objects container)) (name-list NIL))
			  (dolist (o objects name-list)
				  (when (stringp o) (return objects))
				  (setf name-list
					  (cons (funcall get-object-name o) name-list))))))

;; DEPRECATED - replace with number-menu
(defun choose-number-option (option-list)
	"The user chooses one out of a list of options, the index is returned"
	(dotimes (i (length option-list))
		(format t "~&~S) ~A" (1+ i) (nth i option-list)))
	(simple-input choice)
	(while (or (not (numberp choice)) (< choice 1)
			   (> choice (length option-list)))
		(format t "~&Invalid choice! Please choose again:")
		(simple-input choice))
	(1- choice))

;; DEPRECATED - replace with number-menu
(defun choose-option (option-list)
	"Like choose-number-option, but return the value of the choice"
	;; Basically just a utility wrapper
	(nth (choose-number-option option-list) option-list))

;; SUPERSEDES choose-number-option AND choose-option!
(defun number-menu (entries &optional (header "Please choose an option:"))
	"Display a number-based menu and act on the user's choice"
	;; The param entries is a list of lists in the form
	;; (<description-string> <entry function>)
	(format t "~&~A" header)
	(dotimes (i (length entries))
		(format t "~&~S) ~A" (1+ i) (first (nth i entries))))
	(format t "~&>>> ")
	(setf choice (read))
	(while (or (not (numberp choice)) (> choice (length entries)) (< choice 1))
		(format t "~&Invalid choice! Please choose again:~%>>> ")
		(setf choice (read)))
	(funcall (second (nth choice entries))))