mirror of https://codeberg.org/cage/tinmop/
1165 lines
42 KiB
Common Lisp
1165 lines
42 KiB
Common Lisp
;; tinmop: a multiprotocol client
|
|
;; Copyright © cage
|
|
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
;; uses code from
|
|
|
|
;; niccolo': a chemicals inventory
|
|
;; Copyright (C) 2016 Universita' degli Studi di Palermo
|
|
|
|
;; This program is free software: you can redistribute it and/or
|
|
;; modify it under the terms of the GNU General Public License as
|
|
;; published by the Free Software Foundation, version 3 of the
|
|
;; License, or (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(in-package :misc-utils)
|
|
|
|
(defclass metadata-container ()
|
|
((metadata
|
|
:initform nil
|
|
:initarg :metadata
|
|
:accessor metadata)))
|
|
|
|
;; debug utils
|
|
|
|
(defparameter *debug* nil)
|
|
|
|
(defmacro when-debug (&body body)
|
|
`(when (not (null *debug*))
|
|
,@body))
|
|
|
|
(defun debug-log (format-string &rest parameters)
|
|
(when (not (log:debug))
|
|
(log4cl:remove-all-appenders log4cl:*root-logger*)
|
|
(log:config :debug :nopackage
|
|
:daily (text-utils:strcat (res:home-datadir)
|
|
"tinmop.log")
|
|
:backup nil))
|
|
(let ((message (apply #'format nil format-string parameters)))
|
|
(log:debug message)))
|
|
|
|
(defun dbg (format-string &rest parameters)
|
|
(apply #'debug-log format-string parameters))
|
|
|
|
(defun dbg-and-quit (format-string &rest parameters)
|
|
(apply #'dbg format-string parameters)
|
|
(uiop:quit))
|
|
|
|
(defun debug-stream (stream format-string &rest parameters)
|
|
((lambda (a b)
|
|
(apply #'format stream a b))
|
|
(concatenate 'string format-string "~%")
|
|
parameters))
|
|
|
|
(defun dbg-stdout (format-string &rest parameters)
|
|
(apply #'debug-stream *standard-output* format-string parameters))
|
|
|
|
(defun dbg-stderr (format-string &rest parameters)
|
|
(apply #'debug-stream *error-output* format-string parameters))
|
|
|
|
(defun dump-hash-table (table)
|
|
(let ((res '()))
|
|
(maphash (lambda (k v) (push (format nil "~s -> ~s~%" k v) res)) table)
|
|
res))
|
|
|
|
(defgeneric dump-hashtable (table))
|
|
|
|
(defmethod dump-hashtable ((table hash-table))
|
|
(maphash (lambda (k v) (misc:dbg "~s -> ~s" k v)) table))
|
|
|
|
(defmethod dump-hashtable (table)
|
|
(dbg "~s"table))
|
|
|
|
(defmacro with-messages-start-end ((start-message end-message
|
|
&key (print-only-if-debug-mode t)) &body body)
|
|
(alexandria:with-gensyms (res)
|
|
(let* ((debug-p (find :debug-mode *features*))
|
|
(print-msg-p (or (not print-only-if-debug-mode)
|
|
debug-p)))
|
|
`(progn
|
|
,(when print-msg-p
|
|
`(dbg ,start-message))
|
|
(let ((,res (progn ,@body)))
|
|
,(when print-msg-p
|
|
`(dbg ,end-message))
|
|
,res)))))
|
|
|
|
;; macro utils
|
|
|
|
(defmacro format-fn-symbol (package format &rest format-args)
|
|
`(alexandria:format-symbol ,package ,(concatenate 'string "~:@(" format "~)")
|
|
,@format-args))
|
|
|
|
(defun format-keyword (thing)
|
|
(alexandria:make-keyword (format nil "~:@(~a~)" thing)))
|
|
|
|
(defun check-body-keywords (body ammitted)
|
|
(let ((all-keywords (loop
|
|
for ct from 1
|
|
for i in body when (and (oddp ct)
|
|
(keywordp i))
|
|
collect i)))
|
|
(loop for i in all-keywords do
|
|
(when (not (find i ammitted :test #'eq))
|
|
(error (format nil "keyword must be one of ~a, but ~a was found"
|
|
ammitted
|
|
i))))))
|
|
|
|
;; functions utils
|
|
|
|
(defun function-name (data)
|
|
"Implementation dependent"
|
|
(assert (functionp data))
|
|
(conditions:with-default-on-error ((config:_ "Anonymous function"))
|
|
(multiple-value-bind (x y name)
|
|
(function-lambda-expression data)
|
|
(declare (ignore x y))
|
|
(if name
|
|
(string-downcase (symbol-name name))
|
|
data))))
|
|
|
|
(defmacro fn-delay (a)
|
|
(if (symbolp a)
|
|
`(lambda (&rest p) (apply (function ,a) p))
|
|
`(lambda (&rest p) (apply ,a p))))
|
|
|
|
(defun unsplice (form)
|
|
(and form
|
|
(list form)))
|
|
|
|
(defun a->function (a)
|
|
(cond
|
|
((functionp a)
|
|
a)
|
|
((symbolp a)
|
|
(symbol-function a))))
|
|
|
|
(defmacro gen-type-p (name)
|
|
(alexandria:with-gensyms (a)
|
|
(let ((fname (if (cl-ppcre:scan "-" (symbol-name name))
|
|
(alexandria:format-symbol t "~:@(~a-p~)"
|
|
(symbol-name name))
|
|
(alexandria:format-symbol t "~:@(~ap~)"
|
|
(symbol-name name)))))
|
|
`(defun ,fname (,a)
|
|
(eql (type-of ,a) ',name)))))
|
|
|
|
(defmacro define-compiler-macros (name &body args)
|
|
(alexandria:with-gensyms (low-level-function-name)
|
|
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name)))
|
|
`(progn
|
|
(defalias ,low-level-function-name #',function-name)
|
|
(define-compiler-macro ,function-name (&whole form ,@args)
|
|
(let ((low-funname ',low-level-function-name))
|
|
(if (every #'constantp (list ,@args))
|
|
(funcall (symbol-function low-funname) ,@args)
|
|
(progn
|
|
form))))))))
|
|
|
|
(defmacro definline (name arg &rest body)
|
|
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name)))
|
|
`(progn
|
|
(declaim (inline ,function-name))
|
|
(defun ,function-name (,@arg) ,@body))))
|
|
|
|
(defmacro defun-inline-function (name arg &body body)
|
|
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name))
|
|
(low-level-function-name (alexandria:format-symbol t "~:@(%~a~)" name)))
|
|
`(progn
|
|
(declaim (inline ,function-name))
|
|
(defun ,function-name (,@arg) (,low-level-function-name ,@arg))
|
|
(defun ,low-level-function-name (,@arg) ,@body))))
|
|
|
|
(defmacro defmethod-inline-function (name arg &body body)
|
|
(let* ((function-name (alexandria:format-symbol t "~:@(~a~)" name))
|
|
(low-level-function-name (alexandria:format-symbol t "~:@(%~a~)" name)))
|
|
`(progn
|
|
(declaim (inline ,function-name))
|
|
(defgeneric ,low-level-function-name (,@(loop for i in arg collect
|
|
(if (atom i)
|
|
i
|
|
(first i)))))
|
|
|
|
(defmethod ,function-name (,@arg) (,low-level-function-name
|
|
,@(loop for i in arg collect
|
|
(if (atom i)
|
|
i
|
|
(first i)))))
|
|
(defmethod ,low-level-function-name (,@arg) ,@body))))
|
|
|
|
(alexandria:define-constant +cache-invalid-value+ :invalid-cache-value :test #'eq)
|
|
|
|
(defmacro defcached (name (arg &key (test 'equalp) (clear-cache nil))
|
|
declaration
|
|
(&body body))
|
|
(let* ((function-clear-cache-name (format-fn-symbol t "~a-clear-cache" name))
|
|
(function-name (format-fn-symbol t "~:@(~a~)" name))
|
|
(cache-name (format-fn-symbol t "~:@(cache~)")))
|
|
`(let ((,cache-name (make-hash-table :test (quote ,test))))
|
|
(defun ,function-clear-cache-name () (clrhash ,cache-name))
|
|
(defun ,function-name (,@arg) ,(if declaration
|
|
declaration
|
|
`(declare (optimize (speed 0) (safety 3) (debug 3))))
|
|
|
|
(and ,clear-cache (setf ,cache-name (make-hash-table :test (quote ,test))))
|
|
,@(list body)))))
|
|
|
|
(defmacro defcached-list (name (args &key (equal-fn #'=))
|
|
&body body)
|
|
"Uses a list as cache storage, good only with few elements!"
|
|
(let* ((function-clear-cache-name (format-fn-symbol t "~a-clear-cache" name))
|
|
(function-search-cache-name (format-fn-symbol t "~a-search-cache" name))
|
|
(function-ins-cache-name (format-fn-symbol t "~a-insert-cache" name))
|
|
(function-name (format-fn-symbol t "~:@(~a~)" name)))
|
|
(multiple-value-bind (forms declaration)
|
|
(alexandria:parse-body body)
|
|
(alexandria:with-gensyms (cache)
|
|
`(let ((,cache '()))
|
|
(defun ,function-clear-cache-name ()
|
|
(setf ,cache '()))
|
|
(defun ,function-search-cache-name (d)
|
|
(find d ,cache :test ,equal-fn))
|
|
(defun ,function-ins-cache-name (d)
|
|
(pushnew d ,cache :test ,equal-fn))
|
|
(defun ,function-name (,@args)
|
|
,@declaration
|
|
,@forms))))))
|
|
|
|
(defun nest-expressions (data &optional (leaf nil))
|
|
(if (null data)
|
|
(list leaf)
|
|
(append (first data) (if (rest data)
|
|
(list (nest-expressions (rest data) leaf))
|
|
(nest-expressions (rest data) leaf)))))
|
|
|
|
(defun replace-e! (expr num)
|
|
(if (null (first expr))
|
|
nil
|
|
(if (atom (first expr))
|
|
(append (list
|
|
(if (eq (first expr) :e!)
|
|
num
|
|
(first expr)))
|
|
(replace-e! (rest expr) num))
|
|
(append (list (replace-e! (first expr) num))
|
|
(replace-e! (rest expr) num)))))
|
|
|
|
(alexandria:define-constant +nil-equiv-bag+ '(:none :false :nil) :test #'equalp)
|
|
|
|
(defun build-plist (params)
|
|
(let ((keywords (mapcar #'alexandria:make-keyword
|
|
(loop for i from 0 below (length params) when (oddp (1+ i))
|
|
collect (elt params i))))
|
|
(vals (mapcar #'(lambda (a)
|
|
(typecase a
|
|
(symbol (let ((key (alexandria:make-keyword a)))
|
|
(and (not (find key +nil-equiv-bag+ :test #'eq))
|
|
key)))
|
|
(cons (list a))
|
|
(otherwise a)))
|
|
(loop for i from 0 below (length params) when (evenp (1+ i))
|
|
collect (elt params i)))))
|
|
(mapcar #'(lambda (a b) (cons a b)) keywords vals)))
|
|
|
|
|
|
(defmacro build-assocs-chain (path start)
|
|
(if (null path)
|
|
start
|
|
`(cdr (assoc ,(first path) (build-assocs-chain ,(rest path) ,start)))))
|
|
|
|
(defmacro gen-trivial-plist-predicate (name class var get-fn)
|
|
(let ((name-fn (alexandria:format-symbol t "~:@(~a-p~)" name)))
|
|
`(progn
|
|
(defgeneric ,name-fn (object))
|
|
(defmethod ,name-fn ((object ,class))
|
|
(funcall ,get-fn object ,var)))))
|
|
|
|
(defmacro gen-trivial-plist-predicates (class get-fn &rest vars)
|
|
`(progn
|
|
,@(loop for v in vars collect
|
|
`(gen-trivial-plist-predicate ,(alexandria:symbolicate (string-trim "+" v))
|
|
,class
|
|
,v
|
|
(function ,get-fn)))))
|
|
|
|
(defmacro gen-trivial-plist-get (function-name-prefix name class var get-fn)
|
|
(let ((name-fn (alexandria:format-symbol t "~:@(~a-~a~)" function-name-prefix name)))
|
|
`(progn
|
|
(defgeneric ,name-fn (object))
|
|
(defmethod ,name-fn ((object ,class))
|
|
(funcall ,get-fn object ,var)))))
|
|
|
|
(defmacro gen-trivial-plist-gets (class get-fn function-name-prefix &rest vars)
|
|
`(progn
|
|
,@(loop for v in vars collect
|
|
`(gen-trivial-plist-get ,function-name-prefix
|
|
,(alexandria:symbolicate (string-trim "+" v))
|
|
,class
|
|
,v
|
|
(function ,get-fn)))))
|
|
|
|
;; plist
|
|
|
|
(defun recursive-assoc (path start)
|
|
(if (null path)
|
|
start
|
|
(recursive-assoc (rest path) (cdr (assoc (first path) start)))))
|
|
|
|
(defun recursive-assoc-just-before (path start)
|
|
(if (= (length path) 1)
|
|
start
|
|
(recursive-assoc-just-before (rest path) (cdr (assoc (first path) start)))))
|
|
|
|
(defun n-setf-path-value (db path new-value)
|
|
(let* ((ptr (recursive-assoc-just-before path db))
|
|
(last-key (alexandria:last-elt path))
|
|
(last-cons (assoc last-key ptr)))
|
|
(if last-cons
|
|
(values (setf (cdr last-cons) new-value) t)
|
|
(values nil nil))))
|
|
|
|
(defun plist-path-value (db path)
|
|
(let* ((ptr (recursive-assoc-just-before path db))
|
|
(last-key (alexandria:last-elt path))
|
|
(last-cons (assoc last-key ptr)))
|
|
(if last-cons
|
|
(values (cdr last-cons) t)
|
|
(values nil nil))))
|
|
|
|
;; misc
|
|
|
|
(defun not-null-p (a)
|
|
(not (null a)))
|
|
|
|
(definline code->char (code &key (limit-to-ascii nil))
|
|
(code-char (if limit-to-ascii
|
|
(alexandria:clamp code 0 127)
|
|
code)))
|
|
|
|
(definline char->code (code)
|
|
(char-code code))
|
|
|
|
(defmacro swap (a b)
|
|
`(rotatef ,a ,b))
|
|
|
|
;;;; binary files utils
|
|
;;;; big endian...
|
|
|
|
(defun 2byte->word (byte1 byte2) ;; little endian
|
|
(let ((res #x00000000))
|
|
(boole boole-ior
|
|
(boole boole-ior byte1 res)
|
|
(ash byte2 8))))
|
|
|
|
(defun 2word->int (word1 word2)
|
|
(let ((res #x00000000))
|
|
(boole boole-ior
|
|
(ash (boole boole-ior word1 res) 16)
|
|
word2)))
|
|
|
|
(defun byte->int (bytes)
|
|
(let ((res #x0000000000000000)
|
|
(ct 0))
|
|
(map nil #'(lambda (a)
|
|
(setf res (boole boole-ior
|
|
(ash a ct)
|
|
res))
|
|
(incf ct 8))
|
|
bytes)
|
|
res))
|
|
|
|
(defmacro gen-intn->bytes (bits)
|
|
(let ((function-name (alexandria:format-symbol t "~:@(int~a->bytes~)" bits)))
|
|
`(defun ,function-name (val &optional (count 0) (res '()))
|
|
(if (>= count ,(/ bits 8))
|
|
(reverse res)
|
|
(,function-name (ash val -8)
|
|
(1+ count)
|
|
(push (boole boole-and val #x00ff)
|
|
res))))))
|
|
|
|
(gen-intn->bytes 16)
|
|
|
|
(gen-intn->bytes 32)
|
|
|
|
(defun bytes->string (bytes)
|
|
(coerce (mapcar #'code-char bytes) 'string))
|
|
|
|
(defun read-ieee-float-32 (stream)
|
|
(let ((bytes (make-fresh-list 4)))
|
|
(read-sequence bytes stream)
|
|
(let ((bits (byte->int bytes)))
|
|
(ieee-floats:decode-float32 bits))))
|
|
|
|
(defmacro define-offset-size (package prefix &rest name-offset-size)
|
|
`(progn
|
|
,@(loop for i in name-offset-size collect
|
|
`(progn
|
|
(alexandria:define-constant
|
|
,(alexandria:format-symbol package "~@:(+~a-~a-offset+~)" prefix (first i))
|
|
,(second i) :test #'=)
|
|
,(when (= (length i) 3)
|
|
`(alexandria:define-constant
|
|
,(alexandria:format-symbol package "~@:(+~a-~a-size+~)" prefix
|
|
(first i))
|
|
,(third i) :test #'=))))))
|
|
|
|
(defmacro define-parse-header-chunk ((name offset size object &optional (slot name)))
|
|
(alexandria:with-gensyms (bytes)
|
|
`(progn
|
|
(defgeneric ,(alexandria:format-symbol t "PARSE-~:@(~a~)" name) (,object stream))
|
|
(defmethod ,(alexandria:format-symbol t "PARSE-~:@(~a~)" name) ((object ,object) stream)
|
|
(file-position stream ,offset)
|
|
(let* ((,bytes (make-fresh-list ,size)))
|
|
(read-sequence ,bytes stream)
|
|
,(when (not (null slot))
|
|
`(setf (,slot object) ,bytes))
|
|
(values ,bytes object))))))
|
|
|
|
(defun read-list (stream size &key (offset nil))
|
|
(when offset
|
|
(file-position stream offset))
|
|
(let* ((bytes (misc-utils:make-fresh-list size)))
|
|
(read-sequence bytes stream)
|
|
bytes))
|
|
|
|
(defun read-array (stream size &key (offset nil))
|
|
(when offset
|
|
(file-position stream offset))
|
|
(let* ((bytes (misc-utils:make-array-frame size 0 '(unsigned-byte 8) t))
|
|
(read-so-far (read-sequence bytes stream)))
|
|
(values bytes read-so-far)))
|
|
|
|
(defun read-all (stream)
|
|
"Read all the octent from stream ad returns them as array"
|
|
(let ((raw (loop
|
|
for c = (read-byte stream nil nil)
|
|
while c
|
|
collect c)))
|
|
(coerce raw '(vector (unsigned-byte 8)))))
|
|
|
|
(defun read-line-into-array (stream &key (add-newline-stopper t))
|
|
"Read a line as array of unsigned octets or nil if stream is exausted.
|
|
if `add-newline-stopper' is non nil a newline (ASCII 10) is appended
|
|
to the array"
|
|
(let ((first-byte (read-byte stream nil nil)))
|
|
(when first-byte
|
|
(let ((raw (loop
|
|
for c = first-byte then (read-byte stream nil (char-code #\Newline))
|
|
while (/= c (char-code #\Newline))
|
|
collect c)))
|
|
(when add-newline-stopper
|
|
(let ((rev (reverse raw)))
|
|
(push (char-code #\Newline) rev)
|
|
(setf raw (reverse rev))))
|
|
(misc:list->array raw '(unsigned-byte 8))))))
|
|
|
|
(defun read-stream-chunks (stream buffer-size processing-function)
|
|
(assert (functionp processing-function))
|
|
(assert (typep buffer-size 'fixnum))
|
|
(assert (> buffer-size 0))
|
|
(let ((buffer (make-fresh-array buffer-size 0 '(unsigned-byte 8) t)))
|
|
(labels ((read-chunk ()
|
|
(declare (optimize (debug 0) (speed 3)))
|
|
(declare (function processing-function))
|
|
(declare (fixnum buffer-size))
|
|
(let ((read-so-far (read-sequence buffer stream)))
|
|
(funcall processing-function buffer read-so-far)
|
|
(when (not (< read-so-far buffer-size))
|
|
(read-chunk)))))
|
|
(read-chunk))))
|
|
|
|
(define-condition delimiter-not-found (error)
|
|
((delimiter
|
|
:initarg :delimiter
|
|
:reader delimiter))
|
|
(:report (lambda (condition stream)
|
|
(format stream "delimiter ~s not found and stream closed" (delimiter condition))))
|
|
(:documentation "Condition signalled when a command the user inputed
|
|
was not found in keybindings tree."))
|
|
|
|
(defparameter *read-delimiter* 0)
|
|
|
|
(defun read-delimited-into-array (stream &key
|
|
(delimiter *read-delimiter*)
|
|
(buffer-size 2048)
|
|
(buffer (make-fresh-array buffer-size
|
|
0
|
|
'(unsigned-byte 8)
|
|
t))
|
|
(accum (make-fresh-array 0
|
|
0
|
|
'(unsigned-byte 8))))
|
|
(labels ((delimiter-position ()
|
|
(position delimiter accum :test #'=))
|
|
(get-excess ()
|
|
(subseq accum (1+ (delimiter-position)))))
|
|
(if (delimiter-position)
|
|
(values (subseq accum 0 (delimiter-position))
|
|
(subseq accum (1+ (delimiter-position))))
|
|
(let ((read-so-far (read-sequence buffer stream)))
|
|
(setf accum (concatenate 'vector accum (subseq buffer 0 read-so-far)))
|
|
(if (< read-so-far buffer-size)
|
|
(if (or (< (length accum) 1)
|
|
(not (delimiter-position)))
|
|
(error 'delimiter-not-found :delimiter delimiter)
|
|
(values (subseq accum 0 (delimiter-position))
|
|
(get-excess)))
|
|
(if (delimiter-position)
|
|
(let* ((delimiter-position (delimiter-position))
|
|
(excess (get-excess)))
|
|
(values (subseq accum 0 delimiter-position)
|
|
excess))
|
|
(read-delimited-into-array stream
|
|
:delimiter delimiter
|
|
:buffer-size buffer-size
|
|
:buffer buffer
|
|
:accum accum)))))))
|
|
|
|
(defun read-delimited-into-array-unbuffered (stream &key (delimiter *read-delimiter*))
|
|
(list->array (loop for i = (read-byte stream nil nil) then (read-byte stream nil nil)
|
|
while (and i (/= i delimiter))
|
|
collect i)
|
|
'(unsigned-byte 8)))
|
|
|
|
;; sequence utils
|
|
|
|
(defun safe-elt (sequence index)
|
|
(and (>= index 0)
|
|
(< index (length sequence))
|
|
(elt sequence index)))
|
|
|
|
(defun safe-last-elt (sequence)
|
|
(safe-elt sequence (1- (length sequence))))
|
|
|
|
(defun safe-subseq (sequence start &optional (end nil))
|
|
(when sequence
|
|
(when (or (null start)
|
|
(< start 0))
|
|
(setf start 0))
|
|
(when (and (numberp end)
|
|
(> end (length sequence)))
|
|
(setf end (length sequence)))
|
|
(let* ((actual-start (alexandria:clamp start
|
|
0
|
|
(length sequence)))
|
|
(actual-end (and end
|
|
(max actual-start
|
|
(min end
|
|
(length sequence))))))
|
|
(subseq sequence actual-start actual-end))))
|
|
|
|
(defgeneric sequence-empty-p (a))
|
|
|
|
(defmethod sequence-empty-p ((a vector))
|
|
(vector-empty-p a))
|
|
|
|
(defmethod sequence-empty-p ((a sequence))
|
|
(alexandria:emptyp a))
|
|
|
|
(defun vector-empty-p (v)
|
|
(declare (optimize (speed 3) (safety 0) (debug 0)))
|
|
(declare (vector v))
|
|
(= (length v) 0))
|
|
|
|
(defun random-num-filled-vector (size max)
|
|
(map-into (misc:make-array-frame size max (type-of max) t)
|
|
#'(lambda () (num:lcg-next-upto max))))
|
|
|
|
(definline random-elt (seq)
|
|
(elt seq (num:lcg-next-upto (length seq))))
|
|
|
|
(defun safe-random-elt (seq)
|
|
"note: values nil if (or (null seq) (= (length seq) 0))"
|
|
(and seq
|
|
(> (length seq) 0)
|
|
(elt seq (num:lcg-next-upto (length seq)))))
|
|
|
|
(defun make-fresh-list (size &optional (el nil))
|
|
(map-into (make-list size)
|
|
(if (functionp el)
|
|
el
|
|
#'(lambda () el))))
|
|
|
|
(defun seq->list (sequence)
|
|
(if (listp sequence)
|
|
(copy-list sequence)
|
|
(map-into (make-list (length sequence)) #'identity sequence)))
|
|
|
|
(defmacro *cat (type-return input)
|
|
`(reduce #'(lambda (a b) (concatenate ',type-return a b)) ,input))
|
|
|
|
(defun lcat (&rest v)
|
|
(declare (optimize (speed 3) (safety 1) (debug 0)))
|
|
(*cat list v))
|
|
|
|
(defun vcat (&rest v)
|
|
(declare (optimize (speed 3) (safety 1) (debug 0)))
|
|
(*cat vector v))
|
|
|
|
(defun fresh-list-insert@ (list value pos)
|
|
(declare (optimize (speed 3) (safety 1) (debug 0)))
|
|
(declare (list list))
|
|
(lcat (subseq list 0 pos)
|
|
(list value)
|
|
(subseq list pos)))
|
|
|
|
(defun fresh-list-subst@ (a v pos)
|
|
(declare (optimize (speed 3) (safety 1) (debug 0)))
|
|
(declare (list a))
|
|
(lcat (subseq a 0 pos)
|
|
(list v)
|
|
(subseq a (1+ pos))))
|
|
|
|
(defun fresh-vector-insert@ (a v pos)
|
|
(vcat (subseq a 0 pos)
|
|
(vector v)
|
|
(subseq a pos)))
|
|
|
|
(eval-when (:compile-toplevel :load-toplevel :execute)
|
|
(defun make-array-frame (size &optional (el nil) (type t) (simplep nil))
|
|
"All elements points to the same address/reference!"
|
|
(make-array size
|
|
:fill-pointer (if (not simplep) size nil)
|
|
:adjustable (if (not simplep) t nil)
|
|
:initial-element el
|
|
:element-type type)))
|
|
|
|
(defun make-fresh-array (size &optional (el nil) (type t) (simplep nil))
|
|
(let ((res (make-array size
|
|
:fill-pointer (if (not simplep) size nil)
|
|
:adjustable (if (not simplep) t nil)
|
|
:initial-element el
|
|
:element-type type)))
|
|
(map-into res #'(lambda (a) (setf a (cond
|
|
((functionp el)
|
|
(funcall el))
|
|
((arrayp el)
|
|
(alexandria:copy-array el))
|
|
((listp el)
|
|
(copy-list el))
|
|
(t
|
|
el))))
|
|
res)))
|
|
|
|
(defun list->array (the-list &optional (element-type t))
|
|
(make-array (length the-list)
|
|
:element-type element-type
|
|
:fill-pointer (length the-list)
|
|
:adjustable t
|
|
:initial-contents (copy-list the-list)))
|
|
|
|
(defun copy-list-into-array (from to)
|
|
(assert (= (length from) (length to)))
|
|
(loop
|
|
for i in from
|
|
for ct from 0 by 1 do
|
|
(setf (elt to ct) i))
|
|
to)
|
|
|
|
(defun array-slice (array start &optional (end nil))
|
|
(let* ((new-size (if end
|
|
(- end start)
|
|
(- (length array) start)))
|
|
(new-fill-pointer (cond
|
|
((array-has-fill-pointer-p array)
|
|
(if end
|
|
new-size
|
|
(fill-pointer array)))
|
|
(t
|
|
nil)))
|
|
(new-array (make-array new-size
|
|
:element-type (array-element-type array)
|
|
:fill-pointer new-fill-pointer
|
|
:initial-element (alexandria:first-elt array)
|
|
:adjustable (adjustable-array-p array)))
|
|
(end-iteration (or end
|
|
(length array))))
|
|
(loop
|
|
for index-from from start below end-iteration
|
|
for index-to from 0
|
|
do
|
|
(setf (elt new-array index-to)
|
|
(elt array index-from)))
|
|
new-array))
|
|
|
|
(defun list->simple-array (the-list start-type type)
|
|
(let ((res (make-array-frame (length the-list) start-type type t)))
|
|
(loop
|
|
for element in the-list
|
|
for i from 0 below (length the-list) do
|
|
(setf (elt res i) element))
|
|
res))
|
|
|
|
(defun permutation (li)
|
|
(let ((res-partial '())
|
|
(res '()))
|
|
(labels ((perm (start tail)
|
|
(let ((partial-tree '()))
|
|
(loop for i in start do
|
|
(loop for j in (set-difference tail i) do
|
|
(push (append i (list j)) partial-tree)))
|
|
(setf res-partial (reverse (copy-tree partial-tree))))))
|
|
(loop for ct in li do
|
|
(do ((start (list (list ct)) res-partial))
|
|
((null (set-difference li (first start)))
|
|
(progn
|
|
(setf res (append res res-partial))
|
|
(setf res-partial '())))
|
|
(perm start li))))
|
|
res))
|
|
|
|
(defun shuffle (sequence)
|
|
(loop for i from (1- (length sequence)) downto 1 do
|
|
(let ((rnd (num:lcg-next-upto (1+ i))))
|
|
(swap (elt sequence rnd) (elt sequence i))))
|
|
sequence)
|
|
|
|
(defun %split-into-chunks (sequence subseq-fn chunk-length &optional (accum ()))
|
|
(assert (> chunk-length 0))
|
|
(cond
|
|
((null sequence)
|
|
(reverse accum))
|
|
((< (length sequence) chunk-length)
|
|
(%split-into-chunks nil subseq-fn chunk-length (push sequence accum)))
|
|
(t
|
|
(%split-into-chunks (funcall subseq-fn sequence chunk-length)
|
|
subseq-fn
|
|
chunk-length
|
|
(push (funcall subseq-fn sequence 0 chunk-length) accum)))))
|
|
|
|
(defgeneric split-into-chunks (object chunk-length))
|
|
|
|
(defmethod split-into-chunks ((object list) chunk-length)
|
|
(%split-into-chunks object #'subseq chunk-length))
|
|
|
|
(defmethod split-into-chunks ((object vector) chunk-length)
|
|
(%split-into-chunks object #'array-slice chunk-length))
|
|
|
|
(defun group-by (sequence &key (test #'=))
|
|
(let ((distinct '()))
|
|
(loop for i in sequence do
|
|
(pushnew i distinct :test test))
|
|
(loop for i in distinct collect
|
|
(remove-if-not #'(lambda (a) (funcall test a i)) sequence))))
|
|
|
|
(defgeneric delete@ (sequence position))
|
|
|
|
(defgeneric safe-delete@ (sequence position)
|
|
(:documentation "Return sequence if position is out of bound"))
|
|
|
|
(defmacro gen-delete@ ((sequence position) &body body)
|
|
`(if (and (>= ,position 0)
|
|
(< ,position (length ,sequence)))
|
|
,@body
|
|
(error 'conditions:out-of-bounds :seq sequence :idx position)))
|
|
|
|
(defmethod delete@ ((sequence list) position)
|
|
(gen-delete@
|
|
(sequence position)
|
|
(append (subseq sequence 0 position)
|
|
(and (/= position (- (length sequence) 1))
|
|
(subseq sequence (1+ position))))))
|
|
|
|
(defmethod delete@ ((sequence vector) position)
|
|
(gen-delete@
|
|
(sequence position)
|
|
(make-array (1- (length sequence))
|
|
:fill-pointer (1- (length sequence))
|
|
:adjustable t
|
|
:initial-contents (concatenate 'vector (subseq sequence 0 position)
|
|
(and (/= position (- (length sequence) 1))
|
|
(subseq sequence (1+ position)))))))
|
|
|
|
(defmethod safe-delete@ ((sequence sequence) position)
|
|
(restart-case
|
|
(delete@ sequence position)
|
|
(return-nil () nil)
|
|
(return-whole () sequence)
|
|
(new-index (i) (safe-delete@ sequence i))))
|
|
|
|
(defun safe-all-but-last-elt (sequence)
|
|
(handler-bind ((conditions:out-of-bounds
|
|
#'(lambda (c)
|
|
(declare (ignore c))
|
|
(invoke-restart 'return-nil))))
|
|
(safe-delete@ sequence (1- (length sequence)))))
|
|
|
|
(defgeneric remove-compact-remap-sequence (sequence predicate))
|
|
|
|
(defmethod remove-compact-remap-sequence ((sequence list) predicate)
|
|
(let ((nullified (loop
|
|
for i in sequence
|
|
for ct from 0 collect
|
|
(if (funcall predicate ct i)
|
|
nil
|
|
i)))
|
|
(mapping nil)
|
|
(results '()))
|
|
(loop
|
|
for i in nullified
|
|
for pos from 0 do
|
|
(when (not (null i))
|
|
(push i results)
|
|
(push (list pos (1- (length results))) mapping)))
|
|
(values (reverse results) mapping)))
|
|
|
|
(defmethod remove-compact-remap-sequence ((sequence vector) predicate)
|
|
(let ((nullified (loop for i from 0 below (length sequence) collect
|
|
(if (funcall predicate i (elt sequence i))
|
|
nil
|
|
(elt sequence i))))
|
|
(mapping nil)
|
|
(results (make-array-frame 0)))
|
|
(loop for i from 0 below (length nullified) do
|
|
(when (not (null (elt nullified i)))
|
|
(vector-push-extend (elt nullified i) results)
|
|
(push (list i (1- (length results))) mapping)))
|
|
(values results mapping)))
|
|
|
|
(defun remove-if-null (a)
|
|
(remove-if #'null a))
|
|
|
|
(defun remove-if-not-null (a)
|
|
(remove-if #'(lambda (i) (not (null i))) a))
|
|
|
|
(defun copy-multiply (from to length source-step copy-num)
|
|
(loop for ct from 0 below (* source-step length) by source-step
|
|
for ct2 from 0 below (* length source-step copy-num) by (* source-step copy-num) do
|
|
(loop for ct3 from 0 below (* source-step copy-num) by 1 do
|
|
(setf (elt to (+ ct2 ct3))
|
|
(elt from (+ ct (mod ct3 source-step))))))
|
|
to)
|
|
|
|
(defun all-but-last-elt (s)
|
|
(if s
|
|
(let ((length (length s)))
|
|
(if (> length 0)
|
|
(subseq s 0 (1- length))
|
|
s))
|
|
s))
|
|
|
|
(defgeneric intersperse (seq new-elt))
|
|
|
|
(defmethod intersperse ((seq list) new-elt)
|
|
(loop for (item . rest) on seq
|
|
if (null rest)
|
|
collect item
|
|
else collect item
|
|
and collect new-elt))
|
|
|
|
(defmethod intersperse ((seq sequence) new-elt)
|
|
(if (< (length seq) 2)
|
|
(copy-seq seq)
|
|
(let* ((len1 (length seq))
|
|
(len2 (1- (* 2 len1)))
|
|
(ret (typecase seq
|
|
(string
|
|
(make-string len2))
|
|
(vector
|
|
(make-fresh-array len2))))
|
|
(j 0))
|
|
(loop for i below len2 do
|
|
(if (oddp i)
|
|
(setf (elt ret i) new-elt)
|
|
(progn
|
|
(setf (elt ret i) (elt seq j))
|
|
(incf j))))
|
|
ret)))
|
|
|
|
;; iterations
|
|
|
|
(defmacro do-while (declaration return-form &body body)
|
|
"C-like \"do { ...} while (condition)\" statement: body is evaluated
|
|
even if exit condition is t at the very first iteration"
|
|
(alexandria:with-gensyms (first-iteration)
|
|
`(do ,(append (list `(,first-iteration t nil))
|
|
declaration)
|
|
,(append (list `(if ,first-iteration
|
|
nil
|
|
,(first return-form)))
|
|
(rest return-form))
|
|
,@body)))
|
|
|
|
(defmacro do-while* (declaration return-form &body body)
|
|
"C-like \"do { ...} while (condition)\" statement: body is evaluated
|
|
even if exit condition is t at the very first iteration"
|
|
(alexandria:with-gensyms (first-iteration)
|
|
`(do* ,(append (list `(,first-iteration t nil))
|
|
declaration)
|
|
,(append (list `(if ,first-iteration
|
|
nil
|
|
,(first return-form)))
|
|
(rest return-form))
|
|
,@body)))
|
|
|
|
;; cg vectors
|
|
|
|
(defmacro gen-vec-comp ((prefix-name comp-name index) &rest declarations)
|
|
(let ((name (format-fn-symbol t "~a-~a" prefix-name comp-name))
|
|
(set-name (format-fn-symbol t "%set-~a-~a" prefix-name comp-name))
|
|
(arg (format-fn-symbol t "v")))
|
|
`(progn
|
|
(defun ,set-name (vec value)
|
|
(setf (elt vec ,index) value))
|
|
(defsetf ,name ,set-name)
|
|
(defun ,name (,arg)
|
|
,@declarations
|
|
(elt ,arg ,index))
|
|
(define-compiler-macros ,name ,arg))))
|
|
|
|
;; cffi
|
|
|
|
(definline make-null-pointer ()
|
|
(cffi:null-pointer))
|
|
|
|
(defun null-pointer-p (ptr)
|
|
(cffi:null-pointer-p ptr))
|
|
|
|
;; plugins, sort of
|
|
|
|
(defmacro with-load-forms-in-var ((special-var output-var file) &body body)
|
|
`(let* ((,special-var nil))
|
|
(load ,file)
|
|
(let ((,output-var ,special-var))
|
|
,@body)))
|
|
|
|
;;;; derived from local-time library
|
|
|
|
(alexandria:define-constant +unix-epoch+ (encode-universal-time 0 0 0 1 1 1970 0)
|
|
:test #'=)
|
|
|
|
(defun time-unix->universal (unix-timestamp)
|
|
"Return the UNIVERSAL-TIME corresponding to the TIMESTAMP"
|
|
;; universal time is seconds from 1900-01-01T00:00:00Z
|
|
;; unix timestamp is seconds from 1970-01-01T00:00:00Z
|
|
(+ unix-timestamp +unix-epoch+))
|
|
|
|
(defmacro gen-time-access (name pos)
|
|
`(defun ,(format-fn-symbol t "time-~a-of" name) (time-list)
|
|
(elt time-list ,pos)))
|
|
|
|
(defmacro gen-all-time-access (&rest name-pos)
|
|
`(progn
|
|
,@(loop for i in name-pos collect
|
|
`(gen-time-access ,(car i) ,(cdr i)))))
|
|
|
|
(gen-all-time-access (seconds . 0)
|
|
(minutes . 1)
|
|
(hour . 2)
|
|
(date . 3)
|
|
(month . 4)
|
|
(year . 5)
|
|
(day . 6)
|
|
(daylight-p . 7)
|
|
(zone . 8))
|
|
|
|
(defun year->timestamp (year)
|
|
(local-time:encode-timestamp 0
|
|
0
|
|
0
|
|
0
|
|
1
|
|
1
|
|
(truncate (max 0
|
|
(num:safe-parse-number year)))))
|
|
|
|
(defun current-year ()
|
|
(local-time:timestamp-year (db-utils:local-time-obj-now)))
|
|
|
|
(defun extract-year-from-timestamp (ts)
|
|
(local-time:timestamp-year ts))
|
|
|
|
(defun command-terminated-no-error-p (command-error-code)
|
|
(= command-error-code 0))
|
|
|
|
(defun format-time (local-time-object format-control-list)
|
|
(with-output-to-string (stream)
|
|
(local-time:format-timestring stream local-time-object :format format-control-list)))
|
|
|
|
;; threads
|
|
|
|
(defmacro with-lock-held ((lock) &body body)
|
|
`(bt:with-lock-held (,lock)
|
|
,@body))
|
|
|
|
(defmacro defun-w-lock (name parameters lock &body body)
|
|
(multiple-value-bind (remaining-forms declarations doc-string)
|
|
(alexandria:parse-body body :documentation t)
|
|
`(defun ,name ,parameters
|
|
,doc-string
|
|
,declarations
|
|
(with-lock-held (,lock)
|
|
,@remaining-forms))))
|
|
|
|
(defparameter *thread-default-special-bindings* bt:*default-special-bindings*)
|
|
|
|
(definline make-thread (function &key (name nil) (initial-bindings *thread-default-special-bindings*))
|
|
(bt:make-thread function :name name :initial-bindings initial-bindings))
|
|
|
|
(definline make-lock (&optional name)
|
|
(bt:make-lock name))
|
|
|
|
(definline make-condition-variable (&key (name nil))
|
|
(bt:make-condition-variable :name name))
|
|
|
|
(definline condition-wait (condition-variable lock &key (timeout nil))
|
|
(bt:condition-wait condition-variable lock :timeout timeout))
|
|
|
|
(definline condition-notify (condition-variable)
|
|
(bt:condition-notify condition-variable))
|
|
|
|
(definline join-thread (thread)
|
|
(bt:join-thread thread))
|
|
|
|
(definline destroy-thread (thread)
|
|
(bt:destroy-thread thread))
|
|
|
|
(definline threadp (maybe-thread)
|
|
(bt:threadp maybe-thread))
|
|
|
|
(definline thread-alive-p (thread)
|
|
(bt:thread-alive-p thread))
|
|
|
|
;; http
|
|
|
|
(defun get-url-content (url)
|
|
(multiple-value-bind (stream response-code)
|
|
(drakma:http-request url
|
|
:want-stream t
|
|
:verify :required
|
|
:external-format-out :utf8)
|
|
(values stream response-code)))
|
|
|
|
(defun get-url-content-body (url)
|
|
(drakma:http-request url
|
|
:want-stream nil
|
|
:verify :required
|
|
:external-format-out :utf8))
|
|
|
|
;; profiling
|
|
|
|
(defmacro with-profile-time (&body body)
|
|
`(with-output-to-string (stream)
|
|
(let ((*trace-output* stream))
|
|
(time (progn ,@body)))))
|
|
|
|
(defmacro with-debug-print-profile-time ((&optional prefix) &body body)
|
|
`(misc:dbg "~a ~a" ,prefix (with-profile-time ,@body)))
|
|
|
|
;; package building utils
|
|
|
|
#+quicklisp
|
|
(defun ql-system-equals (a b)
|
|
(string= (ql::short-description a)
|
|
(ql::short-description b)))
|
|
|
|
#+quicklisp
|
|
(defun remove-system-duplicates-test (systems)
|
|
(remove-duplicates systems
|
|
:test #'string=))
|
|
|
|
#+quicklisp
|
|
(alexandria:define-constant +github-quicklisp-source-url-template+
|
|
"https://raw.githubusercontent.com/quicklisp/quicklisp-projects/master/projects/~a/source.txt"
|
|
:test #'string=)
|
|
|
|
#+quicklisp
|
|
(defun get-quicklisp-original-file (system-name)
|
|
(multiple-value-bind (stream response-code)
|
|
(get-url-content (format nil
|
|
+github-quicklisp-source-url-template+
|
|
system-name))
|
|
(when (or (< response-code 400)
|
|
(> response-code 499))
|
|
(let* ((line (text-utils:to-s (read-line-into-array stream)))
|
|
(fields (text-utils:split-words line)))
|
|
fields))))
|
|
|
|
#+quicklisp
|
|
(defun asdf-depends-on (&optional (system-name config:+program-name+))
|
|
(let ((symbol-system (alexandria:symbolicate (string-upcase system-name))))
|
|
(remove-if-not #'stringp
|
|
(asdf:system-depends-on (asdf:find-system symbol-system)))))
|
|
|
|
#+quicklisp
|
|
(defun all-dependencies (system-name)
|
|
(flet ((get-direct-dependencies (system-name)
|
|
(remove-system-duplicates-test (asdf-depends-on system-name))))
|
|
(let* ((direct (get-direct-dependencies system-name))
|
|
(results (copy-list direct)))
|
|
(loop for i in direct do
|
|
(let ((dependencies (get-direct-dependencies i)))
|
|
(loop for j in dependencies do
|
|
(pushnew j results :test #'string=)
|
|
(setf results
|
|
(remove-duplicates (append results (all-dependencies j))
|
|
:test #'string=)))))
|
|
(sort results #'string<))))
|
|
|
|
(defun all-program-dependencies (&optional download)
|
|
#+quicklisp
|
|
(let* ((dependencies (all-dependencies config:+program-name+))
|
|
(clean-dependencies (mapcar (lambda (a)
|
|
(cond
|
|
((string= a "sqlite")
|
|
"cl-sqlite")
|
|
((string= a "marshal")
|
|
"cl-marshal")
|
|
(t
|
|
a)))
|
|
dependencies)))
|
|
(flet ((download-package (fields)
|
|
(if (cl-ppcre:scan "git" (first fields))
|
|
(os-utils:run-external-program "git"
|
|
(list "clone" (second fields))
|
|
:search t)
|
|
(let ((data (get-url-content-body (second fields))))
|
|
(with-open-file (out-stream (fs:path-last-element (second fields))
|
|
:direction :output
|
|
:element-type '(unsigned-byte 8))
|
|
(write-sequence data out-stream))))))
|
|
(loop for system-name in (sort clean-dependencies #'string<) do
|
|
(let ((fields (get-quicklisp-original-file system-name)))
|
|
(if fields
|
|
(cond
|
|
((string= (first fields) "ediware-http")
|
|
(let ((url (format nil "https://github.com/edicl/~a.git" system-name)))
|
|
(format t "~a ~a ~a~%" system-name "git" url)
|
|
(when download
|
|
(download-package (list "git" url)))))
|
|
((string= (first fields) "kmr-git")
|
|
(let ((url (format nil "http://git.kpe.io/~a.git" system-name)))
|
|
(format t "~a ~a ~a~%" system-name "git" url)
|
|
(when download
|
|
(download-package (list (first fields) url)))))
|
|
(t
|
|
(format t "~a ~a ~a~%" system-name (first fields) (second fields))
|
|
(when download
|
|
(download-package fields))))
|
|
(format t "!error: ~a~%" system-name))))))
|
|
#-quicklisp
|
|
(format t
|
|
"Unable to print dependencies because quicklisp was not loaded when compiling ~a.~%"
|
|
config:+program-name+))
|