;;; general utils
(defpackage :utils
  (:use :cl)
  (:export :append1 :conc1f :group :abbrev :abbrevs :mvbind :dbind
           :it :with-gensyms :aif :aif2 :acond2 :compose :transpose
           :chain-call
           :curry :rcurry
           :pop1 :perm :c-prod
           :mkstr :symb
           :bits-to-int :int-to-bits))

#+clisp
(unuse-package :ext)


(in-package utils)

(defun append1 (lst &rest args)
  (append lst args))

(defun last1 (lst)
  (car (last lst)))

(define-modify-macro conc1f (obj)
  (lambda (place obj)
    (nconc place (list obj))))

(defun group (n lst)
  (labels ((rec (l acc)
             (let ((rest (nthcdr n l)))
               (if (null rest)
                 (cons l acc)
                 (rec rest
                      (cons (subseq l 0 n)
                            acc))))))
    (if (<= n 0)
      nil
      (nreverse (rec lst nil)))))

(defmacro abbrev (short long)
  `(defmacro ,short (&rest args)
     `(,',long ,@args)))

(defmacro abbrevs (&rest args)
  `(progn
     ,@(mapcar (lambda (pair) `(abbrev ,@pair))
               (group 2 args))))

(abbrevs
  dbind destructuring-bind
  mvbind multiple-value-bind)

(defun curry (fn &rest args)
  (lambda (&rest args2)
    (apply fn (append args args2))))

(defun rcurry (fn &rest args)
  (lambda (&rest args2)
    (apply fn (append args2 args))))

(defmacro with-gensyms (syms &body body)
  `(let ,(mapcar (lambda (s) `(,s (gensym)))
                 syms)
     ,@body))

(defmacro aif (test then &optional else)
  `(let ((it ,test))
     (if it ,then ,else)))

(defmacro aif2 (test then &optional else)
  (let ((win (gensym)))
    `(mvbind (it ,win) ,test
       (if (or it ,win) ,then ,else))))

(defmacro acond2 (&rest clauses)
  (if (null clauses)
    nil
    (let ((cl1 (car clauses))
          (val (gensym))
          (win (gensym)))
      `(mvbind (,val ,win) ,(car cl1)
         (if (or ,val ,win)
           (let ((it ,val)) ,@(cdr cl1))
           (acond2 ,@(cdr clauses)))))))

(defun compose (&rest fns)
  (if fns
    (lambda (&rest args)
      (reduce #'funcall (butlast fns)
              :initial-value (apply (last1 fns) args)
              :from-end t))
    #'identity))

(defun transpose (lsts)
  (apply #'mapcar (lambda (&rest xs) xs)
                  lsts))

(defun pop1 (lst &key keep)
  (labels ((rec (prev rest acc)
             (if (null rest)
               (nreverse acc)
               (rec (cons (car rest) prev)
                    (cdr rest)
                    (cons (cons (car rest)
                                (if keep
                                  lst
                                  (append (reverse prev)
                                          (cdr rest))))
                          acc)))))
    (rec nil lst nil)))

(defun perm (lst n &key repeat)
  (if (or (<= n 0) (null lst))
    (list nil)
    (mapcan (lambda (poped)
              (mapcar (lambda (p)
                        (cons (car poped) p))
                      (perm (cdr poped) (1- n)
                            :repeat repeat)))
            (pop1 lst :keep repeat))))

(defun c-prod2 (xs yss)
  (mapcan (lambda (x)
            (mapcar (lambda (ys) (cons x ys))
                    yss))
          xs))

(defun c-prod (&rest args)
  "cartesian product or direct product"
  (reduce #'c-prod2 args
          :initial-value (list nil)
          :from-end t))

(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

(defmacro chain-call (obj cl1 &rest clauses)
  (reduce (lambda (acc cl)
            `(,(car cl) ,acc ,@(cdr cl)))
          clauses
          :initial-value `(,(car cl1) ,obj ,@(cdr cl1))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; integer <-> bit list
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun bits-to-int (l)
  (reduce (lambda (x acc) (+ (* 2 acc) x))
          l :initial-value 0 :from-end t))

(defun int-to-bits (i)
  (if (<= i 0)
    nil
    (mvbind (q r) (truncate i 2)
      (cons r (int-to-bits q)))))
