common.lisp

;;; common.lisp - aggregator of different tools
;;; used in scripts
;;; author: Necto
;;; uses pregexp.lisp - library for work with regular expressions

(defun lib/ (str)
  (if (find-symbol "+/CL+")
    (concatenate 'string +/cl+ str)
    str))

(load (lib/ "pregexp.lisp") :verbose nil)

(if (find-symbol "+CMD-ARGS+")
    (defun symbol-mentioned-in-params (symb)
      (find symb +cmd-args+)))

;; Predicate checks if some keywords are given
(defun verbose-enabled-p ()
  (and (find-symbol "+CMD-ARGS+")
       (or (find 'talkative +cmd-args+)
           (find 'verbose +cmd-args+))))

;; A output stream which you can enable by taking option "talkative"
;; to a script using it
(defconstant extra-out (if (verbose-enabled-p)
                         t
                         (make-string-output-stream)))

(defconstant +max-syms-in-line+ 10000)

;; Also if user doesn't want to view all it's loads, disable it:
(setf *load-verbose* (verbose-enabled-p))


;; process every line in given stream
(defmacro for-every-line-in-file (file line &rest body)
  `(loop for ,line = (read-line ,file nil nil)
            then    (read-line ,file nil nil)
         while ,line do ,@body))

;; append to given dir list some directories
(defun sub-dir (dir &rest dirs)
  (append (if (pathnamep dir)
              (pathname-directory dir)
              dir)
          dirs))

;; make pathname for directory inside given path
(defmacro sub-dir-path (dir &rest dirs)
  `(make-pathname :directory (sub-dir ,dir ,@dirs)))

;; open any file with name=name and type=type in given directory, and
;; execute if-exists form, if file exists, and
;; if-missing form, otherwise
(defmacro with-open-any-file (file dir name type direction if-exists if-missing)
  (let ((path-name (gensym))
        (dir-list `(if (pathnamep ,dir) (pathname-directory ,dir) ,dir)))
    `(let ((,path-name (directory (make-pathname :directory ,dir-list
                                                 :name ,name :type ,type))))
       (if ,path-name
           (with-open-file (,file (first ,path-name);get single file
                                  :direction ,direction
                                  :if-does-not-exist nil)
             (if ,file
                 ,if-exists
                 ,if-missing))
       ,if-missing))))

;; process each file, satisfying to the given path pattern
(defmacro process-every-file (file path-pattern direction &rest body)
  (let ((path-name (gensym)))
    `(dolist (,path-name (directory ,path-pattern))
       (with-open-file (,file ,path-name :direction ,direction)
         ,@body))))

;; find first file, according to given path pattern
(defun a-path (path-pattern)
  (car (directory path-pattern)))

;; parse string "+354.2" to float value 345.2
(defun parse-float (str)
  (let ((dotted-pair (pregexp-match " *([-+]?[0-9]*)[.]([0-9]+)" str))
        (int (pregexp-match " *[+-0-9]+" str)))
    (float
      (if dotted-pair
        (+ (parse-integer (second dotted-pair))
           (let ((after-dot (parse-integer (third dotted-pair))))
             (do ((mantiss after-dot (/ mantiss 10)))
               ((< mantiss 1) mantiss))))
        (parse-integer int)))))

;; substitute symbols for each given pair
(defmacro subst-many (new+old tree)
  (labels ((subst-rec (new+old tree)
                      (cond ((null new+old) tree)
                            (t `(subst ,(caar new+old) ,(cadar new+old)
                                       ,(subst-rec (cdr new+old) tree))))))
    (subst-rec new+old tree)))

;; bind each value to given symbols, calling, if exists,
;; corresponding function before binding, and join it,
;; if a number cpecified, for example:
;; ("fdg" 34 23 t) : (a (b '1+ 1) (c :rest)) ->
;; (let ((a "fdg") (b (list (1+ 34)) (c (list 23 t)))
;;   body)
(defmacro list-bind (list-form symbols &rest body)
  (let ((list-name (gensym))
        (n 0))
    (labels ((get-val1 (processor)
                (prog1
                    (if processor
                        `(,processor (nth ,n ,list-name))
                        `(nth ,n ,list-name))
                    (incf n)))
             (get-valK (processor K)
                `(list ,@(loop repeat k
                               collect (get-val1 processor))))
             (get-val-rest (processor)
                `(subseq ,list-name ,n))
             (push-sym (sym)
                (if (symbolp sym)
                    (list sym (get-val1 nil))
                    (if (and (listp sym) sym) ;list contains at least one element
                      (let ((val (if (numberp (second sym))
                                     (get-valK (third sym) (second sym))
                                     (if (eq (second sym) :rest)
                                         (get-val-rest (third sym))
                                         (get-val1 (second sym))))))
                        (if (first sym) ;if first token is nil, then omit certain amount of elements
                          (list (first sym) val)))
                      (incf n))))) ;omit element
    `(let ((,list-name ,list-form))
        (if ,list-name
            (let ,(loop for sym in symbols
                        collect (push-sym sym))
                 ,@body))))))

;; parse integer, if it is really integer string representation
(defun safe-parse-integer (arg)
  (if (pregexp-match "^ *[-+]?[0-9]+" arg)
    (parse-integer arg)))

;; parse float, if it is really floating point string representation
(defun safe-parse-float (arg)
  (if (pregexp-match "^ *[-+]?[0-9]+[.]?[0-9]*" arg)
    (parse-float arg)))

;; abbreviate some useful functions to short symbols
(defun expand-abbreviations (symbs)
  (subst-many (('parse-integer :i)
               ('parse-float :f)
               ('safe-parse-integer :si)
               ('safe-parse-float :sf)
               ('identity t))
              symbs))

;; parse string, and bind certain groups to corresponding symbols
(defmacro parse-let (regexp line symbs &rest body)
 `(if (> (length ,line) +max-syms-in-line+)
    (format extra-out "~%warning! line \"~a...\"(~a) exceeds maximum lenght(~a) for match~%"
            (subseq ,line 0 15)
            (length ,line)
            +max-syms-in-line+)
   ,(if (listp symbs)
     `(list-bind (cdr (pregexp-match ,regexp ,line))
                ,(expand-abbreviations symbs)
          ,@body)                                             ;bind all groups to separate symbol
     `(let ((,symbs (car (pregexp-match ,regexp ,line))))     ;bind only whole match
        (when ,symbs ,@body)))))

;; process every line, satisfying given pattern, with parsing it to given symbols
(defmacro for-every-appropriate-line (file pattern symbols &rest body)
  (let ((line-name (gensym)))
  `(for-every-line-in-file ,file ,line-name
    (parse-let ,pattern ,line-name ,symbols ,@body))))

;; sum all hash values or keys
(defun for-hash (table &key (summarize :values sum-suplied-p))
  (let ((sum 0))
    (flet ((add-val (key val)
                    (setf sum (+ val sum)))
           (add-key (key val)
                    (setf sum (+ key sum))))
      (maphash (if (or (eq summarize :values)
                       (eq summarize :val)
                       (eq summarize :value))
                   #'add-val #'add-key)
               table)
      (if sum-suplied-p sum))))

;; bind the sym to the val, and evaluate body if it is not null
(defmacro let-if-non-null (sym val &rest body)
  `(let ((,sym ,val))
     (if ,sym
       (progn ,@body))))

;; expand list with quantifiers like ( ... (5 a) ... )
;; to a plain list: ( ... a a a a a ... )
(defun expand-quantifiers (list)
  (let (result)
    (dolist (entry list (reverse result))
      (if (and (listp entry)
               (numberp (first entry)))
        (dotimes (i (first entry)) (setf result (append (cdr entry) result)))
        (push entry result)))))

;; read a standart representation of a object from file, named fname
(defun init-obj (fname &key (reader #'read))
  (with-open-file (file fname :direction :input :if-does-not-exist nil)
    (if file
      (funcall reader file))))

;; check file file-name, if it exists, read value from it, or eval fun,
;; and store it's value otherwise
(defun eval-or-read (file-name fun &key (reader #'read) (writer #'print))
  (with-open-file (store file-name :direction :output :if-exists nil)
    (if store
      (let ((val (funcall fun)))
        (funcall writer val store)
        val)
      (progn
        (format extra-out "~%using stored value at ~a" file-name)
        (init-obj file-name :reader reader)))))

;; get a single value from a string by given pattern
(defmacro extract (pattern str &optional (type nil type-supplied-p))
  (let ((val-name (gensym)))
    `(parse-let ,pattern ,str (,(if type-supplied-p
                                  (list val-name type)
                                  val-name))
       ,val-name)))

;; extract all matches of given pattern from str
(defun all-matches (pattern str)
  (loop for positions = (first (pregexp-match-positions pattern str))
                   then (first (pregexp-match-positions pattern str (cdr positions)))
        while positions
        collect (subseq str (car positions) (cdr positions))))

;; A macro useful for such constructions (let (var) (do stuff with var) var)
;; you can take a list (var-name initial-form final-transformation) instead
;; of just var
(defmacro returning (variable &rest body)
  `(let (,(if (atom variable)
             variable
             (list (first variable) (if (cdr variable)
                                      (second variable)))))
     ,@body
     ,(if (atom variable)
        variable
        (if (< (length variable) 3)
          (first variable)
          `(funcall ,(third variable) ,(first variable))))))