;;; ----------------------------------------------------------------------
;;; This file is part of ILOG Talk.
;;; Inquiries to ILOG S.A.
;;;              9 rue de Verdun, BP 85,
;;;              94253 Gentilly Cedex, France.
;;;
;;; Copyright (c) 1993-1996 by ILOG
;;; ----------------------------------------------------------------------
;;;

;;; a minor-league loop

;;; Examples:
;;; 
;;; (tm:loop ((a from: 1 to: 5))
;;;   (tm:collect a))
;;;   ==> (1 2 3 4 5)
;;;
;;; (tm:loop ((a from: 1 to: 5))
;;;   (when (= a 4)
;;;     (tm:collect a)))
;;;   ==> (4)
;;;   
;;; (tm:loop ((a in: '(a b c))
;;;           (b in: '(1 2 3)))
;;;   (tm:collect (cons a b)))
;;;   ==> ((a . 1) (b . 2) (c . 3))
;;;
;;; (tm:loop ((a in-vector: [a b c])
;;; 	      (b in: '(x y z w))
;;; 	      (c from: 5 to: 10))
;;;  (tm:nconc (list a b c)))
;;;   ==> (a x 5 b y 6 c z 7)
;;;
;;; (tm:loop ((a from: 1))
;;;   (when (= a 10) (tm:return 'ok)))
;;;   ==> ok

(require 'backquote)
(require 'cl)

(defmacro tm:loop (iterators &rest body)
  "a stupid loop"
  (let* ((index-vars (tm:collect-index-vars iterators))
	 (iterator-vars (tm:collect-iterator-vars iterators))
	 (conditions (tm:collect-conditions iterators))
	 (updaters (tm:collect-updators iterators)))
    (` (catch 'tm:loop
	 (let* ((tm:loop-result (tm:tail-cons ()))
		(,@ iterator-vars)
		(,@ index-vars))
	   (while (and (,@ conditions))
	     (,@ updaters)
	     (,@ body))
	   (throw 'tm:loop (tm:tail-cons-value tm:loop-result)))))))

(defun tm:return (value)
  (throw 'tm:loop value))

(defun tm:collect (value)
  (setq tm:loop-result (tm:tail-conc1 tm:loop-result value)))

(defun tm:nconc (value)
  (setq tm:loop-result (tm:tail-conc-last tm:loop-result value)))

(defun tm:tail-cons (init)
  (let ((pair (cons init ())))
    (cons pair pair)))

(defun tm:tail-conc1 (tail-cons elt)
  (let ((new-last (cons elt ())))
    (rplacd (cdr tail-cons) new-last)
    (rplacd tail-cons new-last)
    tail-cons))

(defun tm:tail-conc-last (tail-cons tail)
  (let ((new-last tail))
    (when new-last
      (rplacd (cdr tail-cons) new-last)
      (rplacd tail-cons (last new-last)))
    tail-cons))

(defun tm:tail-cons-value (tail-cons) (cdr (car tail-cons)))

(defun tm:collect-index-vars (iterators)
  (let ((result ()))
    (dolist (iterator iterators)
      (setq result (cons (tm:get-index-var iterator) result)))
    (nreverse result)))

(defun tm:collect-conditions (iterators)
  (let ((result ()))
    (dolist (iterator iterators)
      (setq result (cons (tm:get-condition iterator) result)))
    (nreverse result)))

(defun tm:collect-iterator-vars (iterators)
  (let ((result ()))
    (dolist (iterator iterators)
      (setq result (cons (cons (car iterator) nil) result)))
    (nreverse result)))

(defun tm:collect-updators (iterators)
  (let ((result ()))
    (dolist (iterator iterators)
      (setq result (cons (tm:get-updator iterator) result)))
    (nreverse result)))

(defun tm:get-updator (iterator)
  (let* ((var (nth 0 iterator))
	 (type (nth 1 iterator))
	 (value (nth 2 iterator))
	 (index-var (tm:make-index-var var)))
    (cond ((eq type 'in:)
	   (` (progn (setq (, var) (car (, index-var)))
		     (setq (, index-var) (cdr (, index-var))))))
	  ((eq type 'in-vector:)
	   (` (progn (setq (, var) (aref (, value) (, index-var)))
		     (setq (, index-var) (+ (, index-var) 1)))))
	  ((eq type 'from:)
	   (` (progn (setq (, var) (, index-var))
		     (setq (, index-var) (+ (, index-var) 1)))))
	  (t (error "unknown iterator %s" type)))))

(defun tm:get-index-var (iterator)
  (let* ((var (nth 0 iterator))
	 (type (nth 1 iterator))
	 (value (nth 2 iterator))
	 (index-var (tm:make-index-var var)))
    (cond ((eq type 'in:)
	   (list index-var value))
	  ((eq type 'in-vector:)
	   (list index-var 0))
	  ((eq type 'from:)
	   (list index-var value))
	  (t (error "unknown iterator %s" type)))))
	 
(defun tm:get-condition (iterator)
  (let* ((var (nth 0 iterator))
	 (type (nth 1 iterator))
	 (value (nth 2 iterator))
	 (index-var (tm:make-index-var var)))
    (cond ((eq type 'in:)
	   index-var)
	  ((eq type 'in-vector:)
	   (` (< (, index-var) (length (, value)))))
	  ((eq type 'from:)
	   (let ((to (tm:getf 'to: (cdr (cdr (cdr iterator))))))
	     (if to
		 (` (<= (, index-var) (, to)))
	       t)))
	  (t (error "unknown iterator %s" type)))))

(defun tm:make-index-var (sym)
  (intern (concat (symbol-name sym) "_index")))

(defun tm:getf (key plist)
  (cond ((null plist) ())
	((eq key (car plist))
	 (car (cdr plist)))
	(t (tm:getf key (cdr (cdr plist))))))

(provide 'talk-loop)
