(in-package :clf)

;; параметры

(defparameter *output-filename-format* "~8,'0d.field")
(defparameter *nodes-filename-format* "~8,'0d.nodes")

;; макросы

(defun complain-key (function key)
  (error "Функция ~a требует задания ключа ~a" function key))

(defmacro check-mandatory-keys (function &rest keys)
  `(progn ,@(loop for key in keys
	       collect (let ((key-name (or (and (consp key)
						(car key))
					   key))
			     (key-sym (or (and (consp key)
					       (cadr key))
					  key)))
			 `(unless ,key-sym
			    (complain-key ',function ',key-name))))))

(defmacro send-output-to-file (filename &body body)
  (let ((file (gensym)))
    `(with-open-file (,file ,filename
			    :direction :output
			    :if-exists :supersede
			    :if-does-not-exist :create)
       (let ((*standard-output* ,file))
	 (progn ,@body)))))

(defmacro make-header-for-class (class-name)
  (let ((headers-slot (intern (format nil "HEADERS/~s" class-name))))
    `(defmethod make-header ((obj ,class-name) (format-list list))
       (let ((format-list
	      (mapcar (lambda (header)
			(if (equal (header-inheritance-class header)
				   ',class-name)
			    (slot-value obj ',headers-slot)
			    header))
		      format-list)))
	 (if (filter #'inherited-header-p format-list)
	     (call-next-method obj format-list)
	     (reduce #'append format-list))))))

(defmacro make-header-for-class/dimensions (class-name)
  (let ((headers-slot (intern (format nil "HEADERS/~s" class-name))))
    `(defmethod make-header ((obj ,class-name) (format-list list))
       (let ((format-list
	      (mapcar (lambda (header)
			(if (equal (header-inheritance-class header)
				   ',class-name)
			    (take (slot-value obj ',headers-slot)
				  (dimensions obj))
			    header))
		      format-list)))
	 (if (filter #'inherited-header-p format-list)
	     (call-next-method obj format-list)
	     (reduce #'append format-list))))))

(defmacro print-functions-for-class (class-name header-format)
  `(progn
     (defmethod print-headers (stream (obj ,class-name))
       (let* ((header (make-header obj ',header-format))
	      (template (string-join (loop repeat (length header) collect "~d"))))
	 (apply #'format stream template header)))
     (defmethod print-content (stream (obj ,class-name) &key (with-headers t))
       (let* ((header (make-header obj ',header-format))
	      (template (string-join (loop repeat (length header) collect "~d")))
	      (accessors (mapcar #'symbol-function header)))
	 (when with-headers
	   (apply #'format stream template header)
	   (newline stream))
	 (apply #'format stream template
		(mapcar (lambda (accessor) (funcall accessor obj))
			accessors))))))

;; вспомогательные функции

(defun enbreak (text)
  "Остановиться и запустить дебаггер, если выставлен в истину флаг
`*enable-breaks*'"
  (when *enable-breaks* (break text)))

(defun dbgmsg (text)
  (when *debug-messages*
    (format t text)))

(defun vector-double-float->vector (agrid)
  "В документации сказано (см. раздел 11 системы antik), что объекты
типа `vector-double-float' можно преобразовать к типу `vector'
автоматически при помощи функции `cl-array' только в том случае, если
эти объекты не были порождены cffi-функцией. К сожалению, у меня
именно такой случай, поэтому есть необходимость разбирать поля
полученных структур вручную."
  (list->vector
   (loop for i to (1- *number-of-conservative-variables*)
	       for v = (cons (grid:aref agrid i) v)
	       finally (return (reverse v)))))

(defun curryr (function &rest args)
  (lambda (x) (apply function x args)))

(defun filter (&rest args)
  (apply #'remove-if-not args))

(defun take (lst num)
  (subseq lst 0 num))

(defun vector->list (v)
  (coerce v 'list))

(defun list->vector (l)
  (coerce l 'vector))

(defun string-join (str-list &optional (separator " "))
  (with-output-to-string (out)
    (princ (car str-list) out)
    (dolist (s (cdr str-list))
      (princ separator out)
      (princ s out))))

(defun andmap (function &rest lists)
  (reduce (lambda (elem acc) (and elem acc))
	  (apply #'mapcar `(,function ,@lists))))

(defun newline (&optional (stream t))
  (format stream "~%"))

(defun 2+ (num)
  (+ num 2))

(defun constant-function (constant)
  (lambda (&rest args) args constant))

(defun noop (&rest args)
  "Do nothing."
  (declare (ignore args))
  (values))

;; функции формирования заголовка

(defun inherited-header-p (header)
  (and (consp header)
       (equal (car header) 'inherit)))

(defun header-inheritance-class (header)
  (cdr header))


;; методы

(defgeneric make-header (obj format-list)
  (:documentation "Подставляет заголовки объекта `obj' в нужные места
  `format-list'. Вставляет они их туда, где в `format-list' стоит
  конструкция (inherit . obj-type), где `obj-type' совпадает с типом
  объекта"))

(defgeneric print-headers (stream obj)
  (:documentation "Печатает заголовки объекта `obj'."))

(defgeneric print-content (stream obj &key with-headers)
  (:documentation "Печатает содержимое объекта `obj'. Если установлен
  флаг `:with-headers', то печатает вместе с заголовком"))

(defgeneric P (vars)
  (:documentation "Возвращает значение P в ячейке"))

(defgeneric phi (vars)
  (:documentation "Возвращает значение phi в ячейке"))

(defgeneric ug (vars)
  (:documentation "Возвращает значение ug в ячейке"))

(defgeneric ul (vars)
  (:documentation "Возвращает значение ul в ячейке"))

(defgeneric rg (vars)
  (:documentation "Возвращает значение rg в ячейке"))

(defgeneric (setf P) (num vars)
  (:documentation "Устанавливает значение P в ячейке"))

(defgeneric (setf phi) (num vars)
  (:documentation "Устанавливает значение phi в ячейке"))

(defgeneric (setf ug) (num vars)
  (:documentation "Устанавливает значение ug в ячейке"))

(defgeneric (setf ul) (num vars)
  (:documentation "Устанавливает значение ul в ячейке"))

(defgeneric (setf rg) (num vars)
  (:documentation "Устанавливает значение rg в ячейке"))

(defgeneric x-coord (coordinate)
  (:documentation "Возвращает координату по оси x"))

(defgeneric y-coord (coordinate)
  (:documentation "Возвращает координату по оси y"))

(defgeneric z-coord (coordinate)
  (:documentation "Возвращает координату по оси z"))

(defgeneric (setf x-coord) (new coordinate)
  (:documentation "Устанавливает новое значение для координаты по оси x"))

(defgeneric (setf y-coord) (new coordinate)
  (:documentation "Устанавливает новое значение для координаты по оси y"))

(defgeneric (setf z-coord) (new coordinate)
  (:documentation "Устанавливает новое значение для координаты по оси z"))

(defgeneric distance (coord1 coord2)
  (:documentation "Возвращает расстояние между `coord1' и `coord2'"))

(defgeneric x-size (cell)
  (:documentation "Возвращает размер ячейки по оси x"))

(defgeneric y-size (cell)
  (:documentation "Возвращает размер ячейки по оси y"))

(defgeneric z-size (cell)
  (:documentation "Возвращает размер ячейки по оси z"))

(defgeneric (setf x-size) (new cell)
  (:documentation "Устанавливает новое значение размера ячейки по оси x"))

(defgeneric (setf y-size) (new cell)
  (:documentation "Устанавливает новое значение размера ячейки по оси y"))

(defgeneric (setf z-size) (new cell)
  (:documentation "Устанавливает новое значение размера ячейки по оси z"))

(defgeneric cell (grid indx)
  (:documentation "Возвращает ячейку (не копию, а саму ячейку) из
  сетки `grid' по индуксу `indx'"))

(defgeneric (setf cell) (obj grid indx)
  (:documentation "Устанавливает новое значение в ячейку из сетки
  `grid' по индексу `indx'"))

(defgeneric print-grid (grid &key print-out-border)
  (:documentation "Печатает сетку"))

(defgeneric clone (obj)
  (:documentation "Создаёт копию объекта и возвращает её в качестве
  значения"))

(defgeneric coord (&rest numbers)
  (:documentation "Создаёт объект типа `cell-coordinates'
  инициализированный списком чисел `numbers'"))

(defgeneric index (&rest numbers)
  (:documentation "Создаёт объект типа `cell-index' инициализированный
  списком чисел `numbers'"))

(defgeneric make-dummy-cell (type)
  (:documentation "Создаёт новую неинициализированную ячейку типа
  `type'"))
  
(defgeneric x-index (index)
  (:documentation "Возвращает соответствующий индекс объекта `index'"))

(defgeneric y-index (index)
  (:documentation "Возвращает соответствующий индекс объекта `index'"))

(defgeneric z-index (index)
  (:documentation "Возвращает соответствующий индекс объекта `index'"))

(defgeneric init-grid (grid &key &allow-other-keys)
  (:documentation "Устанавливает значения координат и размеров
  ячеек во всей сетке"))

(defgeneric update-boundary-cells (grid)
  (:documentation "Обновляет заграничные ячейки в соответствии с
  выставленными сеткой граничными условиями"))

(defgeneric zeroe (grid index border)
  (:documentation "Граничное условие экстраполяции нулевого порядка"))

(defgeneric fixed (grid index border)
  (:documentation "Граничное условие фиксированных значений"))

(defgeneric border-flux (grid indx tau border)
  (:documentation "Считает поток через границу ячейки. Граница может
быть одним из значений: :left :right :top :down"))

(defgeneric max-timestep (grid method cu)
  (:documentation "Считает максимальный шаг по времени для выбранного
метода `method'. Метод может быть одним из следующих
значений: :lax-frederichs :kurganov-tadmor"))

(defgeneric make-step (grid newgrid tau method)
  (:documentation "Делает в сетке `grid' шаг по времени величиной
  `tau'. Результат записывается в `newgrid'"))

(defgeneric flux (vars)
  (:documentation "Возвращает потоковый вектор, рассчитанный по
  переменным `vars'"))

(defgeneric source (vars)
  (:documentation "Возвращает вектор источниковых членов, рассчитанный
  по переменным `vars'"))

(defgeneric update-boundary-cells (grid)
  (:documentation "Устанавливает в сетке `grid' заграничные ячейки в
  соответствии с её граничными условиями"))

(defgeneric minmod (type &rest params)
  (:documentation "Вычисляет минимум по модулю"))

(defgeneric count-convergence (old new)
  (:documentation "Вычисляет невязку по старым и новым
  параметрам. Параметры, вообще говоря, могут быть как ячейками, так и
  сетками. Если параметры являются ячейками, то метод должен
  возвращать число. Если сетками, то вычисляется невязка в каждой
  ячейке, после чего она записывается в новую сетку."))