;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2023 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(in-package :kira)

(defmacro eval-always (&body body)
  "eval-when (:compile-toplevel :load-toplevel :execute)"
  `(eval-when (:compile-toplevel :load-toplevel :execute)

  (defun whereas->when (var-info body-and-declarations)
    (destructuring-bind (variable . type) var-info
      (when (null type)
        (return-from whereas->when
          `((when ,variable
      ;; We have an actual type, so we emit a declaration for it.
      (push `(declare (type ,type ,variable)) body-and-declarations)
      (cond ((subtypep 'null type) body-and-declarations)
            (t `((when ,variable (locally ,@body-and-declarations))))))))

  (defun make-var-alist (var-list decl-list)
    "Map each variable to its type (or NIL)."
    (loop until (endp var-list)
          collect (cons (pop var-list)
                        (pop decl-list)))))

  (defun whereas-1 (binding r)
    "Process a BINDING, where R is the accumulated (from the end) reduction."
    (destructuring-bind (var-list expression &optional decl-list) binding
      (if (atom var-list)
          `(let ((,var-list ,expression))
             ,@(whereas->when (cons
                              (list r)))
          ;; Both VAR-LIST and DECL-LIST must be lists.
          `(multiple-value-bind ,var-list ,expression
             ,@(reduce #'whereas->when
                       (make-var-alist var-list decl-list)
                       :from-end t :initial-value (list r)))))))

(defmacro whereas ((&rest bindings) &body body)
  "As described in <https://cl-pdx.com/comp.lang.lisp/2002/dec/100245.html>."
  (reduce #'whereas-1 bindings :from-end t :initial-value `(locally ,@body)))

(defun constant-form-p (form)
  "Return true if FORM is a (bound) constant variable."
  (and (symbolp form) (constantp form) (boundp form)))

(defun macro-eval (form &optional env)
  (prog ((expansion form) expanded-p)
    (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))
    (return (if (constant-form-p expansion)
                ;; (1) We have a constant variable, and
                ;; (2) the value is actually available.
                (values (symbol-value expansion) t)
                ;; No evaluation.
                (values form nil)))))

  (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)))))

(defmacro rebinding (variables &body body)
  (loop with prefix = (symbol-name '#:re)
        for var in variables
        for g = (gensym prefix)
        for temp = `(gensym ,(string var))
        collect `(,g ,temp) into gensyms
        collect ``(,,g ,,var) into temps
        collect `(,var ,g) into renames
        finally (return `(let ,gensyms
                           `(let (,,.temps)
                              ,(let ,renames

(defun ensure-list (thing)
  (unless (eq thing nil)
    (if (atom thing)
        (list 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 ensure-package (package-name &rest package-options)  
  "Make package if non-existent. The default use-list is empty."
  (or (find-package package-name) (let (*make-package-use-defaults*)
                                    (apply #'make-package

(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)
                         ;; Skip matching key and value.
                         finally (setq plist (cddr plist))))))))

  (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))

(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))

  (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)
    (let* ((new-form `(or ,@forms)) (set-form `(multiple-value-bind ,news ,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))) ; NIL => anonymous.
         (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)))
         ;; Recursively create a COLLECTING environment for the LISTS.
         (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))))))

(defmacro defstruct* (name-and-options &rest description &aux documentation)
  (when (stringp (car description)) (setq documentation (pop description)))
  `(defstruct ,name-and-options ,@(when documentation (list documentation))
              ,.(loop for slot-definition in description
                      collect (if (atom slot-definition)
                                  `(,slot-definition nil)

  (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))))

(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-bit-vector (size &optional (initial-element 0))
  "Make bit vector of SIZE with the INITIAL-ELEMENT defaulting to zero."
  (make-array size :initial-element initial-element :element-type 'bit))

(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 print-escape-p ()
  "True if printing escape characters."
  (or *print-escape* *print-readably*))

(defun make-temporary-name (&optional (ut (get-universal-time)))
  (let ((name (format nil "Kira-~36R~36R" (random (* 36 36)) ut)))
    (make-pathname :name name :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))

(defmacro with-new-file ((stream pathname . options) &body body)
  (setq options (copy-list options)) ; Since GETF is destructive.
  (loop for default-option in '((:if-does-not-exist . :create)
                                (:if-exists . :supersede)
                                (:direction . :output))
        when (eq (getf options (car default-option) options) options)
        do (setf (getf options (car default-option)) (cdr default-option))
        finally (setq pathname `(ensure-directories-exist ,pathname))
                (return `(with-open-file (,stream ,pathname ,.options)

(defun directory-name (pathname)
  (let ((directory (pathname-directory pathname)))
    (when (cdr directory) (car (last directory)))))

(defun typed-pathname (pathname)
  "If the PATHNAME has no type, then make one with the :UNSPECIFIC type."
  (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 log-condition (condition)
  (let ((now (universal-time-string (get-universal-time))))
    (with-open-log (stream "kira:data;error.log")
      (format stream "~&[~A] ~A~%" now condition))))

(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)))
          ;; No existing vector is available.
          finally (setq vector (map-file-to-ivector truename upgraded-element-type))
                  (return-from mmap (caar (push (cons vector truename) *mmap-alist*))))
    ;; MAP-FILE-TO-IVECTOR will make a new vector, but
    ;; we'll adjust the existing vector to be equivalent.
    (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
                                                 :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)))))

(defvar *epipe-handler* nil
  "Called on EPIPE stream-io-error.")

(defmethod stream-io-error ((stream stream) (errno (eql #$EPIPE)) context)
  (if *epipe-handler* (funcall *epipe-handler* stream context) (call-next-method)))

(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