;;; This software is being provided to you, the LICENSEE, by the
;;; Massachusetts Institute of Technology (M.I.T.), and the NEC Research
;;; Institute (NECI) under the following license.  By obtaining, using
;;; and/or copying this software, you agree that you have read,
;;; understood, and will comply with these terms and conditions:
;;; 
;;; Permission to use, copy, modify and distribute, including the right to
;;; grant others rights to distribute at any tier, this software and its
;;; documentation for research purposes only and without fee or royalty is
;;; hereby granted, provided that you agree to comply with the following
;;; copyright notice and statements, including the disclaimer, and that
;;; the same appear on ALL copies of the software and documentation,
;;; including modifications that you make for internal use or for
;;; distribution:
;;; 
;;; Copyright 1995 by the Massachusetts Institute of Technology.  All
;;; rights reserved.  Copyright 1995 by NEC Research Institute Inc. All
;;; rights reserved
;;; 
;;; THIS SOFTWARE IS PROVIDED "AS IS", AND M.I.T. and NECI MAKE NO
;;; REPRESENTATIONS OR WARRANTIES, EXPRESS OR IMPLIED.  By way of example,
;;; but not limitation, M.I.T. and NECI MAKE NO REPRESENTATIONS OR
;;; WARRANTIES OF MERCHANTABILITY OR FITNESS FOR ANY PARTICULAR PURPOSE OR
;;; THAT THE USE OF THE LICENSED SOFTWARE OR DOCUMENTATION WILL NOT
;;; INFRINGE ANY THIRD PARTY PATENTS, COPYRIGHTS, TRADEMARKS OR OTHER
;;; RIGHTS.
;;; 
;;; The name of the Massachusetts Institute of Technology or M.I.T., or
;;; NEC Research Institute, or NECI may NOT be used in advertising or
;;; publicity pertaining to distribution of the software.  Title to
;;; copyright in this software and any associated documentation shall at
;;; all times remain with M.I.T. and NECI, and USER agrees to preserve
;;; same.
;;; 

(in-package g)

(export '(*TIMES* RESET-TIME TIME-TOTALS DEFTIME DEFTIME-BY-RESULT PROGNTIME ADD-TIME! DEFMEMO 
          CLEAR-MEMOIZED-FUNCTION *VERY-LARGE-NUMBER*
	  ERROR-FUDGE DIV slice-list reslice-list ONE AWRITE WRITE-ARRAY FIRST-N FIRST-TEST 
          ;; SIGN
           REMLIST REMDUPS-AND-APPEND
	  DIFFERENT-RANDOM-BETWEEN ALL-ORDERED-NTUPLES ALL-NTUPLES ALL-INSERTIONS ALL-PERMUTATIONS ALL-COMBINATIONS
	  ;; REPEAT 
          LIST?
	  2LENGTH? MERGE-PARTITIONS PARTITION SORTED-INTERSECTION MAX-TEST RASTER-ARRAY-DIMENSIONS
	  TIMED-SORT TIMED-REMOVE TIMED-AREF2 FLET* COPY-ARRAY COPY-INTO-ARRAY COPY-INTO-BIT-ARRAY FLIP-ARRAY CONVERT-ARRAY CLEAR-ARRAY!
	  ARRAY-NULL-VALUE ARRAY-BITBLTABLE? BITBLTABLE-DIMENSIONS OR-ARRAYS WRITE-4D-ARRAY-AS-BINARY
	  FIND-ARRAY PROJECT-ARRAY BITS-IN-ELEMENT-TYPE TIMES-N-IS-FACTOR WHOLE? LENGTH= RESIZE-BINARY-RASTER
	  ROTATE-LIST ALL-ROTATIONS MULTI-MEMBER SCALE-IMAGE REALP
	  MAKE-CYCLE CYCLE-P CYCLE-LENGTH ROTATE-CYCLE-RIGHT ROTATE-CYCLE-LEFT CYCLE-CAR POP-CYCLE
	  PUSH-CYCLE DOCYCLE DOTIMES-CYCLE CYCLE-LIST CYCLE-NTH-RIGHT CYCLE-NTH-LEFT REMOVE-FROM-CYCLE
	  ADD-TO-CYCLE))

