;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Lambda algebra stuff
;; John Palmieri, 2004/02/06
;;
;; Lambda algebra stuff
;;
;; contents:
;;    list-to-mono
;;    lex-order
;;    lex-less-than
;;    sort-poly
;;    add-polys
;;    choose-mod-two
;;    *relations*
;;    adem
;;    coboundary-lambda
;;    inadmissible-p
;;    admissible-p
;;    make-mono-admissible
;;    coboundary-mono
;;    coboundary
;;    add-poly-to-set
;;    lambda-basis
;;    adem-table
;;    poly-to-string
;;    mono-to-string
;;    set-to-string
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (load "front.lisp")
;; (in-package bss)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lex-order:
;; what to use to order monomials.  can change to > for different
;; cohomology class representatives
(defparameter lex-order #'<)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lex-less-than:
;; what to use to order monomials.  may not work well on monomials
;; of different lengths, and may be inefficient if called with equal
;; monomials.
(defun lex-less-than (mono1 mono2)
  (and (consp mono1)
       (consp mono2)
       (or (funcall lex-order (car mono1) (car mono2))
	   (and (= (car mono1) (car mono2))
		(lex-less-than (cdr mono1) (cdr mono2))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; sort-poly:
;; arguments: polynomial poly
;; return:
;; poly sorted with lex-order
(defun sort-poly (poly)
  "sort POLY lexicographically"
  (sort poly #'lex-less-than))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; add-polys:
;; arguments: polynomial poly1, polynomial poly2
;; return:
;; sum of poly1 and poly2, mod 2
(defun add-polys (poly1 poly2 &key no-sort)
  "return mod 2 sum of POLY1 and POLY2.  If key NO-SORT is
non-nil, don't sort the result."
  (if no-sort
      (set-exclusive-or poly1 poly2 :test #'equal)
    (sort-poly (set-exclusive-or poly1 poly2 :test #'equal))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; choose-mod-two:
;; arguments: int n, int k
;; return: 
;; n choose k, mod 2.
(defun choose-mod-two (n k)
  "N choose K, mod 2"
  (declare (fixnum n k))
  (if (< n k)
      0
    (if (zerop (logand k (- n k)))
	1
      0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; *relations*:
;; update this in adem and make-mono-admissible.
(defvar *relations* (make-hash-table :test #'equal)
  "relations in Lambda")

;; this slows down the initial startup, and the table gets rebuilt
;; pretty quickly from scratch.  so don't bother storing it.
;; (setf *relations* (car (excl:fasl-read "relations.fasl")))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; adem:
;; arguments: int a, int b
;; return:
;; product of lambda_a and lambda_b in Lambda.
;;
;; so if 2a < b, use Adem relations; otherwise,
;; just return the polynomial (a,b).
(defun adem (a b)
  "lambda_a lambda_b as a sum of admissible monomials"
  (declare (fixnum a b))
  (if (>= (* 2 a) b)
      (list (list a b))
    (multiple-value-bind (entry hashed)
	(gethash (list a b) *relations*)
      (if hashed
	  entry
	(let ((n (- b (* 2 a) 1)))
	  (declare (fixnum n))
	  (setf (gethash (list a b) *relations*)
		(loop for j from 0 to (/ (- n 1) 2)
		      unless (zerop (choose-mod-two (- n j 1) j))
		      ;;unless (and (= -1 a) (zerop j))
		      collect (list (+ a n (- j))
				    (+ (* 2 a) 1 j)))))))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; *differentials*:
;; update this in coboundary-lambda and coboundary-mono.
(defvar *differentials* (make-hash-table :test #'equal)
  "differentials in Lambda")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; coboundary-lambda:
;; arguments: int n
;; return:
;; coboundary of lambda_n
(defun coboundary-lambda (n)
  "coboundary of lambda_n"
  (multiple-value-bind (entry hashed)
      (gethash (list n) *differentials*)
    (if hashed
	entry
      (setf (gethash (list n) *differentials*) (cdr (adem -1 n))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; inadmissible-p:
;; arguments: monomial mono
;; return: 
;; nil if mono is admissible;
;; otherwise return first index where inadmissible
(defun inadmissible-p (mono)
  "nil if MONO is admissible, otherwise return
head of list (reversed): all elements before bad pair,
tail of list, including bad pair."
  (do ((tail mono (cdr tail))
       (rev-head '() (cons (car tail) rev-head))
       (next (cdr mono) (cdr next)))
      ((null next) nil)
    (unless (>= (* 2 (car tail)) (car next))
      (return-from inadmissible-p
        (values rev-head tail)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; admissible-p
;; arguments: mono
;; t if mono is admissible, nil otherwise
(defun admissible-p (mono)
  "t if MONO is admissible, nil otherwise."
  (null (inadmissible-p mono)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; make-mono-admissible:
;; arguments: mono
;; return:
;; mono in admissible form.
;;
;; given mono, make it admissible by applying Adem relations. 
;; that is, find first place where mono is inadmissible
;; and apply adems there to get a polynomial where each term
;; looks like     (start of mono) (BLAH) (end of mono).  
;; examine each new term for admissibility and work recursively.
(defun make-mono-admissible (mono)
  "Given MONO, return it in admissible form, as a polynomial."
  (let (temp
	answer)
    (multiple-value-bind (rev-head tail) (inadmissible-p mono)
      (if (not tail)
	  (list mono)
	(multiple-value-bind (entry hashed)
	    (gethash mono *relations*)
	  (if hashed
	      (setf answer entry)
	    (progn
	      (setf temp (mapcar
			  (function
			   (lambda (x)
			     (revappend rev-head (append x (cddr tail)))))
			  (adem (car tail)
				(cadr tail))))
	      (dolist (mono-new temp)
		(setf answer (add-polys
			      (make-mono-admissible mono-new)
			      answer
			      :no-sort t)))
	      (setf answer (sort-poly answer)
		    (gethash mono *relations*) answer))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; coboundary-mono:
;; arguments: monomial mono
;; return:
;; coboundary of mono
(defun coboundary-mono (mono)
  "Coboundary of MONO.  Returns a poly."
  (multiple-value-bind (entry hashed)
      (gethash mono *differentials*)
    (if hashed
	entry
      (if (null mono)
	  nil
	(if (= (length mono) 1)
	    (coboundary-lambda (car mono))
	  (setf (gethash mono *differentials*)
		(butlast (make-mono-admissible (cons -1 mono)))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; coboundary:
;; arguments: polynomial * poly
;; return: 
;; coboundary of poly
(defun coboundary (poly)
  "Coboundary of POLY."
  (let (answer)
    (loop for mono in poly
	  for cbdry = (coboundary-mono mono) do
	  ;; don't sort at every step, just at the end.
	  (setf answer (add-polys cbdry answer :no-sort t)))
    (sort-poly answer)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; add-poly-to-set:
;; arguments: poly, set
;; return:
;; union of set and {poly}
(defun add-poly-to-set (poly set)
  (adjoin poly set :test #'equal))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lambda-basis:
;; arguments: homological, internal, key max
;; return:
;; basis elements for Lambda in bidegree (homological, internal)
;; which have leading term at most max.
;;
;; work recursively.
(defun lambda-basis (homological internal &key max) 
  "Basis of Lambda algebra in bidegree (HOM,INT), i.e., the list of
admissible sequences of bidegree (HOM,INT).  If key MAX is non-nil,
then all such admissible sequences with first term at most MAX."
  (declare (fixnum homological internal))
  (if (or
       (null max)
       (not (integerp max)))
      (setf max internal))
  (if (or 
       (<= internal 0)
       (zerop homological)
       (and (= homological 1) (< max (1- internal)))
       (and (= homological (1- internal)) (zerop max))
       (< internal homological))
      nil
    (cond
     ((= homological 1)
      (list (list (1- internal))))
     ((= homological internal)
      (list (make-list homological :initial-element 0)))
     ((= homological (1- internal))
      (list (cons 1 (make-list (1- homological) :initial-element 0))))
     (t
      (let (answer)
	;; include  (int-hom 0 0 . . . 0)
	(if (<= (- internal homological) max)
	    (push (cons (- internal homological)
			(make-list (1- homological) :initial-element 0))
		  answer))
	;; include  (int-hom-1 1 0 . . . 0)
	(if (<= (- internal homological 1) max)
	    (push (cons (- internal homological 1)
			(cons 1 (make-list (- homological 2) :initial-element 0)))
		  answer))
	;; include  (i blah) recursively, as i goes from 1 to int-hom-2
	(setf
	 answer
	 (nconc
	  answer 
	  (loop for i fixnum from 1 to (min max (- internal homological 2))
		nconc
		(mapcar
		 (function
		  (lambda (lam)
		    (cons i lam)))
		 (lambda-basis (- homological 1) (- internal i 1) :max (* 2 i))))))
	(sort-poly answer))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; adem-table:
;; arguments: i max
;; print adem relations (i,j), as j goes from 0 to max
(defun adem-table (i max)
  (loop for j from (1+ (* 2 i)) to max do
    (format t "~A = ~A~%"
	    (mono-to-string (list i j))  
	    (poly-to-string (adem i j)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; poly-to-string:
;; arguments: polynomial poly
;; convert poly to string
(defun poly-to-string (poly &key no-sort)
  "convert POLY to a pretty string"
  (if (null poly)
      " nil "
    (let ((output-string "") (beginning t))
      (dolist (mono (if no-sort poly (nreverse (sort-poly (copy-list poly)))))
	(if beginning
	    (setf beginning nil)
	  (setf output-string (concatenate 'string output-string " + ")))
	(setf output-string (concatenate 'string output-string
					 (mono-to-string mono))))
      output-string)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; mono-to-string:
;; arguments: monomial mono
;; convert mono to string
(defun mono-to-string (mono)
  "convert MONO to a string"
  (if (null mono)
      " nil "
    (let ((output-string "") (beginning t))
      (dolist (n mono)
	(if beginning
	    (setf output-string (concatenate 'string output-string "(")
		  beginning nil)
	  (setf output-string (concatenate 'string output-string " ")))
	(setf output-string
	      (concatenate 'string output-string (prin1-to-string n))))
      (concatenate 'string output-string ")"))))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; set-to-string:
;; arguments: set
;; convert set to string
(defun set-to-string (set)
  "convert SET to string"
  (if (null set)
      " empty set "
    (let (output-string (beginning t))
      (dolist (poly set)
	(if beginning
	    (setf beginning nil)
	  (setf output-string (concatenate 'string output-string ", ")))
	(setf output-string
	      (concatenate 'string output-string (poly-to-string poly))))
      output-string)))

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

;; (load "front.fasl")
;; (in-package lambda-alg)

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