(in-package :maxima)
#| EMACS thinks this file does not have balanced parens. At the moment, at least, it does! 

Change from e18a, make test an explicit parameter to blankproc and blank1proc.|#

#| 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
Last revised 12/28/2016
|#
(defvar bindings nil)
(defvar flathead nil)
;;(defvar test '$print)
(eval-when (:compile-toplevel)
  (proclaim '(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(mma-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 mma-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) ;; 12/2016
      (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_ test c) ;;
  ;; 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)
	  ((and (null headcheck)
		(pushcheck name_ N test)
		(funcall c)) t) ;;2016 rjf
	  (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 test c)  ;; added ...test...
    ;; (...  (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)
       (setf flathead nil)
       (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" name_)
       (cond ((m18x (car M) (car N) name_ test
		    #'(lambda()
			;;(format t "~%the name_ second = ~s" name_)
			(and (pushcheck name_
					(car N)
					test)
			     #+ignore (e18x (cdr M) (cdr N) nil test c)
			      (e18x (cdr M) (cdr N) nil 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.
|#
;;; hacked 2/15 to fix patterntest

(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)))
			     
			     ;;(test (if (eq (caar wtm) '|$Blank|)nil test)) ;; 2016 patch ??
			     
			     (oldbindings bindings))
			;;(format t "~%pattern  ~s name_=~s wtm=~s test=~s" M name_ wtm test)
			;; if the pattern matches, name_ is bound to (car N).
			(cond
			 ((e18x  (cons (car wtm) (cdr M) ) ;; the test is not applicable any more
					  N ;; (car N) ;;??
					  name_ ;;name_ ;!!!!
					  test 
					  c)
			  t) ;return this if matched
			 
			 (t (setf bindings oldbindings) nil ) ; failed to match
			 )))
		     
		     ;; blankN 
		     ;; any binding resulting from this match will come from surrounding (pattern..)
		   
		     ((blankp (car M)) (blankproc 
					M N 
					name_
					(case (caar M) (|$Blank| 1)
					      (|$BlankSegment| 2)
					      (|$BlankNullSegment| 3))
					test
					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
					       name_
					       test
					       c
					       ))
				    c) ) ;; added 12/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)
		       (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 
		    name_
		      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 name_ test c)			
  ;; M looks like (Condition pat  test) where test is maxima expression
    (m18x (second M) N name_ 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)))))


(defun m18x (M N name_ 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)(mma-orderlessp (car M)) (eq (car M)(car N)))
      (cond ((eom4 M N nil test 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) name_ 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 name_ test #'(lambda() ;; if what-to-match matches N, optionally name_d,c
			  (and(pushcheck name_ N test)
			      (funcall c))))
	  t)
	 
	 ((m18x wtm N name_ 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 name_ test c)) ;2016
     ;;; 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 name_ test c))
	
     ((and (consp M)(eq (car M) '|$PatternTest|))
      
        (m18x (second M) N name_ 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(r)(setf bindings oldbindings)
		       (m18x r N name_ 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
	    name_
	    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 name_ 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) name_ 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..

(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))))))


;; maybe this is right for sbcl?
(defmspec |$:>|(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)))

(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

	   (coerce `(lambda(,e) 
	     (let((,ans ($m1 ',lhs , e)) )
	       (if (null ,ans) 
		   (values nil nil)
		 (values (substall
			  ,ans ',rhs)
			 t))))
		   'function)
	   ))
    
  ;;  (format t "~% ruletofn body=~s ~%lhs=~s ~%R=~s ~%name=~s" 	    body lhs R name)
    (setf (symbol-function name) body)
  name
  ;;(list '(mtext) name " is defined by rule " R)
  ))

;; 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.

(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))))))))

(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 |$/;| (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 (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)))))
(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 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 nil #'(lambda()
			      (cond 
			       (bindings 
			(if (not (member bindings allbindings :test #'equal))
				    ;; somehow we are getting duplicates..
			     (push bindings allbindings)
			   ;;  (format t "~% here's a set of bindings ~s" bindings)
			  nil) 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_ test 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"~%eom4 upat=~s uexp=~s"  upat uexp)
    
    (if (and (null uexp)(null upat))
	(cond ((funcall c)(return-from eom4 t))
	      (t  (setf bindings oldbindings);sbcl compiler thinks this unreachable?
		 (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
		;;       (format t "~% 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) 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)))))))

;; what else? attributes oneidentity?  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)
	 ((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)))


;; 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
		    )
		(declare(fixnum blanks))

		(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)))


(displa-def |$Rule| dimension-infix " -> " 80 80)
(displa-def |$PatternTest| dimension-infix " ?")
(displa-def |$Condition| dimension-infix " /; ")

;; DISPLAY hacks
;; wxmaxima has its own display that doesn't always do the right thing.
;; Disconnecting all of this can be done by display2d:false.
;; Then the display is rather like the Mathematica FullForm.

(displa-def |$Condition| dimension-infix " /; ")
(displa-def |$Optional| dimension-postfix ".$")  ;; 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 |$BlankNullSegment| dimension-blank "___") ;; doesn't work in wxmaxima
(displa-def |$Blank| dimension-blank "_") ;; doesn't work in wxmaxima

(defun dimension-blank(f r) 
  (if (null (cdr f))			;e.g. ((blank)  ), dont do a:$(_false)
      (nthcdr 5 (dimension-prefix f r))
    (dimension-prefix f r)))

(displa-def |$Pattern| dim-pat " ")

;; this may not work for wxmaxima
(defun dim-pat(f r)
  (dimension-atom
   (intern
	 (concatenate 'string (symbol-name (cadr f))
	(case (caar (third f))
	  (|$Blank| "_")
	  (|$BlankSegment| "__")
	  (|$BlankNullSegment| "___")
	  (t "pattern-invalid-"))
	(let ((head (cadr (third f))))
	  (if (null head)""(symbol-name (stripdollar head)))))) 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
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).
 
 We already do processing of flat and optional.
 We can also compile the programs.
 
 |#
				   

#|
($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/e18a.lisp") 		;  /* this file */

there are many tests in testmma.mac.

Here are simple ones

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) */
|#

;;; these hacks won't make the match work regarding the difference between a__ and z__. hm.
(defun $reform_pat(x)(reform-pat x))
	  
(defun reform-pat (x)(cond ((atom x) x)
			   ((flatp (caar x))
			    (cons (car x) (rearrange-pat (mapcar #'reform-pat (cdr x)))))
			   (t(cons (car x) (mapcar #'reform-pat (cdr x))))))

(defun rearrange-pat(L)
  ;; move any patterns to the end of the argument list

  (let ((segs nil)(rem nil))
    (loop for k in L do (cond ((patternp k)
			       (push k segs) )
			      (t (push k rem))))
    
    (append rem segs)))