(in-package :maxima)
#| A program in common lisp that does much of the pattern matching expected of
Mathematica.  syntax _, __, ___. is Blank, BlankSequence, BlankNullSequence.
Segment is used instead of Sequence in a result
Richard Fateman 2015
|#
(defvar bindings nil)
(defvar flathead nil)

(defun flatp(r)(or(member r '(mplus mtimes $FF $FO) :test #'eq)  
		 (and (symbolp r) (get r '|$Flat|))))

(defun orderlessp(r)(or(member r '(mplus mtimes $FO $OO) :test #'eq)  ;; stub, just for now
		    (and (symbolp r)   (get r '|$Orderless|))))

(defun $mdeclare (a b)(setf (get a b)t))  ;  (mdeclare 'ff '|$Orderless|)  or (mdeclare 'ff '|$Flat|)

(defun segmentize(r)(cons (or flathead '|%Segment|) r)) ;; the NOUN form. maybe 

(defun head(x) 
  (cond 
   #+sbcl((integerp x) '$integer) ;; needed for sbcl since (type-of 3) is (integer 0 536870911) 
   #+sbcl((floatp x) '$float)
   ((atom x)
    (typecase x ;; sbcl doesn't like float, double-float, complex ... What does it want?
      (integer '$integer)
      (ratio '$ratio) ;; won't happen in maxima if 1/2  is ((rat) 1 2)
      #-sbcl  ((single-float double-float short-float long-float float extended-float) '$float)
      (null nil)
      ;; (complex complex)	    ;insufficient for (mplus 2 (mtimes 3 $%i))
      (symbol '$symbol)
      (t '$unknown_atomic_head)))
   ;; x is a cons
   ((eq (car x) 'rat) '$ratio)
   (t (car x))))

;;;...........



(defun  pushcheck(k val) 
  ;; push (k . val) on bindings unless conflict or already there
  ;;(format t "~%pushcheck( ~s, ~s)" k val)
  (cond ((null k) t)	 ;un-name_d pattern means no binding. succeeds.
	(t(let ((b (assoc k bindings)))
	    (cond ((null b)(push (cons k val) bindings))
		  ((equal val (cdr b)) bindings)
	    ;; if there is a binding but does not match, return nil
	    )))))

(defun blankp (M) (and (consp M)
		       (member (car M) '(|$Blank| |$BlankSequence| |$BlankNullSequence|) :test 'eq)))
	 
(defun patternp (M) (and (consp M) (eq (car M) '|$Pattern|)))

(defun patternblankp(M)(and(patternp M)(blankp (third M))))

(defun headmatch(a b)(or (null a)(eq a b)))

(defun blank1proc (M N name_ c) ;; just  
  ;; M=( blank1 head) or just (blank1  )  N = anything used from m1 only
  (let  ((headcheck (if (cdr M)(cadr M) nil)) ; headcheck is nil if missing
	 (oldbindings bindings))
    (cond ((and (headmatch headcheck (head N)) ; heads match if specified
		(pushcheck name_ N)	; name_ can be bound if specified
		(funcall c))
	   t)
	  (t (setf bindings oldbindings) ; match fails; any bindings revoked
	     nil))))

(defun prefix (L tail) 
  ;; L = (prefix .. tail).  find prefix. tail must be eq to some nthcdr of L
  (if (or (null L)(eq L tail)) nil
    (cons (car L)(prefix (cdr L) tail))))

(defun blankproc (M N name_ blanknum c)  ;; probably buggy
    ;; (...  (blank2 head) ...
    ;;  M is perhaps  ((blank2  foo) more and more)
    ;;  N is perhaps  ((foo 34)  more and more)
    ;; or
    ;;  N is perhaps  ((foo 1)(foo 2) and more)
    ;; blanknum is 1,2,3 corresponding to Mathematica _, __,___  

	;;(format t "~% blank match ~s ~s name_= ~s blankN= ~s" M N name_ blanknum)
  (let ((headcheck (if (cdar M)(cadar M) nil))
	(oldbindings bindings))
    ;; 0 to L for mma blank___, 1 to L for blank__,
	;;(format t "~% blankproc: headcheck=~s, name_=~s, M=~s, N=~s bindings=~s" headcheck name_ M N bindings)
    (case blanknum
      ((2 3)
       (loop for i from 
	     (if (eq blanknum 2) 1 0) ;blanknum 3 starts count from zero
	   to (length N) do 
	     (let* ((r (nthcdr i N))
		    (p (prefix N r))) ;; each item in p must have headcheck
	    ;; (format t "~%segment trial N= ~s, remainder=~s name_=~s binds=~s" p r name_ bindings)
	      ;; try to match the remainder of the expr with the remainder of pattern
	     (cond
	      ((and 
		(loop for j in p
		   always 
		      (headmatch headcheck (head j)))
;;****		;;(progn (format t "~% bindings =~s" bindings) (setf bindings oldbindings) t)
		(pushcheck name_ (segmentize p))
		
		(cond ((e18x (cdr M) r nil c) (return-from blankproc t)) ; out of whole program
		      (t (setf bindings oldbindings) nil))  ;; if the follow-on pattern & expression match
		
		)
	       (return t)) ;return out of let
	      (t (setf bindings oldbindings)
		  nil ;(return nil)
		 ))
					;end cond
	     ))				; end loop i
       (setf bindings oldbindings) ;fell out of loop
      ;; t
       (return-from blankproc nil)
       )				; end of (2 3). failed to get a match even though we tried hard
		
      (1   ;; ((blank1 head )  stuff
;;       (format t "~% the name_ first is ~s" name_)
       (cond ((m18x (car M) (car N)
		    #'(lambda()
			;;(format t "~%the name_ second = ~s" name_)
			(and (pushcheck name_ (car N))
			     (e18x (cdr M) (cdr N) nil c))))
	      t)
	     (t(setf bindings oldbindings)
	       nil))))))


#| there seem to be inevitably two matching schemes because of __ blank2 and blank3
matching which can occur only in the middle of a list... e18x does this,  and
the "whole" list done by m18x  and friends.  Thus we are looking for (... (blank2 head) ...)
in e18,  but   (blank2 head) in m.
|#

(defun e18x (M N  name_ c)  ;usually name_ is nil 
	        ;(format t "~% e18x M=~s ~%  N=~s  bindings=~s" M N bindings)
	       (cond ((null M)(and (null N)(funcall c)))
		     ((and (not (consp M))(not (consp N)))
		      (and (equal M N) (funcall c)))
		     
		     ;; There is a (.... (pattern name_ (blank head))....)
		     ;; in the pattern form
		     

		     ((patternp (car M)) 
		      (let* ((name_ (second(car M)))
			     (wtm (cddr (car M)))
			     (oldbindings bindings))
			;;			;(format t "~%patternNOblank ~s name_=~s wtm=~s " M name_ wtm)
			;; if the pattern matches, name_ is bound to (car N).
			(cond
			 ((e18x  (cons (car wtm) (cdr M) )
					  N ;; (car N) ;;??
					  name_ ;;name_ ;!!!!
					  c) t)
			 
			     (t (setf bindings oldbindings) nil ))))
		     
		     ;; blankN 
		     ;; any binding resulting from this match will come from surrounding (pattern..)
		   
		     ((blankp (car M)) (blankproc M N name_    ;was (blankp (car M))
						  (case (caar M) (|$Blank| 1)
							(|$BlankSequence| 2)(|$BlankNullSequence| 3))
						  c))


		     ;;; add other stuff here.  Like patterntest, and condition
		     ;;; but should this be treated here like  (.... a__?test ... ) or like (a__)?test
		     ;;; except, etc 
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$Condition|))
		      (e18x (cdr M)(cdr N) nil
				   #'(lambda()(conditiontestproc
						   (second (car M)) 
						   N  ; the expression
						   c))) )
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$Optional|))
		      (or
		       (e18x (cons (second (car M))(cdr M)) N nil c)
		       (e18x (cdr M) N nil c)))
		     
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$Alternatives|))  ;; need to allow more than 2
		      (some #'(lambda(r)(e18x (cons r (cdr M)) N name_ c)) (cdr(car M)))
		      #+ignore
		      (or
		       (e18x (cons (second (car M))(cdr M)) N name_ c)
		       (e18x (cons (third (car M)) (cdr M)) N name_ c)))
		     
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$PatternTest|))
		      (e18x (cdr M)(cdr N) nil
				   #'(lambda()(conditiontestproc
						   (second (car M)) 
						   N  ; the expression
						   c)))	      
		      )
		     
	     ((and (consp M)(consp (car M))
	      (eq (caar M) 'defaultbind) ;; ((defaultbind var val pattern)
	      (pushcheck (second (car M))(third (car M)))
	      (e18x (cons (fourth (car M))(cdr M)) N name_ c)) t)

	     ((and(consp M)(consp(car M))(not (consp N)))
		      nil)
		     
	     ((and(consp M)(consp N))
		      (m18x (car M)(car N) ;;nil 
			    #'(lambda()  ;; name or nil?
				(e18x (cdr M)(cdr N) 
				      nil
				      #'(lambda()
					  (and (pushcheck name_ (car N))
					       (funcall c)))))))  ;; name or nil?
		     ;; no blanks, no sublists
	     (t				; at least one is an atom
	      (setf bindings oldbindings)
	      nil)))

(defun conditiontestproc (M N c) ; M looks like (PatternTest pat  test)
   (let ((oldbindings bindings))
     
	   (cond
	    ((and (m18x (second M) N c) ;ie (m18x pat exp c);  c does not include test yet.
		 
;; this next line requires maxima!
		  (eq t (ignore-errors(meval(list '($is) (carzip(substall bindings (third M)))))))

		  ) t)
				;; well, should be some cleverer symbolic version
	    (t(setf bindings oldbindings) 
	      nil))))


(defun patterntestproc (M N c) ; M looks like (PatternTest pat  test)
  (let ((oldbindings bindings)
	(test (third M)))
     
	   (cond
	    ((and (m18x (second M) N c) ;ie (m18x pat exp c);  c does not include test yet.
		 
		  ;; this next line requires maxima!
		  
		  #+ignore
		(progn (format t "~% test is ~s bindings=~s N=~s meval is--~s"
			  test  bindings  N 
			  (meval(list '($is)(list (carzip test) N)))
			  ) t)
		  
		  (eq t (ignore-errors(meval(list '($is)(list (carzip test) N))))))
		   t)
	    (t(setf bindings oldbindings) 
	      nil))))

(defun m18x (M N c) 
  ;; this is for matching pattern M = (f x y z) 
  ;; to expression N = (f x y z) with conditions c
  ;; but M may have pattern notations like blank, pattern, etc.
  
					;(format t "~% M18x ~s ~s"M N)


  (cond ((consp N) 
	 (if (flatp (car N)) (setf flathead (car N)))))
  
					;(format t "~%flathead=~s" flathead)
  
  (cond 
   ;; #+ignore  ;; this clause and eom4 causes problems  . Gotta fix 1/29/2015
   ;; is this the right condition?? seems to work for now 1/30
   ((and (consp N)(consp M)(orderlessp (car M)) (eq (car M)(car N)))
	 (cond ((eom4 M N flathead c) t) ;; name_??
	       (t 
		;;(setf bindings oldbindings)
		nil)))
	
	((atom M)(and (atom N) (equal M N) (funcall c))) ;NIL is also an atom
		 		 
	;; we go through each of the clauses and instead of expecting as in E18x
	;; that there is a (.... (pattern name_ (blank head))....)
	;; in the pattern form, we assume it is, e.g. (pattern name_ ....)
	;; to match the whole expression.
		 
	;;pattern. e.g.   (pattern z wtm).  wtm is WhatToMatch
		 
	((patternp M)
					;(format t "~% m18 pattern ~s ~s" M N)
	 (let* ((name_ (second M))
		(wtm (third M))
		(oldbindings bindings)
		;; (headcheck (if (cdr wtm)(cadr wtm) nil) ;head? or nil
		)
	   ;;   (format t "~% wtm=~s" wtm)
	   (cond
	    ((m18x wtm N #'(lambda() ;; if what-to-match matches N, optionally name_d,c
			     (and(pushcheck name_ N)
				 (funcall c))))
	     t)
	    (t (setf bindings oldbindings) ;just in case some bindings happened
	       nil))))
			 
	;; blank1,2,3 in "head" position for the "m" matcher
	;; can only match all that there is, no segment possible. I think.
		 
	((blankp M) 
	;;(format t "~% blank processing in M18 M=~s N=~s as blank1" M N)
	 (blank1proc M N nil c))
     ;;; add other stuff here.  Like patterntest. and condition and alternatives
     ;;; but should this be treated here like
	((and (consp M)(eq (car M) '|$Condition|))
	 (conditiontestproc M N c))
	
	((and (consp M)(eq (car M) '|$PatternTest|))
	 (patterntestproc M N c))
	
	((and (consp M)(eq (car M) '|$Alternatives|))
	;; (format t "~%SOME  M=~s N=~s " M N)
	 (some #'(lambda(r)(m18x r N c)) (cdr M)))
	
	((and (consp N)(consp M)(eq (car M) 'matqapply)) ;; case of f_(x). pattern is oper
	 (m18x (cadr M) (car N)	; match operators
		#'(lambda()
		    (e18x (cddr M)	; match operands x y z in (matqapply f x y z)
			  (cdr N)
			  nil ;;
			  c))))
	
	
	  ((and (consp M)
		(eq (car M) 'defaultbind) ;; ((defaultbind var val pattern)
		(pushcheck (second M)(third M ))
		(m18x (fourth M) N c))
	   t) 
	  
	  
	
	;; M is a list, but is not headed by blankN, patterntest, pattern  etc
	((and(consp M)(not (consp N))) ;can't match if structure is different
	 nil)

	((and(consp M)(consp N)) ;nothing special in pattern. Just list compared to list
	 (m18x (car M)(car N) #'(lambda()(e18x (cdr M)(cdr N) nil c))))
	;; maybe just the operator can be matched??
	#+ignore
	((and (consp M) (atom N)	; f(x) /. f-> g
	      (m18x (car M) N )))
	 

	(t nil)))

(defun substall(alist tree) ; alist looks like   ((($-> simp) $A B) (($-> ) ..))
  (if (consp alist)
      (maxima-substitute (fix-seg(third(car alist)))
			 (second(car alist))
			 (substall (cdr alist) tree))
    tree))



(defun $scandown(f M)			;M is a maxima expression. topdown; run maxima function f on it.
  ;; first try f on the whole expression.
  ;; if that works, return it.
  (cond ((mfuncall f M))		; if it returns non-NIL  (not false) return it
	((listp M)
	 (let ((headmatch(mfuncall f (caar M))))
	 (cons (list (or  headmatch (caar M)))
	       (scandown1 f (cdr M) ))))
	(t M)))

(defun scandown1(f L)			; L is a lisp list, cd..dr of M
  ;; this could be rewritten to be mostly non-recursive
  ;; or tail-recursion-removable.
  (if (consp L) (cons ($scandown f (car L))
		      (scandown1 f (cdr L)))))

(defun fix-seg(m)(subst '|$Segment|  '|%Segment| m))

(defun apply-seg(m) (cond ((atom m) m) ; all levels
			  (t (let ((head (car m))
				   (args (mapcar #'apply-seg(cdr m)))
					;(args (cdr m)) ;one level
				   )
			       (cons head  (if(every #'nonsegmentp args) 
					       args 
					     (splice-segment-args args)))))))

(defun |$ProcOptional|(r)(carzip(applyoptional(carunzip r))))
       
(defun applyoptional(m) (cond ((atom m) m) ; all levels
			  (t (let ((head (car m))
				   (args (mapcar #'applyoptional(cdr m))))
			       (if(every #'nonoptionalp args) (cons head args)
					     (optional-to-alternatives (cons head args)))))))

(defun nonoptionalp(r)(or (atom r)
			 (not (listp r))
			 (not (eq (car r) '|$Optional|))))

(defun optional-to-alternatives (m)
  ;; m looks like  (head .... (Optional p v ...) ;;one or more?? Optionals
  ;; it should end up as
  ;;               (Alternatives (head ... p...) (simplify..(head ... v...)))
  ;; with 2 Optionals has 4 alternatives etc.
  
  (let ((head (car m))
	alt1 alt2 kar kdr optvar defaultval )
    (loop for k on m do			; successive cdrs
	  (setf kar (car k))
	  (cond ((nonoptionalp kar) (push kar alt1)(push kar alt2))
		(t (push (second kar) alt1)
		   (if (and (consp (second kar))(eq (caadr kar) '|$Pattern|)) nil
		     (merror "Optional object ~m invalid"(carzip (second kar))))
		   (setf optvar (second(second kar))) ; x in must be Optional[x_]
		   (setf defaultval (mget head '|$Default|))
		   (if (null defaultval)
		       (merror "need default for optional ~m" head))
		   (push defaultval alt2) ;; mplus default is 0, mtimes is 1
		   (setf kdr (cdr k))
		   (return 'foundoptional)))) ;exit loop
	  
	  (setf alt1 (carunzip(simplifya (apply-seg(carzip(nconc (nreverse alt1)kdr))) nil)))
		   ;; phew. 
	  (setf alt2 (list 'defaultbind optvar defaultval (carunzip(simplifya (apply-seg(carzip(nconc (nreverse alt2)kdr))) nil))))

	 (flattenop   (list '|$Alternatives|  ;; return this
			(applyoptional alt1)
			(applyoptional alt2)))))

(defun flattenop(M) ;; option to flatten (alt (alt a b)(alt c d)) to (alt a b c d)
  (let ((header (car M)))
    (cons header   (mapcan #'(lambda(r)
			       (if (and (consp r)(eq (car r) header)) 
				   (cdr r)
				 (list r)))
			   (cdr M)))))


		   
;;I wonder. Here we do a+alternative(b,c). maybe alternative(a+b,a+c) is better? not that I see.

;;(defun oa(x)(optional-to-alternatives x))
			 
;; e.g. (setf q '((MPLUS SIMP) $X (($Optional SIMP) $Y 0)))
;; (carzip (oa (carunzip q))
;; result is  ... (($Alternatives) ((MPLUS) $X $Y) $X) 

;;defaults

(defun |$SetDefault|(op val)(setf (mget op '|$Default|) val))
;; set via  SetDefault(?caar(a+b), 0).   Can't use inpart(a+b,0) which returns + */
(defun getDefault(op)(mget op '|$Default|))
(|$SetDefault| 'mplus 0)
(|$SetDefault| 'mtimes 1)
       
       

(defun |$Substall|(alist tree)
  (cond ((and (consp alist)(eq (caar alist) 'mlist)) (apply-seg(substall (cdr alist) tree)))
	
	(t (error "~s not proper substitution list Substall" alist))))

(defun truth()t)

(defun m1(pat exp)
  (setf bindings nil flathead nil)
  (let ((result(m18x pat exp #'truth)))
    ;(format t "~%m1 bindings= ~s result=~s" bindings result)
    (or bindings result)))

;; collect ALL matches

(defun m1all(pat exp)
  (setf bindings nil flathead nil)
  (let ((allbindings nil))

    (m18x pat exp #'(lambda()
		      (cond (bindings 
			     (push bindings allbindings)
			   ;;  (format t "~% here's a set of bindings ~s" bindings)
	
			     nil)
			    (t t))))
    allbindings))


(defun e1 (pat exp &optional (condition #'truth)) (e18x pat exp nil condition)) ; match args with a condition.


#| eom4 is called
when head(e) is orderless.  This means that pattern  (e a b)
could match pattern (e a b)  or (e b a).  [etc for a b c .. ]

|#

(defun eom4  (p e name_ c) ; condition, too
  (if (atom p) nil 
  (let* ((oldbindings bindings)
	 (upat (set-difference p e)) ;unmatched pattern pieces, if any
	 (uexp (set-difference e p)	;unmatched expression pieces
			      ))	
    (if (and (null uexp)(null upat))
	(cond ((funcall c)(return-from eom4 t))
	      (t (setf bindings oldbindings)
		 (return-from eom4 nil)))
      ;else
      ;; ok, there is something to match with some work.
      (cond ((null (cdr upat))	;; only one pattern part is left 
	    ;; (m18x (car upat) uexp c) ;no
	       (e18x upat uexp name_ c)			;stub
	       )
	      ;; if there are several pattern pieces we are stuck with.
	      ;; trying different orders
	      (t (let  ()
		   (loop for k in (permlist uexp) do
			 (if (e18x upat k name_ c) (return-from eom4 t) (setf bindings oldbindings))
			 
			 			
			 )
					; end of loop. never matched
		   nil)))))))


(defun permlist (l)
  (cond ((null l) nil)			; empty list to start?
	((atom l)(list (list l)))  ;(permlist 'a) error or ((a)),as here
	((null (cdr l)) (list l))
	

	;; for each element p in l, a list of n items
	;; form a list q of n lists, consisting of l with p removed
	;;    that is q = (remove p l).
	;;    compute (recursively) S= (permlist q) a list of n-1 items
	;; for each element in S, compute (cons p S)
	;; 
	(t 
	 (apply #'append
		(loop for p in l collect 
		      (loop for m in (permlist (remove p l)) collect
			    (cons p m)))))))
#|

these example are the non-Maxima versions

They won't work any more unless you replace pattern with |$Pattern| etc.

(m1 '(a b) '(a b))

 (m1 '(pattern z (a b)) '(a b)) ;ok
  (m1 '(pattern z (a (pattern q b))) '(a b)) ;ok
  (m1 '(blank1 integer) 3)  
  (m1 '(pattern z (blank1 integer)) 3) 
  (m1 '(pattern z (blank1 symbol)) 'a)
  (m1 '(a (pattern z b)) '(a b))  
(m1 '(blank1 symbol) 'a)
(m1 '(pattern z (f (blank1 integer)))'(f 3) )
(m1 '(blank1 nil) '(a b))		; yes
 (m1 '(blank1 a) '(a b)) ; yes
 (m1 '(pattern z (blank1 symbol)) 'a)
 (m1 '(pattern z ((blank1 integer))) '(23)) 
 (m1 '(a) '(b))				; returns  nil

(e1 ' ((blank2 integer)) '(123 45))  ; t
(e18x nil nil #'truth)  ;; t
(BLANKPROC '((BLANK2 INTEGER)) '(56 78) NIL 2 #'truth)  ;; ok
(BLANKPROC '((BLANK1 INTEGER)) '(56)  NIL 1 #'truth) ; t, ok
(BLANKPROC '((BLANK1 INTEGER)(pattern two(blank1 integer))) '(56 78)  NIL 1 #'truth) ;ok
(BLANKPROC '((BLANK3 INTEGER)) '(56 78) NIL 3 #'truth) ; ok
(m1 '(f (pattern z (blank1 integer)))'(f 34)) ; good
(m1 '(f (pattern z (blank2 integer)))'(f 34 )) ; good (z . (segment 34))
(m1 '(f (pattern z (blank1 integer)) (blank1 integer))'(f 34  56)) ;  (z . 34)

 (m1 '(f (pattern z (blank1 integer)) (pattern w (blank1 integer)))'(f 34  56)) ; yay!
(m1 '(f (pattern z (blank2 integer)) (blank1 integer))'(f 34 56 78 )) ; yay  (z . (segment 34 56))
(m1 '(f (pattern z (blank1 integer)) (pattern w (blank2 integer)))'(f 34 56 78 )) ; yes ((W SEGMENT 56 78) (Z . 34))
(m1 '(f (pattern z (blank2 integer)) (pattern w (blank1 integer)))'(f 34 56 78 )) ; yes ((W . 78) (Z SEGMENT 34 56))


(eom4 '(ff (blank1 integer) 2 3) '(ff  3 2 1)) ; yes

;; ff is flat and orderless

(m1 '(ff (pattern z (blank1 integer)) c) '(ff c 3)) 
(m1 '(ff (pattern z (blank1 symbol)) c) '(ff c b)) 
(m1 '(ff (pattern z (blank2 integer)) c) '(ff 1 c 2)) ; yes. ((Z FF 2 1))

(m1 '(ff (pattern z (blank1 symbol)) (pattern w (blank1 symbol))) '(ff c b)) 
(m1all '(try (pattern z (blank2 symbol)) (pattern w (blank2 symbol))) '(try a b c))  ;;yay

(m1all '(ff (pattern z (blank1 symbol)) (pattern w (blank1 symbol))) '(ff c b)) 
(m1all '(ff (pattern z (blank2 symbol)) (pattern w (blank2 symbol))) '(ff c b a)) ;; lots of possibilities matching

(m1 '(patterntest (mmm (pattern z (blank1 integer))(pattern w (blank1 integer)))  '(> w z))  '(mmm 3 4)) ; works

|#
;; what else? attributes oneidentity? Condition? Default? 

;; cheap hack to make maxima-compatible sort of
;; if we need to call meval etc we need to do (carunzip(meval(carzip ..))) maybe..

(defun carzip(u) ;; (f a b)  --> ((f) a b)
  (if(consp u) 
	 (cons (list (car u))
	       (mapcar #'carzip (cdr u)))
    u))

(defun carunzip(u) ;; ((f) a b) --> (f a b)
  (if (consp u)
      (cons (caar u)(mapcar #'carunzip (cdr u)))
    u))


(defun $m1(pat exp) ;; in maxima  . return false, []  or [a->b; ... etc]
  (let ((ans (m1 (carunzip pat)(carunzip exp))))
    
    (cond((null ans) nil)
	  ((consp ans) (assoc2rule ans))
	  (t '((mlist) )))))


#+ignore
(defmspec $m1(L) ;; in maxima  . return false, []  or [a->b; ... etc]
  (let ((ans (m1 (carunzip (cadr L)(carunzip (caddr L))))))
    
    (cond((null ans) nil)
	  ((consp ans) (assoc2rule ans))
	  (t '((mlist) )))))


(defun assoc2rule(ans)
  (cons '(mlist)
	(mapcar #'(lambda(z)(list '(|$Rule| simp) 
				  (car z)
				  (carzip (cdr z))))
		ans)))

(defun $m1all(pat exp)
  (let ((h (m1all (carunzip pat)(carunzip exp))))
    (cons '(mlist)  (mapcar #'assoc2rule h))))

;; segment changes Maxima meval to handle  f(a,b,segment(c,d)) -->   f(a,b,c,d)

(defun mevalargs (args) ;; implements segment.   was mevalargs-segment
  (cond (noevalargs (setq noevalargs nil) args)
	(t (setf args(mapcar #'meval args))
	   (cond
		 ((every #'nonsegmentp args)
		  args)
		 (t (splice-segment-args args))))))
	   
(defun nonsegmentp(r)(or (atom r)
			 (not (listp (car r)))
			 (not (eq (caar r) '|$Segment|))))

 (defun splice-segment-args(h)
      (reduce #'append (mapcar #'(lambda(x) (if (nonsegmentp x) (list x) (cdr x))) h)))


;; see  mma2maxfun.lisp in mma5max for comments
       
;; this next pattern optimization could change defaults to alternatives etc.
;; but now is not doing anything.
(defun pattern-opt(x) x) ;; identity, for now

;; We don't want to evaluate any of these pieces when they are
;; read in.
#| (defmacro makespec(k) `(defmspec ,k (L) (cons '(,k) (cdr L))))
(makespec |$?|)
(makespec |$/;|)
(makespec |$\||)
(makespec |$:$|)
;;(makespec |$/.|) need to evaluate
(makespec |$//.|)
(makespec |$@|)
(makespec |$//|)
;(makespec |$|)
|#


;;(defmspec |$->|(L) (mfuncall '|$Rule| ($pt(cadr L))(caddr L))) ;; need to evaluate specially because of $Segment


(defun $pt(qi) ;; pattern transform from maxima expression to pattern thing
  ;;; this deals with atoms that look like a_, a__, a___
  ;;; Could it work for bare  __?  Sorry, the maxima command processor grabs atoms $_ and $__.
  (pattern-opt
   (cond ((consp qi)
	  ;; not a symbol but an expression. Here we have
	  ;; two cases, one is that there is a pattern in the CAAR
	  ;; and the (simple) case where there is just an operator.
	  (let ((r ($pt (caar qi))) 
		(s (mapcar #'$pt(cdr qi)))) ;; recursive on sublists
	    (if (symbolp r) (cons (car qi) s) ;look at operator
	      (cons '(matqapply simp) (cons r s))))) ; operator is a pattern
	 
	 ((not (symbolp qi)) qi) ;; numbers, strings, array, unchanged.
	 
	 (t ;; at this point we know we have a symbol.
	  (let*((q (symbol-name qi))
		(r (position #\_ q)))
	    (if (null r)qi ;; if there is no _, then just return it
	      ;; at this point we know there is at least one _ in the name.    
	      (let ((front(subseq q 0 r))
		    (afterblank (subseq q (1+ r)))
		    (head nil)
		    (pred nil)
		    (qq nil)
		    (blanks 1)		; count of underscores
		    )

		(dotimes (i 2)
		  (when (and(>(length afterblank)0)
			    (char= #\_ (aref afterblank 0)))
		    (setq afterblank (subseq afterblank 1))
		    (incf blanks)))
		
		;;(format t "~% ~s ~s ~s ~s ~s ~s blanks=~s" front afterblank head pred qq s blanks)
		;;qmark stuff used to be here but is now done with parser.
		;;dot stuff can't work here, either.
		;; check for the case a__Stuff.  Stuff is afterblank

		(if (not(string= afterblank ""))
		    (setf head (list (intern (concatenate 'string "$" afterblank) :maxima))))
		;(format t "~% front=~s ~s ~s ~s ~s ~s blanks=~s" front afterblank head pred qq s blanks)

		(setf qq (list '(|$Pattern|) (intern front :maxima) 
			       (case blanks 
				 (1 (cons '(|$Blank|)
					  head ))
				 (2 (cons '(|$BlankSequence|) head ))
				 (3 (cons '(|$BlankNullSequence|) head ))
				 (otherwise (merror "I can't figure out your pattern ~m" qi)))))
		;; test for empty name. e.g. _, __, ___. Unfortunately, _ and __ will be
		;; caught by command line process without some other hack.
		;; so unless we disable that, this next test will always fail
		(if (member front '("" "$"):test 'string=) (setq qq (caddr qq)))
		
		qq)  ))))))










	  
	 

      
	    
      
      



;; FIXED BY PARSER, I hope to 
;; foo_?(lambda([z], blahblah). Mma allows foo_?(blahblah[#]&
;; pt( foo_?(lambda([z], blahblah)));  returns   PatternTest(Pattern(foo,Blank()),lambda([z],blahblah))

;;pt( a:$mumble(foo_,bar_?(lambda([z], blahblah)))->[a,foo,bar]);  returns
;; Rule(Pattern(a,mumble(Pattern(foo,Blank()),PatternTest(Pattern(bar,Blank()),lambda([z],blahblah)))),[a,foo,bar])

;;pt( a:$mumble(foo_,bar_?(lambda([z], blahblah)))/;check(a,foo,bar)->[a,foo,bar]); returns
;; Rule(Condition(Pattern(a,mumble(Pattern(foo,Blank())
;;,PatternTest(Pattern(bar,Blank()),lambda([z],blahblah)))), check(a,foo,bar)),[a,foo,bar])


;; also
;; prefix("?",300,300)
;; this now allows  a?b
;; but also allows ?print(%);

(defun $?(&rest x) (if (null (cdr x))(if (atom (car x))(stripdollar (car x))(car x)) (cons '(|$PatternTest|) x)))


;; what could pattern optimization do?
#| 1. tag all constant subexpressions so that we know there
 are no patterns inside them.

e.g. (+  ((PatternTest simp) ....  stuff)   ((foo simp) ....)
where foo has no pattern stuff
is changed to
e.g. (+  ((PatternTest simp) ....  stuff)   ((foo nopattern simp) ....)

2. At the very top level if we have
say   K: a_+b_ which internally is ((MPLUS SIMP) $A_ $B_)
and mma changes K to  Pattern(b, Blank()) + Pattern(a, Blank()) which
is internally ((mplus simp) (($Pattern) b (($Blank) ....)))....
we can change K to

((mplus simp pattern ((mplus simp) (($Pattern ..)...)))
 
 so that the pattern processor can use this cached value.
 
 Also the default/optional indicator can be changed into a
 Alternatives something..  In fact, necessary so that
 
 (sin(A)+Optional(B)) looks like Alternatives(sin(A),A+b).
 
 |#
				   
				   

#|
($m1 '(($f simp)((|$Pattern|) $z ((|$Blank|) $integer))) '(($f) 3))

In Maxima... try something like

m1(f(Pattern(z, Blank(integer))), f(23)) ;
m1(f(Pattern(z, BlankSequence(integer))),f(1,2,3));
|#

;;(defun testm1()  ($m1 '(($f simp)((|$Pattern|) $z ((|$Blank|) $integer))) '(($f) 3)))

#| even more for maxima...   batch the following ...
infix.mac, which loads this file...
load ("c:/lisp/e18u.lisp")		;  /* this file */


mma(a_foo?bar)				;  /* should be Patterntest(Pattern(a,Blank(foo)),bar) */


m1(f(Pattern(z, Blank(integer))), f(23)) ;
mp1(pat,exp):= m1(mma(pat),exp);
mp1(  f(a_integer,b__integer),f(3,4,5))	;  /* [b=Segment(4,5), a=3] */
mp1(f(a_,b_)?(a>b), f(4,3))		; /* [b=3,1=4] */
mp1(f(a_,b_)?(a>b), f(3,4))		; /* false  */
mp1(a_+b__,x+y+z)			; /* sequence matching with flat head */
mp1(a_integer+b_symbol, 3+z)		; /* + is "orderless" */
mp1(b_symbol+a_integer, 3+z)		;
mp1 (f(a_integer)?(a=3), f(3))		;
PatternTest(f(Pattern(a,Blank(integer))),a=3)  ;ok
mp1 (f(a_integer?(a=3)), f(3)) ; nope bug?
f(PatternTest(Pattern(a,Blank(integer)),a=3))

mp1(a_integer?(a=3),3)			;
m1all(pt(f(a__integer,b__integer)),f(1,2,3))
mp1all((f(a__integer,b__integer)),f(1,2,3)) ;
mp1all(a__+b__,x+y+z);  /* 12 answers since + is flat and orderless */
mp1all(ff(a__,b__),ff(1,2,3))		; /* 2 ans ff is flat */
mp1all(fo(a__,b__),fo(1,2,3))		; /* 12 answers since fo is flat and orderless */
mp1all(oo(a__,b__),oo(1,2,3))		; /* 12 answers since oo is orderless */
mp1(f_(a__),g(3,4));
mma(  a+b /.[a->3,b->4] )		;

mp1(f(a_,Optional(b_)),f(r))		;
mp1(f(a_,Optional(b_)),f(r,s))		;

mp1(Pattern(z,a|b)+3, a+3);
mp1(Pattern(z,a|b)+3, b+3);
mp1( (z:$a|b)+3,a+3);
 mma( f(3)+g(q)/. f->h); /* g(q)+h(3) */
 mma(f(3)/. a_integer->2*a); /*f(6) */
 mp1( f(a,x_integer),f(a,3)); 
 mp1( f(a,x_integer),f(3,a));
 mdeclare(f,Orderless);
 mp1( f(a,x_integer),f(3,a)); /* try again, now succeeds */
 mp1( f(a,x__integer),f(3,a,4));  /* x is Segment(4,3) */
 Substall(%,g(x));  /* should be g(4,3) or g(3,4) */
 mdeclare(f,Flat);
  mp1( f(a,x__integer),f(3,a,4));  /* x is f(4,3) */
|#