srfi-42.lisp

;;;; SRFI-42 Eager Comprehensions ( 先行評価的内包表記 ) in Common Lisp
(defpackage srfi-42
  (:use :cl)
  (:export ))

(in-package :srfi-42)


;;; Qualifiers

(defparameter *control-qualifiers*
  `( (if <test>)
     (not <test> &rest <tests>)
     (and <test> &rest <tests>)
     (or <test> &rest <tests>)
     (begin &rest <commands>)
     (nested &rest <qualifiers>)) )

;; <vars> -> <variable1> [ (index <variable2> ]
;; command = an expression begin evaluated for its side-effects
;; ob = outer binding
;; oc = outer command
;; ne1? = not-end1?
;; ne2? = not-end2?
;; lb = loop binding
;; ib = inner binding
;; ic = inner command
;; ls = loop step

(defparameter *generator-qualifiers*
  `( (:any <vars> <arg1> &rest <args>) ;; (: <vars> <arg1> &rest <args>)
     (:list <vars> <arg1> &rest <args>)
     (:string <vars> <arg1> &rest <args>)
     (:vector <vars> <arg1> &rest <args>)
     (:integers &rest <vars>)
     (:range <vars> <stop>)
     (:range <vars> <start> <stop>)
     (:range <vars> <start> <stop> <step>)
     (:real-range <vars> <stop>)
     (:real-range <vars> <start> <stop>)
     (:real-range <vars> <start> <stop> <step>)
     (:char-range <vars> <min> <max)
     (:port <vars> <port>)
     (:port <vars> <port> <read-proc>)
     (:dispatched <vars> <dispatch> <arg1> &rest <args>)
     (:do (&rest <lbs>) <ne1?> (&rest <lss>))
     (:do (let (&rest <obs>) &rest <ocs>)
	  (&rest <lbs>) <ne1?>
       (let (&rest <ibs>) &rest <ics>) <ne2?> (&rest <lss>))
     (:let <vars> <expression>)
     (:parallel &rest <generator-qualifiers>)
     (:while <generator-qualifier> <expression>)
     (:until <generator-qualifier> <expression>) ))


(defmacro do-ec (&rest args)
  (cond
    ((null args) args)
    ((null (cdr args)) (car args))
    (T
     (labels
	((lp (rest)
	   (if (null (cdr rest))
	       ;; body
	       (car rest)
	       ;; qualifier
	       (let ((q (car rest)))
		 `(loop
		   ,@(expand-qualifier (car q) (cdr q))
		   :do
		   ,(lp (cdr rest)))))))
      (lp args)))))

(defmacro fn-ec (fn base &rest args)
  (if (null args) nil
      (let ((result (gensym))
	    (f (gensym)))
	`(let ((,result ,base)
	       (,f ,fn))
	   (do-ec
	       ,@(append
		  (butlast args)
		  `((setf ,result (funcall ,f ,result ,(car (last args)))))))
	   ,result))))

(defmacro list-ec (&rest args)
  (if (null args) nil
      (let ((result (gensym)))
	`(let ((,result nil))
	   (do-ec
	       ,@(append
		 (butlast args)
		 `((push ,(car (last args)) ,result))))
	   (nreverse ,result)))))

(defmacro string-ec (&rest args)
  `(coerce (list-ec ,@args) 'string))

(defmacro vector-ec (&rest args)
  `(coerce (list-ec ,@args) 'vector))

(defmacro string-append-ec (&rest args)
  `(apply #'concatenate 'string (list-ec ,@args)))

(defmacro append-ec (&rest args)
  `(fn-ec #'append nil ,@args))

(defmacro sum-ec (&rest args)
  `(fn-ec #'+ 0 ,@args))

(defmacro product-ec (&rest args)
  `(fn-ec #'* 0 ,@args))

(defmacro min-ec (&rest args)
  `(apply #'min (list-ec ,@args)))

(defmacro max-ec (&rest args)
  `(apply #'max (list-ec ,@args)))

(defmacro any?-ec (&rest args)
  (let ((s (gensym)))
  `(block ,s
     (fn-ec #'(lambda (b a)
		(declare (ignore b))
		(and a (return-from ,s T)))
	    T
	    ,@args)
     nil)))

(defmacro every?-ec (&rest args)
  (let ((s (gensym)))
    `(block ,s
       (fn-ec #'(lambda (b a)
		  (declare (ignore b))
		  (or a (return-from ,s nil)))
	      T
	      ,@args)
       T)))

(defmacro first-ec (default &rest args)
  (let ((s (gensym))
	(d (gensym)))
    `(block ,s
       (let ((,d ,default))
	 (fn-ec #'(lambda (b a)
		    (declare (ignore b))
		    (return-from ,s a))
		T
		,@args)
	 ,d))))
       

(defmacro last-ec (default &rest args)
  (let ((d (gensym)))
    `(let ((,d ,default))
       (fn-ec #'(lambda (b a)
		  (declare (ignore b))
		  a)
	      ,d
	      ,@args))))


(defmacro vars-bind ((var index rest) qualifier &body body)
  (let ((sym (gensym)))
    `(let ((,sym ,qualifier))
       (let ((,var (first ,sym))
	     (,index (if
		      (and (listp (second ,sym))
			   (eq (intern "INDEX") (car (second ,sym))))
			   (cadr (second ,sym))
			   nil)))
     (let ((,rest (if (and (listp (second ,sym))
			   (eq (intern "INDEX") (car (second ,sym))))
		      (nthcdr 2 ,sym)
		      (nthcdr 1 ,sym))))
       ,@body)))))


(defgeneric expand-qualifier (qualifier args))

(defmethod expand-qualifier ((qualifier (eql :list)) args)
  (vars-bind (var index rest) args
    (destructuring-bind (arg1 &rest args) rest
      `(:for ,var :in (append ,arg1 ,@args)
	     ,@(when index `(:for ,index :from 0))))))

(defmethod expand-qualifier ((qualifier (eql :range)) args)
  (vars-bind (var index rest) args
    `(,@
      (case (length rest)
	((1) `(:for ,var :from 0 :below ,(first rest)))
	((2) `(:for ,var :from ,(first rest) :below ,(second rest)))
	((3) `(:for ,var :from ,(first rest) :below ,(second rest)
		    :by ,(third rest)))
	(T (error "invalid number of :range qualifier argument")))
      ,@(when index `(:for ,index :from 0)))))
    
(defmethod expand-qualifier ((qualifier (eql :parallel)) args)
  (loop :for arg in args
     :append (expand-qualifier (car arg) (cdr arg))))


;; examples

(do-ec (:list x (index i) (list 1 2 3))
  (:list y (index j) (list 10 11 12))
  (format t "(~A, ~A) (~A, ~A)~%" i x j y))

(list-ec
 (:range i 0 10 2) (:list x '(100 200))
 (list i x))

(list-ec
 (:parallel (:list x '(1 2 3)) (:list y '(11 12 13)))
 (:list j '(a b))
 (list x y j))