;;;This is the public version of the code for the proofs in "Affine partitions and Affine Grassmannians" by Billey and Mitchell.
;;; The proofs in that article are verified using the following commands:
;;;(gather-affine-data 8 40)  =  lists palindromics for B-G.  Can be modified to include type A but many more palindromics exits
;;;(grind-affine-partition-gf 'affine-g 2 20)    ;;; these give the generating functions for affine partitions in each type.
;;;(grind-affine-partition-gf 'affine-f 4 20)
;;;(grind-affine-partition-gf 'affine-e 6  40)
;;;(grind-affine-partition-gf 'affine-e 7  40)
;;;(grind-affine-partition-gf 'affine-e 8  40)


(in-package :user)
(defun start-up ()
  (cfl "affine.partitions.lisp"))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; from coxeter.lisp  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; code to generate all or part of a Coxeter group 
;;;;just from the Coxeter matrix.  Affine Weyl groups also encoded.
;;; coroot lattice notation and eriksson all 1's vector notation included. 


(defun make-coxeter-group  (cox-matrix thresh &optional (type 'new-type))
 ;;;  cmatrix is a Coxeter matrix and thresh is a length threshold
  (setf *cox-matrix* cox-matrix)
  (setf *n* (array-dimension *cox-matrix* 0))	;;; rank of the Coxeter group
  (setf *type* (cons type *n*))
  (setf *thresh* thresh)
  (setf *cox-group-hash* (make-hash-table :test 'equal))
  (setf *identity-element* (loop for i from 1 to *n* collect 1))
  (push *identity-element* (gethash 0 *cox-group-hash*))
  (loop for i from 1 to thresh do (cox-group-helper i)))


(defun make-coxeter-group-quotient (cox-matrix thresh parab &optional (type 'new-type)) 
 ;;;  cmatrix is a Coxeter matrix and thresh is a length threshold
  (make-coxeter-group cox-matrix thresh type)
  (setf *type* (list (cons type *n*) 'mod parab))
o  (setf *parabolic* parab)
  (setf *gens* (if (member type (list 'affine-b 'affine-d :test 'equal)) '(0 1) '(0)))
 (setf *one-elem-index* '(0))
  (setf *cox-quotient-hash* (make-hash-table :test 'equal))
  (push *identity-element* (gethash 0 *cox-quotient-hash*))
  (loop for i from 1 to thresh do	(format t "~a."  i) 
	(cox-quotient-helper i parab)))


(defun make-affine-weyl-group (type n thresh)
 ;;;  cmatrix is a Coxeter matrix and thresh is a length threshold
  (setf *type* (cons type n))
  (setf *cox-matrix* (make-coxeter-matrix type (1+ n)))
  (setf *thresh* thresh)
  (setf *cox-1-chain* (append (loop for k from 1 to n collect k) (loop for k downfrom (1- n) to 1 collect k)))
  (setf *cox-0-chain* (append '(0) (loop for k from 2 to n collect k) (loop for k downfrom (1- n) to 2 collect k) '(0)))
  (setf *n* (array-dimension *cox-matrix* 0))   ;;; rank of the Coxeter group
  (setf *cox-group-hash* (make-hash-table :test 'equal))
  (setf *coroot-identity-element* (cons 1 (loop for i from 1 to n collect 0)))
  (setf *identity-element* (loop for i from 1 to *n* collect 1))
  (push *identity-element* (gethash 0 *cox-group-hash*))
  (loop for i from 1 to thresh do (format t " ~a"  i) (cox-group-helper i)))

(defun make-affine-quotient (type n thresh &optional (parabolic nil))
  (let ((parab (if parabolic parabolic (loop for i from 1 to n collect i))))
 ;;;  cmatrix is a Coxeter matrix and thresh is a length threshold
    (make-affine-weyl-group type n 0)
    (setf *type* (list (cons type n) 'mod parab))
    (setf *thresh* thresh)
    (setf *parabolic* parab)
    (setf *gens* (if (member type '(affine-b affine-d) :test 'equal) '(1 0) '(0)))
    (setf *one-elem-index* '(0))
    (setf *cox-quotient-hash* (make-hash-table :test 'equal))
    (push *identity-element* (gethash 0 *cox-quotient-hash*))
    (loop for i from 1 to thresh do	(format t "~a."  i) 
					(cox-quotient-helper i parab))))


(defun make-standard-affine-quotient (type n thresh &optional (parabolic nil))   ;;;; was this written before and lost?  
  (let ((parab (if parabolic parabolic (loop for i from 1 to n collect i))))
 ;;;  cmatrix is a Coxeter matrix and thresh is a length threshold
    (make-affine-weyl-group type n 0)
    (setf *type* (list (cons type n) 'mod parab))
    (setf *thresh* thresh)
    (setf *parabolic* (loop for i from 1 to n collect i))
    (setf *gens* (if (member type '(affine-b affine-d) :test 'equal) '(1 0) '(0)))
    (setf *one-elem-index* '(0))
    (setf *cox-quotient-hash* (make-hash-table :test 'equal))
    (push *identity-element* (gethash 0 *cox-quotient-hash*))
    (loop for i from 1 to thresh do	(format t "~a."  i) 
					(cox-quotient-helper i parab))))


(defun cox-quotient-helper (index parab)
  (let ((new-elem nil))
    (loop for elem in (gethash (1- index) *cox-quotient-hash*)
	do (loop for gen from 0 below *n*
	       do (setf new-elem (fire-node-left gen elem))
		  (when  (and (min-length-coset-rep-p new-elem parab)
			      (= (cox-length new-elem) index)
			      (not (member new-elem (gethash index *cox-quotient-hash*) 
					   :test 'equal)))
		    (push new-elem (gethash index *cox-quotient-hash*)))))
    (when (= 1 (length (gethash index *cox-quotient-hash*)))
      (push index *one-elem-index*))))


(defun make-wely-group (type n  thresh &optional(rows nil))
 ;;;  cmatrix is a Coxeter matrix and thresh is a length threshold
  (setf *type* (cons type n))
  (setf *cox-matrix* (make-coxeter-matrix type n rows))
  (setf *thresh* thresh)
  (setf *n* n)
  (setf *cox-group-hash* (make-hash-table :test 'equal))
  (setf *identity-element* (loop for i from 1 to *n* collect 1))
  (push *identity-element* (gethash 0 *cox-group-hash*))
  (loop for i from 1 to thresh do (cox-group-helper i)))
  
(defun cox-group-helper (index)
  (let ((new-elem nil))
    (loop for elem in (gethash (1- index) *cox-group-hash*)
	do (loop for val in elem
	       for gen from 0 below *n*
	       when (< 0 val)
	       do (setf new-elem (fire-node gen elem))
		  (when (not (member new-elem (gethash index *cox-group-hash*) :test 'equal))
		    (push new-elem (gethash index *cox-group-hash*)))))))

(defun fire-node (gen elem)
  (let ((node-weight (nth gen elem)))
    (loop for val in elem
	for j from 0 
	collect (+ val (* (aref *cox-matrix* gen j) node-weight)))))

(defun fire-node-left (gen elem)
  (cox-build-elem (cons gen (cox-find-reduced elem))))

(defun make-coxeter-matrix (type n &optional (rows nil))
  (let ((mat nil))
    (cond (rows (setf mat (make-array (list n n) :initial-contents rows)))
	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'a) 
	   (setf mat (make-array (list n n) ))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))
  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'affine-a)  (= n 2))
	   (setf mat (make-array (list n n) ))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= (1- n) j)) 4)
						      ((and (= (1- n) i) (= 0 j)) 1)
						      (t 0))))))


  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'affine-a) 
	   (setf mat (make-array (list n n) ))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((= (abs (- i j)) 1) 1)
						      ((and (= 0 i) (= (1- n) j)) 1)
						      ((and (= (1- n) i) (= 0 j)) 1)
						      (t 0))))))
  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ;;From BB, chose edge weights k_{i,j) k_(j,i) = 4 cos^2(pi/m(s_i,s_j))
	  ;;for m=3 use 1,1; for m=4 use 2,1; for m=6 use 3,1;
	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'b) 
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= (- n 2) i) (= (- n 1) j)) 2)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))

  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (= n 3) 
		(or (equal type 'affine-b) 
		    (equal type 'affine-c) ))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 2)
						      ((and (= (- n 2) i) (= (- n 1) j)) 2)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))
	  
	  
  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'affine-b) 
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 0)
						      ((and (= 0 j) (= 1 i)) 0)
						      ((and (= 0 i) (= 2 j)) 1)
						      ((and (= 0 j) (= 2 i)) 1)
						      ((and (= (- n 2) j) (= (- n 1) i)) 2)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))
  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'affine-c) 
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 2)
						      ((and (= (- n 2) j) (= (- n 1) i)) 2)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))

 	  
    	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'd) 
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 0)
						      ((and (= 0 j) (= 1 i)) 0)
						      ((and (= 0 i) (= 2 j)) 1)
						      ((and (= 0 j) (= 2 i)) 1)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))

	  
     	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'affine-d) 
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 0)
						      ((and (= 0 j) (= 1 i)) 0)
						      ((and (= 0 i) (= 2 j)) 1)
						      ((and (= 0 j) (= 2 i)) 1)
						      ((and (= (- n 2) i) (= (- n 1) j)) 0)
						      ((and (= (- n 2) j) (= (- n 1) i)) 0)
						      ((and (= (- n 3) i) (= (- n 1) j)) 1)
						      ((and (= (- n 3) j) (= (- n 1) i)) 1)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))

    	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'affine-e) ;;; \tilde{E}_6
		(= n 7))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 1 i) (= 2 j)) 0)   ;; 2-3-4-5-6
						      ((and (= 1 j) (= 2 i)) 0)   ;;     |
						      ((and (= 1 i) (= 4 j)) 1)   ;;     1
						      ((and (= 1 j) (= 4 i)) 1)   ;;     |
						      ((= (abs (- i j)) 1) 1)     ;;     0
						      (t 0))))))
	      	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'affine-e) ;;; \tilde{E}_7
		(= n 8))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 0)  ;; 0-2-3-4-5-6-7
						      ((and (= 0 j) (= 1 i)) 0)  ;;       |
						      ((and (= 0 i) (= 2 j)) 1)  ;;       1
						      ((and (= 0 j) (= 2 i)) 1)
						      ((and (= 1 i) (= 2 j)) 0)
						      ((and (= 1 j) (= 2 i)) 0)
						      ((and (= 1 i) (= 4 j)) 1)
						      ((and (= 1 j) (= 4 i)) 1)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))

      	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'affine-e) ;;; \tilde{E}_8
		(= n 9))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 0)  ;;   2-3-4-5-6-7-8-0
						      ((and (= 0 j) (= 1 i)) 0)  ;;       |
						      ((and (= 0 i) (= 8 j)) 1)  ;;       1
						      ((and (= 0 j) (= 8 i)) 1)
						      ((and (= 1 i) (= 2 j)) 0)
						      ((and (= 1 j) (= 2 i)) 0)
						      ((and (= 1 i) (= 4 j)) 1)
						      ((and (= 1 j) (= 4 i)) 1)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))
	  
    	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'new-affine-e) ;;; \tilde{E}_6
		(= n 7))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 5 i) (= 2 j)) 1)   ;; 4-3-2-5-6
						      ((and (= 5 j) (= 2 i)) 1)   ;;     |
						      ((and (= 5 i) (= 4 j)) 0)   ;;     1
						      ((and (= 5 j) (= 4 i)) 0)   ;;     |
						      ((= (abs (- i j)) 1) 1)     ;;     0
						      (t 0))))))
	      	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'new-affine-e) ;;; \tilde{E}_7
		(= n 8))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 1)  ;; 0-1-2-3-5-6-7
						      ((and (= 0 j) (= 1 i)) 1)  ;;       |
						      ((and (= 3 i) (= 5 j)) 1)  ;;       4
						      ((and (= 3 j) (= 5 i)) 1)
						      ((and (= 4 i) (= 5 j)) 0)
						      ((and (= 4 j) (= 5 i)) 0)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))

      	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((and (equal type 'new-affine-e) ;;; \tilde{E}_8
		(= n 9))
	   (setf mat (make-array (list n n)))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 0 i) (= 1 j)) 0)  ;;   8-7-5-4-3-2-1-0
						      ((and (= 0 j) (= 1 i)) 0)  ;;       |
						      ((and (= 7 i) (= 5 j)) 1)  ;;       6
						      ((and (= 7 j) (= 5 i)) 1)
						      ((and (= 6 i) (= 7 j)) 0)
						      ((and (= 6 j) (= 7 i)) 0)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))	  
	  
	  
  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'affine-f) 
	   (setf mat (make-array (list n n) ))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
					;((and (= 2 i) (= 3 j)) 2)
						      ((and (= 3 i) (= 2 j)) 2)
						      ((= (abs (- i j)) 1) 1)
						      (t 0))))))  
	  
  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'affine-g) 
	   (setf mat (make-array (list n n) ))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 2 i) (= 1 j)) 3)
						      ((and (= 2 j) (= 1 i)) 1)
						      ((and (= 0 j) (= 2 i)) 1)
						      ((and (= 0 i) (= 2 j)) 1)
						      (t 0))))))  

  	  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
	  ((equal type 'new-affine-g) 
	   (setf mat (make-array (list n n) ))
	   (loop for i from 0 below n
	       do (loop for j from 0 below n 
		      do (setf (aref mat i j ) (cond  ((= i j) -2)
						      ((and (= 2 j) (= 1 i)) 3)  ;;;    >3>
						      ((and (= 2 i) (= 1 j)) 1)  ;;; 0-1--- 2
						      ((and (= 0 j) (= 2 i)) 0)
						      ((and (= 0 i) (= 1 j)) 1)
						      ((and (= 0 j) (= 1 i)) 1)
						      (t 0))))))  
	  
	  ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

    mat))

