added ftab, fset and fvec iterators and optional ITERATE drivers

x.fdatatypes-iterate.asd

@@ -0,0 +1,8 @@
+(in-package :cl-user)
+
+(asdf:defsystem :x.fdatatypes-iterate
+  :depends-on (:x.let-star :x.fdatatypes :iterate)
+  :serial t
+  :components ((:module "x.fdatatypes-iterate"
+                :components ((:file "package")
+                             (:file "iterate")))))

x.fdatatypes-iterate/iterate.lisp

@@ -0,0 +1,50 @@
+(in-package :x.fdatatypes-iterate)
+
+(defmacro-driver (for key/val :in-fdatatype container)
+  (destructuring-bind (key val) key/val
+    (let ((kwd (if generate 'generate 'for))
+          (iterator (gensym))
+          (result-template (gensym))
+          (tmp-key (gensym))
+          (tmp-val (gensym))
+          (validp (gensym)))
+      `(progn
+         (with ,iterator = (iterator ,container))
+         (while ,iterator)
+         (with ,result-template = (list nil nil))
+         (with ,tmp-key)
+         (with ,tmp-val)
+         (with ,validp)
+         (,kwd (,key ,val) next
+               (progn
+                 (multiple-value-setq (,iterator ,tmp-key ,tmp-val ,validp)
+                   (iterator-next ,iterator))
+                 (unless ,validp (terminate))
+                 (setf (first ,result-template) ,tmp-key
+                       (second ,result-template) ,tmp-val)
+                 ,result-template))))))
+
+(defmacro-driver (for key :in-fdatatype-keys container)
+  (let ((kwd (if generate 'generate 'for)))
+    `(progn
+       (,kwd (,key _) :in-fdatatype ,container))))
+
+(defmacro-driver (for val :in-fdatatype-vals container)
+  (let ((kwd (if generate 'generate 'for)))
+    `(progn
+       (,kwd (_ ,val) :in-fdatatype ,container))))
+
+(defmacro-driver (for val :in-fvec fvec)
+  (let ((kwd (if generate 'generate 'for)))
+    `(progn
+       (,kwd ,val :in-fdatatype-vals (the fvec ,fvec)))))
+
+(defmacro-driver (for key :in-fset fset)
+  (let ((kwd (if generate 'generate 'for)))
+    `(progn
+       (,kwd ,key :in-fdatatype-keys (the fset ,fset)))))
+
+(defmacro-driver (for key/val :in-ftab ftab)
+  (let ((kwd (if generate 'generate 'for)))
+    `(progn
+       (,kwd ,key/val :in-fdatatype (the ftab ,ftab)))))

x.fdatatypes-iterate/package.lisp

@@ -0,0 +1,51 @@
+(in-package :x.fdatatypes)
+
+(defpackage :x.fdatatypes-iterate
+  (:use :cl :iterate :x.fdatatypes))
+
+;; This package does not export anything in itself,
+;; it uses x.fdatatypes:iterator and x.fdatatypes:iterator-next
+;; function to create iterate drivers.
+;;
+;; These iterate drivers also support iterate generators, when the key, value or both
+;; are updated on demand with (next key) ;; or (next val) 
+;; in iterate loop.
+;;
+;; Wildcards '_' can be used instead of key or val when they are not needed
+;;
+;; Iterate's drivers are recognized by keywords, and x.fdatatype's iterate
+;; drivers are:
+;;
+;; ------------------------
+;; :IN-FDATATYPE
+;; ex: (iter (for (key val) :in-fdatatype ftab/fset/fvec) ;; or instead 'for' - 'generate'
+;;
+;; ------------------------
+;; :IN-FDATATYPE-KEYS
+;; ex: (iter (for key :in-fdatatype-keys ftab/fset/fvec) ;; or instead 'for' - 'generate'
+;;
+;; for fvec, it's key is it's index
+;;
+;; ------------------------
+;; :IN-FDATATYPE-VALS
+;; ex: (iter (for val :in-fdatatype-vals ftab/fset/fvec) ;; or instead 'for' - 'generate'
+;;
+;; for fset, it's value it always T
+;;
+;; ------------------------
+;; :IN-FVEC
+;; ex: (iter (for val :in-fvec fvec) ;; or instead 'for' - 'generate'
+;;
+;; ------------------------
+;; :IN-FSET
+;; ex: (iter (for key :in-fset fset) ;; or instead 'for' - 'generate'
+;;
+;; ------------------------
+;; :IN-FTAB
+;; ex: (iter (for (key val) :in-ftab ftab) ;; or instead 'for' - 'generate'
+;;
+;;
+;; Drivers :IN-FVEC, :IN-FSET and :IN-FTAB accepts only fvec, respectively fset and ftab,
+;; or fail otherwise.
+;;
+;; With :IN-FDATATYPE, :IN-FDATATYPE-KEYS and :IN-FDATATYPE-VALS any x.fdatatype can be used.

x.fdatatypes.asd

@@ -3,12 +3,14 @@
 (asdf:defsystem :x.fdatatypes
   :depends-on (:x.let-star)
   :serial t
-  :components ((:file "package")
-               (:file "common")
-               (:file "tab-ctx")
-               (:file "vec-ctx")
-               (:file "ftab")
-               (:file "fvec")
-               (:file "fset")
-               (:file "test")))
+  :components ((:module "x.fdatatypes"
+                :components ((:file "package")
+                             (:file "macros")
+                             (:file "common")
+                             (:file "tab-ctx")
+                             (:file "vec-ctx")
+                             (:file "ftab")
+                             (:file "fvec")
+                             (:file "fset")
+                             (:file "test")))))
 

common.lisp → x.fdatatypes/common.lisp

@@ -18,6 +18,9 @@
 (defgeneric fold (container function &key init from-end))
 (defgeneric filter (container predicate &key from-end))
 
+(defgeneric iterator (container))
+(defgeneric iterator-next (iterator))
+
 ;;;;;;;;;; INTERFACE TO FTAB, FVEC
 
 (defgeneric vals (container))
@@ -104,64 +107,6 @@
         (return-container-as-is ()
           container)))))
 
-(defun %reevaluate-constant (name value test)
-  (if (not (boundp name))
-      value
-      (let ((old (symbol-value name))
-            (new value))
-        (if (not (constantp name))
-            (prog1 new
-              (cerror "Try to redefine the variable as a constant."
-                      "~@<~S is an already bound non-constant variable ~
-                       whose value is ~S.~:@>" name old))
-            (if (funcall test old new)
-                old
-                (restart-case
-                    (error "~@<~S is an already defined constant whose value ~
-                              ~S is not equal to the provided initial value ~S ~
-                              under ~S.~:@>" name old new test)
-                  (ignore ()
-                    :report "Retain the current value."
-                    old)
-                  (continue ()
-                    :report "Try to redefine the constant."
-                    new)))))))
-
-(defmacro define-constant (name initial-value &key (test ''eql) documentation)
-  `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
-     ,@(when documentation `(,documentation))))
-
-(defun before-last (list)
-  (if (cddr list)
-      (before-last (cdr list))
-      list))
-
-(defmacro nconcing ((&key (init nil)
-                          (into 'nconc-result)
-                          (call 'nconc-it)
-                          (count nil)
-                          (last nil)
-                          (before-last nil))
-                    &body body)
-  (let ((head-sym (gensym "HEAD"))
-        (tail-sym (gensym "TAIL")))
-    `(let* ((,head-sym (cons nil ,init))
-            (,tail-sym (last ,head-sym))
-            (,into (cdr ,head-sym))
-            ,@(when count `((,count (length ,init))))
-            ,@(when last `((,last nil)))
-            ,@(when before-last `((,before-last (before-last ,init)))))
-       (flet ((,call (x)
-                ,@(when before-last
-                        `((setf ,before-last 
-                                (unless (eq ,head-sym ,tail-sym)
-                                  ,tail-sym))))
-                (rplacd ,tail-sym (setf ,tail-sym (list x)))
-                (setf ,into (cdr ,head-sym))
-                ,@(when last `((setf ,last ,tail-sym)))
-                ,@(when count `((incf ,count)))))
-         ,@body))))
-
 (defun nth-split (list n)
   (values (subseq list 0 n) (nthcdr n list)))
 
@@ -203,20 +148,20 @@
   (declare (shift shift) (fixnum hash))
   (logand (ash hash (- shift)) #x1f))
 
-(declaim (inline mask))
+(declaim (inline bit-position))
 (defun bit-position (hash shift)
   (declare (shift shift) (fixnum hash))
   (ash 1 (mask hash shift)))
 
-(declaim (inline mask))
+(declaim (inline shrink-clone-simple-vector))
 (defun shrink-clone-simple-vector (orig index)
   (declare (simple-vector orig) (fixnum-1 index))
   (let* ((new (make-array (1- (length orig)))))
     (replace new orig :end1 index)
     (replace new orig :start1 index :start2 (1+ index))
     new))
 
-(declaim (inline mask))
+(declaim (inline expand-clone-simple-vector))
 (defun expand-clone-simple-vector (orig index value)
   (declare (simple-vector orig) (fixnum-1 index))
   (let* ((new (make-array (1+ (length orig)))))

fset.lisp → x.fdatatypes/fset.lisp

@@ -185,12 +185,25 @@
           x
           (%make-fset :tab-ctx new-tab-ctx)))))
 
+(defmethod iterator ((x fset))
+  (tab-ctx-iterator (fset-tab-ctx x)))
 
 ;;;;;;;;;; FSET COMMON UTILS
 
+(defmethod sequence-fset ((xs sequence) &key (key-test #'equal) (hash-fun #'sxhash))
+  (let ((result (fset-ex :key-test key-test
+                         :hash-fun hash-fun)))
+    (map nil (lambda (x)
+               (setf result (add-key result x)))
+         xs)
+    result))
+
 (defmethod fset-list ((x fset))
   (fmap-to 'list x #'identity))
 
+(defmethod fset-vector ((x fset))
+  (fmap-to 'simple-vector x #'identity))
+
 (defmethod fset-difference ((x fset) &rest fsets)
   (labels ((difference-1 (fset-1 fset-2)
              (filter fset-1 (lambda (key) (has-key fset-2 key)))))

ftab.lisp → x.fdatatypes/ftab.lisp

@@ -170,6 +170,9 @@
           x
           (%make-ftab :tab-ctx new-tab-ctx)))))
 
+(defmethod iterator ((x ftab))
+  (tab-ctx-iterator (ftab-tab-ctx x)))
+
 ;;;;;;;;;; FTAB COMMON UTILS
 
 (defmethod ftab-alist ((x ftab))

fvec.lisp → x.fdatatypes/fvec.lisp

@@ -164,6 +164,9 @@
           (setf res-ctx (vec-ctx-del-tail res-ctx)))
         (%make-fvec :vec-ctx res-ctx))))
 
+(defmethod iterator ((x fvec))
+  (vec-ctx-iterator (fvec-vec-ctx x)))
+
 ;;;;;;;;;; FVEC COMMON UTILS
 
 (defmethod fvec-iota (n &key (start 0) (step 1))

x.fdatatypes/macros.lisp

@@ -0,0 +1,56 @@
+(in-package :x.fdatatypes)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (defun %reevaluate-constant (name value test)
+    (if (not (boundp name))
+        value
+        (let ((old (symbol-value name))
+              (new value))
+          (if (not (constantp name))
+              (prog1 new
+                (cerror "Try to redefine the variable as a constant."
+                        "~@<~S is an already bound non-constant variable ~
+                       whose value is ~S.~:@>" name old))
+              (if (funcall test old new)
+                  old
+                  (restart-case
+                      (error "~@<~S is an already defined constant whose value ~
+                              ~S is not equal to the provided initial value ~S ~
+                              under ~S.~:@>" name old new test)
+                    (ignore ()
+                      :report "Retain the current value."
+                      old)
+                    (continue ()
+                      :report "Try to redefine the constant."
+                      new))))))))
+
+(defmacro define-constant (name initial-value &key (test ''eql) documentation)
+  `(defconstant ,name (%reevaluate-constant ',name ,initial-value ,test)
+     ,@(when documentation `(,documentation))))
+
+(defmacro nconcing ((&key (init nil)
+                          (into 'nconc-result)
+                          (call 'nconc-it)
+                          (count nil)
+                          (last nil)
+                          (before-last nil))
+                    &body body)
+  (let ((head-sym (gensym "HEAD"))
+        (tail-sym (gensym "TAIL")))
+    `(let* ((,head-sym (cons nil ,init))
+            (,tail-sym (last ,head-sym))
+            (,into (cdr ,head-sym))
+            ,@(when count `((,count (length ,init))))
+            ,@(when last `((,last nil)))
+            ,@(when before-last `((,before-last (last ,init 2)))))
+       (flet ((,call (x)
+                ,@(when before-last
+                        `((setf ,before-last 
+                                (unless (eq ,head-sym ,tail-sym)
+                                  ,tail-sym))))
+                (rplacd ,tail-sym (setf ,tail-sym (list x)))
+                (setf ,into (cdr ,head-sym))
+                ,@(when last `((setf ,last ,tail-sym)))
+                ,@(when count `((incf ,count)))))
+         ,@body))))
+

package.lisp → x.fdatatypes/package.lisp

@@ -8,7 +8,9 @@
    "FSET"             ;; constructor
    "FSET-EX"          ;; constructor
    "COERCE-FSET"      ;; converts data type to fset
+   "SEQUENCE-FSET"    ;; converts sequence to fset
    "FSET-LIST"        ;; converts fset to list
+   "FSET-VECTOR"      ;; converts fset to vector
    "FSET-DIFFERENCE"  ;; fset difference
    "FSET-EXCLUSIVE-OR";; fset exlusive or
    "FSET-UNION"       ;; fset union
@@ -58,6 +60,8 @@
    "FMAP-TO"          ;; maps function over container, returns type supplied as argument (nil, list, vector, bit-vector, ...)
    "FOLD"             ;; fold function over container
    "FILTER"           ;; filter function over container, returns new container
+   "ITERATOR"         ;; gets iterator of the container
+   "ITERATOR-NEXT"    ;; advances iterator, returns (values next-iterator key val validp)
    ))