;; -*- Mode: Lisp; -*-
;; ---------------------------------------------------------------------------
;;     Title: OVER Clause for LOOP
;;   Created: 2023-08-14
;;    Author: Gilbert Baumann <gilbert@bauhh.de>
;;   License: MIT style (see below)
;; ---------------------------------------------------------------------------
;;  (c) copyright 2023 by Gilbert Baumann

;;  Permission is hereby granted, free of charge, to any person obtaining
;;  a copy of this software and associated documentation files (the
;;  "Software"), to deal in the Software without restriction, including
;;  without limitation the rights to use, copy, modify, merge, publish,
;;  distribute, sublicense, and/or sell copies of the Software, and to
;;  permit persons to whom the Software is furnished to do so, subject to
;;  the following conditions:
;; 
;;  The above copyright notice and this permission notice shall be
;;  included in all copies or substantial portions of the Software.
;; 
;;  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;  EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
;;  MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 
;;  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
;;  CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
;;  TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

;;;;

;; The syntax we recognize here is:
;;
;; :FOR <any> [ FIXNUM | FLOAT | T | NIL | :OF-TYPE <any> ] :OVER <any>
;;
;; This will iterate over a sequence. It's like an IN-clause for lists
;; and like an ACROSS-clause for vectors.
;;
;; What is needed as well is some clause that would iterate over some
;; repeated sequence like coordinate pairs

(defmacro loop* (&rest body)
  (labels ((frob (q)
             (cond ((endp q) nil)
                   (t
                    (multiple-value-bind (won var-spec type seq more)
                        (for-over-clause-p q)
                      (cond ((not won)
                             (cons (car q) (frob (cdr q))))
                            (t
                             (let* ((prefix (if (symbolp var-spec) (string var-spec) "G"))
                                    (s  (gensym (concatenate 'string prefix ".SEQ/")))
                                    (i  (gensym (concatenate 'string prefix ".I/")))
                                    (n  (gensym (concatenate 'string prefix ".N/")))
                                    (q  (gensym (concatenate 'string prefix ".Q/")))
                                    (v? (gensym (concatenate 'string prefix ".VECTORP/"))))
                               (list* ':WITH s '= seq
                                      ':WITH v? '= `(vectorp ,s)
                                      ':WITH n ':OF-TYPE `(INTEGER 0 ,array-total-size-limit) '= `(IF ,v? (LENGTH ,s) 0)
                                      ':FOR i ':OF-TYPE `(INTEGER 0 ,array-total-size-limit) ':FROM 0
                                      ':FOR q '= s ':THEN `(UNLESS ,v? (CDR ,q))
                                      ':WHILE `(IF ,v? (< ,i ,n) (NOT (ENDP ,q)))
                                      ':FOR var-spec ':OF-TYPE type '= `(IF ,v? (AREF ,s ,i) (CAR ,q))
                                      (frob more)))))))))
           (for-over-clause-p (body)
             ;; -> win? ; var-spec ; type ; seq ; remaining-loop-body
             (and (consp body)
                  (symbolp (car body))
                  (string= ':for (car body))
                  (consp (cdr body))
                  (consp (cddr body)))
             (let* ((var-spec (cadr body))
                    (body (cddr body))
                    (type
                     (cond ((member (car body) '(fixnum float t nil))
                            (pop body))
                           ((and (symbolp (car body)) (string= (car body) ':of-type)
                                 (consp (cdr body)))
                            (pop body)
                            (pop body))
                           (t
                            't))))
               (and (consp body)
                    (consp (cdr body))
                    (symbolp (car body))
                    (string= (car body) ':over)
                    (values t var-spec type (cadr body) (cddr body))))))
    ;;
    `(loop ,@(frob body))))