(in-package :kira)
(defmacro eval-always (&body body)
"eval-when (:compile-toplevel :load-toplevel :execute)"
`(eval-when (:compile-toplevel :load-toplevel :execute)
,@body))
(defun macro-eval (form &optional env)
(prog ((expansion form) expanded-p)
macro-eval-1
(when (self-evaluating-p expansion)
(return (values expansion t)))
(when (quoted-form-p expansion)
(return (values (cadr expansion) t)))
(multiple-value-setq (expansion expanded-p)
(macroexpand-1 expansion env))
(when expanded-p (go macro-eval-1))
(let ((value-available-p (and (symbolp expansion) (constantp expansion) (boundp expansion))))
(return-from macro-eval (if value-available-p (values (symbol-value expansion) t) form)))))
(eval-always
(defmacro with-gensyms (variables &body body)
(loop for var in variables as name = (string var)
collect `(,var (gensym ',name)) into bindings
finally (return `(let ,bindings ,@body)))))
(eval-always
(defmacro rebinding (variables &body body)
(loop for var in variables as name = (symbol-name var) as temp = (gensym name)
collect ``(,',temp ,,var) into temps collect `(,var ',temp) into renames
finally (return ``(let (,,.temps) ,(let (,.renames) ,@body))))))
(eval-always
(defmacro whereas (bindings &body body)
(flet ((make-single-level (var val x) `(let ((,var ,val)) (when ,var ,x))))
(let ((function #'(lambda (a b) (make-single-level (car a) (cadr a) b))))
(reduce function bindings :from-end t :initial-value `(locally ,@body))))))
(defun ensure-list (thing)
(unless (eq thing nil)
(if (atom thing)
(list thing)
thing)))
(defmacro load-time-package (package-name)
`(load-time-value (find-package ,package-name)))
(defun ensure-keyword (thing)
(when (or (not thing) (keywordp thing)) (return-from ensure-keyword thing))
(let ((keyword-name (if (symbolp thing) (string thing) (string-upcase thing))))
(values (intern keyword-name (load-time-package :keyword)))))
(defun sans (plist &rest keys &aux (sans '()))
"Return PLIST with the given properties removed non-destructively."
(loop (let ((tail (nth-value 2 (get-properties plist keys))))
(cond ((null tail) (return (nreconc sans plist)))
(t (loop until (eq plist tail)
do (push (pop plist) sans)
(push (pop plist) sans)
finally (setq plist (cddr plist))))))))
(eval-always
(defun get-removal-macro-expansion (item place options environment function-name)
(multiple-value-bind (temps vals news writer reader) (get-setf-expansion place environment)
(let ((modification-form `(,function-name ,item ,reader ,@options)) (new (car news)))
(unless (endp (cdr news)) (error "Multiple values aren't supported."))
`(let* (,.(mapcar #'list temps vals) (,new ,modification-form))
,writer)))))
(defmacro deletef (item place &rest options &environment environment)
(get-removal-macro-expansion item place options environment 'delete))
(defmacro removef (item place &rest options &environment environment)
(get-removal-macro-expansion item place options environment 'remove))
(eval-always
(define-modify-macro coercef (&rest args) coerce)
(define-modify-macro reversef (&rest args) reverse)
(define-modify-macro nreversef (&rest args) nreverse)
(define-modify-macro appendf (&rest args) append)
(define-modify-macro nconcf (&rest args) nconc)
(define-modify-macro butlastf (&rest args) butlast)
(define-modify-macro nbutlastf (&rest args) nbutlast)
(define-modify-macro logiorf (&rest args) logior)
(define-modify-macro logxorf (&rest args) logxor)
(define-modify-macro sortf (&rest args) sort)
(define-modify-macro sansf (&rest args) sans)
(define-modify-macro absf (&rest args) abs)
(define-modify-macro maxf (&rest args) max)
(define-modify-macro minf (&rest args) min)
(define-modify-macro ashf (&rest args) ash))
(defmacro orf (place &rest forms &environment environment)
(multiple-value-bind (temps vals news writer reader) (get-setf-expansion place environment)
(unless (endp (cdr news)) (error "Multiple values aren't supported by the ~S macro." 'orf))
(let* ((new (car news)) (new-form `(or ,@forms)) (set-form `(let ((,new ,new-form)) ,writer)))
`(let* (,.(mapcar #'list temps vals)) (or ,reader ,set-form)))))
(defmacro %get-collecting-context (name)
(error "Can't collect into: ~S." name))
(defmacro collecting (lists &body body &environment environment)
(let* ((list (if lists (car lists) (gensym (string 'anonymous-list))))
(list-name (when lists (pop lists)))
(context `(,list ,(gensym (string 'tail)))))
(unless list-name (setq body `(,@body ,list)))
(let ((next-macro-function (macro-function '%get-collecting-context environment)))
`(macrolet ((%get-collecting-context (name &environment internal-environment)
(when (eq name ',list-name) (return-from %get-collecting-context ',context))
(funcall ,next-macro-function `(%get-collecting-context ,name) internal-environment)))
(let ,context ,@(if lists `((collecting ,lists ,@body)) body))))))
(defmacro collect (new-element &key into &environment environment)
(destructuring-bind (list tail) (macroexpand-1 `(%get-collecting-context ,into) environment)
`(setq ,tail (if ,tail (setf (cdr ,tail) (list ,new-element)) (setq ,list (list ,new-element))))))
(defun make-collector ()
(collecting (anonymous-list)
#'(lambda (&optional (thing nil thing-supplied-p))
(cond ((not thing-supplied-p) anonymous-list)
(t (collect thing :into anonymous-list))))))
(eval-always
(defun parse-binding (binding &optional default-form)
(cond ((null binding) (values nil default-form))
((symbolp binding) (values binding default-form))
((cdr binding) (values (car binding) (cadr binding)))
(t (values (car binding) default-form)))))
(deftype array-index ()
`(integer 0 ,array-total-size-limit))
(defun check-vector-bounds (array start end &aux (rank (array-rank array)))
(let ((length (if (= (the array-rank rank) 1) (length array) (array-total-size array))))
(prog1 (prog1 (orf end length) (check-type start array-index) (check-type end array-index))
(locally (declare (type array-index start end))
(when (or (minusp start) (> start end) (> end (the array-index length)))
(error "Invalid bounding indexes for ~S: ~D, ~D." array start end))))))
(defmacro with-array-data (((vector array) . optional-bindings) &body body)
(destructuring-bind (&optional start-binding end-binding) optional-bindings
(multiple-value-bind (body declarations) (parse-body body nil nil)
(multiple-value-bind (start start-value) (parse-binding start-binding)
(multiple-value-bind (end end-value) (parse-binding end-binding)
(rebinding (array)
(with-gensyms (offset)
(let* ((optimize-settings '(declare (optimize (safety 0) (speed 3))))
(offset-specs `((type array-index ,offset) (ignorable ,offset)))
(bounds-check-form `(check-vector-bounds ,array ,start ,end))
(bounding-indexes (delete nil (list start end)))
(type-declaration `(declare (type array-index ,.bounding-indexes)))
(declarations `(,@declarations ,optimize-settings ,type-declaration))
(new-body `(,(if end `(setq ,end ,bounds-check-form) bounds-check-form))))
(dolist (bx bounding-indexes) (push `(setq ,bx (+ ,bx ,offset)) body))
(setq new-body (append new-body (list `(locally ,.declarations ,@body))))
`(multiple-value-bind (,vector ,offset) (array-data-and-offset ,array)
(declare (type (simple-array * (*)) ,vector)) (declare ,@offset-specs)
(let* (,@(if start `((,start ,start-value))) ,@(if end `((,end ,end-value))))
,@new-body))))))))))
(defun make-indirect-vector (displaced-to &key (start 0) end)
(let ((displaced-to-element-type (array-element-type displaced-to)))
(setq end (check-vector-bounds displaced-to start end))
(locally (declare (type array-index start end))
(make-array (the array-index (- end start))
:displaced-to displaced-to
:displaced-index-offset start
:element-type displaced-to-element-type))))
(defun make-buffer (&optional (size 512) (element-type '(unsigned-byte 8)))
(make-array size :fill-pointer 0 :adjustable t :element-type element-type))
(defun reset-buffer (buffer)
"Zero fill-pointer and return BUFFER."
(setf (fill-pointer buffer) 0) buffer)
(defun make-temporary-name (&aux (time (get-universal-time)) (random-part (random most-positive-fixnum)))
(make-pathname :name (format nil "Kira-~36R~36R" time random-part) :type "tmp" :defaults #p"kira:data;"))
(defun open-temporary-file (&rest options)
(appendf options '(:if-exists nil :direction :output))
(loop thereis (let ((pathname (make-temporary-name)))
(apply #'open pathname options))))
(defmacro with-temporary-file ((stream . options) &body body)
`(with-open-stream (,stream (open-temporary-file ,@options))
,@body))
(defun typed-pathname (pathname)
(symbol-macrolet ((default (load-time-value (make-pathname :type :unspecific))))
(if (pathname-type pathname) pathname (merge-pathnames pathname default))))
(defun open-log (pathname &rest options)
(appendf options '(:if-exists :append :if-does-not-exist :create))
(appendf options '(:direction :output :external-format :utf-8))
(apply #'open pathname options))
(defmacro with-open-log ((stream pathname &rest options) &body body)
`(with-open-stream (,stream (open-log ,pathname ,@options)) ,@body))
(defun type-equal (type1 type2)
(and (subtypep type1 type2)
(subtypep type2 type1)))
(defstaticvar *mmap-alist* '()
"Alist of mapping -> truename.")
(defun mmap (pathname element-type &aux vector (truename (truename pathname)))
(let ((upgraded-element-type (upgraded-array-element-type element-type)))
(loop for mapping in *mmap-alist* when (equal (cdr mapping) truename)
do (unless (type-equal (array-element-type (car mapping)) upgraded-element-type)
(error "Existing vector ~S is incompatible with ~S." (car mapping) element-type))
(return (setq vector (car mapping)))
finally (setq vector (map-file-to-ivector truename upgraded-element-type))
(return-from mmap (caar (push (cons vector truename) *mmap-alist*))))
(unmap-ivector vector)
(let* ((new-displaced-vector
(map-file-to-ivector truename upgraded-element-type))
(size (array-total-size new-displaced-vector)))
(declare (type array-index size) (type (vector unsigned-byte) new-displaced-vector))
(multiple-value-bind (data offset) (array-displacement new-displaced-vector)
(adjust-array vector size :displaced-to data :displaced-index-offset offset)))))
(defun munmap (vector &aux (mapping (assoc vector *mmap-alist*)))
(unless mapping (error "Not mapped with ~S: ~S." 'mmap vector))
(prog1 (unmap-ivector vector) (deletef mapping *mmap-alist*)))
(defun get-mmap-displaced-vector (vector &optional (start 0) end)
(with-array-data ((underlying-data vector) (start start) (end end))
(loop with data-offset of-type array-index = 0 and data as (ivector) in *mmap-alist*
do (multiple-value-setq (data data-offset) (array-data-and-offset ivector))
when (eq data underlying-data) return (make-indirect-vector
ivector
:start (- start data-offset)
:end (- end data-offset)))))
(defmacro fail-safe (attempt &rest failure-forms)
(let* ((ok (gensym "OK")) (protected-form `(progn ,attempt (setq ,ok t))))
`(let (,ok) (unwind-protect ,protected-form (unless ,ok ,@failure-forms)))))
(defstatic +content-external-format+
'(:character-encoding :utf-8
:line-termination :crlf))
(defun file-string (pathname &key (external-format +content-external-format+))
(with-open-file (stream pathname :external-format external-format)
(loop with buffer = (make-buffer (file-length stream) 'character)
for start of-type array-index = (fill-pointer buffer)
do (setf (fill-pointer buffer) (array-total-size buffer))
(let ((end (read-sequence buffer stream :start start)))
(setf (fill-pointer buffer) (the array-index end)))
(unless (listen stream) (return-from file-string buffer))
(when (= (fill-pointer buffer) (array-total-size buffer))
(adjust-array buffer (ceiling (length buffer) 4/5))))))
(defmacro with-heap-ivector ((vector macptr size element-type) &body body)
`(multiple-value-bind (,vector ,macptr) (make-heap-ivector ,size ,element-type)
(unwind-protect (progn ,@body) (dispose-heap-ivector ,vector))))
(defun files-equal (pathname1 pathname2)
"Return true if both files exist, and they have identical contents."
(symbol-macrolet ((element-type '(unsigned-byte 8)) (buffer-size 8192))
(let ((size1 (file-data-size pathname1)) (size2 (file-data-size pathname2)))
(unless (and size1 size2 (eql size1 size2)) (return-from files-equal nil)))
(with-open-file (stream1 pathname1 :direction :input :element-type element-type)
(with-open-file (stream2 pathname2 :direction :input :element-type element-type)
(with-heap-ivector (buffer1 buffer-memory-1 buffer-size element-type)
(with-heap-ivector (buffer2 buffer-memory-2 buffer-size element-type)
(loop for position1 of-type fixnum = (read-sequence buffer1 stream1)
for position2 of-type fixnum = (read-sequence buffer2 stream2)
until (= position1 position2 0)
always (and (= position1 position2)
(zerop (#_memcmp buffer-memory-1
buffer-memory-2
position1))))))))))
(defun %lcs-lens (xs ys)
(declare (optimize (safety 0) (speed 3)))
(loop with ys-length of-type array-index = (length ys)
with curr = (make-array (1+ ys-length) :initial-element 0)
with prev = (make-array (1+ ys-length) :initial-element 0)
for index of-type array-index below (length xs)
for x = (aref xs index) finally (return curr)
do (replace prev curr)
(loop for j of-type array-index from 1
for i of-type array-index below ys-length
do (setf (svref curr j) (if (equal x (aref ys i))
(1+ (the array-index (svref prev i)))
(max (the array-index (svref curr i))
(the array-index (svref prev j))))))))
(defun hirschberg-lcs (xs ys &aux (nx (length xs)) (ny (length ys)))
(when (and (eql nx 1) (find (aref xs 0) ys :test #'equal)) (return-from hirschberg-lcs xs))
(when (<= (the array-index nx) 1) (return-from hirschberg-lcs #()))
(let* ((i (ash (the array-index nx) -1)) (xb (subseq xs 0 i)) (xe (subseq xs i)))
(declare (type array-index i nx ny) (optimize (safety 0) (speed 3)))
(multiple-value-bind (yb ye)
(loop with ll-e = (%lcs-lens (reverse xe) (reverse ys))
with max of-type array-index = -1 and ll-b = (%lcs-lens xb ys)
with k of-type array-index = 0 for j of-type array-index from 0 to ny
for score of-type array-index = (+ (svref ll-b j) (svref ll-e (- ny j)))
if (> score max) do (setq max score k j)
finally (return (values (subseq ys 0 k) (subseq ys k))))
(concatenate 'simple-vector
(hirschberg-lcs xb yb)
(hirschberg-lcs xe ye)))))