(in-package :data-lens)
 

 (declaim

  (inline data-lens:over data-lens:transform-tail
          data-lens:applicable-when data-lens:of-min-length
          data-lens:on data-lens:over data-lens:slice
          data-lens:compress-runs data-lens:combine-matching-lists
          data-lens:juxt data-lens:element data-lens:sorted))

 (defgeneric functionalize (it)
   (:method ((it hash-table))
     (lambda (key &optional default)
       (gethash key it default)))
   (:method ((it vector))
     (lambda (idx &optional default)
       (let ((present-p (and (>= idx 0)
                             (< idx (length it)))))
         (values (if present-p
                     (aref it idx)
                     default)
                 present-p))))
   (:method ((it symbol))
     (fdefinition it))
   (:method ((it function))
     it))
 

 (define-compiler-macro functionalize (&whole whole it)
   (typecase it
     (cons (destructuring-bind (h . tail) it
             (declare (ignore tail))
             (case h
               (quote it)
               (function it)
               (t whole))))
     (t whole)))
 

 ;;; TODO: consider making this wrap defalias?

 (defmacro shortcut (name function &body bound-args)
   `(eval-when (:load-toplevel :compile-toplevel :execute)
      (setf (fdefinition ',name)
            (,function ,@bound-args))))
 
 (defmacro defun-ct (name (&rest args) &body body)
   `(eval-when (:load-toplevel :compile-toplevel :execute)
      (defun ,name ,args
        ,@body)))
 

 (defmacro let-fn ((&rest bindings) &body body)
   (let ((binding-forms (mapcar (lambda (form)
                                  `(,(car form) ,(cadr form)

                                    (funcall ,@(cddr form) ,@(cadr form))))

                                bindings)))
     `(labels ,binding-forms
        ,@body)))
 
 (defgeneric extract-key (map key)
   (:method ((map hash-table) key)
     (gethash key map))
   (:method ((map list) key)
     (typecase (car map)
       (cons (cdr (assoc key map :test 'equal)))
       (t (loop for (a-key . value) on map by #'cddr

                when (equal key a-key) do
                  (return (car value)))))))

 (defun == (target &key (test 'eql))

   (lambda (v)
     (funcall test target v)))
 

 (defun deduplicate (&optional (test 'eql))

   (lambda (it)
     (remove-duplicates it :test test)))
 
 (defun cons-new (&key (test 'eql) (key 'identity))
   (lambda (acc next)
     (if (and acc
              (funcall test
                       (funcall key (car acc))
                       (funcall key next)))
         acc
         (cons next acc))))
 

 (defun matching-list-reducer (test acc next)
   (if (and acc
            (funcall test (caar acc) (car next)))
       (cons (cons (caar acc)
                   (append (cdar acc)
                           (cdr next)))
             (cdr acc))
       (cons next acc)))
 

 (defun combine-matching-lists (&key (test 'eql) &allow-other-keys)
   (lambda (acc next)

     (matching-list-reducer test acc next)))

 (defun compress-runs (&key (collector 'cons-new) (test 'eql) (key 'identity))

   (lambda (it)
     (nreverse
      (reduce (funcall collector :test test :key key)
              it
              :initial-value ()))))
 

 (defun of-length (len)

   (lambda (it)
     (= (length it)
        len)))
 

 (defun of-min-length (len)

   (lambda (it)
     (>= (length it)
         len)))
 

 (defun of-max-length (len)

   (lambda (it)

     (<= (length it)

         len)))
 

 (defun applicable-when (fun test &optional (default nil default-p))
   (if default-p
       (lambda (it)
         (if (funcall test it)
             (funcall fun it)
             default))
       (lambda (it)
         (if (funcall test it)
             (funcall fun it)
             it))))

 (defmacro conj (&rest fns)
   (let ((dat (gensym "dat")))
     `(lambda (,dat)

        (declare (ignorable ,dat))

        (and ,@(mapcar (lambda (fn)
                         `(funcall ,fn ,dat))
                       fns)))))
 
 (defmacro disj (&rest fns)
   (let ((dat (gensym "dat")))
     `(lambda (,dat)

        (declare (ignorable ,dat))

        (or ,@(mapcar (lambda (fn)
                        `(funcall ,fn ,dat))
                      fns)))))
 
 

 (defun sorted (comparator &rest r &key key)

   (declare (ignore key))
   (lambda (it)

     (apply #'stable-sort (copy-seq it) comparator r)))

 (defun element (num)

   (lambda (it)
     (elt it num)))
 

 (defun key (key)

   (lambda (map)
     (declare (dynamic-extent map))
     (extract-key map key)))
 

 (defun keys (key &rest keys)
   (lambda (map)
     (loop for key in (cons key keys)
           for cur = (extract-key map key) then (extract-key cur key)
           finally (return cur))))
 

 (defun regex-match (regex)

   (lambda (data)
     (cl-ppcre:scan-to-strings regex data)))
 

 (defun include (pred)

   (lambda (seq)
     (remove-if-not pred seq)))
 

 (defun exclude (pred)

   (lambda (seq)
     (remove-if pred seq)))
 

 (defun pick (selector)

   (lambda (seq)
     (map 'list selector seq)))
 

 (defun tap (cb)
   (lambda (it)
     (prog1 it
       (funcall cb it))))
 

 (defun slice (start &optional end)
   (lambda (it)
     (subseq it start end)))
 

 (defun update (thing fun &rest args)

   (apply fun thing args))
 
 (define-modify-macro updatef (fun &rest args)
   update)
 

 (defun suffixp (suffix &key (test 'eql test-p))

   (lambda (it)
     (if test-p
         (alexandria:ends-with-subseq suffix
                                      it
                                      :test test)
         (alexandria:ends-with-subseq suffix
                                      it))))
 

 (defun of-type (type)
   (lambda (it)
     (when (typep it type)
       it)))
 

 (defun transform-head (fun)

   (lambda (it)

     (typecase it
       (list (list* (funcall fun (car it))
                    (cdr it)))
       (vector (let ((result (copy-seq it)))
                 (prog1 result
                   (updatef (elt result 0) fun)))))))

 (defun transform-tail (fun)

   (lambda (it)

     (typecase it
       (list (list* (car it)
                    (funcall fun (cdr it))))
       (vector (let ((result (copy-seq it)))
                 (prog1 result
                   (updatef (subseq result 1)
                            fun)))))))

 (defun splice-elt (elt fun)

   (lambda (it)
     (append (subseq it 0 elt)
             (funcall fun (nth elt it))
             (subseq it (1+ elt)))))
 

 (defun transform-elt (elt fun)

   (lambda (it)

     (concatenate (type-of it)
                  (subseq it 0 elt)
                  (list (funcall fun (elt it elt)))
                  (subseq it (1+ elt)))))

 (defun key-transform (fun key-get key-set)

   (lambda (it)
     (let ((key-val (funcall key-get it)))
       (funcall key-set
                (funcall fun key-val)))))
 

 (defun juxt (fun1 &rest r)

   (lambda (&rest args)
     (list* (apply fun1 args)
            (when r
              (mapcar (lambda (f)
                        (apply f args))
                      r)))))

 (defun delay ()
   "Return a function that always returns the last thing it was called with"
   (let ((result nil))
     (lambda (v)
       (prog1 result
         (setf result v)))))
 

 (defun =>> (fun1 fun2)
   (lambda (i)
     (prog1 (funcall fun1 i)
       (funcall fun2))))
 

 (defun derive (diff-fun &key (key #'identity))

   (lambda (seq)
     (typecase seq
       (list (cons (cons nil (car seq))
                   (mapcar (lambda (next cur)
                             (cons (funcall diff-fun
                                            (funcall key next)
                                            (funcall key  cur))
                                   next))
                           (cdr seq)
                           seq)))
       (vector (coerce (loop for cur = nil then next
                             for next across seq
                             if cur
                               collect (cons (funcall diff-fun
                                                      (funcall key next)
                                                      (funcall key cur))
                                             cur)
                             else collect (cons nil next))
                       'vector)))))

 (defun inc (inc)

   (declare (optimize (speed 3)))
   (lambda (base)
     (+ base inc)))
 

 (defun cumsum

     (&key (add-fun #'+) (key #'identity) (combine (lambda (x y) y x)) (zero 0))

   (lambda (seq)
     (nreverse
      (reduce (lambda (accum next)
                (let ((key-val (funcall key next))
                      (old-val (if accum
                                   (funcall key (car accum))
                                   zero)))
                  (cons (funcall combine
                                 (funcall add-fun old-val key-val)
                                 next)
                        accum)))
              seq
              :initial-value ()))))
 

 (defun over (fun &rest funs)
   (let* ((fun (functionalize fun))
          (rt-pos (position :result-type funs))
          (result-type (cond
                         ((null rt-pos) 'list)
                         ((>= (1+ rt-pos)
                              (length funs))
                          (error "invalid result-type"))
                         (t
                          (elt funs (1+ rt-pos)))))
          (funs (if rt-pos
                    (append (mapcar #'functionalize
                                    (subseq funs 0 rt-pos))
                            (mapcar #'functionalize
                                    (subseq funs (+ rt-pos 2))))
                    (mapcar #'functionalize funs)))
          (combined-fun (if funs
                            (apply #'alexandria:compose fun funs)
                            fun)))
     (lambda (seq &rest seqs)
       (if seqs
           (apply #'map result-type combined-fun seq seqs)
           (map result-type combined-fun seq)))))

 (defun denest (&key (result-type 'list))

   (lambda (seq)
     (apply #'concatenate result-type
            seq)))
 

 (defun transform (arg &rest args)
   (if args
       (lambda (fn)
         (apply fn arg args))
       (lambda (fn)
         (funcall fn arg))))
 

 (defmacro calling (fun &rest args)
   (alexandria:with-gensyms (first-arg)
     `(lambda (,first-arg)
        (funcall (functionalize ,fun) ,first-arg ,@args))))
 

 (defmacro calling* (fun &rest args)
   (alexandria:with-gensyms (last-arg)
     `(lambda (,last-arg)
        (funcall (functionalize ,fun) ,@args ,last-arg))))
 

 (defmacro applying (fun &rest args)

   (alexandria:with-gensyms (seq fsym)
     `(let ((,fsym (functionalize ,fun)))
        (lambda (,seq)
          (apply ,fsym ,@args ,seq)))))

 (defun on (fun key)

   "Transform arguments with KEY and then apply FUN
 
 > (eql (funcall (on 'equal 'car)
 >          '(\"a\" 1 2)
 >          '(\"a\" 2 e))
 >      t)"

   (let ((fun (functionalize fun))
         (key (functionalize key)))

     (lambda (&rest its)

       (apply fun (mapcar key its)))))

 
 (defun filler (length1 length2 fill-value)
   (if (< length1 length2)
       (make-sequence 'vector (- length2 length1) :initial-element fill-value)
       #()))
 

 (defun zipping (result-type &key (fill-value nil fill-value-p))

   (lambda (seq1 seq2)
     (let ((length1 (when fill-value-p (length seq1)))
           (length2 (when fill-value-p (length seq2))))
       (let ((seq1 (if fill-value-p
                       (concatenate result-type
                                    seq1
                                    (filler length1 length2 fill-value))
                       seq1))
             (seq2 (if fill-value-p
                       (concatenate result-type
                                    seq2
                                    (filler length2 length1 fill-value))
                       seq2)))
         (map result-type #'list
              seq1 seq2)))))
 

 (defun maximizing (relation measure)

   (lambda (it)
     (let ((it-length (length it)))
       (when (> it-length 0)
         (values-list

          (reduce (lambda (|arg1764| |arg1765|)
                    (destructuring-bind (cur-max max-idx) |arg1764|
                      (destructuring-bind (next next-idx) |arg1765|
                        (if (funcall relation (funcall measure cur-max) (funcall measure next))
                            (list next next-idx)
                            (list cur-max max-idx)))))

                  (funcall (zipping 'vector)
                           it
                           (alexandria:iota it-length))))))))

 (defun group-by (fn &key (test 'equal))

   (lambda (seq)
     (let ((groups (make-hash-table :test test)))
       (map nil
            (lambda (it)
              (push it
                    (gethash (funcall fn it)
                             groups)))
            seq)
       (mapcar (lambda (it)
                 (cons (car it)
                       (reverse (cdr it))))
               (alexandria:hash-table-alist groups)))))
 

 (defun x-group (fn)
   (lambda (groups)
     (loop for (key . group) in groups
           collect (funcall fn key group))))
 

 (defun hash-join (probe join-fn &key (test 'eql) (key 'car))
   (let* ((lookup (make-hash-table :test test :size (length probe)))
          (lookup-fn (functionalize lookup)))
     (map nil
          (lambda (it)
            (setf (gethash (funcall key it)
                           lookup)
                  it))
          probe)
     (lambda (collection)
       (map (etypecase collection
              (list 'list)
              (vector 'vector)
              (sequence 'list))
            (lambda (it)
              (let* ((key-value (funcall key it))
                     (matching-probe (funcall lookup-fn key-value)))
                (funcall join-fn it matching-probe)))
            collection))))
 

 #+nil

 (defmacro <> (arity &rest funs)
   (let ((arg-syms (loop repeat arity collect (gensym))))
     `(lambda (,@arg-syms)
        (declare (dynamic-extent ,@arg-syms))
        ,(fw.lu:rollup-list (mapcar (lambda (x)
                                      (etypecase x
                                        (list `(funcall ,x))
                                        (symbol (list x))))
                                    funs)
                            arg-syms))))
 
 (defmacro <>1 (&rest funs)

   `(alexandria:compose ,@funs))

 (defmacro • (&rest funs)

     `(alexandria:compose ,@funs))
 (defmacro ∘ (&rest funs)

   `(alexandria:compose ,@funs))