;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
;;; Richard Fateman 4/22/2016.  
;;; an augmented  version of the for-loop, to use instead of makelist
;;; Adding "collect" as keyword in for i:1 thru 3 collect f(i)
;;; returns [ f(1), f(2), f(3) ].  All other keywords in for ... do
;;; work the same.
;;; 

;;; for i:1 next 2*i while i< 20 collect f(i)  is translated to
;;; block([g15:[]],
;;;      for i next 2*i unless i>=20 do  push(f(i),g15),
;;;      reverse(g15))

;;;   also supported,   for i:1 thru 10 dosum f(i) 
;;;   also supported,   for i:1 thru 10 doproduct f(i) 
;;;   also supported,   for i:1 thru 10 donumsum f(i) ; f(i) must be a number.


(in-package :maxima)
(load-macsyma-macros defcal mopers)

(def-lbp $collect	 25.)
(def-rbp $collect      25.)
(def-rpos $collect     $expr)

(def-lbp $dosum	 25.)
(def-rbp $dosum      25.)
(def-rpos $dosum     $expr)

(def-lbp $donumsum	 25.)
(def-rbp $donumsum      25.)
(def-rpos $donumsum     $expr)

(def-lbp $doproduct	 25.)
(def-rbp $doproduct      25.)
(def-rpos $doproduct     $expr)

(def-collisions $do
    ($do	   . ())
  ($collect . ())
  ($dosum . ())
    ($donumsum . ())
  ($doproduct . ())
  ($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  . ()))

(def-nud-equiv $collect    parse-$do)
(def-nud-equiv $dosum    parse-$do)
(def-nud-equiv $donumsum    parse-$do)
(def-nud-equiv $doproduct    parse-$do)

(defun parse-$do (lex &aux (left (make-mdo)))
  (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))
    (let ((data (parse (rpos op) (rbp op))))
      (case op
	($do   	(setf (mdo-body left) data) (return (cons '$any left)))
	;; 3 lines added for collect, dosum, donumsum doproduct
	($collect   	(return (cons  '$expr (for-collect data left 'collect))))
	($dosum   	(return (cons  '$expr (for-collect data left 'sum))))
	($donumsum   	(return (cons  '$expr (for-collect data left 'numsum))))
	($doproduct   	(return (cons  '$expr (for-collect data left 'product))))
	($for		(setf (mdo-for  left) data))
	($from		(setf (mdo-from left) data))
	($in		(setf (mdo-op   left) 'mdoin)
			(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)))))
	(t (parse-bug-err '$do))))))

(def-nud-equiv $for    parse-$do)	; reset parser to use the def above.

;; new function to handle the collect, dosum, donumsum,  doproduct clause


#+ignore
(defun for-collect (data L which)	;macro-expand the "for ..collect" into a do-loop
  (let* ((newvar (gensym))
	 (tail (if (eq which 'collect)
		   `(($reverse) ,newvar)
		 newvar))
	 (init (case which
		 (collect '((mlist)))
		 (product 1)
		 (sum 0)
		 (numsum 0))))
		 

    (setf (mdo-body L) (case which
			 (collect `(($push)  ,data ,newvar))
			 (product `(msetq ,newvar
					    (mul ,newvar ,data)))
			 (sum `(msetq ,newvar
				      (add ,newvar ,data)))
			 (numsum `(incf ,newvar ,data))))
	  
    `((mprog)
      ((mlist)((msetq) ,newvar ,init) ) ,L   ,tail)))


;; faster? smaller?  than sum();  not necessarily

(defun for-collect (data L which)	;macro-expand the "for ..collect" into a do-loop
  (let* ((newvar (gensym))
	 (tail (if (eq which 'collect)
		   `(($reverse) ,newvar)
		 newvar))
	 (init (case which
		 (collect '((mlist)))
		 (product 1)
		 (sum 0))))
		 

    (setf (mdo-body L) (case which
			 (collect `(($push)  ,data ,newvar))
			 (product `(msetq ,newvar
					    (mul ,newvar ,data)))
			 (sum `(msetq ,newvar
					(add ,newvar ,data)))))
    
	  
    `((mprog)
      ((mlist)((msetq) ,newvar ,init) ) ,L   ,tail)))

      

#| something else we might do..

infix(filter)$
L filter fun := block(ans:[], 
 for i in L do 
   if apply(fun, [i]) then push(i,ans), 
 reverse (ans))$

then we could have something like 
(for i:1 thru 5 collect i) filter oddp  ==> [1,3,5]


|#