(in-package :maxima)
#| This is the lisp part of a program in common lisp and Maxima
that does much of the pattern matching expected of
Mathematica.  syntax _, __, ___. is Blank, BlankSequence, BlankNullSequence.
Segment is used instead of Sequence in a result
matapply is used instead of mqapply, whose semantics are uncomfortable.
There is also a new pattern match operator called |$DefaultBind| which allows for
the setting of local variables without actually matching them. Used by default match.
Although Mathematica allows  pattern   a:f[_], we cannot use "bare" blanks because
Maxima uses the special variable _  and also __.  So we use nil_ and nil__ instead. Nor
can we use : in the way used in Mma, since it is used already in Maxima. Instead we use :$ .
We of course use () instead of [].  So it looks like a:$f[nil_] .
We also can't use  a_. for default, but we can use a_.$ 
We set attributes via mdeclare; the attributes are attached to the global operators,
not (should they be considered appropriate?) local block variables.

Richard Fateman 2015
|#
(defvar bindings nil)
(defvar flathead nil)
(eval-when (:compile-toplevel)(declaim (optimize (speed 3)(safety 1)(space 0)#+allegro(debug 0))
			     ))
;; in Maxima-speak, the Flat stuff should be any n-ary "function". These are
;; the ones I found

(defun flatp(r)(and (symbolp r) (get r '|$Flat|)))

;; more elaborate

(defun $flatexpand(r)			; r is a rule p->e
  (let* ((p (cadr r))
	 (origp p)
	 (orige (caddr r))
	 (e orige)
	 (globzz 'ggzz)
	 (testzz nil))
    ;;    so s^2+c^2->1  works like s^2+c^2+w___ -> 1+w
    (cond ((and (consp p)(flatp (caar p)) ;; like (caar p) is mplus
					; (not(and (consp e)(eq(caar p) (caar e))))
		)	       ; heuristic? if it looks like a+b->c+d?
	   (let ((g (gensym "zz")))
	     (setf globzz g)
	     ;; tack match-anything at the end
	     (setf p (append p `(((|$Pattern|) ,g ((|$BlankNullSegment|))))))
	     
	     (if (not(orderlessp (caar p))) ;; so c.d->z works for a.b.c.d.e
		 ;; tack match-anything at the first argument
		 
		 (let ((g2 (gensym "zzx")))
		  ; (format t "~% flatexpand dot hack p=~s, e=~s%" p e)
		   (setf p (cons (car p)
				 (cons
				  `((|$Pattern|) ,g2 ((|$BlankNullSegment|)))
				  (cdr p))))
		   (setf e
			 (mflattenop (list (car p)
					   g2
					   e)))
		 
			;  (format t "~% flatexpand dot hack changed:~s, e=~s~%" p e)
		   ))
					    
		   (if (listp e)(setf e (append e nil))) ;copy it
		   (setf e (mflattenop `((,(caar p)) ,e ,g)))
		   (list '(|$Rule|) p e)))
	  
	  ;; oops, it is not ((Rule) a b) quite.  It is more like
	  ;;  ((Rule)((Condition) a test) b)
	  
	  ((and (consp p)(eq (caar p) '|$Condition|) ;; like (caar p) is Condition
		(consp (second p))
		(flatp (caar (second p)))) ;; caar of a, above.
	   (let* ((g (gensym "zz"))
		  (np (second p)) ;; p is ((Condition) a test) np is a. in the pattern above
		  (test (third p)))
	     (setf globzz g)
	     (setf np (append np  `(((|$Pattern|) ,g ((|$BlankNullSegment|))))))
	     (if (listp e)(setf e (append e nil))) ;copy
	     (setf e (mflattenop `((,(caar np)) ,e ,g)))
	     (setf np `((|$Condition|) , np ,test))
	     (setf p np)))
	  ;; oops, it is not ((Rule) a b).   r is ((Condition)((Rule) a b) test)
	  ;; shouldn't happen if we did movecond, but whatever.
	  
	  ((and (consp (car r))(eq '|$Condition| (caar r)))
	   (return-from $flatexpand
	     (list '(|$Condition|) ($flatexpand (second r)) (third r)))))
    ;; at this point p, e should be set up
    (if (and (eq p origp)(eq e orige)) r ;; nothing to do here, leave alone
      `((|$Rule|)
	((|$Alternatives|)
	 ;;((|$DefaultBind|) ,globzz |##X##| ,origp)
	 ((|$DefaultBind|) ,globzz ,(setf testzz (gensym "t")) ,origp)
	,p)
	;; if globzz is bound to self, the rhs is the original e, the whole subtree
	((mcond) (($is) ((mequal) ,globzz ,testzz)) ,orige t ,e)
		)))) 
	
(defun orderlessp(r)  (and (symbolp r)   (get r '|$Orderless|)))

(defun $mdeclare (a b)(setf (get a b)t)) ;  (mdeclare 'ff '|$Orderless|)  or (mdeclare 'ff '|$Flat|)
;; $FF for testing is flatp, $FO is flat orderless

(mapc #'(lambda(r)($mdeclare r '|$Orderless|) t) '(mplus mtimes))
(mapc #'(lambda(r)($mdeclare r '|$Flat|) t) '(mplus mtimes mnctimes mand mor))

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

(defun head(x) 
  (cond 
   ((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)
      (double-float '$float)
      (single-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)
   ((member(car x) '(mplus mtimes mexpt) :test 'eq)
     (cdr (assoc (car x) '((mplus . $plus)(mtimes . '$times) (mexpt . '$expt)))))
   (t (or (get (car x) 'reversealias)(car x)))))

(defun $head(r)(if (atom r)(head r)(head (car r)))) ;for maxima command level

;; it is possible that one might want   foo_number to match
;; if head(foo) is something more specific..   maybe foo_/;numberp(foo) would
;; be an alternative?

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

(setf (mget 'mplus  '|$Default|) 0)
(setf (mget 'mtimes '|$Default|) 1)
(setf (mget 'mexpt  '|$Default|) 1) ;; inconvenient to say in maxima

(defun runtest(val test)
  (if test
      (if (and (consp val)(or (eq (car val) flathead) (eq (car val) '|%Segment|)))
	   (every #'(lambda(r)(runtest r test)) (cdr val))  ;; if the value is (Segment x y z), run (test x), (test y) etc.
	(eq t (ignore-errors (mfuncall test (carzip val)))))
  t)) ; return t if test is nil

(defun pushcheck(k val test) 
  ;; push (k . val) on bindings unless conflict or already there
  ;;(format t "~%pushcheck( ~s, ~s ~s)" k val test)
  (cond  
   ;; ahh, this is screwy.  ri3 interval rule in testmma il(0,1)+4/. ri3, numberp
  ;; ((and (null k)(null val))t )
    ((null k)t)
   ((eq k '$anon)				; t
	     (runtest val test) ; run test but bind nothing
	     )
   ((null val)    nil)			;not allowed to bind to nil  i.e. false. Bad hack, maybe later we'll allow this.

	(t(let ((b (assoc k bindings))
		(sv (carunzip(simplifya (carzip val) nil))))
	    ;; (format t "~% pushcheck sv=~s" sv)
	    (cond ((null(runtest sv test)) nil) ;gotta pass the test if we will allow the binding.
		  ((null b)(push (cons k sv ) bindings)) ;;no previous binding, or an equal binding, return bindings.
		  ((equal sv (cdr b)) bindings)
		  ;; if there is a binding but does not match, return nil
		  )))))

(defun blankp (M) (and (consp M)
		       (member (car M) '(|$Blank| |$BlankSegment| |$BlankNullSegment|) :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)
  (blankproc (list M) (list N) name_ 3 c))  ;; this works just as well as below.

#+ignore
(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 test)	; 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)
	(test (cadr M))) ;; ?? 1/2016
    ;; 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)
    (if (and (= 1 blanknum) flathead) (setf blanknum 2))
    (case blanknum
      ((2 3)
       (setf flathead nil) ;; uncomment this  to make mp1(z_+m_integer,  a+b+4); work
       (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) test) 
		
		(cond ((e18x (cdr M) r nil test 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 flathead is ~s" name_ flathead)
         (cond ((m18x (car M) (car N) test
		    #'(lambda()
			;;(format t "~%the name_ second = ~s" name_)
			(and (pushcheck name_
					#+ignore
					(or (car N) (mget flathead '|$Default|))
					(car N)
					test
					)
			     (e18x (cdr M) (cdr N) nil test c))))
	      t)
	     (t(setf bindings oldbindings)
	       nil))

	 ))))

;; new version.  fixes stuff but breaks others.
#+ignore
(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)
  ;;  (if (and (= 1 blanknum) flathead) (setf blanknum 2))
    (case blanknum
      ((2 3)
       (setf flathead nil) ;; uncomment this  to make mp1(z_+m_integer,  a+b+4); work
       (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) test)
		
		(cond ((e18x (cdr M) r nil test 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
      
     (cond (flathead
	    (loop for i from 1
	    ;;  (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) test)
		
		(cond ((e18x (cdr M) r nil test 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)
       )
      (t   ;; ((blank1 head )  stuff but not flathead

;;       (format t "~% the name_ first is ~s flathead is ~s" name_ flathead)
         (cond ((m18x (car M) (car N) test
		    #'(lambda()
			;;(format t "~%the name_ second = ~s" name_)
			(and (pushcheck name_
					#+ignore
					(or (car N) (mget flathead '|$Default|))
					(car N)
					test
					)
			     (e18x (cdr M) (cdr N) nil test 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_ test 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)))
		     
		     ;; e.g. to match  (+ ... b_) might need to match b against 0
		     
		     ((and (null N) flathead (setf N (list (mget flathead '|$Default|))))
		      (e18x M N name_ test 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 "~%pattern  ~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_ ;!!!!
					  test
					  c) t)
			 
			     (t (setf bindings oldbindings) nil ))))
		     
		     ;; blankN 
		     ;; any binding resulting from this match will come from surrounding (pattern..)
		   
		     ((blankp (car M)) 
		      
		      ;; under some circumstances a_+z_integer, a_ works sort of like a___.
		      ;; x+y+4 /. a_ +z_Integer-> foo[a,z] returns foo[x+y,4]
		      ;; x+y+4 /. a__+z_Integer-> foo[a,z] returns foo[x,y,4]
		      
		      (blankproc 
			 M N 
			 name_
			 (case (caar M) (|$Blank| 1)
			       (|$BlankSegment| 2)
			       (|$BlankNullSegment| 3))
			 c)
				      
		
		      )

		     ;;; add other stuff here. 
		     ;;; 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()(condproc
					       (car M) ; the condition
					       (car  N) ; the expression
					       test  )) c) ) ;1/15/2016
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$Optional|))
		      (or
		       (e18x (cons (second (car M))(cdr M)) N nil test c)
		       (e18x (cdr M) N nil test c)))
		     
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$Alternatives|))  ;; need to allow more than 2
		  ;;    (format t "~%Alternatives in e18 ~s" M)
		      (let* ((oldbindings bindings)
			     (ans (some #'(lambda(r)
					    (setf bindings oldbindings)
					    (e18x (cons r (cdr M)) N name_ test c)) (cdr(car M)))))
			;;(format t "~% ans in E18x Alternative is ~s" ans)
			(cond ((null ans)(setf bindings oldbindings) nil)
			      (t t))))
		     ((and (consp M)(consp(car M))
			   (eq (caar M) '|$PatternTest|))
		      
		     ;** (format t "~% e18x doing patterntest, with M=~s N=~s ~%  new pattern is ~s" M N (cons (second(car M)) (cdr M)) )
		      (e18x (cons (second(car M)) (cdr M)) N  name_  (third (car M)) ;the test
			   c))

		     
		     ((and 
		       (consp M)(consp (car M))
		       (eq (caar M) '|$DefaultBind|) ;; ((|$DefaultBind| var val pattern)
		       (pushcheck (second (car M))(third (car M)) test)
		     ;;  (pushcheck (second (car M))(third (car M)) nil)
		       (e18x (cons (fourth (car M))(cdr M)) N name_ test c))
		      t)

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

(defun condproc (M N c)			
  ;; M looks like (Condition pat  test) where test is maxima expression
    (m18x (second M) N (caddr M); was test 
	  #'(lambda()(and  
		     ;; (progn (format t "~% condproc test=~s bindings=~s" (third M) bindings) t)
		      (let* ((theguts (substall ;; meval here?
				      (assoc2rule bindings) 
				      (carzip (third M))))
			      (thetest (list '($is) theguts)))
			;;(format t"~% the guts:~s ~% the test is ~s" theguts thetest)
			(eq t (ignore-errors  (meval thetest))))
		      (funcall c)))))

(defvar test '$print)
(defun m18x (M N test 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.
  (let ((flathead nil))
	
    (declare (special flathead))
					;(format t "~% M18x ~s ~s"M N)
    (cond ((consp N) 
	   (if (flatp (car N)) (setf flathead (car N)))))
					;(format t "~%flathead=~s" flathead)
    (cond 
     ;; 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 nil c) ;;***
					; (format t "~% after eom4 bindings =~s" bindings)
	     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
     
     ;; how to make  (+ x^2 a___)  match x^2 -- car's don't match? make x^2 into (+ x^2)
     ((and (consp M)(flatp (car M)) (not (eq (head M)(head N))))
      (m18x M (list (car M) N) test c))
		 
     ((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 "~%m18  wtm= ~s bindings= ~s" wtm bindings)
	(cond
	 #+ignore
	 ((m18x wtm N test #'(lambda() ;; if what-to-match matches N, optionally name_d,c
			  (and(pushcheck name_ N test)
			      (funcall c))))
	  t)
	 
	 ((m18x wtm N test #'(lambda() ;; if what-to-match matches N, optionally name_d,c
			  (and(pushcheck name_ N nil) ;; changed
			      (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|))
      (condproc M N c))
	
     ((and (consp M)(eq (car M) '|$PatternTest|))
      
        (m18x (second M) N test
	#'(lambda()
	    (and
	     (eq t (ignore-errors (mfuncall 
				   (third M) (carzip N))))
	     (funcall c)))))
	
     ((and (consp M)(eq (car M) '|$Alternatives|))
;      (format t "~% in m18, some M=~s ~% N=~s " M N)
      (let ((oldbindings bindings))
	(some #'(lambda(fr)(setf bindings oldbindings)
		       (m18x fr N test 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
	    test
	    #'(lambda()
		(e18x (cddr M) ; match operands x y z in (matqapply f x y z)
		      (cdr N)
		      nil ;;
		      test
		      c))))
	
     ((and (consp M)
	   (eq (car M) '|$DefaultBind|) ;; ((|$DefaultBind| var val pattern)
	   (pushcheck (second M)(third M) test))
					;(progn (format t "~% m18 default M=~s N=~s" M N) t)
      (if (m18x (fourth M) N test c) t nil))
     	
     ;; 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
  #+ignore    (format t 
      "~%m18x just chugging along with trying out pat=~s exp=~s and then ~%rest of pat=~s vs rest of exp=~s" 
      (car M)(car N)(cdr M)(cdr N))
  
      (m18x (car M)(car N) test #'(lambda()(e18x (cdr M)(cdr N) nil test c))))

     (t nil))))

(defun substall (alist tree)
  (meval (substall1 alist tree)))
(defun substall1(alist tree)		; alist looks like   ((Rule $A B) (Rule ..))
   (if (consp alist)
       (setf tree  
	 (maxima-substitute (fix-seg(third(car alist)))
			 (second(car alist))
			 (substall1 (cdr alist) tree))))
     ;;   (if (and (consp tree)(consp (car tree)))  (setf (caar tree) (substall alist (caar tree))))
   (apply-seg tree))
    ;; this above works but not when parallel substitution is needed.  Try this..

#+ignore  ;; not used at the moment. Maybe it should be. copied from other code
(defun psubstall(alist tree)
  (apply-seg
   (let ((l alist) (z tree)) ;; alist, l, is (  ($Rule name1 val1) ($Rule name2 val2))
    (cond
     ((and (consp l)
	   (null (cdr l)))
      ;; A list with one equation. Actually, rule.
      (setf z (simplifya (maxima-substitute (fix-seg(third (car l)))(second (car l)) z) nil)))
     (t
      ;; We have a list of equations. We do parallel substitution.
      (let (gensymbol genlist eqn ($simp nil))
	(declare (special $simp))
	;; At first substitute a gensym for the expressions of
	;; the left hand side of the equations.
	(do ((l l  (cdr l)))
	    ((null l) z)
	  (setq eqn (car l))
	  (setq gensymbol (gensym))
	  ;; Store the gensym and the new expression into a list.
	  (push (cons gensymbol (caddr eqn)) genlist)
	  ;; Substitute a gensym for the old expression.
	  (setq z (simplifya (maxima-substitute gensymbol (cadr eqn) z) nil)))
	;; Substitute the new expressions for the gensyms.
	(do ((l genlist (cdr l)))
	    ((null l)
	     ;; Resimplify the result. ;; too many times??
	     (let (($simp t)) (resimplify z))
	  (setq z (simplifya (maxima-substitute (fix-seg(cdar l)) (caar l) z) nil)))))
      (if (and (consp z)(consp (car z))) 
	  (setf (car z) 
	    (list (psubstall alist (caar z)))))
      (resimplify z))))))


(putprop '|$:>| (compile nil ;; needed for SBCL  1/2016
			'(lambda(k)	; k bound to ($:> a b) nothing evaluated
		 ;; this would be RuleDelayed in Mathematica
		 ;; but I think we can just use Rule also in Maxima
		 (list '(|$Rule|) (meval(cadr k)) (caddr k))
		 
		 )) 'mfexpr*)

(defmspec |$RuleToFn| (l)		; 
					; don't evaluate the name
  (ruletofn1(cadr l)(meval (caddr l))) 
  )

;;; maybe we could elaborate on the rhs of a rule so 
;;; that if it looks like (|$Case| test a b)
;;; it is processed as  substall (lisp::if  (mevalb (substall test)) a b)
(defun ruletofn1 (name R)  
  ;; generate a named function that returns a multiple-value
  ;; of 2 items.  either  (false false)   or (theReplacement with subst,  true)
  (setf R ($movecond R))
  (let* ((e (gensym "e"))
	 (ans (gensym "a"))
	 (lhs (cadr R))
	 (rhs (caddr R))
	 (body
	  `(lambda(,e)  
	     (let((,ans ($m1 ',lhs ,e)) )
	       (if (null ,ans) 
		   (values nil nil)
		 (values (#+ignore 
			       psubstall 
			  substall
			  ,ans ',rhs)
			 t))))  

	  ))
    
;;    (format t "~% ruletofn body=~s ~%lhs=~s ~%R=~s ~%name=~s" 	    body lhs R name)
    
    (compile name body)  ; this works for '(lambda()); doesn't need #'(lambda())
    
   ; (setf (symbol-function name) body  )
    
    )

;;  (list '(mtext) name " is defined by rule " R)
  name
  )

;; changed from matrun.lisp
;;changed version of apply1, renamed matapply1, taken from matrun.lisp.
;; dunno if so many calls to simplifya are needed.

;; Note that original rule design in maxima has rules 
;; or rather their derived functions, returning 2 multiple values: ans and hit.
;; our mma-version returns just ans, providing that if ans=nil, it didn't hit.
;; this is bad if your intention was to have a rule  pattern->false, which will not
;; ever succeed!  so we fixed the interface and the generation of programs in RuleToFn.

;#+ignore

(defmfun matapply1 (expr *rule depth) 
  (cond
    ((> depth $maxapplydepth) expr)
    (t
     (prog nil 
	(*rulechk *rule)
	(setq expr (rule-apply *rule expr))
	b    (cond
	       ((or (atom expr) (mnump expr)) (return expr))
	       ((eq (caar expr) 'mrat)
		(setq expr (ratdisrep expr)) (go b))
	       (t
		(return
		  (simplifya
		   (cons
		   (list (matapply1 (caar expr) *rule (1+ depth)))
		   
		    (mapcar #'(lambda (z) (matapply1 z *rule (1+ depth)))
			    (cdr expr)))
		   nil))))))))

#+ignore
(defmfun matapply1 (expr *rule depth) 
  (cond
    ((> depth $maxapplydepth) expr)
    (t
     (prog nil 
	(*rulechk *rule)
	(setq expr (rule-apply *rule expr))
	   ))))


#+ignore 
(defmspec $matapply1 (l) (setq l (cdr l))
	  ;; 1st item is expression
	  ;; 2nd through end is functions returning mvs (val, hit)
	  (let  ((expr (meval (car l))))

	    (mapc #'(lambda (z) (setq expr (matapply1 expr z 0))) (cdr l))
	    expr))


(defmspec $matapply1 (l) (setq l (cdr l))
	  ;; 1st item is expression
	  ;; 2nd through end is functions returning mvs (val, hit)
	  (let ((expr (meval (car l))))
	    (mapc #'(lambda (%z) 
		      (multiple-value-bind (val hit)
			  (funcall %z expr)
			(cond (hit (setf expr val))
			      ((atom expr) expr)
			      (t (setf expr (matapply1 expr %z 0))))))

		  (cdr l))
	    expr))




(defmspec |$/;| (l) `( (|$Condition|) ,(meval (cadr l)),(caddr 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 $movecond(m)  
  ;; look for (Condition (Rule a b) test). Change to (Rule (Condition a test) b)
  (if(and(consp m)(eq (caar m) '|$Condition|)
	 (consp (second m)) (eq (caar (second m)) '|$Rule|))
      (list '(|$Rule|) 
	    (list '(|$Condition|) 
			     (second(second m))  ;pattern, a
			     (third m))	;test
	    (third (second m))		;replacement, b
	    )
    m))

(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 (mfuncall '$get 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)))))
(defun mflattenop(M) ;; option to flatten ((alt) ((alt) a b)(alt c d)) to (alt a b c d)
  (let ((header (caar M)))
    (cons (car M)   (mapcan #'(lambda(r)
			       (if (and (consp r)(eq (caar r) header)) 
				   (cdr r)
				 (list r)))
			   (cdr M)))))

;;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(psubstall (cdr alist) tree))  ;; which is the winner??
	 (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 nil #'truth)))
;;	(format t "~%m1 bindings= ~s result=~s" bindings result)
     (if (null result) nil (if (null bindings) t  bindings))
;;    (or bindings result)
    ))

;; collect ALL matches
(defun m1all(pat exp)
  (setf bindings nil flathead nil)
  (let ((allbindings nil))

    (m18x pat exp nil #'(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 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
	 (upat p)
	 (uexp e)
	       )	
  ; (format t"~%enter eom4 upat=~s ~%uexp=~s"  upat uexp)
    
    (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_ test c)			;stub
	       
	       )
	      ;; if there are several pattern pieces we are stuck with.
	      ;; trying different orders
	    (t (let  ((p (cdr upat))
		      (plst (permlist (cdr uexp))))
		 (loop for k in plst do
;;		       (mformat t "~% eom4: match upat=~s ~%with uexp=~s" p k)
			 (if (e18x p k name_ test c) 
			     (return-from eom4 t) 
			   (setf bindings oldbindings))
			 )
					; end of loop. never matched
		   nil)))))))

;; really we should not compute the permlist, but implement something like
;; (loopoverperms foo l do ...)  and generate the permutations as needed, not all of them

(defun permlist (l)  ;; all permutations of the list l
  (cond ((null l) (list 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)))))))

;; another rather different approach to itemizing a permlist, 
;; one at a time... in order. requires ordering of the items, e.g
;; sort order for characters.
;; here's a start.  

#+ignore
(defun next-perm (vec cmp) ; modify vector to get the next permutation in order.. found on internet
  (declare (type (simple-array * (*)) vec))
  (macrolet ((el (i) `(aref vec ,i))
             (cmp (i j) `(funcall cmp (el ,i) (el ,j))))
    (loop with len = (1- (length vec))
       for i from (1- len) downto 0
       when (cmp i (1+ i)) do
         (loop for k from len downto i
            when (cmp i k) do
              (rotatef (el i) (el k))
              (setf k (1+ len))
              (loop while (< (incf i) (decf k)) do
                   (rotatef (el i) (el k)))
              (return-from next-perm vec)))))
 
;;; test code
;;(loop for a = "123" then (next-perm a #'char<) while a do     (write-line a))

#+ignore
(defun kpermlist (list) (loop for a = (perm-pairup list)
    then (next-perm a #'(lambda(x y)(< (cdr x)(cdr y)))) while a collect
			      (perm-unpair a)))

#+ignore 
(defun perm-pairup(list) ;; take ( a b c) return #( (a . 1) (b . 2) (c . 3))
  (if (atom list)(setf list (list list)))
  (let* ((count 0) 
	 (vec (map 'simple-vector #'(lambda (r)(incf count) (cons r count))  list)))
    vec))

#+ignore
(defun perm-unpair(vec) (map 'list #'car  vec))  ;; ((b . 2) (c . 3) (a . 1)) to (b c a)


#+ignore ;; what we could do to run through permutations. Something like this..
(loop for a = (perm-pairup '(r s t))
    then (next-perm a #'(lambda(x y)(< (cdr x)(cdr y))))
    while a do (if (test (perm-unpair a)) (return (list a "is a winner"))))


;; kpermlist is 2 or 3 times faster for generating ALL the permutations,
;; and uses about 1/3 the cons cells.
;; and presumably is even faster if you stop after, oh, half of them.


;; what else to implement?  oneidentity?

;; cheap hack to make maxima-compatible/  maxima expression is like ((f) a b). matcher is (f a b).
;; 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)
	 ((eq t ans) '((mlist)))
	 ((consp ans) (assoc2rule ans))
	  (t '((mlist) )))))

(defun assoc2rule(ans)  ;convert an assoc list to a Maxima list of Rules
  (cons '(mlist)
	(nreverse
	 (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)))
2

;; see  mma2maxfun.lisp in mma5max for possibly relevant comments
       
;; this next pattern optimization could do various things to speed up matching
;; but now is not doing anything.
(defun pattern-opt(x) x) ;; identity, for now

;; We thought we didn't want to evaluate any of these pieces when they were
;; read in, and then have a function make the changes. We changed our mind and
;; now most things are immediately put into "FullForm".
;; (defmacro makespec(k) `(defmspec ,k (L) (cons '(,k) (cdr L))))

;;(defmspec $-> (L) (list '(|$Rule|) (mfuncall '$pt (cadr L))(caddr L)))

;(makespec |$?|)
;(makespec |$/;|)
;(makespec |$\||)
;(makespec |$:$|)
;;(makespec |$/.|) need to evaluate
;(makespec |$//.|)
;(makespec |$@|)
;(makespec |$//|)
;(makespec |$|)


(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)
		    (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 '(|$BlankSegment|) head ))
				 (3 (cons '(|$BlankNullSegment|) 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, or have the user type nil_ etc
		;; this next test will always fail
		;;(format t "~% in pt, front=~s" front)
		(if (member front '("" "$" "$nil" "$NIL"):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)))


;; DISPLAY hacks
;; wxmaxima has its own display that doesn't always do the right thing.
;; commenting all this out means that "FullForm" display 
;; or possibly the leftover display from the parser extension is used.

#|

(displa-def |$Rule| dimension-infix " -> " 80 80)
(displa-def |$PatternTest| dimension-infix " ?")
(displa-def |$Condition| dimension-infix " /; ")
(displa-def |$Optional| dimension-postfix ".$")  ;; doesn't work in wxmaxima
;;;(displa-def |$Blank| dimension-prefix "_") ;; doesn't work in wxmaxima
;;;(displa-def |$BlankSegment| dimension-prefix "__") ;; doesn't work in wxmaxima
;;;(displa-def |$BlankNullSegment| dimension-prefix "___") ;; doesn't work in wxmaxima
;;;(displa-def |$BlankNullSegment| dimension-blank "___") ;; doesn't work in wxmaxima
;;;(displa-def |$BlankSegment| dimension-blank "__") ;; doesn't work in wxmaxima
;;;(displa-def |$Blank| dimension-blank "_") ;; doesn't work in wxmaxima
;;;(defun dimension-blank(f r))


;;;(displa-def |$Pattern| dimension-infix ":$") ;; not really what we want. 
;(displa-def |$Pattern| dim-pat " ")

;; this doesn't work.
;; because I don't understand displa dim-functions
#+ignore
(defun dim-pat(f r)
;  (format t "~% dim-pat called on ~s ~s" f r)
  (dimension-nofix
   (list '(mtext)
	 (concatenate 'string (symbol-name (cadr f))
	(case (caar (third f))
	  (|$Blank| "_")
	  (|$BlankSegment| "__")
	  (|$BlankNullSegment| "___")
	  (t "pattern-invalid-")))
	 (if (cdr (third f)) (cadr (third f)) "")) r)
  r)

|#


;; 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
a pattern that is altered by flatexpand or opt or something,
store it as a cached value with index of the rule. Thus is
a rule is processed twice, it is faster the second time. Done.
 
 |#
				   
				   

#|
($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,a=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) */

 
|#

	  
  #|

 Things Mma does.

 a+b+3/. s_   +r_ -> yes[s,and,r]  is yes[a+b,and, 3]    **** noteworthy ***
 a+b+3/. s_   +r_ -> yes(s,And,r);   is yes(b, And, 3, a) ** different **

 
 a+b+3/. s__+r_ -> yes[s,and,r]  is yes[a,b,and, 3]
 a+b+3/. s__+r_-> yes(s,And,r);  is yes(a,b,And,3)   
 **different but OK.
 
 
 a + b + 3 /. s_Symbol + r_   -> yes[s, and, r]  is yes[b, and, 3+a]
 a+b+3     /. s_symbol+r_-> yes(s,And,r);        is yes(b,And,3,a)  ** different
 
 a + b + 3 /. s__Symbol + r_  -> yes[s, and, r]  is yes[a,b, and, 3]
 a+b+3     /. s__symbol+r_-> yes(s,And,r);       is yes(a,b,And,3)
 
 a + b + 3 /. s___Symbol + r_ -> yes[s, and, r]  is yes[a,b, and, 3]
 a+b+3/. s___symbol+r_-> yes(s,And,r); 
    bind stack overflow .  ugh.
 
 a + b + 3 /. s_Symbol + r_Integer   ->  yes[s, and, r]  is b+yes[a,and,3] 
 a+b+3/. s_symbol+r_integer-> yes(s,And,r);  
 is b+yes(a,And,3)
 
 a + b     /. s__Symbol + r_Integer  -> yes[s, and, r]   is a+b
 a+b/. s_symbol+r_integer-> yes(s,And,r);  is               b+a
 
 a + b     /. s__Symbol + r_.Integer -> yes[s, and, r]   is a+b
 a+b/. s__symbol+r_integer-> yes(s,And,r);  is               b+a
 
 a + b     /. s__Symbol + r_. -> yes[s, and, r]   is yes[b,and,a]
 a + b     /. s__symbol + Optional(r_) -> yes(s,And, r) // simplifya illegal form ..
 a + b     /. s_ + Optional(r_) -> yes(s,And, r)  loops forever.
 
   a         /. s_Symbol + r_.  -> yes[s, and, r]  is  yes[a, and, 0] 
   a         /. s_Symbol + r_   -> yes[s, and, r] is yes[a, and, 0] is a
  |#