;;;;; This file contains some of my experimentation while I was learning Common Lisp

(defmacro hf (&body body)
  "(hf ...) = (lambda (h) ...)"
  `(lambda (h) ,@body))

(defmacro with-gensyms (gensyms &rest body)
  `(let ,(loop for x in gensyms collecting `(,x (gensym)))
    ,@body))

(defun id (x) x)

(defmacro defhash (name &rest default-hashtable-arguments)
  "(defhash myhash) creates a hash table that can be accessed with (setf (myhash x) y) and (myhash x)
instead of (setf (gethash x myhash) y) and (gethash x myhash).  Also allows the setting and getting
of nested hash tables, i.e. (setf (myhash x y z) w) and (myhash x y z).  The hash table
itself is stored in the variable myhash."
  `(locally
       (declare (special ,name))
     (defparameter ,name (make-hash-table ,@default-hashtable-arguments))
     (defun ,name (&rest keys)
       (loop for x in (cons nil keys)
	  for y = ,name then
	  (multiple-value-bind (val present) (gethash x y)
	    (if (eq present nil)
		(return (values val present))
		val))
	  finally (return (values y t))))
     (defun (setf ,name) (value &rest keys)
       (if (eq keys nil)
	   (setf ,name value)
	   (loop for x = (cons nil keys) then (cdr x)
	      for y = ,name then 
	      (multiple-value-bind (val present) (gethash (car x) y)
		(if (eq present nil)
		    (progn
		      (setf (gethash (car x) y) (make-hash-table ,@default-hashtable-arguments))
		      (gethash (car x) y))
		    val))
	      until (eq (cddr x) nil)
	      finally (progn (setf (gethash (cadr x) y) value)
			     (return value)))))
     ,name))

(defun show-hash-table (table &optional (show-function #'id))
  "Print a representation of a hash table as a list of (key value) pairs.
If a value is a hash table itself, recursively call show-hash-table on it.
Otherwise call show-function on it."
  (loop for x being the hash-keys in table
       collecting
       `(,(handler-case (funcall show-function x)
		    (SIMPLE-TYPE-ERROR ()
				       x) 
		    (SIMPLE-ERROR ()
				  x))
	 ,@(if (hash-table-p (gethash x table))
		(show-hash-table (gethash x table) show-function)
		(handler-case (list (funcall show-function (gethash x table)))
		    (SIMPLE-TYPE-ERROR ()
		      (list (gethash x table))) 
		    (SIMPLE-ERROR ()
		      (list (gethash x table))))))))


(defmacro m-incf (&rest args) 
  "(m-incf (x 3) y z (w 5)) increments x by 3, y by 1, and z by 1, and w by 5"
  `(progn ,@(loop for x on args by #'cddr collecting `(incf ,(car x) ,(or (cadr x) 1)))))

(defun reverse-num (num)
  "(reverse-num 123) = 321"
  (read (make-string-input-stream
	 (reverse (format nil "~a" num)))))

(defun scramble-list (list)
  "permutes the list randomly"
  (loop for length = (length list) then (- length 1)
     for y = list then (delete-if (constantly t) y :start x :end (1+ x))
     for x = (random length)
     collecting (elt y x)
     until (eql length 1)))

(defun all-permutations (last)
  "returns a list of all permutations of the given list"
  (if (eq last nil) '(nil)
      (mapcan #'id (loop for x from 0 to (- (length last) 1)
		      for y = (elt last x)
		      for z = (subseq last 0 x)
		      for q = (nthcdr x last)
		      collecting
			(mapcar (lambda (f) (cons (car q) f))
				(all-permutations (append z (cdr q))))))))

(defmacro f-defun (name args &rest body)
  "allows functions to be passed in the function namespace, using the &function keyword.
if you do (f-defun foo (&function x) (x 3)) 
and then call (foo (lambda (x) (+ x 1)))
the result will be 4"
  (let ((normalargs
	 (loop for x in args
	    when (not (eql x '&function)) collect x))
	(fargs
	 (loop for x in args
	    for fstart = (eql x '&function)
	    for fflag = (if fstart t fflag)
	    when (or (eql x '&optional)
		     (eql x '&rest)
		     (eql x '&key))
	    do (setf fflag nil)
	    if (and fflag (not fstart)) collect x)))
    `(defun ,name ,normalargs
       (labels
	   ,(loop for x in fargs
	       collecting (let ((xarg (gensym)))
			    `(,x (&rest ,xarg) (apply ,x ,xarg))))
	 ,@body))))

(defun enum-bin (n string pos num nums)
  "Produces a Gray code for n-digit binary numbers.  
Call like (enum-bin 4 nil 0 0 (make-hash-table))"
  (if (eql pos (expt 2 n)) (append (make-sequence 'list (- n 1) :initial-element 0)
				   (reverse string))
      (let ((v (mod (* num 2) (expt 2 n))))
	(or
	 (if (not (gethash v nums))
	     (prog2 (setf (gethash v nums) t)
		 (enum-bin n (cons 0 string)
			   (+ pos 1) v nums)
	       (setf (gethash v nums) nil))
	     nil)
	 (if (not (gethash (1+ v) nums))
	     (prog2 (setf (gethash (1+ v) nums) t)
		 (enum-bin n (cons 1 string)
			   (+ pos 1) (1+ v) nums)
	       (setf (gethash (1+ v) nums) nil))
	     nil)))))

(defun enum-base-k (k n string pos num nums)
  "Produce a binary Gray code for n-digit base-k numbers.
Call like (enum-base-k 3 4 nil 0 0 (make-hash-table))"
  (if (eql pos (expt k n)) (append (make-sequence 'list (- n 1) :initial-element 0) (reverse string))
      (let ((v (mod (* num k) (expt k n))))
	(loop for x from 0 to (- k 1)
	   for y = (if (not (gethash (+ x v) nums))
		       (prog2 (setf (gethash (+ x v) nums) t)
			   (enum-base-k k n (cons x string)
					(+ pos 1) (+ x v) nums)
			 (setf (gethash (+ x v) nums) nil))
		       nil)
	   if y do (return y)
	   finally (return nil))))
  )

(defmacro with-hash-value ((hash key value) &rest body)
  "Update the hash with the key-value pair and evaluate body,
afterwards returning the hash's value on key to the value it had prior
to executing the statement."
  (with-gensyms (x)
    `(let ((,x (gethash ,key ,hash)))
       (setf (gethash ,key ,hash) ,value)
       (unwind-protect
	    (progn ,@body)
	 (setf (gethash ,key ,hash) ,x)))))

(defun total-macroexpand-all (bodies)
  (loop for b in bodies
       collecting (total-macroexpand b)))

(defun total-macroexpand (body)
"Recursively macroexpands body, stepping inside special forms when appropriate, so that the resulting expression does not contain any macros"
  (let ((b (macroexpand body)))
    (cond ((atom b) b)
	  ((not (symbolp (car b)))
	   (cons (append (list (caar b) (cadar b))
			 (total-macroexpand-all (cddar b)))
		 (total-macroexpand-all (cdr b))))
	  ((special-operator-p (car b))
	   (case (car b)
	     ((block catch eval-when multiple-value-call the)
		 (append (list (car b) (cadr b))
			 (total-macroexpand-all (cddr b))))
	     ((let* symbol-macrolet flet macrolet labels let)
		    (append (list (car b) (loop for (x . y) in (cadr b)
					  collecting (cons x (total-macroexpand-all y))))
			       (total-macroexpand-all (cddr b))))
	     (return-from
	      (list (car b) (cadr b) (total-macroexpand (caddr b))))
	     (load-time-value
	      (list (Car b) (total-macroexpand (cadr b))))
	     (setq
	      (cons (car b)
		    (loop for x on (cdr b) by #'cddr
		       appending (list (car x) (total-macroexpand (cadr x))))))
	     ((locally tagbody multiple-value-prog1 throw if progn unwind-protect progv)
		 (cons (car b) (total-macroexpand-all (cdr b))))
	     ((go quote)
	       b)
	     (function
	      (if (atom (cadr b)) b
		  (list (car b) (append
				 (list (caadr b) (cadadr b))
				 (total-macroexpand-all (cddadr b))))))
	     (otherwise
	      (format t "error~%~a~%" b))))
	  (t
	   (cons (car b) (total-macroexpand-all (cdr b)))))))

(defmacro protected-reset (places-values &rest body)
  "temporarily sets each place to the corresponding value for the duration of body"
  (let ((temps (loop for x in places-values collecting (gensym))))
    `(let ,(loop for (x . y) in places-values
		for z in temps
		collecting `(,z ,x))
       ,@(loop for (x y) in places-values
	      collecting `(setf ,x ,y))
       (unwind-protect
	    ,@body
	 ,@(loop for (x . y) in places-values
	      for z in temps
	      collecting `(setf ,x ,z))))))


(defun monotonic-sequences (list)
  "Find all monotonically increasing subsequences of list"
  (if (eq list nil) '(nil)
      (let* ((first (car list))
	     (greater (loop for x in (cdr list)
			 when (>= x first) collect x))
	     (lesser (loop for x on (cdr list)
			when (< (car x) first) return x))
	     (msg (monotonic-sequences greater))
	     (msgf (mapcar (lambda (x) (cons first x)) msg))
	     (msl (monotonic-sequences lesser)))
	(remove-duplicates 
	 (append msg msgf msl) :test #'equalp))))

(defhash colors)
(defhash neighbors)
(defhash node-color)

(defun prep-neighbors ()
  (loop for x being the hash-keys in (colors)
     do (loop for y in (colors x)
	   do (setf (neighbors y) (remove-duplicates (append (neighbors y) (colors x)))))))

(defun prep-colors ()
  (loop for x in colors
     for y = (gensym)
     do (loop for z across x
     do (setf (colors z) (cons y (colors z))))
     collecting y))

(defun hamilton-solve (activenode moves nnodes)
  (if (eql nnodes 0) moves
      (loop for x in (neighbors activenode)
      if (not (dead x)) do
      (progn
	(setf (dead x) t)
	(let ((soln (hamilton-solve x (cons x moves) (- nnodes 1))))
	  (if soln (return soln) (setf (dead x) nil)))))))