;;; changes to Maxima to allow
;;;  for i from 1 thru 4 collect i;  ==> [1,2,3,4]
;;;  for i in [a,b] collect f(i);    ==> [f(a),f(b)]

;;;  for i from 1 thru 10 summing i; ==> 55
;;;  for i in [a,b] summing i;       ==> b+a

;;; written by Richard Fateman, 4/25/2010
(in-package :maxima)

;; changes to mlisp.lisp
(defmspec				;new function, mdo-collect   based on mdo in mlisp
    mdo-collect
    (form) (setq form (cdr form))
  ;;  (format t" ~% using mdo-collect on ~s" form)
	  (funcall #'(lambda (mdop var next test do result)
		       (setq next (or (cadddr form) (list '(mplus) (or (caddr form) 1) var)))
		 ;;      (format t "~%next=~s" next)
		       (setf
			     test (list '(mor)
					(cond ((null (car (cddddr form))) nil)
					      (t (list (if (mnegp ($numfactor (simplify (caddr form))))
							   '(mlessp)
							   '(mgreaterp))
						       var (car (cddddr form)))))
					(cadr (cddddr form))))
		       ;;(format t "~%test=~s" test)
		       (setf  do  (caddr (cddddr form)) )
;;		       (format t "~%do=~s" do)
		       (mbinding ((ncons var)
				       (ncons (if (null (cadr form)) 1 (meval (cadr form)))))
			     
				 (do ((val) (bindl bindlist))
				     ((is test) (nreverse result))
				   (cond ((null (setq val (catch 'mprog (prog2 (push (meval do) result) nil))))
					  (mset var (meval next)))
					 ((atom val) (merror "`go' not in `block':~%~M" val))
					 ((not (eq bindl bindlist))
					  (merror "Illegal `return':~%~M" (car val)))
					 (t (return (nreverse result)))))))
		   t (or (car form) 'mdo) nil nil nil (cons '(mlist) nil)))


;; changes to nparse.lisp
;; additional code
(def-lbp $collect 25.)
(def-rbp $collect 25.)

(def-nud-equiv $collect parse-$do)
(def-nud-equiv $thru parse-$do)

(def-rpos $collect $any)

(def-lbp $summing 25.)
(def-rbp $summing 25.)
(def-nud-equiv $summing parse-$do)
(def-rpos $summing $any)

;; mysterious patch; could this be put somewhere near the end of nparse.lisp ?
(push '($collect . 512) (get '$do 'keys)) 
(push '($summing . 1024) (get '$do 'keys))

;; redefinition in nparse.
(def-collisions $do
  ($do . ())
  ($collect . ($do ))
  ($summing . ($do))
  ($for    . ($for))
  ($from   . ($in $from))
  ($in     . ($in $from $step $next))
  ($step   . ($in       $step $next))
  ($next   . ($in	$step $next))
  ($thru   . ($in $thru))		;$IN didn't used to get checked for
  ($unless . ())
  ($while  . ()))


(defun parse-$do (lex &aux (left (make-mdo))(setin nil) )    ;;  from nparse. redefined
   ;added setin flag to get mdoin-collect to work. rjf.
 ;; (format t"~%entering parse-$do with lex=~s" lex)
  (setf (car left) (mheader 'mdo))
  (do ((op lex (pop-c))  (active-bitmask 0))
      (nil)
    (if (eq op '|$:|) (setq op '$from))
    (setq active-bitmask (collision-check '$do active-bitmask op))
   ;; (format t "~%in parse-do, op=~s " op)
    (let ((data (parse (rpos op) (rbp op))))
;;            (format t "~%op=~s, left=~s"  op  left)
      
      (case op
	($do		(setf (mdo-body left) data) (return (cons '$any left)))
	($for		(setf (mdo-for  left) data))
	($from		(setf (mdo-from left) data))
	($in		(setf (mdo-op   left) 'mdoin)(setf setin t)
			(setf (mdo-from left) data))
	($step		(setf (mdo-step left) data))
	($next		(setf (mdo-next left) data))
	($thru		(setf (mdo-thru left) data))
	(($unless $while)
			(if (eq op '$while)
			    (setq data (list (mheader '$not) data)))
			(setf (mdo-unless left)
			   (if (null (mdo-unless left))
			       data
			     (list (mheader '$or) data (mdo-unless left)))))
	;; this next business doesn't really get mdoin-collect to be used.
	($collect	;;(format t"~% mdo-op is ~s set is ~s" (mdo-op) set)
	 (setf (mdo-op left) (if setin 'mdoin-collect 
			       'mdo-collect))
	 (setf (mdo-body left) data)(return (cons '$any left))	)
	
	;; possible addition here ..
	($summing
	 (setf (mdo-op left) (if setin 'mdoin-summing		       
			       'mdo-summing))
	 (setf (mdo-body left) data)(return (cons '$any left))	)
	
	
	(t (parse-bug-err '$do))))))

(setf (get '$for 'nud) #'parse-$do)

;;; changes to displa.lisp


(defun dim-mdo (form result) (dim-mdo-gen form result "do " 4))  ;; replace old dim-mdo
(defun dim-mdoin (form result) (dim-mdoin-gen form result "do " 4)) ;; replace old dim-mdoin

(defun dim-mdo-collect (form result) (dim-mdo-gen form result "collect " 9))
(defun dim-mdoin-collect (form result) (dim-mdoin-gen form result "collect " 9))

(defun dim-mdo-summing (form result) (dim-mdo-gen form result "summing " 9))
(defun dim-mdoin-summing (form result) (dim-mdoin-gen form result "summing " 9))
  

(defun dim-mdo-gen (form result tag tagwidth)   ;; add to display.lisp
  (prog ((w 0) (h 0) (d 0) brkflag) (declare (fixnum w h d))
	(cond ((not (null (cadr form)))
	       (push-string "for " result)	
	       (setq result (cons #\space (dimension (cadr form) result 'mdo 'mparen 4 right))
		     w (f+ 4 width) h height d depth brkflag t)))
	(cond ((or (null (caddr form)) (equal 1 (caddr form))))
	      (t (push-string "from " result)
		 (setq result
		       (cons #\space (dimension (caddr form) result 'mdo 'mparen (f+ 6 w) 0))
		       w (f+ 6 w width) h (max h height) d (max d depth))))
	(setq form (cdddr form))
	(cond ((equal 1 (car form)))
	      ((not (null (car form)))
	       (push-string "step " result)
	       (setq result (cons #\space (dimension (car form) result 'mdo 'mparen (f+ 6 w) 0))
		     w (f+ 6 w width) h (max h height) d (max d depth)))
	      ((not (null (cadr form)))
	       (push-string "next " result)
	       (setq result (cons #\space (dimension (cadr form) result 'mdo 'mparen (f+ 6 w) 0))
		     w (f+ 6 w width) h (max h height) d (max d depth))))
	(cond ((not (null (caddr form)))
	       (push-string "thru " result)
	       (setq result (cons #\space (dimension (caddr form) result 'mdo 'mparen (f+ 6 w) 0))
		     w (f+ 6 w width) h (max h height) d (max d depth) brkflag t)))
	(cond ((not (null (cadddr form)))
	       (cond ((and (not (atom (cadddr form))) (eq (caar (cadddr form)) 'mnot))
		      (push-string "while " result)
		      (setq result
			    (cons #\space (dimension (cadr (cadddr form)) result 'mdo 'mparen (f+ 7 w) 0))
			    w (f+ 7 w width) h (max h height) d (max d depth)))
		     (t (push-string "unless " result)
			(setq result
			      (cons #\space (dimension (cadddr form) result 'mdo 'mparen (f+ 8 w) 0))
			      w (f+ 8 w width) h (max h height) d (max d depth))))))
	(if brkflag (checkbreak result w))
	;;(push-string tag result) ;push-strng macro is crappy, works only for literal string
    (setf result (append (reverse (exploden tag)) result))
	(setq result (dimension (car (cddddr form)) result 'mdo-collect rop (f+ tagwidth w) right)
	      width (f+ tagwidth w width) height (max h height) depth (max d depth))
    (return result)))

(displa-def mdo-collect dim-mdo-collect)
(displa-def %mdo-collect dim-mdo-collect)
(displa-def mdoin-collect dim-mdoin-collect)
(displa-def %mdoin-collect dim-mdoin-collect)
;; provide code for summing
(displa-def mdo-summing dim-mdo-summing)
(displa-def %mdo-summing dim-mdo-summing)
(displa-def mdoin-summing dim-mdoin-summing)
(displa-def %mdoin-summing dim-mdoin-summing)

(defun dim-mdoin-gen (form result tag tagwidth)  ;; add to displa.lisp.
  (prog ((w 0) (h 0)  ( d 0)) (declare (fixnum w h d))
	(push-string "for " result)
	(setq result (dimension (cadr form) result 'mdo 'mparen 4 0)
	      w (f+ 4 width) h height d depth)
	(push-string " in " result)
	(setq result (dimension (caddr form) result 'mdo 'mparen (f+ 4 w) 0)
	      w (f+ 4 w width) h (max h height) d (max d depth))
	(setq form (cdr (cddddr form)))
	(cond ((not (null (car form)))
	       (push-string " thru " result)
	       (setq result (dimension (car form) result 'mdo 'mparen (f+ 6 w) 0)
		     w (f+ 6 w width) h (max h height) d (max d depth))))
	(cond ((not (null (cadr form)))
	       (push-string " unless " result)
	       (setq result (dimension (cadr form) result 'mdo 'mparen (f+ 8 w) 0)
		     w (f+ 8 w width) h (max h height) d (max d depth))))
        (setf result (append (reverse (exploden tag)) result))
    (setq result (dimension (caddr form) result 'mdo rop (f+ tagwidth w) right)
	  width (f+ tagwidth w width) height (max h height) depth (max d depth))
	(return result)))


;;;;;;;;;;;;;;;; support  for i:1 thru 10 summing i ,  for i in X summing f(i) etc

;; additions to mlisp.lisp

(defmspec mdoin-summing (form) 
  (setq form (cdr form))
  (funcall 
   #'(lambda  (mdop var set test action result)

       (setq set (if ($atom (setq set (format1 (meval (cadr form)))))
		     (merror "Atomic 'in' argument to `do' statement:~%~M" set)
		   (margs set))
	     test (list '(mor)
			(if (car (cddddr form))
			    (list '(mgreaterp) var (car (cddddr form))))
			(cadr (cddddr form)))
	     action (caddr (cddddr form)))
       (cond ((atom set) result)
	     (t (mbinding ((ncons var) (ncons (car set)))
			  (do ((val) (bindl bindlist))
			      ((or (atom set) (is test))
			       result)
			    (cond ((null (setq val 
					   (catch 'mprog 
					     ;; note changes to next line
					     ;; we could generalize this to any binary operation
					     ;; not just summation.

					     (prog2 (setf result(add (meval action) result)) nil))))
				   
				   (if (setq set (cdr set)) (mset var (car set))))
				  ((atom val) (merror "`go' not in `block':~%~M" val))
				  ((not (eq bindl bindlist))
				   (merror "Illegal `return':~%~M" (car val)))
				  (t (return result))))))))
   t (or (car form) 'mdo) nil nil nil 0))

(defmspec				;mdo-summing   based on mdo in mlisp
  mdo-summing
  (form) 
  (setq form (cdr form))
  (funcall #'(lambda (mdop var next test do result)
	       (setq next (or (cadddr form) (list '(mplus) (or (caddr form) 1) var)))
	       (setf
		test (list '(mor)
			   (cond ((null (car (cddddr form))) nil)
				 (t (list (if (mnegp ($numfactor (simplify (caddr form))))
					      '(mlessp)
					    '(mgreaterp))
					  var (car (cddddr form)))))
			   (cadr (cddddr form))))

	       (setf  do  (caddr (cddddr form)) )

	       (mbinding ((ncons var)
			  (ncons (if (null (cadr form)) 1 (meval (cadr form)))))
			     
			 (do ((val) (bindl bindlist))
			     ((is test) result)
			   (cond ((null (setq val 
					  (catch 'mprog 
					    (prog2 (setf result(add (meval do) result)) nil))))
				  (mset var (meval next)))
				 ((atom val) (merror "`go' not in `block':~%~M" val))
				 ((not (eq bindl bindlist))
				  (merror "Illegal `return':~%~M" (car val)))
				 (t (return result))))))
	   t (or (car form) 'mdo) nil nil nil 0))


;;; changes courtesy of andrej vodeopivec to make wxmaxima work!

(defvar *mdo-keyword* "do")

(defprop mdo-collect 30. wxxml-rbp)
(defprop mdo-collect wxxml-mdo-collect wxxml)
(defprop mdo-summing 30. wxxml-rbp)
(defprop mdo-summing wxxml-mdo-summing wxxml)

(defprop mdoin-collect 30. wxxml-rbp)
(defprop mdoin-collect wxxml-mdoin-collect wxxml)
(defprop mdoin-summing 30. wxxml-rbp)
(defprop mdoin-summing wxxml-mdoin-summing wxxml)

;;; from grind.lisp 

(defprop mdo-collect msz-mdo-collect grind)
(defprop mdoin-collect msz-mdoin-collect grind)
(defprop mdo-summing msz-mdo-summing grind)
(defprop mdoin-summing msz-mdoin-summing grind)

(defun msz-mdo-collect (x l r)
  (msznary (cons '(mdo) (strmdo-gen x '$collect)) l r '(#\space)))

(defun msz-mdoin-collect (x l r)
  (msznary (cons '(mdo) (strmdoin-gen x '$collect)) l r '(#\space)))

(defun msz-mdo-summing (x l r)
  (msznary (cons '(mdo) (strmdo-gen x '$summing)) l r '(#\space)))

(defun msz-mdoin-summing (x l r)
  (msznary (cons '(mdo) (strmdoin-gen x '$summing)) l r '(#\space)))


(defun strmdo-gen (x tag)
  (nconc (cond ((second x) `($for ,(second x))))
	 (cond ((equal 1 (third x)) nil)
	       ((third x)  `($from ,(third x))))
	 (cond ((equal 1 (fourth x)) nil)
	       ((fourth x) `($step ,(fourth x)))
	       ((fifth x)  `($next ,(fifth x))))
	 (cond ((sixth x)  `($thru ,(sixth x))))
	 (cond ((null (seventh x)) nil)
	       ((eq 'mnot (caar (seventh x)))
		`($while ,(cadr (seventh x))))
	       (t `($unless ,(seventh x))))
	 `(,tag ,(eighth x))))

(defun strmdoin-gen (x tag)
  (nconc `($for ,(second x) $in ,(third x))
	 (cond ((sixth x) `($thru ,(sixth x))))
	 (cond ((null (seventh x)) nil)
	       ((eq 'mnot (caar (seventh x)))
		`($while ,(cadr (seventh x))))
	       (t `($unless ,(seventh x))))
	 `(,tag ,(eighth x))))


;; the wxmaxima interface

(defun wxxml-mdo-collect (x l r)
  (let ((*mdo-keyword* "collect"))
    (wxxml-list (wxxmlmdo x) l r "<mspace/>")))

(defun wxxml-mdo-summing (x l r)
  (let ((*mdo-keyword* "summing"))
    (wxxml-list (wxxmlmdo x) l r "<mspace/>")))

(defun wxxml-mdoin-collect (x l r)
  (let ((*mdo-keyword* "collect"))
    (wxxml-list (wxxmlmdoin x) l r "<mspace/>")))

(defun wxxml-mdoin-summing (x l r)
  (let ((*mdo-keyword* "summing"))
    (wxxml-list (wxxmlmdoin x) l r "<mspace/>")))

(defun wxxmlmdo (x)
  (nconc (cond ((second x) (list (make-tag "for" "fnm") (second x))))
	 (cond ((equal 1 (third x)) nil)
	       ((third x)  (list (make-tag "from" "fnm") (third x))))
	 (cond ((equal 1 (fourth x)) nil)
	       ((fourth x)
		(list (make-tag "step" "fnm")  (fourth x)))
	       ((fifth x)
		(list (make-tag "next" "fnm") (fifth x))))
	 (cond ((sixth x)
		(list (make-tag "thru" "fnm") (sixth x))))
	 (cond ((null (seventh x)) nil)
	       ((eq 'mnot (caar (seventh x)))
		(list (make-tag "while" "fnm") (cadr (seventh x))))
	       (t (list (make-tag "unless" "fnm") (seventh x))))
	 (list (make-tag *mdo-keyword* "fnm") (eighth x))))


(defun wxxmlmdoin (x)
  (nconc (list (make-tag "for" "fnm") (second x)
	       (make-tag "in" "fnm") (third x))
	 (cond ((sixth x)
		(list (make-tag "thru" "fnm") (sixth x))))
	 (cond ((null (seventh x)) nil)
	       ((eq 'mnot (caar (seventh x)))
		(list (make-tag "while" "fnm") (cadr (seventh x))))
	       (t (list (make-tag "unless" "fnm") (seventh x))))
	 (list (make-tag *mdo-keyword* "fnm") (eighth x))))