(in-package :maxima)

#|Zeitlinie@yahoo.de asks

Let's say I have two atoms a and b, they can be non-commutatively
multiplied, and should satisfy the rule

 a.b = b.a + 1

now it is (far too) simple to
 tellsimp(a.b,b.a+1);
But this will only apply the rule to
 a.b
The generic case of any product, with any number and order of a and b,
is not expanded according to a.b = b.a + 1.

How would one do this?
...
Actually I'd be very surprised if this would have never been implemented
by 'someone', because it is a stripped down version of something that
many-body physicist like to do when they 'normal' order bosons (in my
case its just single boson).
|#

#| Fairly easy and hugely hugely faster to do this without patterns.

1. Convert from a.b.c...   to  array or string "abc..."
2. Consider 2 hash tables indexed by strings.  processing and done.
3. Strings in which the characters are in the proper order are in the
table "done"  with a count of how many times they were inserted. 
The empty string is in order.
4. Strings in the processing table are tested:
  a. If s in proper order, it is removed and the entry in the done table
  is incremented. If no entry, it is inserted with count 1.
  b. for each string s in processing, let n be the location of the first pair out of order, s[n] and s[n+1]. 
  i. Insert in the processing table the string s with s[n],s[n+1] reversed.
  ii. Also insert the string with s[n..n+1]  removed. That is, shorter by 2.
  iii. Finally, remove the string s from the table.

5. If all strings removed from processing table, go through the done table
and convert to form you would like. Let the Maxima simplifier simplify 1*b to b etc.

|#

(defun mnc2string(r)
  ;; assume  a.b.c.a.b .  Single chars seems to be OK?
  ;; ((mnctimes simp) $a $b $c ...)
  (if (and(consp r)(eq (caar r) 'mnctimes))
  (let ((len (length (cdr r)))
	(inits (mapcar #'(lambda(c)(aref (symbol-name c) 1)) (cdr r ))))
    (make-array len :element-type 'character :initial-contents inits)) r))

;; (mnc2string  '((mnctimes) $a $b $foo $a $g))
;; returns "abfag"


(defun string2mnc(s)
  (if (stringp s)
  (let ((result nil))
    (map nil #'(lambda(c) 
		 (push (intern(concatenate 'string '(#\$)(list c))) result))
	 s)
    (if (null result) 1 
      (cons '(mnctimes simp)(nreverse result))))
  s))

;;(string2mnc "abcd")  returns  ((mnctimes simp) $a $b $c $d)

;; (unorder s) returns integer n if  s[n] and s[n+1] are out of order.
;; nil if everything is in order.

(defun unorder(s)
  (let ((h (length s)))
    (cond ((= h 0) nil)	;; empty string is in order
	  (t (do ((i 0 (1+ i))
		  (j 1 (1+ j)))
		 ((= j h) nil)
	       (if (char-lessp (aref s i)(aref s j))(return i)))))))

;;(unorder "cbab")  is 2
;; (unorder "cba")  is nil

(defun removepair(s n) ;; remove items n, n+1 from string s of length <n+1
  (concatenate 'string
		(subseq s 0  n)
		(subseq s (+ 2 n) )))

;; (removepair "abcdefg" 2)  returns  "abefg".  Note, string index starts at 0


(defun reversepair(s n) ;; remove items n, n+1 from string s of length <n+1
  (concatenate 'string
    (subseq s 0 n)
    (list (aref s (+ 1 n))(aref s  n))
    (subseq s (+ 2 n) )))

;; (reversepair "abcdefg" 2) returns "abdcefg"

;; e.g.  (run '((mnctimes) $a $b $c))  ;; assume initial case is one term?
(defun run (m)
  
    (let ((processing (make-hash-table :test 'equal)) ;; equalp except in GCL?
	  (done (make-hash-table :test 'equal))
	  (start (mnc2string m))
	  (res nil))
      (cond ((not (stringp start)) m)
	   (t
      (setf (gethash start processing ) 1) ; count is 1 to start
      ;; repeat until processing hash table is empty
      (while (> (hash-table-count processing) 0)
	(maphash #'(lambda(key val)		     
		     (let ((n (unorder key)))
		       (cond ((null n) 
			      (setf (gethash key done)
				(+ val (gethash key done 0)))
			      (remhash key processing))
			     (t (let ((rem (removepair key n))
				      (rev (reversepair key n)))
				  (setf (gethash rem processing)
				  (+ val(gethash rem processing 0)))
				(setf (gethash rev processing)
				  (+ val (gethash rev processing 0)))
				(remhash key processing))))))
		 processing))

      (maphash #'(lambda (key val)
		   (push (list '(mtimes) val (string2mnc key)) res))
	       done)
      (cons '(mplus) res)))))