(in-package :mma)

(defun m1 (p e name gh c)
  ;; p is pattern, e is expression, name (maybe nil) is the variable name
  ;; that would be bound in case a binding is indicated. m1 doesn't make
  ;; bindings directly, but through mblanks or related subroutines.
  ;; oddly, the "main" program here can't truly process, directly,
  ;; most interesting patterns. Mlist, below, is usually doing the job.
  ;; Why is this?  While a pattern like x_ can "match anything", a pattern
  ;; like x__ {match a sequence} does not make much sense alone.
  ;; Rather f[x__] makes sense, where x__ will match all the arguments to f.
  
  ;; the |Alternatives| clause shows how backtracking can be done.
  ;; gh stands for governing head.
  ;; gh is the |Head| of the pattern that governs the attributes to make the pattern
  ;; e.g. in (f  (|Pattern| x ...) (|Pattern| y ...) z ...)
  ;; in the arguments of |Pattern| [x] and [y], as well as z, the governing head is f.
  ;; c is a function to be called, accumulated in the matching,
  ;; that must return t for the match to succeed. That is,
  ;; The success of m1 matching requires that (funcall c)
  ;; result in a non-nil value. As a side effect, the global variable env
  ;; will contain the bindings for pattern variables.
  ;; 
  ;;(print env)
  (let* ((hp (|Head| p))
	 (ha (and gh (cdr (|Attributes| gh)))) ;; if non-null gh, get attributes. could cache.
	 (hpa (|Attributes| hp))
	 )
   (format t "~% hp=~s, hpa=~s name=~s" hp hpa name)
    ;; could this be called at rule-definition time??
   ;; (if (and *anyopts* (hasoptionalp p))(return-from m1 (m1 (remopts p hp) e name gh c)))
    
    (if (or (member '|Flat| hpa :test 'eq)
	    (member '|Orderless| hpa :test 'eq))
	(return-from m1 (m2 p e name gh c)))
    
    (dformat t "~%ha=~s" ha) ;; attributes of head of p
    (cond 
     ;; first check for simple termination conditions in which
     ;; the pattern is exhausted and all that needs to be checked
     ;; is the functional condition that has been accumulated to this
     ;; point and is the 'c' function
     ((null p)(if (null e) (funcall c) nil)) ; check the conditions.
     ((atom p)(if (and (equal p e)(bindifposs name e))(funcall c) 'True nil))
     ((equal p e)(and (bindifposs name e) (funcall c)))
     ((and (atom e)*extended-atom-match* (member hp '(|Rational| |Complex|) :test 'eq))
    ;;  (print 'hi)
      ;; check below is for "ratiop" not in GCL?
      (cond ((and (rationalp e) (not (integerp e))) (m1 p `(|Rational| ,(numerator e),(denominator e)) name gh c))
	    
	    ;; the expression is a complex number
	    ((complexp e) 
	   ;  (print 'AHA)
	     (let ((re (realpart e))
		   (im (imagpart e)))
	       #+ignore
	       (m1 p `(|Plus| ,re  (|Times| ,im #c(0 1))) name gh c)
	       (m1 p `(Complex  ,re   ,im) name gh c)
	       )				  )))

     ;; check for a |Pattern|.  This construction provides a NAME for
     ;; the result of the sub-expression matching.  That is, matching
     ;; (|Pattern| Q  <stuff>)  is exactly the same as matching <stuff>
     ;; but with the side consequence of making the binding of the name Q
     ;; to the expression matching <stuff>
     ((eq hp '|Pattern|) 
      (dformat t "~% calling mpattern from m1 with  p=~s, e=~s gh=~s" p e gh)
      (mpattern  p 
		 e			;the expression
		 name;; ??
		 ;;nil
		 gh ;governing head, whose |Attributes| may be important
		 c)) ;condition, necessary for the rest of the pattern match

     ;; generally, the execution of this next clause signals a problem
     ;; in the composition of a pattern if gh has attribute Flat
     ((member hp '(|Blank|) :test 'eq)
      (dformat t "~% ~s match to expr ~s with name ~s" p e name)
      (mblanks p e name gh c) )
     ;; generally, the execution of this next clause signals a problem
     ;; in the composition of a pattern anytime.
     ;; the reason is, we need to have the context in the pattern -- what
     ;; else follows the X=blank[Null]sequence, to see how much X should
     ;; absorb.
      
     ((member hp '(|BlankSequence| |BlankNullSequence| :test 'eq))
      (dformat t "~% ~s match to expr ~s with name ~s" p e name)
      (mblanks p e name gh c))
     ;; next, go through the cases
     ;; Condition belongs only on the top level of a function, and
     ;; probably should not be encountered here, ever
     
    ((eq hp '|Condition|)
     (dformat t "~%processing |Condition| ~s "(caddr p))
     ;; transform the condition to be THIS condition AND whatever else.
     (m1 (cadr p)e name gh (let ((ccc (caddr p)))
			     (eformat t "~%x2 p=~s e=~s c=~s" p e ccc)
			     #'(lambda()(and (meval ccc)(funcall c))))) )
    ((eq hp '|Alternatives|) 
     ;; if we change |Alternatives| to be n-ary, 
     ;; this still works.
     (dolist (alt (cdr p) nil)		; range through alternatives.
       (dformat t "~% check alternative ~s" alt)
      ;; (spushframe env '|Alternatives|)
       (if (m1 alt e name gh c)
	   (return t)
	nil;; (spopframe env) ; if this choice failed, try another til exhausted
	 )))
    ((eq hp '|Action|) ;; would be (Action pattern (Bind name val)) ;; only case now handled
     (let* ((apat (cadr p))
	    (act (caddr p))		; action clause looks like (Bind name val)
	    (theact (car act))
	    (bindvar (cadr act))
	    (bindval (caddr act)))
       ;; assume it is a bind
       (dformat t "~% processing Action ~s" p)
       (if (eq '|Bind| theact)
	   (m1 `(|Pattern| , bindvar (|Blank|)) bindval name gh #'(lambda()(m1 apat e name gh c)))
	 (format t "~%invalid action specified in ~s" act))
       ))

    ((eq hp '|Except|)
     (not (m1 (cadr p) e name gh c)));; not really right since bindings are lost!!
    ((member hp '(|Repeated| |RepeatedNull|))
     (error "Matching of |Pattern| objects with |Head| ~s not installed, used in ~s" hp p))
    ((eq hp '|PatternTest|) ;;  a_?pred  for example
     (m1 (cadr p)e name gh
	 (let ((ccc (caddr p)))
	   #'(lambda()
	       (eformat t "~%x3 p=~s e=~s c=~s" p e c)
	       (and (meval (list ccc e))
			   (funcall c))))))
    ;; mlist takes care of the rest here..
    ;; if (|Head| p) is neither flat nor orderless, match in order.
    ;; Here, we match the heads and go through the rest via mlist.
    ;; simplified coding here
    ;; Note. (|Head| p) is NOT "|Pattern|" at this point in m1
     
    ;; now both p and e are expressions.
    ;; we match (recursively) their heads, and match,
    ;; in sequence, elements in their cdrs, by mlist.
    ;; in mlist we worry about attributes of phead, e.g. flat, orderless
    ((and (member '|Flat| ha :test 'eq)
	  (member '|Orderless| ha :test 'eq))
     (matchfol p e phead (|Default| phead) name phead c))

     ;;; THIS NEXT CLAUSE IS THE MAIN LOCUS OF ACTIVITY, usually
     
    (t (print 'yy) (format t "~%name=~s" name)

     ;; start matching in order.
     ;; (format t "~%in m1 should bind name ~s to ~s" name e)
     (cond (name
	    (multiple-value-bind (val found)
	      (sfind-loc env name)
		(print 'xx)
	      
		;;(sfind env name)
	      ;; (print 'ww)

	      (cond (found (and (equal val e) ; if found and equal, don't change
				(m1 hp 
				    (|Head| e)
				    nil
				    gh
				    #'(lambda()
					(eformat t "~%x4 p=~s e=~s c=~s" p e c)
					(mlist (rest p)(rest e) nil  gh c))))) ;; no binding for name was found
		    (t  (spush env name e)
		  
			(if  (m1 hp 
				 (|Head| e)
				 nil
				 gh
				 #'(lambda()
				     (eformat t "~%x5 p=~s e=~s c=~s" p e c)
				     (mlist (rest p)(rest e) nil  gh c)))
			    t
			  (let ()(spop env) nil))))))
	   ((atom e)
 ;    (format t"~% atomic e e=~s p=~s" e p)
	    nil)
	    ;; if no name
	    (t (m1 hp    (|Head| e)  name  gh  #'(lambda()
						   (eformat t "~%x6 p=~s e=~s c=~s" p e c)
						   (mlist (rest p)(rest e) nil  hp c)
						   ))))))))