new file mode 100644

@@ -0,0 +1,6 @@

+(in-package #:fwoar.lisputils)

+

+(defmacro with-accessors* ((&rest accessors) object &body body)

+  `(with-accessors ,(ensure-mapping accessors) ,object

+     ,@body))

+       

new file mode 100644

@@ -0,0 +1,55 @@

+(defpackage :fwoar.counter

+  (:use :cl))

+

+(in-package :fwoar.counter)

+

+(defclass counter ()

+  ((%counts :type hash-table :accessor item-counts)

+   (%test :initarg :test :initform 'eql :accessor counter-test)

+   (%key :initarg :key :initform 'identity :accessor counter-key)))

+

+(defmethod initialize-instance :after ((counter counter) &rest initargs &key test)

+  (declare (ignorable initargs))

+  (setf (item-counts counter) (make-hash-table :test test)))

+

+(defgeneric count-sequence (sequence &key test key)

+  (:documentation "take a sequence, count it using test to compare elements and key to extract values from them"))

+

+(defgeneric update-counts (counter sequence)

+  (:documentation "given a sequence, update a counter"))

+

+(defgeneric extract-count (counter item)

+  (:documentation "Given a counter and an item, return the number of times that item has been counted."))

+

+(defgeneric format-counts (counter stream)

+  (:documentation "Given a counter and a stream, format the counter's counts to that stream"))

+

+(defmethod extract-count ((counter counter) item)

+  (gethash (funcall (counter-key counter)

+                    item)

+           (item-counts counter)

+           0))

+

+(defmethod count-sequence ((sequence string) &key (test 'eql) (key 'identity))

+  (let ((result (make-instance 'counter :test test :key key)))

+    (loop for c across sequence

+          do (incf (gethash (funcall key c)

+                            (item-counts result)

+                            0))

+          finally (return result))))

+

+(defmethod format-counts ((counter counter) (stream stream))

+  (let ((result '()))

+    (maphash (lambda (key val)

+               (push (list key val)

+                     result))

+             (item-counts counter))

+    (format t "~:{~s: ~2d~%~}"

+            (stable-sort result #'< :key #'cadr))))

+

+(defmethod update-counts ((counter counter) sequence)

+  (with-accessors ((item-counts item-counts) (test counter-test) (key counter-key)) counter

+    (maphash (lambda (key value)

+               (incf (gethash key item-counts 0)

+                     value))

+             (item-counts (count-sequence sequence :test test :key key)))))

@@ -6,6 +6,16 @@

   :license "MIT"

   :serial t

   :components ((:file "package")

-               (:file "fwoar.lisputils"))

-  :depends-on (#:anaphora #:alexandria #:iterate #:plump))

+               (:file "fwoar.lisputils")

+	       (:file "hash-functions")

+	       (:file "multiple-values")

+	       (:file "clos-helpers")

+	       (:file "vector-utils"))

+  :depends-on (#:anaphora

+	       #:alexandria

+	       #:serapeum

+	       #:cl-containers

+	       #:iterate

+	       #:plump

+	       #:positional-lambda))

@@ -48,55 +48,96 @@

      ,@body))

 (eval-when (:compile-toplevel :load-toplevel :execute)

+  (defun map-cons (cb cons)

+    (cond

+      ((null cons) '())

+      ((consp (cdr cons)) (cons (funcall cb (car cons))

+				(map-cons cb (cdr cons))))

+      (t (list (funcall cb (car cons))

+	       (funcall cb (cdr cons))))))

+

+  (defun generate-declarations-for (sym ignored ignorable)

+    (let ((ignores (list))

+	  (ignorables (list)))

+      (map-cons (op (cond ((member _1 ignorable)

+			   (push _1 ignorables))

+			  ((member _1 ignored)

+			   (push _1 ignores))))

+		(ensure-cons sym))

+      (if (or ignores ignorables)

+	  `((declare

+	     ,@(when ignores

+		 `((ignore ,@ignores)))

+	     ,@(when ignorables

+		 `((ignorable ,@ignorables)))))

+	  '())))

+

+  (defun find-ignored-vars (body)

+    (let ((possible-declarations (car body))

+	  (ignored-vars nil)

+	  (ignorable-vars nil))

+      (if (and (eq (car possible-declarations) 'declare)

+	       (consp (cadr possible-declarations)))

+	  (let* ((declarations (cdr possible-declarations)))

+	    (setf ignored-vars (cdr (assoc 'ignore declarations))

+		  ignorable-vars (cdr (assoc 'ignorable declarations))

+		  body (cdr body))))

+      (values ignored-vars

+	      ignorable-vars

+	      body)))

+

   (defun ensure-mapping (list)

     "Take a list and make sure that it's parseable as a let-style binding.

      Very handy for certain sorts of macros."

     (let ((symbols->mappings (lambda-cond (x)

-                               ((symbolp x) `(,x ,x))

-                               ((null (cdr x)) `(,#1=(car x) ,#1#))

-                               (t x))))

+					  ((symbolp x) `(,x ,x))

+					  ((null (cdr x)) `(,#1=(car x) ,#1#))

+					  (t x))))

       (mapcar symbols->mappings list)))

-    (defun rollup-list (list &optional body)

-      (labels ((helper (list &optional accum start)

-                 (tagbody

-                   start

-                   (cond

-                     ((endp list) (return-from rollup-list accum))

-                     (t (psetf accum  (cond

-                                        ((null accum) (car list))

-                                        (start `(,@(car list) ,@accum)) 

-                                        (t `(,@(car list) ,accum)))

-                               list (cdr list)

-                               start nil)

-                        ;; NOTE: REMEMBER! This call to #'GO is the "tail call"

-                        (go start))))))

-        (helper (reverse list) body t))))

+  (defun rollup-list (list &optional body)

+    (labels ((helper (list &optional accum start)

+	       (tagbody

+		start

+		  (cond

+		    ((endp list) (return-from rollup-list accum))

+		    (t (psetf accum  (cond

+				       ((null accum) (car list))

+				       (start `(,@(car list) ,@accum)) 

+				       (t `(,@(car list) ,accum)))

+			      list (cdr list)

+			      start nil)

+		       ;; NOTE: REMEMBER! This call to #'GO is the "tail call"

+		       (go start))))))

+      (helper (reverse list) body t))))

 (defmacro m-lambda (sym &rest args)

   (let ((arglist (loop for x in args

-                       unless (member x (list '&optional '&key '&rest))

-                       collect (ctypecase x

-                                          (cons                  (car x))

-                                          ((or symbol keyword string) x)))))

+		       unless (member x (list '&optional '&key '&rest))

+		       collect (ctypecase x

+					  (cons                  (car x))

+					  ((or symbol keyword string) x)))))

     `(lambda (,@args)

        (,sym ,@arglist))))

 (defmacro destructuring-lambda ((&rest args) &body body)

   "A lambda whose arguments can be lambda-lists to be destructured"

-  (let* ((args-syms (mapcar (alambda (gensym "arg"))

-                            args))

-         (args (mapcar #'list args args-syms))

-         (destructuring-expressions

-           (rollup-list

-               (loop for (arg arg-sym) in args

-                     collect (if (consp arg)

-                               `(destructuring-bind ,arg ,arg-sym)

-                               `(let ((,arg ,arg-sym)))))

-               body)))

-    `(lambda ,args-syms

-       ,destructuring-expressions)))

+  (multiple-value-bind (ignored ignorable body) (find-ignored-vars body)

+    (let* ((args-syms (mapcar (lambda (_) (declare (ignore _)) (gensym "arg"))

+			      args))

+	   (args (mapcar #'list args args-syms))

+	   (destructuring-expressions

+	    (rollup-list

+	     (loop for (arg arg-sym) in args

+		collect (if (consp arg)

+			    `(destructuring-bind ,arg ,arg-sym

+			       ,@(generate-declarations-for arg ignored ignorable))

+			    `(let ((,arg ,arg-sym))

+			       ,@(generate-declarations-for arg ignored ignorable))))

+	     body)))

+      `(lambda ,args-syms

+	 ,destructuring-expressions))))

 ;;; CASES:::

@@ -190,9 +231,37 @@

   "Make setf a bit nicer to use with paredit"

   (list* 'setf (apply #'append body)))

+(defmacro prog2-let (first-form (&rest result-binding) &body body)

+  "Execute a form, make a bunch of bindings and retern the bound values via prog1 after executing body"

+  `(progn ,first-form

+	  (let (,@result-binding)

+	    (prog1 (list ,@(mapcar #'car result-binding))

+	      ,@body))))

+

 (defmacro prog1-let ((&rest result-binding) &body body)

+  "Bind a bunch of symbols to values and return them via prog1"

   `(let (,@result-binding)

      (prog1 (list ,@(mapcar #'car result-binding))

        ,@body)))

+(defmacro if-let* ((&rest bindings) &body (then-form &optional else-form))

+  "Like if-let, but sets bindings sequentially.  Doesn't short-circuit."

+  `(let* ,bindings

+     (if (and ,@(mapcar #'car bindings))

+       ,then-form

+       ,else-form)))

+

+(defmacro with ((var val) &body body)

+  "A stripped down let for binding a single name"

+  `(let ((,var ,val))

+     ,@body))

+

+(define-modify-macro aconsf (key datum)

+  (lambda (alist key datum)

+    (acons key datum alist)))

+

+;(defun ensure-list (val)

+;  (typecase val

+;    (list val)

+;    (t (list val))))

new file mode 100644

@@ -0,0 +1,6 @@

+(in-package #:fwoar.lisputils)

+

+(defun pick (keys h-t)

+  (mapcar (plambda:plambda (gethash :1 h-t))

+          keys))

+

new file mode 100644

@@ -0,0 +1,31 @@

+(in-package :fwoar.lisputils)

+

+;; (multiple-value-call #'local-time:encode-timestamp

+;;   (limit-values 7

+;;                 (substitute-values 0 0 0 1

+;;                                    (local-time:decode-timestamp

+;;                                      (local-time:now)))))

+

+(defmacro skip-values (n form)

+  (let* ((gensyms (loop repeat n collect (gensym "V")))

+	 (ignore-sym (gensym))

+	 (value-limiter `(lambda (,@gensyms &rest ,ignore-sym)

+			   (declare (ignore ,@gensyms))

+			   (values-list ,ignore-sym))))

+    `(multiple-value-call ,value-limiter ,form)))

+

+(defmacro limit-values (n form)

+  (let* ((gensyms (loop repeat n collect (gensym "V")))

+	 (ignore-sym (gensym))

+	 (value-limiter `(lambda (,@gensyms &rest ,ignore-sym)

+			   (declare (ignore ,ignore-sym))

+			   (values ,@gensyms))))

+    `(multiple-value-call ,value-limiter ,form)))

+

+(defmacro substitute-values (&rest forms)

+  (let* ((call (car (last forms)))

+	 (values (butlast forms))

+	 (num-values (length values)))

+    `(multiple-value-call #'values

+       ,@values

+       (skip-values ,num-values ,call))))

@@ -3,6 +3,7 @@

 (defpackage #:fwoar.lisputils

   (:use #:cl #:alexandria #:iterate)

   (:nicknames #:fw.lu)

+  (:import-from #:serapeum #:op)

   (:export #:lambda-if #:lambda-cond #:alambda #:rollup-list

            #:ensure-mapping #:alist-string-hash-table #:make-pairs

            #:copy-slots #:transform-alist #:%json-pair-transform

@@ -10,5 +11,8 @@

            #:transform-result #:slots-to-pairs #:normalize-html

            #:destructuring-lambda #:let-each #:let-first #:let-second

            #:neither #:neither-null #:m-lambda #:sets #:defparameters

-           #:setfs #:prog1-let))

+           #:setfs #:prog1-let #:if-let* #:with #:aconsf #:ensure-list #:pick

+	   #:vector-destructuring-bind #:with-accessors*

+	   #:skip-values #:limit-values #:substitute-values

+	   #:op))

new file mode 100644

@@ -0,0 +1,42 @@

+(in-package #:fwoar.lisputils)

+

+(defmacro vector-destructuring-bind ((&rest symbols) vector &body body)

+  (let ((mappings (loop for symbol in symbols

+		     for num from 0

+		     collect (list num symbol))))

+    (once-only (vector)

+      `(symbol-macrolet ,(mapcar (destructuring-lambda ((num symbol))

+				   `(,symbol (aref ,vector ,num)))

+				 mappings)

+	 ,@body))))

+

+(defun v-first (vector)

+  (elt vector 0))

+

+(defun index-table (table &key (test 'eql) (key 'v-first))

+  (declare (optimize (speed 0) (debug 3)))

+  (check-type table (array * (* *)))

+  (let ((table-index (cl-containers:make-container 'cl-containers:simple-associative-container :test test)))

+    (loop for row-num from 0 to (1- (array-dimension table 0))

+       for current-row = (make-array (array-dimension table 1)

+				     :displaced-to table

+				     :displaced-index-offset (apply #'array-row-major-index table (list row-num 0)))

+       do (setf (cl-containers:item-at table-index (funcall key current-row)) row-num))

+    table-index))

+

+(defun join-tables (table1 table2 &key (test 'eql) (key1 'v-first) (key2 'v-first))

+  (declare (optimize (speed 0) (debug 3)))

+  (check-type table1 (array * (* *)))

+  (check-type table2 (array * (* *)))

+  (let ((table2-index (index-table table2 :test test :key key2)))

+    (loop for row-num from 0 to (1- (array-dimension table1 0))

+       for current-row = (make-array (array-dimension table1 1)

+				     :displaced-to table1

+				     :displaced-index-offset (apply #'array-row-major-index table1 (list row-num 0)))

+       for dest-index = (cl-containers:item-at table2-index (funcall key1 current-row))

+       when dest-index

+       collect (let* ((to-row (make-array (array-dimension table2 1)

+					  :displaced-to table2

+					  :displaced-index-offset (apply #'array-row-major-index table2 (list dest-index 0)))))

+		 (concatenate 'vector current-row to-row)))))

+