(defun min-length-coset-rep-hash (parabolic-subgroup-gens)
  (let ((new-hash (make-hash-table :test 'equal)))
    (maphash #'(lambda (key val)
		 (setf (gethash key new-hash) (loop for elem in val when (min-length-coset-rep-p elem parabolic-subgroup-gens)
									 collect elem)))
	     *cox-group-hash*)
    new-hash))

(defun min-length-coset-rep-p (elem parabolic-subgroup-gens)
  (catch 'foo 
    (loop for j in parabolic-subgroup-gens
	for val = (nth j elem)
	when (> 0 val)
	do (throw 'foo nil))
    (throw 'foo t)))

(defun cox-find-reduced (elem &optional (priority '(0 1)))
  (if (member (caar *type*) (list 'affine-d 'affine-b) :test 'equal)
      (reverse (cox-find-reduced-helper-b elem priority *identity-element*))
    (reverse (cox-find-reduced-helper elem *identity-element*))))  


(defun cox-find-reduced-helper (elem identity)
  (let ((last-descent nil))
  (if (equal elem identity) 
      nil
    (progn (setf last-descent  (loop for e in (reverse elem)
				   for j downfrom (1- (length elem) )
				    until (> 0 e)
				   finally (return j)))
	   (cons last-descent (cox-find-reduced-helper (fire-node last-descent elem) identity))
	   ))))

(defun cox-find-reduced-helper-b (elem priority identity)
  (let ((descents nil))
  (if (equal elem identity) 
      nil
    (progn (setf descents  (loop for e in (reverse elem)
			       for j downfrom (1- (length elem) )
			       when (> 0 e)
			       collect j))
	   (if (same-lists-p descents '(1 0))
	       (cons (car priority) (cox-find-reduced-helper-b (fire-node (car priority) elem) (reverse priority) identity))
	     (cons (car descents) (cox-find-reduced-helper-b (fire-node (car descents) elem) priority identity)))))))



(defun cox-length (elem)
  (length (cox-find-reduced elem)))

(defun cox-identity-p (elem)
  (equal *identity-element* elem))


;;;; steve's coroot lattice notation

(defun cox-build-coroot (word)  ;; takes in a red word for a min length coset rep, reverses it, and builds coroot
  (let ((elem (cons 1 (loop for i from 1 below *n* collect 0))))
    (loop for gen in (reverse word)
	do (setf elem (fire-node gen elem)))
    elem))

(defun cox-elem-to-coroot (elem)
  (cox-build-coroot (cox-find-reduced elem)))

(defun coroot-to-cox-elem (elem)
  (cox-build-elem (coroot-find-reduced elem)))

(defun coroot-find-reduced (elem &optional (priority '(0 1)))   ;; doesn't give same red word as cox-red word
  (if (member (caar *type*) (list 'affine-d 'affine-b) :test 'equal)
      (cox-find-reduced-helper-b elem priority *coroot-identity-element*)
     (cox-find-reduced-helper elem *coroot-identity-element*)))

(defun coroot-to-partition (elem)
  (cox-partition *gens* (cox-find-reduced (coroot-to-cox-elem elem))))

(defun cox-dominant-vector-p (coroot)
  (catch 'foo
    (loop for i in *parabolic* when (> 0 (nth i coroot)) do (throw 'foo nil))
    (throw 'foo t)))

(defun cox-antidominant-vector-p (coroot)
  (catch 'foo
    (loop for i in *parabolic* when (< 0 (nth i coroot)) do (throw 'foo nil))
    (throw 'foo t)))

(defun cox-dominant-p (elem)
  (cox-dominant-vector-p (cox-build-elem (reverse (cox-find-reduced elem)))))

(defun cox-antidominant-p (elem)
  (cox-antidominant-vector-p (cox-build-elem (reverse (cox-find-reduced elem)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;; Bruhat order


(defun create-bruhat-hash ()
  (let ((new-hash (make-hash-table :test 'equal)))
    (maphash #'(lambda (key val)
		 (loop for elem in val 
		     do (setf (gethash elem new-hash)
			  (cox-covered-elems elem))))
	     *cox-group-hash*)
    (setf *bruhat-hash* new-hash)
    *bruhat-hash*))

;(defun-create-weak-covering-hash ()
;  (let ((graph (make-hash-table :test #'equal))
;	(bruhat-hash *bruhat-hash*))
;    (maphash #'(lambda (key val)
;		 (loop for y in val do
;		       (loop for x in  ;;;; check here  (gethash (1- key) bruhat-hash)
;			     when (cox-left-weak-order-p x y)
;			     do (push x (gethash y graph)))))
;	     bruhat-hash)
;    (push nil (gethash (first (gethash 0 bruhat-hash)) graph))
;    graph))

;(defun cox-left-weak-order-p (x y)
;  (= 1 (cox-length (cox-build-elem (reverse ( y))))

(defun create-quotient-bruhat-hash ()
  (let ((new-hash (make-hash-table :test 'equal)))
    (maphash #'(lambda (key val)
		 (loop for elem in val 
		     do (setf (gethash elem new-hash)
			  (cox-covered-elems elem (nth 2 *type*)))))
	     *cox-quotient-hash*)
    (setf *quotient-bruhat-hash* new-hash)
    *quotient-bruhat-hash*))


    
;CL-USER(24): (make-coxeter-group 'affine-a 4 10)
;NIL
;CL-USER(25): (graphviz *quotient-bruhat-hash* "affine.a4.Quot.dot")
    


(defun cox-build-elem (word &optional (start-elem *identity-element*))
  (let ((elem (copy-list start-elem)))
    (loop for gen in word
	do (setf elem (fire-node gen elem)))
    elem))

(defun cox-reduced-build-elem (word &optional (start-elem *identity-element*))
  (let ((elem (copy-list start-elem)))
    (catch 'foo
      (loop for gen in word
	  for val = (nth gen elem)
	  do  (when  (> 0 val) (setf elem nil) (throw 'foo nil))
	      (setf elem (fire-node gen elem))
	      )
      (throw 'foo 't))
    elem))


(defun cox-covered-elems (elem &optional (parab nil))
  (when (not (cox-identity-p elem))
    (let ((redword (cox-find-reduced elem))
	  (init-elem *identity-element*)
	  (new-elem nil)
	  (covered-elems nil))
      (push (cox-build-elem (cdr redword)) covered-elems)
      (loop for gen in redword
	  for j from 2 to (length redword)
	  do (setf init-elem (fire-node gen init-elem))
	     (setf new-elem (cox-build-elem (nthcdr j redword) init-elem))
	     (when (and (min-length-coset-rep-p new-elem parab)
			(= (1- (length redword)) (cox-length new-elem)))
	       (push new-elem covered-elems)))
      covered-elems)))

;;start here define a function to use graphviz to see the left weak order related to segment relations.
(defun cox-covering-elems (elem poset)
  (let ((result nil))
    (maphash #'(lambda (key val)
		 (when (member elem val :test 'equal)
		   (push key result)))
	     poset)
    result))
  
  
(defun cox-poincare (elem bruhat-hash group-hash &optional (palindrom-steps 0))   ;; ;*quotient-bruhat-hash* *cox-quotient-hash* 
                                                                                  ;;(1- *one-elem-index*))
  (reverse (cons 1 (cox-poincare-helper (1- (cox-length elem)) (gethash elem bruhat-hash) bruhat-hash group-hash palindrom-steps))))

(defun cox-poincare-helper (index elem-list bruhat-hash group-hash &optional (palindrom-steps 0))   
  (when (and elem-list (or (> 1 palindrom-steps) (= 1 (length elem-list))))
    (if (= (length (gethash index group-hash)) (length elem-list))
	(loop for i downfrom index to 0 collect (length (gethash i group-hash)))
      (let ((covered-elems nil))
	(loop for elem in elem-list
	    do (loop for covered-elem in (gethash elem bruhat-hash)
		   when (not (member covered-elem covered-elems :test 'equal))
		   do (push covered-elem covered-elems)))
	(cons (length elem-list) 
	      (cox-poincare-helper (1- index) covered-elems bruhat-hash group-hash (1- palindrom-steps)))))))

(defun cox-palindromic-p (elem bruhat-hash group-hash)
  (let ((poincare (cox-poincare elem bruhat-hash group-hash (1- (length *one-elem-index*)))))
    (and (= (length poincare) (1+ (cox-length elem)))   ;;; this is a shortcut for when the break point is up near the max so we don't build the whole poincare poly
	 (symmetric-list-p poincare))))   ;; in fact we only need to test symmetric when it actually is symmetric by the shortcut above


(defun poincare-symmetry-break-point  (elem bruhat-hash group-hash)
  (let ((poincare (cox-poincare elem bruhat-hash group-hash (1- (length *one-elem-index*)))))
    (when (and (not (= (length poincare) (1+ (cox-length elem))))
	       (= (length poincare) (1- (length *one-elem-index*))))
      (push elem *long-chains*))
    (if (= (length poincare) (1+ (cox-length elem)))
	(symmetry-break-point poincare)
      (length poincare))))

(setf *palindromic-hash* (make-hash-table :test 'equal))

(defun cox-find-palindromics (bruhat-hash group-hash gens &optional (verbose t))
  (let ((palindromics nil)
	(poincare-break 1))
      (maphash #'(lambda (key val)
		 (if (cox-palindromic-p key bruhat-hash group-hash)
		     (push key palindromics)
		   (setf poincare-break (max poincare-break (poincare-symmetry-break-point  key bruhat-hash group-hash)))
		   ))
	       bruhat-hash)
      (setf *poincare-break-point* poincare-break)
      (setf palindromics (sort (copy-list palindromics) 'cox-length-order) )
      (when verbose 
	(format t "~%~%IN TYPE: ~a ~a, thresh= ~a  number of palindromics = ~a " *type* *n* *thresh* (length palindromics))
	(format t "~%Max-Poincare-break-point:~a" poincare-break)
	(format t "~%First-break-point-at-length:~a" (length *one-elem-index*))
	(loop for elem in palindromics 
	    do (format t "~%~a:  partition: ~a  length: ~a ~%   redword: ~a~%   poincare = ~a  " (cox-elem-to-coroot elem) 
		       (loop for seg in (find-all-segments gens (cox-find-reduced elem)) collect (length seg))
		       (cox-length elem) 
		       (cox-find-reduced elem )  
		       (cox-poincare elem bruhat-hash group-hash)
		       )))
      (setf  (gethash *type* *palindromic-hash*) palindromics)
      palindromics))

  
(defun test-standard-quotient-palindromics (type n thresh )
  (setf *long-chains* nil)
  (setf *gens* (if (member type (list 'affine-b 'affine-d :test 'equal)) '(1 0) '(0)))
  (make-affine-quotient type n thresh (loop for i from 1 to n collect i) )
  (create-quotient-bruhat-hash)
  ;(format t "bruhat-poset-complete")
  (mapcar 'cox-elem-to-coroot (cox-find-palindromics *quotient-bruhat-hash* *cox-quotient-hash* *gens*)))


(defun gather-affine-data (max-n thresh)
  (loop for type in '(affine-b affine-c affine-d)
      do 
	(format t "~%~%**********************************************************************~%
*******  Type ~a n=2 to ~a **************************************~%
**********************************************************************~%" type max-n)
	(loop for n from 2 to max-n do
	      (test-standard-quotient-palindromics type n thresh )))

  (format t "~%~%**********************************************************************~%
*******  Type E n=6 to 8 **************************************~%
**********************************************************************~%" )
  (loop for n from 6 to 8 do 
	(test-standard-quotient-palindromics 'affine-e n thresh ))
  
    (format t "~%~%**********************************************************************~%
*******  Type F n=4 **************************************~%
**********************************************************************~%" )
    (test-standard-quotient-palindromics 'affine-f 4 thresh )

    (format t "~%~%**********************************************************************~%
*******  Type G n=2 **************************************~%
**********************************************************************~%" )
    (test-standard-quotient-palindromics 'affine-g 2 thresh ))


(defun cox-length-order (perm1 perm2)
  (< (cox-length perm1) (cox-length perm2 )))

(defun palindromic-sequence (type start stop)
  (loop for i from start to stop 
      collect (length (car (gethash (list (cons type i) 'mod (loop for j from 1 to i collect j)) *palindromic-hash*)))))

(defun cox-interval (bruhat-hash elem)
  (let ((hash (make-hash-table :test 'equal)))
    (rec-cox-interval bruhat-hash (list elem) hash)
    hash))

(defun restricted-cox-interval-in-coroots (elem i j)
  (let ((bruhat-hash (cox-interval *quotient-bruhat-hash* elem))
	(hash (make-hash-table :test 'equal)))
    (maphash #'(lambda (key val)
		 (when  (and (< i (cox-length key)) (<  (cox-length key) j))
		   (setf (gethash (cox-elem-to-coroot key) hash) 
		     (loop for v in val
			 collect (cox-elem-to-coroot v)))))
	     bruhat-hash)
    hash))
	     

    
  
(defun rec-cox-interval (bruhat-hash elem-list hash)
  (when elem-list
    (let ((new-elems nil))
      (loop for elem in elem-list 
	  do (setf (gethash elem hash) (gethash elem bruhat-hash))
	     (setf new-elems (append (gethash elem hash) new-elems)))
      (rec-cox-interval bruhat-hash (unique-elems new-elems) hash))))


(defun print-cox-poset (poset max-rank)
  (let ((ranks (make-array (list (1+ max-rank)))))
    (maphash #'(lambda (key val)
		 (push key (aref ranks (cox-length key))))
	     poset)
    (loop for i downfrom max-rank to 0 do (print (aref ranks i)))))



(defun cox-right-weak-interval (elem)    ;;; for coxeter group
  (let ((hash (make-hash-table :test 'equal)))
    (rec-cox-right-weak-interval (list elem) hash)
    hash))


(defun rec-cox-right-weak-interval (elem-list hash)   
  (when elem-list
    (let ((new-elems nil))
      (loop for elem in elem-list 
	  for covers = (loop for i from 0 below *n* when (> 0 (nth i elem)) collect (fire-node i elem))
	  do (setf (gethash elem hash) covers)
	     (setf new-elems (append new-elems covers)))
      (rec-cox-right-weak-interval  (unique-elems new-elems) hash))))


(defun cox-left-weak-interval (coroot)    ;;; for standard quotients
  (let ((hash (make-hash-table :test 'equal)))
    (rec-cox-left-weak-interval (list coroot) hash)
    hash))


(defun rec-cox-left-weak-interval (coroot-list hash)   
  (when coroot-list
    (let ((new-coroots nil))
      (loop for coroot in coroot-list 
	  for covers = (loop for i from 0 below *n* when (> 0 (nth i coroot)) collect (fire-node i coroot))
	  do (setf (gethash coroot hash) covers)
	     (setf new-coroots (append new-coroots covers)))
      (rec-cox-left-weak-interval  (unique-elems new-coroots) hash))))




;(graphviz (cox-interval *quotient-bruhat-hash* '(-5 1 1 1 7)) "block.3.dot")
; dot -Tps block.5.dot -o block.5.ps

;;;;; strict partitions
(defun make-strict-partitions (thresh )
  (let ((new-elem nil))
    (setf *strict-partitions* (make-hash-table :test 'equal))
    (setf *strict-partitions-poset* (make-hash-table :test 'equal))
    (setf (gethash 0 *strict-partitions*) (list '()))
    (setf (gethash 1 *strict-partitions*) (list '(1)))
    (setf (gethash '(1) *strict-partitions-poset*) (list '()))
    (loop for index from 2 to thresh do    
      (loop for elem in (gethash (1- index) *strict-partitions*)
	do
          ;;;;  add new part of size 1 if possible
	  (when (< 1 (car elem))
	    (when-new-elem-add (cons 1 elem) elem *strict-partitions* 
			       *strict-partitions-poset* index))
          ;;;; add 1 to last component if possible
	  (setf new-elem (reverse elem))
	  (setf new-elem (reverse (cons (1+ (car new-elem)) (cdr new-elem))))
	  (when-new-elem-add  new-elem elem  *strict-partitions* 
			      *strict-partitions-poset* index)
          ;;; increment parts if possible (up to last part)
	  (loop for e-i in elem 
	      for e-i+1 in (cdr elem)
	      for i from 0
	      when (< e-i (1- e-i+1))
	      do  
		(when-new-elem-add (append (first-n i elem) (cons (1+ (nth i elem)) (nthcdr (1+ i) elem)))
				   elem *strict-partitions* 
				   *strict-partitions-poset* index))))))

(defun test-odd-parts (partition max-odd)
  (catch 'foo 
    (loop for n in partition
	when (null(test-odd-part n max-odd))
	do (throw 'foo nil))
    (throw 'foo t)))
		
(defun test-odd-part (n max-odd)
  (if (evenp n) (test-odd-part (/ n 2) max-odd)
    (<= n max-odd)))

(defun when-new-elem-add  (new-elem old-elem ranked-hash  poset-hash index)
  (push old-elem (gethash new-elem poset-hash))
  (when  (not (member new-elem (gethash index ranked-hash)
		      :test 'equal))
    (push new-elem (gethash index ranked-hash))))

(defun make-strict-partitions-restricted (thresh k)
  ;;; grow all partitions
  (make-strict-partitions thresh)   
  ;;; set up restricted partitions
  (setf *restricted-partitions* (make-hash-table :test 'equal))
  (setf *restricted-partitions-poset* (make-hash-table :test 'equal))
  (loop for i from 0 to thresh do
	(loop for elem in (gethash i *strict-partitions*) 
	    when (test-odd-parts elem k) 
	    do (push elem (gethash i *restricted-partitions*))
	       (setf (gethash elem *restricted-partitions-poset*)
		 (intersect-lists (list (gethash elem *strict-partitions-poset*)
					(gethash (1- i) *restricted-partitions*)))))))
(defun test-rank-gen-conjecture (thresh n)   ;;; true by theorem of Bott
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (make-strict-partitions-restricted thresh (1- (* 2 n)))
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (make-affine-quotient 'affine-b  n thresh (loop for i from 1 to n collect i) )
  (if (equal (loop for i from 0 below n collect (length (gethash i *cox-quotient-hash*)))
	     (loop for i from 0 below n collect (length (gethash i *restricted-partitions*))))
      (format t "~%True: ~a~%" *type*)
      (format t "~%~%~%False!!: ~a~%~%" *type*))
    ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  (make-affine-quotient 'affine-c  n thresh (loop for i from 1 to n collect i) )
  (if (equal (loop for i from 0 below n collect (length (gethash i *cox-quotient-hash*)))
	     (loop for i from 0 below n collect (length (gethash i *restricted-partitions*))))
					(format t "~%True: ~a~%" *type*)
    (format t "~%~%False!!: ~a ~%" *type*)))

(defun test-all-partitions-of-n-restricted (n )
  (let ((results nil)
	(maxval (1- (* 2 (1- *n*))))
	(tail-elem nil)
	(parab (loop for i from 1 below *n* collect i)))
		 
    (flet ((helper (tail)
	     (when (and (= n (apply '+ tail))
			(> 2 (count-matches 1 tail))
			(> 2 (count-matches 2 tail))
			(> 2 (count-matches 3 tail)))
			
	       (setf tail-elem (cox-build-elem (partition-word tail)))
	       (when (and (= (apply `+ tail) (cox-length tail-elem))
			  (min-length-coset-rep-p tail-elem  parab))
		 (push tail results)))))
      (all-partitions-tester n 0 maxval  #'helper nil))
    results))

(defun partition-word (part) 
  (reverse (loop for i in part
      for j from 0  
      append  (if (evenp j) (cox-chain 0 i) (cox-chain 1 i)))))
(defun cox-chain (init-gen i)
  (if (= 1 init-gen) 
      (first-n i *cox-1-chain*)
    (first-n i *cox-0-chain*)))


(defun cox-initial-segment (gen word)
  (first-n (1+ (position-n word gen)) word))

;(defun find-all-segments (gens word)
;  (let ((piece nil)
;	(segments nil))
;    (loop for w in word
;	do (push w piece)
;	   (when (member w gens :test 'equal)
;	     (push (reverse piece) segments)
;	     (setf piece nil)))
;    (reverse segments)))

(defun find-all-segments (gens word)
  (let ((piece nil)
	(segments nil))
    (loop for w in (reverse word)
	do (cond ((null piece) (push w piece))
		 ((not (member w gens :test 'equal))
		  (push w piece))
		 ((and (< 1 (length gens)) (= w (car (last piece))))
		  (push w piece))
		 (t (push  piece segments)
		    (setf piece nil)
		    (push w piece))))
    (cons piece segments)))
  
  
(defun cox-elem-to-partition (elem)
  (loop for seg in (find-all-segments *gens* (cox-find-reduced elem)) 
      collect (length seg)))


(defun cox-elem-to-colored-partition (elem)
  (when (not (equal elem *identity-element*))
    (loop for seg in (find-all-segments *gens* (cox-find-reduced elem)) 
	collect (gethash seg *cox-segment-names*))))

(defun cpart-to-cox-elem (cpart)
  (cox-segments-to-elem 
   (loop for part in cpart 
       collect (cox-segment (cpart-size part) (cpart-color part)))))


(defun cox-partition (gens word)
  (loop for segment in (find-all-segments gens word)
      collect (length segment)))

(defun grind-cox-partitions (gens &optional (verbose t))
  (let ((partitions nil)
	(segment-types nil))
    (loop for i from 0 to *thresh* 
	do (loop for elem in (gethash i *cox-quotient-hash*) 
	       for partition = (cox-partition gens (cox-find-reduced elem))
	       for segments = (find-all-segments gens (cox-find-reduced elem))
	       do (when (not (member partition partitions :test 'equal))
		    (push partition partitions)
		    (when (not (increasing-p partition))
		      (print (list 'not-increasing partition))))
		  (loop for segment in segments do
			(when (not (member segment segment-types :test 'equal))
			  (push segment segment-types)))
		  ))
    ;;; setup segments and cross ref names
    (setf *cox-segments* (make-array (list (1+ (find-supremum (mapcar #'length segment-types) '>)))))
    (loop for segment in segment-types
	do  (push segment (aref *cox-segments* (length segment))))
    (loop for i from 1 to  (find-supremum (mapcar #'length segment-types) '>)
	do  (setf (aref *cox-segments* i) (sort (aref *cox-segments* i) 'lex-order))
	    (when verbose 
	      (loop for segment in (aref *cox-segments* i)
		  do (format t "~%~a len: ~a" segment (length segment)) )))
    (set-segment-name-hash gens)
    ;;; setup partitions
    (setf *cox-partitions* (make-array (list (1+ (find-supremum (mapcar #'length partitions) '>)))))
    (loop for part in partitions
	do  (push part (aref *cox-partitions* (length part))))
    *cox-partitions*))


(defun weak-order-colored-parts ()   ;;; copy from weak order on segments
  (setf *colored-parts-order* (make-hash-table :test 'equal))
  (let* ((longest-segment (car (aref *cox-segments* (1- (array-dimension  *cox-segments* 0)))))
	 (weak-order-interval (cox-left-weak-interval (cox-build-coroot longest-segment)))
	 (coroot-names (make-hash-table :test 'equal)))
    (maphash #'(lambda (key val)
		 (setf (gethash key coroot-names)
		   (coroot-segment-to-colored-part key)))
	     weak-order-interval)
    (maphash #'(lambda (key val)
		 (cond ((null val) nil)
		       ((equal key (cox-build-coroot '(0))) 
			(setf (gethash (gethash key coroot-names) *colored-parts-order*) nil))
		       (t (setf (gethash (gethash key coroot-names) *colored-parts-order*)
			    (loop for coroot in val collect (gethash coroot coroot-names))))))
	     weak-order-interval))
  *colored-parts-order*)
    
    
(defun coroot-segment-to-colored-part (coroot)  
  (gethash (cox-find-reduced (coroot-to-cox-elem coroot)) *cox-segment-names*))



(defun determine-gen-segment-relations (&optional (end nil))
  (loop for i from 1 below (array-dimension  *cox-segments* 0)
      do (loop for seg in (aref *cox-segments* i)
	     when (and end (member (car (last seg)) end :test '=))
	     do  (format t "~%~%Segment: ~a  j=~a ~%Relations: ~a " seg (length seg) (commutation-finder seg)))))

(defun commutation-finder (word)
  (let ((commuting nil)
	(modified nil)
	(non-commuting nil))
    (loop for i from 0 below *n* 
	for  v = (cox-build-elem (cons i word))
	do (if (equal v (cox-build-elem (append word (list i))))
	       (push i commuting)
	     (when (catch 'foo
		     (loop for j from 0 below *n* 
			 for w = (cox-build-elem (append word (list j)))
			 when (equal w v)
			 do  (push (cons i j) modified)
			     (throw 'foo nil))
		     (throw 'foo t))
	       (push i non-commuting))))
	       
    (list commuting modified non-commuting)))
    

(defun set-segment-name-hash (gens)
  (setf *cox-segment-names* (make-hash-table :test 'equal))
  (setf *cox-segments-by-end* (make-hash-table :test 'equal))
  (loop for gen in gens do 
	(loop for i downfrom (1- (array-dimension  *cox-segments* 0)) to 1
	    do (loop for seg in (loop for tegg in (aref *cox-segments* i) when (= gen (car (last tegg))) collect tegg)
		   for j from 0
		   do   (push seg (gethash gen *cox-segments-by-end*))
			(setf (gethash seg *cox-segment-names*) (list i j))))))
			 
  



(defun determine-segment-segment-relations (gens &optional (verbose t))
  ;;; use '(1 0) to set priority for cox-find-reduced
  (let* ((red-prod nil)
	 (ending (if (equal gens '(0)) 0 1))
	 (allowed nil)
	(relations  (make-array (list (+ 1 (length (gethash 0 *cox-segments-by-end*)))
				      (+ 1 (length (gethash  ending *cox-segments-by-end*)))))))
    (setf *segment-repeaters* nil)
    ;; label first row and column
    (loop for seg in (gethash 0 *cox-segments-by-end*)
	for j from 1
	do 
	  (setf (aref relations 0 j) (gethash seg *cox-segment-names*))
	  )
    (loop for teg in (gethash ending *cox-segments-by-end*)
	for i from 1
	do 
	  (setf (aref relations i 0) (gethash teg *cox-segment-names*)))
    ;; set up relations for teg.seg
    (loop for teg in (gethash ending *cox-segments-by-end*)
	for i from 1
	do (loop for seg in (gethash 0 *cox-segments-by-end*)
	       for j from 1
	       for  prod = (cox-build-elem (append teg seg))
	       do  
		 (setf red-prod (cox-find-reduced prod gens ))
		 (cond ((> (+ (length seg) (length teg)) (length red-prod))  ;; not reduced
			(setf (aref relations i j) 'not-red)
			)
		       ((min-length-coset-rep-p prod *parabolic*) 	     ;; allowed product		
			(setf (aref relations i j) 'allowed)
			(push (list teg seg) allowed)
			)
		       (t (setf (aref relations i j)                        ;; reduced but not min length coset rep
			    (loop for leg in  (find-all-segments gens red-prod )
				collect (if (gethash leg *cox-segment-names*) (gethash leg *cox-segment-names*)
					  leg)))

			  ))))
    (when verbose (format t "~%Allowed products of segments:~%")
	  (loop for pair in allowed 
	      for next-pair in (append (cdr allowed) (list nil))
	      do
		(format t " (")
		(cox-print-segment-name (gethash (car pair) *cox-segment-names*))
		(cox-print-segment-name (gethash (second pair) *cox-segment-names*))
		(format t ")")
		(when (not (equal (car pair) (car next-pair)))
		  (format t "~%~%"))))
    (loop for pair in allowed when (equal (car pair) (second pair)) do (push (car pair) *segment-repeaters*))
    (setf *allowed-pairs* allowed)
    (setf *allowed-hash* (make-hash-table :test 'equal))
    (setf (gethash nil *allowed-hash*)
      (loop for i from 1 below (array-dimension  *cox-segments* 0)
	  appending (loop for seg in (aref *cox-segments* i)
			collect seg)))
    (loop for pair in *allowed-pairs*
	do (push (second pair) (gethash (first pair) *allowed-hash*)))
    ;relations
    ))



(defun allowed-segments-with-segment (segment)
  (loop for pair in *allowed-pairs*
      when (and (member segment  pair :Test 'equal) 
		(not (equal (car pair) (second pair))))
      collect (if (equal (car pair) segment) (second pair)
		(car pair))))
(defun cox-segment-repeaters-p (elem)
  (catch 'foo
    (loop for seg in (find-all-segments *gens* (cox-find-reduced elem)) 
	when (member seg *segment-repeaters* :Test 'equal)
	do (throw 'foo t))
    (throw 'foo nil)))

(defun cox-segment-allowed-with-all-p (seg)
  (and (member seg *segment-repeaters* :Test 'equal)
       (=   (length (loop for pair in *allowed-pairs*
			when (member seg pair :test 'equal)
			collect pair))
	    (length       (loop for i from 1 below (array-dimension  *cox-segments* 0)
			      appending (loop for seg in (aref *cox-segments* i)
					    collect seg))))))
	    


(defun  cox-no-repeaters (thresh)
  (loop for i from 0 to thresh 
      appending (loop for elem in (gethash i *cox-quotient-hash*) 
		    when (not (cox-segment-repeaters-p elem)) collect elem)))


(defun cox-find-segmented-reduced (elem)
  (find-all-segments *gens* (cox-find-reduced elem)) )

(defun cox-segments-to-elem (segments)
  (let ((new-elem *identity-element*))
    (loop for seg in segments
	do  (setf new-elem (cox-build-elem seg new-elem)))
    new-elem))
	  
(defun cox-segment (size color)   ;; from size^color to reduced expression
  (nth color (aref *cox-segments* size)))


(defun cox-insert-segment (elem segment)
  (let ((segments (cox-find-segmented-reduced elem))
	(apply t)
	(new-elem *identity-element*))
    (if (null (car segments)) (setf new-elem (cox-build-elem segment))
      (loop for seg in segments
	  for i from 1 
	  do (when (and (< (length segment) (length seg))
			apply)
	       (progn (setf apply nil)
		      (setf new-elem (cox-build-elem segment new-elem))))
	     (setf new-elem (cox-build-elem seg new-elem))
	     (when (and apply (= i (length segments)))
	       (setf new-elem (cox-build-elem segment new-elem)))))
    new-elem))
    
    

(defun cox-print-segment-name (name)
  (when name
    (if (= 0 (second name)) 
	(format t "~a." (car name))
      (format t "~a^~a." (car name) (second name)))))


(defun cox-print-segment-decomposition (w &optional (gens '(0)))
  (print-segment-list  (find-all-segments gens (cox-find-reduced w gens))))

(defun print-segment-list (segments)
    (format t "(")
    (loop for seg in segments 
	do (cox-print-segment-name (gethash seg *cox-segment-names*)))
    (format t ")"))
  

(defun print-segments-latex ()
  (loop for j from 1 below (array-dimension *cox-segments* 0)
      do
	(loop for seg in (aref *cox-segments* j)
	    do (format t "~% \\segment{}{}(")
	       (cox-print-segment-name (gethash seg *cox-segment-names*))
	       (format t ") = ")
	       (loop for i in seg
		   do (format t "s_~a" i))
	       (format t " & ~a \\\\" (length seg)))))
;;;;	       

(defun compare-partitions ()
  (let ((part nil)
	(results nil))
  (maphash #'(lambda (key val)
	       (setf part (cox-partition '(0 1) (cox-find-reduced key)))
	       (loop for u in val
		   for  diff = (sort (mapcar 'abs (unique-elems (subtract-lists part (cox-partition '(0 1) (cox-find-reduced u))))) '>)
		   when (> (car diff) 1)
		   do (format t "~%v= ~a part = ~a~%" key part)
		      (format t "u= ~a u-part = ~a" u (cox-partition '(0 1) (cox-find-reduced u)))))
	   *quotient-bruhat-hash*)
  ))

(defun all-factored-segments-of-length (n)
  (let ((results nil))
    (flet ((helper (tail) 
	     (push tail results)))
      (all-factored-segments-tester n 0  #'helper *allowed-hash* nil)
      results)))

;;;find all factored sequences of segments  of a certain size
(defun all-factored-segments-tester (n k test hash tail)
  (if (= n k)
      (funcall test tail)
    (loop for next-segment in (gethash (car tail) hash)
	when (or (> n (+ k (length next-segment)))
		 (= n (+ k (length next-segment))))
	do 	  
	  (all-factored-segments-tester n (+ k (length next-segment)) 
					 test hash (cons next-segment tail)))))

;;;find all factored sequences of segments  of a certain size ,  this time with at most one segment of each type
(defun all-distinct-factored-segments-of-length (n &optional (hash *allowed-hash*))
  (let ((results nil))
    (flet ((helper (tail) 
	     (push tail results)))
      (all-factored-segments-tester n 0  #'helper hash nil)
      results)))

(defun all-distinct-factored-segments-of-length (n)
  (let ((results nil))
    (flet ((helper (tail) 
	     (push tail results)))
      (all-factored-segments-tester n 0  #'helper *allowed-hash* nil)
      results)))

(defun cox-gen-function (n segment-list )
  (loop for i from 0 to n 
      collect (length (distinct-segments-with-matched-repeaters i segment-list))))
	       
(defun distinct-segments-with-matched-repeaters (n segment-list )	       
  (loop for prod in (all-distinct-factored-segments-of-length n hash)
      when (same-lists-p segment-list (copy-list (intersect-lists (list *segment-repeaters* prod)) ))
      collect prod))
	       
(defun master-maple-formula-e6 ()   ;;; this formula still needs to be divided by deno:=(1-t^20)* (1-t^21)* (1-t^22);
  (let* ((no-repeats (cox-gen-function 100 (list )))
	 (counter 0)
	 (n (+ 10 (position-n no-repeats 0)))
	 (the-list (loop for segment in *segment-repeaters* when (> 20 (length segment)) collect segment))
	 (gen nil))
    (flet ((helper (tail)
	     (when (allowed-product-segments tail)
	       (incf counter)
	       (setf gen (cox-gen-function (+ n (apply '+ (mapcar 'length tail))) tail))
	       (format t "~%gen[~a]:=polyfy(" counter)
	       (print-list-maple gen)
	       (format t ")/mul(1-t^i, i=")
	       (print-list-maple (mapcar 'length tail))
	       (format t "); # ")
	       (loop for seg in tail do (cox-print-segment-name (gethash seg *cox-segment-names*))))))

      (print the-list)
      (all-subsequences-tester (reverse the-list) #'helper nil))))

(defun master-maple-formula-e7 ()
  (let* ((counter 0)
	 (n 180 )  ;; (no-repeats (cox-gen-function 180 (list ))) starts to produce zeros at 177
	 (the-list (loop for segment in *segment-repeaters* when (> 31  (length segment)) collect segment))
	 (gen nil))
    (flet ((helper (tail)
	     (when (allowed-product-segments tail)
	       (incf counter)
	       (format t "~%~%##")
	       (loop for seg in tail do (cox-print-segment-name (gethash seg *cox-segment-names*)))
	       (format t "~%gen[~a]:=polyfy(" counter)
	       (setf gen (cox-gen-function (+ n (apply '+ (mapcar 'length tail))) tail))
	       (print-list-maple gen)
	       (format t ")/mul(1-t^i, i=")
	       (print-list-maple (mapcar 'length tail))
	       (format t ");"))))
      (print the-list)
      (all-subsequences-tester (reverse the-list) #'helper nil))))

  
(defun master-maple-formula ()
  (let* ((counter 0)
	 (the-list nil)
	 (all-allowed-repeaters nil)
	 (gen nil))
    (loop for segment in (reverse *segment-repeaters*) do 
	  (if (cox-segment-allowed-with-all-p segment) 
	      (push (gethash segment *cox-segment-names*) all-allowed-repeaters)
	    (push (gethash segment *cox-segment-names*) the-list)))
    (format t "~%~%## Cut Here and Paste into Maple to Simplify:")
    (format t "~%~%## Denominator corresponding to parts allowed with all: ")
    (format t "~%~%deno[~a,~a]:= mul(1-t^i, i="  (caar *type*) (cdr (car *type*)))
    (print-list-maple (mapcar 'cpart-size all-allowed-repeaters))
    (format t "):")
    (flet ((helper (tail)
	     (when (allowed-cpart-p tail *allowed-cpart-hash*)
	       (incf counter)
	       (format t "~%~%## Repeaters: ~a" tail)
	       (format t "~%gen[~a]:=polyfy(" counter)
	       (setf gen (cpart-rank-gen-function-with-required-repeaters tail))
	       (print-list-maple (car gen))
	       (format t ")/mul(1-t^i, i=")
	       (print-list-maple (mapcar 'cpart-size tail))
	       (format t "):"))))
      ;(print the-list)
      (all-subsequences-tester (reverse the-list) #'helper nil))
    (format t "~%~%## End Cut:")))

(defun master-maple-formula-max-k-size (k)
  (let* ((counter 0)
	 (the-list (loop for part in *repeating-parts* when (> k  (cpart-size part)) collect part))
	 (gen nil))
    (flet ((helper (tail)
	     (when (allowed-cpart-p tail *allowed-cpart-hash*)
	       (incf counter)
	       (format t "~%~%## ~a" tail)
	       (format t "~%gen[~a]:=polyfy(" counter)
	       (setf gen (cpart-rank-gen-function-with-required-repeaters tail))
	       (print-list-maple (car gen))
	       (format t ")/mul(1-t^i, i=")
	       (print-list-maple (mapcar 'cpart-size tail))
	       (format t "):"))))
      (print the-list)
      (all-subsequences-tester (reverse the-list) #'helper nil))))

(defun grind-affine-partition-gf (type n thresh)
  (grind-affine-partitions type n thresh)
  (if (< (array-dimension *cox-segments* 0) thresh)
      (master-maple-formula )
    (format t "~%~%Rerun with higher thresh value, some segments not found.~%")))




(defun allowed-product-segments (segment-list)
  (catch 'foo 
    (loop for seg in segment-list
	for teg in (cdr segment-list)
	when (not (member teg (gethash seg *allowed-hash*) :test 'equal))
	do (throw 'foo nil))
    (throw 'foo t)))
  

	 
    

    

(defun allowed-segments-only-p (elem allowed)
  (or (equal elem *identity-element*)
      (catch 'foo
	(loop for segment in (find-all-segments *gens* (cox-find-reduced elem))
	    when (not (member segment allowed :Test 'equal))
	    do (throw 'foo nil))
	(throw 'foo t))))

(defun avoiding-segments-p (elem disallowed)
    (catch 'foo
      (loop for segment in (find-all-segments *gens* (cox-find-reduced elem))
	  when (member segment disallowed :Test 'equal)
	  do (throw 'foo nil))
      (throw 'foo t)))


(defun cox-sort-by-length (elem-list)
  (let ((elem-hash (make-hash-table :test 'equal)))
    (loop for elem in elem-list
	do  (push elem (gethash (cox-length elem) elem-hash)))
    elem-hash))


(defun nr-partitions-allowed-with-segments (segment-list)
  (let* ((allowed (intersect-lists (loop for segment in segment-list collect (allowed-segments-with-segment segment))))
	 (hash (cox-sort-by-length  (loop for elem in *no-repeat*
					when (allowed-segments-only-p elem allowed)
					collect elem))))
    (loop for i from 0 to *thresh* collect (length (gethash i hash)))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun a-segment (i j)	;;;   0<=i <= n, 1<=j<=n
  (when (= j 0)  (format t "wrong j"))
  (append (loop for a downfrom i to 1 collect a)
	  (loop for b from (- (1+ *n*) j) below *n* collect b)
	  (list 0)))

(defun a-pairs (n)
  (sort (loop for i from 0 to n 
	    appending (loop for j from 1 to n
			  collect (list i j))) 'smaller-sum-p))


(defun check-a-segment-rels ()
  (let ((pairs (a-pairs (1- *n*))))
    (loop for a in pairs 
	for ca = (a-segment (first a) (second a))
	do (loop for b in pairs
	       for cb = (a-segment (first b) (second b))
	       when (not (equal (my-test a b (1- *n*))
				(consecutive-segments-p ca cb)))
	       do (format t "~%New Relation: ~a ~a" a b )
		  (format t "~%   my-test: ~a  min-length:~a"
			  (my-test a b (1- *n*))
			  (consecutive-segments-p ca cb))))))

(defun list-a-segment-rels (n)
  (let ((pairs (a-pairs n)))
    (loop for a in pairs 
	for ca = (a-segment (first a) (second a))
	collect (loop for b in pairs
		    for cb = (a-segment (first b) (second b))
		    when (consecutive-segments-p cb ca)
		    collect (list b a)))))


(defun my-test (a b n)
  (let ((cb (a-segment (first b) (second b)))
	(ca (a-segment (first a) (second a))))
    (or (and (<  n (length ca) )
	     (<= (first a) (first b))
	     (<= (second a) (second b)))
	(and (< n (length cb) ) 
	     (< (first a) (first b))
	     (<= (second a) (second b)))
	(and 
	     (< (first a) (first b))
	     (< (second a) (second b))))))
	
(defun consecutive-segments-p (ca cb)
  (and (= (+ (length ca) (length cb))
	  (cox-length (cox-build-elem (append ca cb)) ))
       (min-length-coset-rep-p (cox-build-elem (append ca cb))
			       *parabolic*)))

(defun find-unique-segment-types ()
  (unique-elems (loop for i from 1 to (* 2 (1- *n*)) appending (loop for seg in (aref *cox-segments* i) collect (colapse-zeros (cox-build-coroot seg))))))


(defun find-unique-segment-product-types ()
  (let ((results nil))
    (maphash #'(lambda (key val)
		 (setf results (unique-elems (append results (loop for seg in val collect (colapse-zeros (cox-build-coroot (append key seg))))))))
	     *allowed-hash*)
    results))

(defun segment-product-hash ()
  (setf *segment-product-hash* (make-hash-table :test 'equal))
  (maphash #'(lambda (key val)
	       (loop for seg in val do (push (append key seg) (gethash (colapse-zeros (cox-build-coroot (append key seg))) *segment-product-hash*))))
	   *allowed-hash*)
  *segment-product-hash*)


(defun mitchell-palindromic (i j k)
  (let ((n (1- *n*)))
    (cond ((and (= i 0) (= (- n j) (mod k n))) 
	   (cox-build-elem (append (a-segment i j) (loop for i from 1 to k appending (a-segment 1 n)))))
	  ((and (= j 1) (= (- n i 1) (mod k n))) 
	   (cox-build-elem (append (a-segment i j) (loop for i from 1 to k appending (a-segment n 1)))))
	  (t (format t "~% Mitchell index not correct: ~a" (list i j k))))))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; from colored.partitions.lisp  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;



;;;; Colored partitions arrise in the affine grassmannians
;;;  and Coxeter.lisp.  These partitions are determined by pairwise adacency rules in *allowed-cpart-hash*.

;; colored partitions are represented by lists of cons cells (list (list lambda_1 c_1) (list lambda_2 c_2) ...)
;;; with the lambda_i's weakly increasing and the c_i's are the colors

(defun grind-affine-partitions     (type n thresh) 
  (make-affine-quotient type n thresh (loop for i from 1 to n collect i))
  (setf *gens* (if (member type (list 'affine-b 'affine-d :test 'equal)) '(1 0) '(0)))
  (grind-cox-partitions *gens* nil)
  (weak-order-colored-parts)
  (setf *gen-young-lattice* (make-hash-table :test 'equal))
  (determine-segment-segment-relations *gens* nil)
  (setup-allowed-segments-to-allowed-cparts))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;(setf *allowed-cpart-hash* (make-hash-table :test 'equal))


;;; the following functions depend on the representation of a colored partition.  Otherwise, it is just a list of "parts".





(defun cpart-color (a)
  (second a))

(defun cpart-size (a) 
  (car a))

(defun cpart-length (cpart)   ;;; size of the colored partition in cpart
  (apply '+ (loop for part in cpart collect (cpart-size part))))


(defun compare-cparts (a b)  ;;; for sorting order
  (cond ((null a) t)
	((null b) nil)
	((< (cpart-size a) (cpart-size b)) t)
	(t (and (= (cpart-size a) (cpart-size b))
	    (< (cpart-color a) (cpart-color b))))))



(defun allowed-cpart-p (cpart  &optional (allowed-hash *allowed-cpart-hash*)) ;;; assumes cpart is sorted in increasing order
  (catch 'foo 
    (loop for p in cpart 
	for q in (cdr cpart)
	when (not (member q (gethash p allowed-hash) :test 'equal))
	do (throw 'foo nil))
    (throw 'foo t)))


;;;find all allowed colored partions  of a certain size
(defun all-allowed-cparts-of-length (n &optional (allowed-hash *allowed-cpart-hash*))
  (let ((results nil))
    (flet ((helper (tail) 
	     (push tail results)))
      (all-allowed-cparts-tester-given-length n 0  #'helper allowed-hash nil)
      results)))

(defun all-allowed-cparts-tester-given-length (n k test hash tail)
  (if (= n k)
      (funcall test tail)
    (loop for next-cpart in (gethash (car tail) hash)
	when (or (> n (+ k (length next-cpart)))
		 (= n (+ k (length next-cpart))))
	do 	  
	  (all-allowed-cparts-tester-given-length n (+ k (length next-cpart)) 
					 test hash (cons next-cpart tail)))))

(defun all-allowed-cparts-tester (test hash tail)   ;;; warning won't terminate if hash has repeaters!!!
  (funcall test (reverse tail))
  (loop for next-cpart in (gethash (car tail) hash)
      do 	  
	  (all-allowed-cparts-tester test hash (cons next-cpart tail))))


(defun restricted-cpart-hash (cpart-list &optional (repeats-p t))
  (let ((hash (make-hash-table :test 'equal)))
    (maphash #'(lambda (key val)
		 (when (member key cpart-list :Test 'equal)
		   (setf (gethash key hash) 
		     (intersect-lists (list cpart-list (loop for cpart in val when (or repeats-p (not (equal cpart key))) collect cpart))))))
	     *allowed-cpart-hash*)
    hash))

  
;;; since these cparts only depend on pairwise adjacent rules, their generating function depends on the 
;;;; finite gen function of distinct allowed cpartitions dived by product of (1-t^i) for each i which is allowed to repeat.  
(defun cpart-rank-gen-function-with-required-repeaters (required-repeaters)
  (when (allowed-cpart-p required-repeaters *allowed-cpart-hash*)
    (let ((restricted-hash (restricted-cpart-hash (loop for part in *non-repeating-parts* 
						      when (allowed-cpart-p (sort (copy-list (cons part required-repeaters)) 'compare-cparts) *allowed-cpart-hash*)
						      collect part) 
						  nil))
	  (n (cpart-length required-repeaters))
	  (counter-hash (make-hash-table :test 'equal)))
      (flet ((helper (tail) 
	       ;(print tail) ;;debug
	       (if (gethash (+ (cpart-length tail) n) counter-hash) 
		   (incf (gethash (+ (cpart-length tail) n) counter-hash))
		 (setf (gethash (+ (cpart-length tail) n) counter-hash) 1))))
	(all-allowed-cparts-tester #'helper restricted-hash nil)  ;; no length constraint
	(list (loop for i from 0 to (find-supremum (hash-keys counter-hash) '>)
		  collect (if (gethash i counter-hash) (gethash i counter-hash) 0))
	      (loop for part in required-repeaters collect (cpart-size  part)))))))

	       

(defun setup-allowed-segments-to-allowed-cparts ()
  (setf *allowed-cpart-hash* (make-hash-table :test 'equal))
  (setf *non-repeating-parts* nil)
  (setf *repeating-parts* nil)
  (loop for pair in *allowed-pairs* 
      for part1 =  (gethash (first pair) *cox-segment-names*) 
      for part2 =  (gethash (second pair) *cox-segment-names*) 
      do (push part2 (gethash part1 *allowed-cpart-hash*))
	 (when (equal part1 part2) (push part1 *repeating-parts*)))
  (maphash #'(lambda (key val)
	       (when key
		 (push key (gethash nil *allowed-cpart-hash*)))	;;; everything can follow nil
	       (when (not (member key *repeating-parts* :Test 'equal))
		 (push key *non-repeating-parts*)))
	   *allowed-cpart-hash*)
  (setf *repeating-parts* (sort *repeating-parts* 'compare-cparts))
  (setf *non-repeating-parts* (sort *non-repeating-parts* 'compare-cparts)))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;Generalized young's lattice
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defun young-interval (cpartition)
  (let ((hash (make-hash-table :test 'equal)))
    (rec-young-interval (list cpartition) hash)
    hash))


  
(defun rec-young-interval (cpart-list hash)
  (when cpart-list
    (let ((new-cparts nil))
      (loop for cpart in cpart-list 
	  do  (setf (gethash cpart hash) (young-covers cpart))
	      (setf new-cparts (append (gethash cpart hash) new-cparts)))
      (rec-young-interval  (unique-elems new-cparts) hash))))

(defun young-covers    (cpart)
  (when (null (gethash cpart *gen-young-lattice*))
    (setf (gethash cpart *gen-young-lattice*) (cpart-covers cpart)))
  (gethash cpart *gen-young-lattice*))

(defun cpart-covers (cpart)
  (when cpart
    (let ((covers nil))
      (loop for part in cpart
	  for i from 0
	  when (or (= 0 i) (not (equal part (nth (1- i) cpart))))  ;; only check corners
	  do  (loop for lower-part in (gethash part *colored-parts-order*)
		  for new-cpart = (append (first-n i cpart) (cons lower-part (nthcdr (1+ i) cpart)))
		  when (allowed-cpart-p new-cpart)
		  do (push new-cpart covers)))
      (when (= 1 (caar cpart))
	(push (cdr cpart) covers))
      covers)))

(defun cpart-poincare (elem &optional (palindrom-steps 0))   
  (if (equal elem (list nil)) '(1)
    (reverse (cons 1 (cpart-poincare-helper (1- (cpart-length elem)) (young-covers elem)  palindrom-steps)))))

(defun cpart-poincare-helper (index elem-list &optional (palindrom-steps 0))   
  (let ((covered-elems nil))
    (when (and elem-list (or (> 1 palindrom-steps) (= 1 (length elem-list))))
      (loop for elem in elem-list
	  do (loop for covered-elem in (young-covers elem)
		 when (not (member covered-elem covered-elems :test 'equal))
		 do (push covered-elem covered-elems)))
	(cons (length elem-list) 
	      (cpart-poincare-helper (1- index) covered-elems (1- palindrom-steps))))))

(defun cpart-palindromic-p (elem)
  (let ((poincare (cpart-poincare elem (1- (length *one-elem-index*))))) ;;;;  *one-elem-index* = list of ranks with 1 elem
    (and (= (length poincare) (1+ (cpart-length elem)))	  ;;; this is a shortcut for when the break point is up near the max so we don't build the whole poincare poly
	 (symmetric-list-p poincare))))   ;; in fact we only need to test symmetric when it actually is symmetric by the shortcut above



(defun thin-interval-p  (elem)
  (let* ((depth (length *one-elem-index*))  ;;;;  *one-elem-index* = list of ranks with 1 elem
	 (poincare (cpart-poincare elem (1- depth)))) 
    (and (= (length poincare) (1+ (cpart-length elem)))	  ;;; this is a shortcut for when the break point is up near the max so we don't build the whole poincare poly
	 (or (< (length poincare) depth)
	     (equal (first-n depth poincare)
		    (loop for i from 1 to depth collect 1))))))

(defun grow-thin-cparts (part-thresh)
  (setf *thin-cparts* (make-array (list (1+ part-thresh))))
  (push nil (aref *thin-cparts* 0))
  (loop for part in   (append *non-repeating-parts* *repeating-parts*)
      when (and part (thin-interval-p (list part)))
      do (push (list part) (aref *thin-cparts* 1)))
  (loop for i from 2 to part-thresh
      do  (loop for cpart in (aref *thin-cparts* (1- i))
	      do  (loop for new-part in (gethash (car (last cpart)) *allowed-cpart-hash*)
		      for new-cpart = (append cpart (list new-part))
		      when (thin-interval-p new-cpart)
		      do (push new-cpart (aref *thin-cparts* i)))))
  *thin-cparts*)


(defun grow-thin-cparts-from (start-cparts)
  (loop for cpart in start-cparts
      appending  (loop for new-part in (gethash (car (last cpart)) *allowed-cpart-hash*)
		      for new-cpart = (append cpart (list new-part))
		      when (thin-interval-p new-cpart)
		     collect new-cpart )))
  

(defun setup-extra-thin-cparts ()
  (setf *extra-thin-cparts* (make-hash-table :test 'equal))
  (push nil (gethash 0 *extra-thin-cparts*))
  (loop for part in   (append *non-repeating-parts* *repeating-parts*)
      when (and part (thin-interval-p (list part)))
      do (push (list part) (gethash 1 *extra-thin-cparts*))))



(defun grow-extra-thin-cparts (i)
  (when (and (null (gethash i *extra-thin-cparts*))
	     (> i 1))
    (setf (gethash i *extra-thin-cparts*)
      (loop for cpart in (grow-extra-thin-cparts (1- i))
	  appending  (loop for new-part in (gethash (car (last cpart)) *allowed-cpart-hash*)
			 for new-cpart = (append cpart (list new-part))
			 when (extra-thin-cpart-p new-cpart)
			 collect new-cpart ))))
  (gethash i *extra-thin-cparts*))

(defun extra-thin-cpart-p (cpart)
  (and (thin-interval-p cpart)
       (not (double-allowed-bruhat-split-p cpart))))


(defun grind-all-thin-cparts (type n thresh)
  (let ((palindromics nil)
	(poincare-break 1))
  (make-affine-quotient type n thresh (loop for i from 1 to n collect i))
  (create-quotient-bruhat-hash)
  (grind-cox-partitions *gens*)
  (weak-order-colored-parts)
  (setf *gen-young-lattice* (make-hash-table :test 'equal))
  (determine-segment-segment-relations *gens*)
  (setup-allowed-segments-to-allowed-cparts)
;;;; 
  (setup-extra-thin-cparts)
  (setf *long-chains* nil)
  (format t "~%~%In Type: ~a" *type*)
  (grow-extra-thin-cparts 7)
  (format t "~%  Extra Thin colored partitions up to length 7:  ~%")
  (print-sorted-hash *extra-thin-cparts* `<)
  (format t "~%  Checking which Extra Thin colored partitions up to len 7 are palindromic:  ~%")

  (loop for i from 0 to 7
      do (setf palindromics nil) 
	 (loop for cpart in (gethash i *extra-thin-cparts*)
	     do 
	       (if (cox-palindromic-p (cpart-to-cox-elem cpart)
				      *quotient-bruhat-hash* *cox-quotient-hash* )
		   (push cpart palindromics)
		 (setf poincare-break (max poincare-break (poincare-symmetry-break-point  (cpart-to-cox-elem cpart)
											  *quotient-bruhat-hash* *cox-quotient-hash* )))))
	 (format t "~%   ~a Parts: ~a" i palindromics))
  (format t "~%Max-Poincare-break-point:~a  achived at: ~a" poincare-break 
	  (loop for elem in *long-chains*
	      collect (cox-elem-to-colored-partition elem)))
  (format t "~%First-break-point-at-length:~a" (length *one-elem-index*))))

	  



(defun checking-bruhat-covers (k)  
  (format t "~% Checking Bruhat covers:")
  (loop for cpart in (aref *thin-cparts* k)
      do  (format t "~%   ~a: ~a" cpart
		  (cpart-bruhat-covers cpart)))
  (setf *remaining-to-check* 
    (loop for cpart in (aref *thin-cparts* k)
	when (not (double-allowed-bruhat-split-p  cpart))
	collect cpart))
  (format t "~%~%  Extra Thin colored partitions of length ~a remaining to check:  ~a " k (length *remaining-to-check*))
  (print *remaining-to-check* )
  nil)



  
  
(defun cpart-bruhat-covers (cpart)
  (let ((cox-elem (cpart-to-cox-elem cpart)))
    (when (null (gethash cox-elem  *quotient-bruhat-hash*))
      (setf (gethash cox-elem  *quotient-bruhat-hash*) 
	(cox-covered-elems cox-elem *parabolic*)))
    (loop for elem in (gethash cox-elem  *quotient-bruhat-hash*) 
	collect (cox-elem-to-colored-partition elem))))


	




(defun double-allowed-bruhat-split-p  (cpart)
  (let ((last-part (last cpart))
	(covered-b-cparts (cpart-bruhat-covers cpart)))
    (< 1 (length (loop for elem in covered-b-cparts
		     when (equal last-part (last elem))
		     collect elem)))))


;;;; testing palindromic elements have isomorphic bruhat and young's lattice intervals:



(defun test-bruhat-and-young-interval-isomorphic  (cpart)
  (cpart-b-y-test (list cpart)))

(defun cpart-b-y-test (elem-list)
  (let ((covered-elems nil))
    (or (equal elem-list '(NIL))
	(catch 'foo 
	  (loop for elem in elem-list
	      for y-covers = (young-covers elem)
	      for b-covers = (cpart-bruhat-covers elem)
	      do (if (not (same-lists-p y-covers b-covers 'equal)) 
		     (throw 'foo nil)
		   (setf covered-elems (unique-elems (append y-covers covered-elems)))))
	  (throw 'foo (cpart-b-y-test covered-elems))))))


(defun test-bruhat-young-palindromic-conjecture (type n thresh)
  (grind-affine-partitions type n thresh)
  (create-quotient-bruhat-hash)
  (format t "~%Testing palindromics:~%")
  (setf *palindromics* (cox-find-palindromics *quotient-bruhat-hash* *cox-quotient-hash* *gens*))
  (format t "~%~%Trouble with Bruhat-Young's lattice isomorphism: ~a" 
	  (loop for pal in *palindromics*
	      when (not (test-bruhat-and-young-interval-isomorphic (cox-elem-to-colored-partition pal)))
	      collect pal)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; tools from perms.lisp, polys.lisp, mat.lisp  ;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;; Hash table functions.

(defun print-hash (hash)
  (maphash #'(lambda (key val)
	       (format t "~%~a:: ~a"  key val))
	   hash))

(defun print-hash-file (hash file)
  (with-open-file
   (stream file :direction :output :if-exists :append)
   (maphash #'(lambda (key val)
		(format stream "~%~a:: ~a" key val))
	    hash)))


;;nice app: (print-sorted-hash *perm-hash* #'lex-order)
(defun print-sorted-hash (hash sort-fn)
  (let ((keys nil))
    (maphash #'(lambda (key val) (push key keys)) hash)
    (loop for key in (sort keys sort-fn)
	  do (format t "~%~a: ~a~%" key (gethash key hash)))))


(defun hash-keys (hash)
  (let ((keys nil))
    (maphash #'(lambda (key val)
		 (push key keys))
	     hash)
    keys))

(defun hash-vals (hash)
  (let ((vals nil))
    (maphash #'(lambda (key val)
		 (push val vals))
	     hash)
    vals))

(defun hash-equal (hash1 hash2 &optional (equal-test 'equal))
  (when (same-lists-p  (hash-keys hash1) (copy-list (hash-keys hash2)) equal-test)
      (catch 'foo 
	(maphash #'(lambda (key val)
		     (when (not (funcall equal-test val (gethash key hash2)))
		       (print val)
		       (print 'val-not-equal)
		       (throw 'foo nil)))
		 hash1)
	(throw 'foo t)
	)))


;;;; polynomial and list functions 

(defun colapse-zeros (alist)
  (let ((new (loop for i in alist
		 for j in (cdr alist)
		 when (not (and (= 0 i) (= 0 j)))
		 collect j)))
    (cons (car alist) new)))

(defun carefully-remove-zeros (l)
  (reverse (nthcdr
	    (catch 'foo
	      (loop for i in (reverse l)
		    for num from 0
		    do (when (not (= 0 i))
			 (throw 'foo num)))
	      (throw 'foo (length l)))
	    (reverse l))))


(defun print-list-maple (alist)
  (if (null alist) (format t "[]")
    (progn (format t "[~a" (car alist))
	   (loop for i in (cdr alist)
	       do (format t ",~a" i))
	   (format t "]"))))

	 
(defun add-lists (list1 list2)
  (append (loop for i in list1
		for j in list2
		collect (+ i j))
	  (when (> (length list1) (length list2))
	    (nthcdr (length list2) list1))
	  (when (< (length list1) (length list2))
	    (nthcdr (length list1) list2))))

(defun subtract-lists (list1 list2)
  (append (loop for i in list1
		for j in list2
		collect (- i j))
	  (when (> (length list1) (length list2))
	    (nthcdr (length list2) list1))))

(defun find-minimum (list)
  (find-supremum list #'<))

(defun find-supremum (list &optional (test #'>))
  "Returns the first element of LIST by the partial order implied by TEST."  ;;; first elem. must be non nil. Others can be nil.
  (loop with max = (car list)
      for e in (cdr list)
      when e
      do (when (funcall test e max)
	   (setq max e))
      finally (return max)))

(defun first-n (n l)
  (when (and l (> n 0))
	     (cons  (car l) (first-n (1- n) (cdr l)))))



(defun unique-elems (l)
  (cond ((null (cdr l)) l)
	((member (car l) (cdr l) :test #'equal)
	 (unique-elems (cdr l)))
	(t (cons (car l) (unique-elems (cdr l))))))
		 


(defun symmetric-list-p (alist)
  (equal alist (reverse alist)))

(defun symmetry-break-point (alist)
  (let ((break nil))
    (loop for i in alist for j in (reverse alist) for k from 0
	while (equal i j)
	finally (when (not (equal i j)) (setf break k)))
    break))



(defun same-lists-p (list1 list2 &optional (test #'equal))  ;;; this is side-affecting list2
  (let ((test-list (copy-list list2)))
    (when (= (length list1) (length list2))
      (catch 'bug
	(loop for item in list1
	      do (let ((t-elem (member item test-list :test test)))
		   (if t-elem
		       (setf (first t-elem) nil)
		       (throw 'bug nil))))
		
	(throw 'bug (null (loop for elem in test-list
				appending (when elem elem))))))))


(defun increasing-p (l)  ;;weakly increasing
  (cond ((null l) nil)
	((= 1 (length l)) t)
	((<= (car l) (cadr l))
	 (increasing-p (cdr l)))
	(t nil)))


(defun position-n (perm n)
  (let ((pos-n nil))
    (loop for i in perm
	  for j from 0 ;; 0 based
	  until  (= (abs i) n)
	  finally  (setf pos-n j))
    pos-n))

(defun count-matches (i word)
  (let ((count 0))
    (loop for j in word when (equal i j) do (incf count))
    count))



(defun rev-lex-order (list1 list2);;;assuming sums  equal
  (let ((a (reverse (carefully-remove-zeros list1)))
	(b (reverse (carefully-remove-zeros list2))))
    (cond ((> (length a) (length b)) t)
	  ((< (length a) (length b)) nil)
	  (t (catch 'foo
	       (loop for x in a
		   for y in b
		   do (cond ((< x y)
			     (throw 'foo nil))
			    ((> x y) (throw 'foo t))))
	       (throw 'foo t)))))) ;;; if equal return t ;;note changed from nil for new.products.lisp


(defun lex-order (list1 list2);;;assuming degrees equal
  (let ((a  (carefully-remove-zeros list1))
	(b  (carefully-remove-zeros list2)))
    (catch 'foo
      (loop for x in a
	for y in b
	do (cond ((> (abs x) (abs y))
		  (throw 'foo nil))
		 ((< (abs x) (abs y)) (throw 'foo t))
		 ((< x y)
		  (throw 'foo nil))
		 ((> x y) (throw 'foo t))))
      (cond ((< (length a) (length b)) t)
	    ((> (length a) (length b)) nil)
	    (t (throw 'foo t))))))

(defun lex-order-lists (list1 list2)
  (when list1 list2
	(catch 'foo
 	  (loop for i in list1
		for j in list2
		do (cond  ((< i j)
			   (throw 'foo t))
			  ((> i j)
			   (throw 'foo nil))))
	  (throw 'foo (< (length list1) (length list2))))))


(defun lex-order-lists-of-lists (list1 list2)
  (when list1 list2
	(catch 'foo
 	  (loop for i in list1
		for j in list2
	      do (cond  ((equal i j) nil)
			((lex-order-lists i j)
			 (throw 'foo t))
			((lex-order-lists j i)
			   (throw 'foo nil))))
	  (throw 'foo (< (length list1) (length list2))))))

;;;;;;

(defun all-subsequences-tester (the-list test tail)  ;;; formerly all-subset-tester
  (if (null the-list)
      (funcall test tail)
      (progn (all-subsequences-tester (cdr the-list) test (cons (car the-list) tail))
	     (all-subsequences-tester (cdr the-list) test tail))))

(defun all-partitions-tester (n-parts minvalue maxvalue test tail)
  (if (= 0  n-parts)
      (funcall test tail)
      (loop for a from minvalue to maxvalue
	    do (all-partitions-tester (1- n-parts) a maxvalue test
					(cons a tail)))))
(defun list-all-partitions (n-parts maxvalue)
  (let ((results nil))
    (flet ((helper (tail)
	     (push tail results)))
      (all-partitions-tester n-parts 0 maxvalue  #'helper nil))
    results))

(defun list-all-partitions-of-n (n n-parts minvalue)
  (let ((results nil))
    (flet ((helper (tail)
		   (when (= n (apply '+ tail))
		     (push tail results))))
      (all-partitions-tester n-parts minvalue n  #'helper nil))
    results))

(defun intersect-lists (list-of-lists &optional (eq-fn #'equal))
  (let ((start (car list-of-lists))
	(intersection nil))
    (loop for i in start
	  do (when (= 1 (apply #'* (loop for l in (cdr list-of-lists)
					 collect (if (member i l :test eq-fn)
						     1 0))))
	       (push i intersection)))
    intersection))