(defvar *TIMES* nil)

(defun RESET-TIME () (setf *TIMES* nil))

(defun TIME-TOTALS (&optional (times *times*))
  (loop for time in times
	doing
	(print (list (car time) :time-in-minutes (/ (round (/ (cadr time) 600)) 100.0)
	             :number-of-calls (caddr time)))))

(defmacro DEFTIME (proc-name args &rest body)
  (let ((time-var-name (gensym (symbol-name proc-name))))
    `(defun ,proc-name ,args
       (let ((,time-var-name (get-internal-real-time)))
	 (let ((result
		 (multiple-value-list
		   ,(cons 'progn body))))
	   (let ((,time-var-name (time-difference (get-internal-real-time) ,time-var-name)))
	     (add-time! (quote ,proc-name) ,time-var-name)
	     (apply #'values result)))))))


(defmacro DEFTIME-BY-RESULT (proc-name args &rest body)
  (let ((time-var-name (gensym (symbol-name proc-name))))
    `(defun ,proc-name ,args
       (let ((,time-var-name (get-internal-real-time)))
	 (multiple-value-bind (val1 val2 val3 val4 val5 val6 val7 val8)
	      ,(cons 'progn body)
	    (let ((,time-var-name (time-difference (get-internal-real-time) ,time-var-name)))
	       (add-time! (list (quote ,proc-name) val1) ,time-var-name)
	       (values val1 val2  val3 val4 val5 val6 val7 val8)))))))

(defmacro PROGNTIME (progn-name &rest exps)
  (let ((time-var-name (gensym (symbol-name progn-name))))
    `(let ((,time-var-name (get-internal-real-time)))
       (multiple-value-bind (val1 val2 val3 val4 val5 val6 val7 val8)
	   ,(cons 'progn exps)
	 (let ((,time-var-name (time-difference (get-internal-real-time) ,time-var-name)))
	   (add-time! (quote ,progn-name) ,time-var-name)
	   (values val1 val2 val3 val4 val5 val6 val7 val8))))))

(defun TIME-DIFFERENCE (t1 t2) (- t1 t2))

(defun ADD-TIME! (name time)
  (let ((time-pair (assoc name *TIMES* :test #'equal)))
    (if (null time-pair)
	(setf *TIMES* (cons (list name time 1) *TIMES*))
	(progn
	  (rplaca (cdr time-pair) (+ time (cadr time-pair)))
	  (rplaca (cddr time-pair) (1+ (caddr time-pair)))))))

(defun CLEAR-MEMOIZED-FUNCTION (fun-name)
  (if (functionp (intern (string-append "CLEAR-MEMO-" fun-name)))
      (funcall (intern (string-append "CLEAR-MEMO-" fun-name)))
      nil))

(defmacro DEFMEMO (proc-name args &rest body)
  (let ((memo-table (make-hash-table :test #'equal)))
    `(progn
       (defun ,(intern (string-append "CLEAR-MEMO-" proc-name)) () (not (not (clrhash ,memo-table))))
       (defun ,proc-name ,args
	 (let ((lookup (gethash ,(cons 'list args) ,memo-table)))
	   (if lookup (apply #'values lookup)
	       (let ((res-list (multiple-value-list ,(cons 'progn body))))
		 (setf (gethash ,(cons 'list args) ,memo-table) res-list)
		 (apply #'values res-list))))))))

(defvar *VERY-LARGE-NUMBER* 9999999999)

(defvar ERROR-FUDGE .00001)

(defun div (x y) (if (= y 0) *VERY-LARGE-NUMBER* (/ x y)))

;(defun FILTER (proc lst &rest arg-lists)
;  (if (null arg-lists)
;      (loop for mem in lst
;	    appending
;	      (if (apply proc (list mem)) (list mem)))
;      (loop for mem in lst
;	     for args in (slice-list arg-lists (length lst))
;	    appending
;	      (if (apply proc (cons mem args)) (list mem)))))

(defun SLICE-LIST (lst-of-lsts res-lengths)
  (if (zerop res-lengths) nil
      (cons (loop for lst in lst-of-lsts
		  collecting
		    (if (consp lst) (car lst) lst))
	    (slice-list (loop for lst in lst-of-lsts
			      collecting
				(if (consp lst) (cdr lst) lst)) (1- res-lengths)))))

(defun RESLICE-LIST (list-of-lists)
  (let ((list-of-lists (copy-list list-of-lists)))
    (loop until (loop for list in list-of-lists
		      never list)
	  collecting
	  (loop for lists on list-of-lists
		collecting
		(pop (car lists))))))

(defun ONE (x) (ignore x) 1)

(defun AWRITE (array) (write array :array t))

(defun WRITE-ARRAY (array x1 y1 x2 y2)
  (loop for j from y1 to y2
	doing
    (format t "~%~A:" j)
    (loop for i from x1 to x2
	  doing
      (format t " ~A" (aref array i j)))))

(defun FIRST-N (n lst) (loop for m in lst for i from 1 to n collecting m))

(defun FIRST-TEST (lst test)
  (if (null lst) nil
      (if (apply test (list (car lst))) (car lst)
	  (first-test (cdr lst) test))))

(defun ROTATE-LIST (n lst)
  "Assumes (< n (length lst))"
  (append (nthcdr n lst)
	  (loop for i in lst
		repeat n
		collecting i)))

(defun ALL-ROTATIONS (lst)
  (loop for i from 0 below (length lst)
	collecting
	(rotate-list i lst)))

(defun MULTI-MEMBER (item lst &key (test #'eql) (key #'identity))
  (loop for item2 in lst
	when (funcall test item (funcall key item2))
	  collect item2))

(defun SIGN (x)
  (if (< x 0)
      -1
      1))

;;; Remove all occurrences of lst1 from lst2
(defun REMLIST (lst1 lst2 &key (test #'eql))
  (remove lst1 lst2 :test (lambda (lst item) (member item lst :test test))))

;;; Like remdups, but we know that each list contains no duplicates.
(defun REMDUPS-AND-APPEND (lsts)
  (flet ((thing-in-list-of-lists (thing list-of-lists)
	   (loop for lst in list-of-lists
		 thereis
		   (member thing lst))))
    (loop for lst in lsts
	  for rest on lsts
	  appending
	    (if (null (cdr rest)) lst
		(loop for mem in lst
		      appending
			(if (thing-in-list-of-lists mem (cdr rest))
			    nil
			    (list mem)))))))

;;; We assume start and end are integers, and n integers between/including them are desired.
(defun DIFFERENT-RANDOM-BETWEEN (start end n)
  (if (= n 0) nil
      (let ((num (random-between start (1+ end)))
	    (rest-nums (different-random-between start (1- end) (1- n))))
	(cons num
	      (loop for m in rest-nums
		    collecting
		      (if (< m num) m (1+ m)))))))

(defun ALL-ORDERED-NTUPLES (lst n)
  (if (= n 0) (list nil)
      (if (length= lst n) (all-permutations lst)
	  (append (all-ordered-ntuples (cdr lst) n)
		  (loop for sub-tup in (all-ordered-ntuples (cdr lst) (1- n))
			appending
			(all-insertions (car lst) sub-tup))))))

(defun ALL-NTUPLES (lst n)
  (if (= n 0) (list nil)
      (if (length= lst n) (list lst)
	  (append (all-ntuples (cdr lst) n)
		  (loop for sub-tup in (all-ntuples (cdr lst) (1- n))
			collecting
			(cons (car lst) sub-tup))))))

(defun ALL-INSERTIONS (elm lst)
  (loop for i from 0 to (length lst)
	collecting
	  (append (first-n i lst)
		  (list elm)
		  (copy-list (nthcdr i lst)))))

(defun ALL-PERMUTATIONS (lst)
  (if (null lst) nil
      (if (length= lst 1) (list lst)
	  (loop for sub-permut in  (all-permutations (cdr lst))
		append
		(all-insertions (car lst) sub-permut)))))

(defun ALL-COMBINATIONS (lst-of-lsts)
  (if (null lst-of-lsts)
      nil
      (loop for lst in lst-of-lsts
	    with result = (list nil)
	    doing
	(setq result
	      (loop for res in result
		    appending
		      (loop for item in lst
			    collecting
			      (cons item res))))
	    finally (return (mapcar #'reverse result)))))

(defun MERGE-PARTITIONS (part1 part2 test)
  (labels ((add-set-to-partitions (set part)
	     (let ((n (position set part :test (lambda (s1 s2) (apply test (list (car s1) (car s2)))))))
	       (if (null n) (cons set part)
		   (append (first-n n part) (list (append set (nth n part))) (nthcdr (1+ n) part))))))
    (if (null part1) part2
	(merge-partitions (cdr part1) (add-set-to-partitions (car part1) part2) test))))

(defun PARTITION (set test &optional len)
  (when (null len) (setf len (length set)))
  (if (= len 0) nil
      (if (= len 1) (list set)
	  (merge-partitions (partition (first-n (floor (/ len 2)) set) test (floor (/ len 2)))
			    (partition (nthcdr (floor (/ len 2)) set) test (ceiling (/ len 2)))
			    test))))

;;; Find the intersection of two sorted lists.  Comparison function 
(defun SORTED-INTERSECTION (lst1 lst2 comparison-function equality-function)
  (cond ((or (null lst1) (null lst2)) nil)
	((apply equality-function (list (car lst1) (car lst2)))
	 (cons (car lst1) (sorted-intersection (cdr lst1) (cdr lst2)
					       comparison-function equality-function)))
	((apply comparison-function (list (car lst1) (car lst2)))
	 (sorted-intersection (cdr lst1) lst2 comparison-function equality-function))
	(t (sorted-intersection lst1 (cdr lst2) comparison-function equality-function))))

;;; compare function returns t if the second arguement is bigger.
(defun MAX-TEST (set binary-compare-function)
  (if (null (cdr set)) (car set)
      (let ((other (max-test (cdr set) binary-compare-function)))
	(if (apply binary-compare-function (list (car set) other))
	    other
	    (car set)))))

(defun RASTER-ARRAY-DIMENSIONS (a)
  (let ((dim (array-dimensions a)))
    (when (/= (length dim) 2)
      (error "~A is not a raster array" a))
    (list (nth 1 dim) (nth 0 dim))))

(deftime TIMED-SORT (lst proc &key key)
  (if key (funcall #'sort lst proc :key key)
  (funcall #'sort lst proc)))

(deftime TIMED-REMOVE (x lst &key test)
  (funcall #'remove x lst :test test))

(deftime TIMED-AREF2 (ar i j)
  (aref ar i j))

(defmacro FLET* (&rest rest)
  (cons 'labels rest))

(defun COPY-ARRAY (ar)
  (let* ((dims (array-dimensions ar))
	 (new-array (make-array dims :element-type (array-element-type ar))))
;    (if (array-bitbltable? ar)
;	(bitblt tv:alu-seta (cadr dims) (car dims) ar 0 0 new-array 0 0)
	(let ((1d-ar (make-array (list (apply #'* dims)) :element-type (array-element-type ar)
				 :displaced-to ar))
	      (1d-new-array (make-array (list (apply #'* dims)) :element-type (array-element-type ar)
					:displaced-to new-array)))
	  (loop for i from 0 to (1- (apply #'* dims))
		doing
	    (setf (aref 1d-new-array i) (aref 1d-ar i))))
;       )
    new-array))

(deftime COPY-INTO-ARRAY (ar1 ar2)
  "Arrays must be same size."
  (let* ((dims (array-dimensions ar1)))
	(let ((1d-ar1 (make-array (list (apply #'* dims)) 
                                 :element-type (array-element-type ar1)
				 :displaced-to ar1))
	      (1d-ar2 (make-array (list (apply #'* dims)) 
                                        :element-type (array-element-type ar2)
					:displaced-to ar2)))
	  (loop for i from 0 to (1- (apply #'* dims))
		doing
	    (setf (aref 1d-ar2 i) (aref 1d-ar1 i))))
    ar2))

(deftime COPY-INTO-BIT-ARRAY (ar1 ar2)
  "Arrays must be same size, and must both be binary."
   (bit-and ar1 ar1 ar2))

(defun FLIP-ARRAY (ar)
  (let ((dimensions (array-dimensions ar)))
    (when (not (= (length dimensions) 2)) (error "FLIP-ARRAY can only work on 2d arrays."))
    (let ((new-ar (make-array (reverse dimensions) :element-type (array-element-type ar))))
    (loop for i from 0 below (car dimensions)
          doing
          (loop for j from 0 below (cadr dimensions)
                doing
                (setf (aref new-ar j i) (aref ar i j))))
    new-ar)))
"
  (let ((dimensions (array-dimensions ar)))
    (when (not (= (length dimensions) 2)) (error "FLIP-ARRAY can only work on 2d arrays."))
    (let ((new-ar (make-array (reverse dimensions) :element-type (array-element-type ar))))
      (declare (compiler:array-register-1d ar))
      (declare (compiler:array-register-1d new-ar))
      (loop for ar-index from 0 to (1- (apply #'* dimensions))
	    doing
	(let* ((i (mod ar-index (cadr dimensions)))
	       (j (floor (/ ar-index (cadr dimensions))))
	       (new-ar-index (+ j (* i (car dimensions)))))
	  (setf (sys:%1d-aref new-ar new-ar-index) (sys:%1d-aref ar ar-index))))
      new-ar)))
"

(defun CONVERT-ARRAY (ar)
  (multiple-value-bind (w h span) (decode-raster-array ar)
    (ignore w)
    (make-raster-array h span :element-type (array-element-type ar) :displaced-to ar)))

(defun CLEAR-ARRAY! (ar)
  (let ((null-value (array-null-value ar))
	(dims (array-dimensions ar)))
;    (if (array-bitbltable? ar)
;	(bitblt tv:alu-setz (cadr dims) (car dims) ar 0 0 ar 0 0)
	(let ((1d-ar (make-array (list (apply #'* dims)) :element-type (array-element-type ar)
				 :displaced-to ar)))
	  (loop for i from 0 to (1- (apply #'* dims))
		doing
	    (setf (aref 1d-ar i) null-value)))))
;  )

(defun ARRAY-NULL-VALUE (ar)
  (if (eq t (array-element-type ar)) nil 0))

(defun ARRAY-BITBLTABLE? (ar)
  (if (= 2 (length (array-dimensions ar)))
      (if (listp (array-element-type ar))
	  (and
	    (eq (car (array-element-type ar)) 'integer)
	    (let ((bits (bits-in-element-type (array-element-type ar))))
	      (= 0 (mod (cadr (array-dimensions ar)) (/ 32 bits)))))
	  (eq (array-element-type ar) 'fixnum))))

(defun BITBLTABLE-DIMENSIONS (x y)
  (values (* 32 (ceiling (/ x 32))) y))

(defun OR-ARRAYS (first-array &rest arrays)
  (if (null arrays) first-array
      (let ((element-type (array-element-type first-array)))
	(loop for et in (mapcar #'array-element-type arrays)
	      doing
	  (when (not (equal element-type et)) (error "Arrays must have same element type")))
	(loop for a in (cons first-array arrays)
	      doing
	  (when (not (= (length (array-dimensions a)) 2)) (error "Arrays must all be raster arrays"))
	  (when (not (array-bitbltable? a)) (error "Arrays must all be bitblt-able")))
	(let ((x (apply #'max (mapcar #'cadr (mapcar #'array-dimensions (cons first-array arrays)))))
	      (y (apply #'max (mapcar #'car (mapcar #'array-dimensions (cons first-array arrays))))))
	  (let ((new-array (make-raster-array x y :element-type element-type)))
	    (loop for ar in (cons first-array arrays)
		  doing
	      (bitblt boole-ior (cadr (array-dimensions ar)) (car (array-dimensions ar))
		      ar 0 0 new-array 0 0))
	    new-array)))))

;;; Inspecting 4d arrays.

(defun WRITE-4D-ARRAY-AS-BINARY (struct)
  (let* ((array (find-array struct))
	 (dims (array-dimensions array)))
    (format t "~%")
    (loop for i from 0 to (1- (car dims))
	  doing
      (loop for j from 0 to (1- (cadr dims))
	    doing
	(loop for k from 0 to (1- (caddr dims))
	      doing
	  (loop for l from 0 to (1- (cadddr dims))
		doing
	    (if (aref array i j k l) (format t "1") (format t "0")))
	  (format t "~%"))
	(format t "~%"))
      (format t "~%"))))

(defun FIND-ARRAY (struct)
  (if (arrayp struct) struct
      (if (not (consp struct)) nil
	  (let ((a? (find-array (car struct))))
	    (if (arrayp a?) a?
		(find-array (cdr struct)))))))

(defun PROJECT-ARRAY (array dims-wanted)
  (labels ((next-indices (inds dims)
	     (if (null inds) nil
		 (if (< (car inds) (1- (car dims))) (cons (1+ (car inds)) (cdr inds))
		     (let ((rest-inds (next-indices (cdr inds) (cdr dims))))
		       (if (null rest-inds) nil
			   (cons 0 rest-inds)))))))
    (let* ((old-dims (array-dimensions array))
	   (new-array (make-array (loop for dim in dims-wanted collecting (nth dim old-dims))
				  :element-type '(unsigned-byte 1)))
	   (start-indices (loop for d in old-dims  collecting 0))
	   (indices start-indices))
      (loop until (null indices)
	    doing
	(setf (apply #'aref (cons new-array (loop for dim in dims-wanted collecting (nth dim indices))))
	      (if (or (= 1 (apply #'aref (cons new-array (loop for dim in dims-wanted collecting (nth dim indices)))))
		      (apply #'aref (cons array indices)))
		  1
		  0))
	(setf indices (next-indices indices old-dims)))
      new-array)))

;;; This is not complete.  I'm only making it work on types of 'integer, for now.
(defun BITS-IN-ELEMENT-TYPE (element-type)
  (round (log (caaddr element-type) 2)))

(defun TIMES-N-IS-FACTOR (n num)
  (if (whole? (/ num n))
      (1+ (times-n-is-factor n (/ num n)))
      0))

(defun WHOLE? (n)
  (= n (round n)))

;;; Efficient testing if (= n (length lst))
(defun LENGTH= (lst n)
  (if (null lst)
      (if (= n 0) t nil)
      (if (= n 0) nil
	  (length= (cdr lst) (1- n)))))

(defun RESIZE-BINARY-RASTER (ar factor)
  (let ((new-ar (make-array (list (floor (/ (car (array-dimensions ar)) factor)) (floor (/ (cadr (array-dimensions ar)) factor)))
			    :element-type '(unsigned-byte 1))))
    (loop for i from 0 to (1- (car (array-dimensions new-ar)))
	  doing
      (loop for j from 0 to (1- (cadr (array-dimensions new-ar)))
	    doing
	(setf (aref new-ar i j)
	      (if (loop for k from (* i factor) to (1- (+ (* i factor) factor))
			thereis
			(loop for l from (* j factor) to (1- (+ (* j factor) factor))
			      thereis
			      (= 1 (aref ar k l))))
		  1
		  0))))
    new-ar))

;;; (defun SCALE-IMAGE (im)
;;;   "given an image, scale the pixel values so that they are between 0 and 255"
;;;   (let* ((new-im (make-array (array-dimensions im) :element-type '(unsigned-byte 8))))
;;;     (declare (compiler:array-register-1d im))
;;;     (declare (compiler:array-register-1d new-im))
;;;     (let ((max-val 0)
;;; 	  (min-val 255))
;;;       (loop for i from 0 below (reduce #'* (array-dimensions im))
;;; 	    for val = (sys:%1d-aref im i)
;;; 	    doing
;;; 	(setq max-val (max max-val val)
;;; 	      min-val (min min-val val)))
;;;       (loop for i from 0 below (reduce #'* (array-dimensions im))
;;; 	    with scale = (/ 255 (- max-val min-val))
;;; 	    doing
;;; 	(setf (sys:%1d-aref new-im i) (floor (* scale (- (sys:%1d-aref im i) min-val)))))
;;;       new-im)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; RANDOM SIMPLE PROCS
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun REPEAT (mem n)
  (loop for i from 1 to n collecting mem))

(defun LIST? (lst)
  (if (null lst) t
      (if (atom lst) nil
	  (loop for a on lst
		doing
	    (if (atom a) (return nil)
		(if (null (cdr a)) (return t)))))))

(defun 2LENGTH? (lst)
  (and (not (null lst)) (not (null (cdr lst))) (null (cddr lst))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Cycle abstraction
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; (defstruct (CYCLE
;;; 	     :named
;;; 	     (:constructor make-cycle-internal (first-element length))
;;; 	     :predicate
;;; 	     (:print-function (lambda (cycle stream &rest ignore)
;;; 				(cycle-print-function cycle stream)))
;;; 	     )
;;;   first-element
;;;   length)
;;; 
;;; (defmacro DOCYCLE ((var cycle &optional resultform) &body forms)
;;;   "this is a little primitive.  For example, if an error occurs
;;;    inside this loop, the results will be unpredictable.
;;;   "
;;;   (append `(dotimes-cycle (,var ,cycle (cycle-length ,cycle) ,resultform))
;;;      forms))
;;; 
;;; (defmacro DOTIMES-CYCLE ((var cycle n &optional resultform) &body forms)
;;;   "This says loop through n elements of a cycle, but don't disturb its state."
;;;   (let ((elm-var (gensym "elm")))
;;;     `(loop repeat ,n
;;; 	   for ,elm-var first (cycle-first-element ,cycle)
;;; 			then (cycle-element-right ,elm-var)
;;; 	   for ,var = (cycle-element-val ,elm-var)
;;; 	   do  ,(cons 'progn forms)
;;; 	   finally
;;; 	     (return ,(if resultform resultform 'nil)))))
;;; 
;;; (defun CYCLE-PRINT-FUNCTION (cycle stream)
;;; ;				(if (= 0 (cycle-length cycle))
;;; ;				    (format stream "[#CYCLE ()]")
;;; ;				    (progn
;;; ;				      (format stream "[#CYCLE (")
;;; ;				      (loop repeat (1- (cycle-length cycle))
;;; ;					    do (format stream "~A " (cycle-car cycle))
;;; ;					       (rotate-cycle-right cycle))
;;; ;				      (format stream "~A)]" (cycle-car cycle))
;;; ;				      (rotate-cycle-right cycle)))))
;;;   (format stream "[#CYCLE (")
;;;   (dotimes-cycle (elm cycle (cycle-length cycle))
;;;     (format stream "~A " elm))
;;;   (format stream ")]"))
;;; 
;;; (defstruct (CYCLE-ELEMENT
;;; 	     (:constructor make-cycle-element (val &optional right left))
;;; 	     (:print-function (lambda (ce stream &rest ignore)
;;; 				(format stream "~A"
;;; 					(cycle-element-val ce)))))
;;;   val
;;;   right
;;;   left)
;;; 
;;; (defun MAKE-CYCLE (lst)
;;;   (if (null lst)
;;;       (make-cycle-internal nil 0)
;;;       (let ((elements (mapcar #'make-cycle-element lst)))
;;; 	(loop with first-element = (car elements)
;;; 	      for len from 1
;;; 	      for e in elements
;;; 	      for next-e in (cdr elements)
;;; 	      do (setf (cycle-element-right e) next-e)
;;; 		 (setf (cycle-element-left next-e) e)
;;; 	      finally (setf (cycle-element-right e) first-element)
;;; 		      (setf (cycle-element-left first-element) e)
;;; 		      (return (make-cycle-internal first-element len))))))
;;; 
;;; (defun CYCLE-LAST-ELEMENT (cycle) (cycle-element-left (cycle-first-element cycle)))
;;; 
;;; (defun ROTATE-CYCLE-RIGHT (cycle &optional (n 1))
;;;   (loop repeat n
;;; 	doing
;;;         (setf (cycle-first-element cycle) (cycle-element-right (cycle-first-element cycle)))))
;;; 
;;; (defun ROTATE-CYCLE-LEFT (cycle &optional (n 1))
;;;   (loop repeat n
;;; 	doing
;;;         (setf (cycle-first-element cycle) (cycle-last-element cycle))))
;;; 
;;; (defun CYCLE-CAR (cycle) (cycle-element-val (cycle-first-element cycle)))
;;; 
;;; (defun CYCLE-NTH-RIGHT-ELEMENT (n cycle)
;;;   (if (< n 0)
;;;       (cycle-nth-left-element (- n) cycle)
;;;       (loop for element first (cycle-first-element cycle)
;;; 			then (cycle-element-right element)
;;; 	    repeat n
;;; 	    finally (return element))))
;;; 
;;; (defun CYCLE-NTH-RIGHT (n cycle)
;;;   (cycle-element-val (cycle-nth-right-element n cycle)))
;;; 
;;; (defun CYCLE-NTH-LEFT-ELEMENT (n cycle)
;;;   (if (< n 0)
;;;       (cycle-nth-right-element (- n) cycle)
;;;       (loop for element first (cycle-first-element cycle)
;;; 			then (cycle-element-left element)
;;; 	    repeat n
;;; 	    finally (return element))))
;;; 
;;; (defun CYCLE-NTH-LEFT (n cycle)
;;;   (cycle-element-val (cycle-nth-left-element n cycle)))
;;; 
;;; (defun POP-CYCLE (cycle)
;;;   (let* ((first-element (cycle-first-element cycle))
;;; 	 (last-element (cycle-element-left first-element))
;;; 	 (second-element (cycle-element-right first-element)))
;;;     (setf (cycle-element-right last-element) second-element)
;;;     (setf (cycle-element-left second-element) last-element)
;;;     (setf (cycle-first-element cycle) second-element)
;;;     (decf (cycle-length cycle))
;;;     (cycle-element-val first-element)))
;;; 
;;; (defun PUSH-CYCLE (cycle val)
;;;   (let* ((first-e (cycle-first-element cycle))
;;; 	 (last-e (cycle-last-element cycle))
;;; 	 (e (make-cycle-element val first-e last-e)))
;;;     (setf (cycle-element-left first-e) e)
;;;     (setf (cycle-element-right last-e) e)
;;;     (setf (cycle-first-element cycle) e)    
;;;     (incf (cycle-length cycle))
;;;     cycle))
;;; 
;;; (defun REMOVE-FROM-CYCLE (cycle from to)
;;;   "Remove all elements of the cycle from (cycle-nth-right cycle from)
;;;    to (cycle-nth-right cycle to)
;;;    Currently restricted so that (< from to cycle-length)
;;;   "
;;;   (let ((from (mod from (cycle-length cycle)))
;;; 	(to (mod to (cycle-length cycle))))
;;;     (let ((left-of-remove (cycle-nth-right-element (1- from) cycle))
;;; 	  (right-of-remove (cycle-nth-right-element (1+ to) cycle))
;;; 	  (number-removed (if (<= from to) (1+ (- to from))
;;; 			      (1+ (- (+ to (cycle-length cycle)) from)))))    
;;;       (setf (cycle-element-right left-of-remove) right-of-remove)
;;;       (setf (cycle-element-left right-of-remove) left-of-remove)
;;;       (decf (cycle-length cycle) number-removed)    
;;;       (when (or (<= from 0 to) (< to from))
;;; 	(setf (cycle-first-element cycle) left-of-remove)))))
;;; 
;;; (defun ADD-TO-CYCLE (cycle object n)
;;;   "Make OBJECT the N'th thing in CYCLE"
;;;   (let* ((left-element (cycle-nth-right-element (1- n) cycle))
;;; 	 (right-element (cycle-nth-right-element n cycle))
;;; 	 (new-element (make-cycle-element object right-element left-element)))
;;;     (setf (cycle-element-left right-element) new-element)
;;;     (setf (cycle-element-right left-element) new-element)
;;;     (incf (cycle-length cycle))
;;;     (when (= n 0)
;;;       (setf (cycle-first-element cycle) new-element))))
;;; 
;;; (defun CYCLE-LIST (c &optional (len (cycle-length c)))
;;;   (let ((res nil))
;;;     (dotimes-cycle (val c len)
;;;       (push val res))
;;;     (reverse res)))
