Commit 012042d2 authored by Liam M. Healy's avatar Liam M. Healy
Browse files

Split formatting functions up by non-grid, array, foreign-array

Move formatting functions, and in the case of #'nf, write new
methods. Functions and methods are placed in the appropriate system
directory. Systems antik-base, grid, foreign-array all load an all
tests pass at each system load.
parent ee2c6490
;; Foreign array system definition
;; Liam Healy 2012-03-23 19:06:29EDT foreign-array.asd
;; Time-stamp: <2014-01-07 23:30:09EST foreign-array.asd>
;; Time-stamp: <2014-01-08 22:58:46EST foreign-array.asd>
;; Copyright 2012 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -43,7 +43,7 @@
(:file "foreign-array" :depends-on ("types" "element-types"))
(:file "vector-matrix" :depends-on ("element-types" "subclass"))
(:file "methods" :depends-on ("foreign-array" "vector-matrix"))
(:file "print-foreign-array")))))
(:file "format-output")))))
(asdf:defsystem-connection #:foreign-array-tests
:serial t
......
;; Format of foreign (C or C-compatible) arrays
;; Liam Healy 2008-12-28 10:44:22EST foreign-array.lisp
;; Time-stamp: <2013-11-30 15:34:44EST print-foreign-array.lisp>
;; Time-stamp: <2014-01-08 22:58:25EST print-foreign-array.lisp>
;;
;; Copyright 2013 Liam M. Healy
;; Copyright 2013, 2014 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -29,3 +29,6 @@
(if (and *print-foreign-array-readably* *print-contents*)
(antik::cl-readable-nf (antik::nf-grid object stream))
(call-next-method)))
(defmethod antik:nf ((object foreign-array) &optional (stream *standard-output*))
(antik::nf-grid object stream))
;; Antik system definition
;; Liam Healy 2010-12-24 09:43:28EST antik.asd
;; Time-stamp: <2014-01-07 23:22:53EST grid.asd>
;; Time-stamp: <2014-01-08 23:13:23EST grid.asd>
;; Copyright 2011, 2012, 2013, 2014 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
......@@ -49,7 +49,8 @@
(:file "iterate" :depends-on ("compose"))
(:file "mathematics" :depends-on ("map"))
(:file "index-functions")
(:file "indexed")))))
(:file "indexed" :depends-on ("specification"))
(:file "parameters")))))
(asdf:defsystem-connection #:grid-tests
:serial t
......
;; Format numerical output for grids and sequences
;; Liam Healy Wed Dec 11 2002 - 16:37
;; Time-stamp: <2014-01-08 22:56:50EST format-output.lisp>
;; Copyright 2011, 2013, 2014 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; 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/>.
(in-package :antik)
;;;;****************************************************************************
;;;; Grids
;;;;****************************************************************************
(defmethod nf ((object array) &optional (stream *standard-output*))
(nf-grid object stream))
;;;;****************************************************************************
;;;; Sequences nf
;;;;****************************************************************************
(define-parameter nf :vector-format
:value :horizontal :type (member :horizontal :vertical :coordinate-unit-vectors)
:documentation
"Rank-1 grids (vectors) are formatted as rows, columns or as linear
combination of coordinate unit vectors.")
(define-parameter nf :components
:value '("I" "J" "K") :type list
:documentation
"Names of vector components to use :vector-format is :coordinate-unit-vectors.")
(define-parameter nf :tex-element-separator
:value (format nil " \\\\~%") :type string
:documentation
"What to put between vertically separated elements for LaTeX.")
(define-parameter nf :tex-decimal-align
:value t :type boolean
:documentation
"Align columns of numbers on decimal point in LaTeX.")
(define-parameter nf :vertical-element-separator
:value #\Newline :type character
:documentation
"What to put between vertically separated elements for plain style.")
(define-parameter nf :horizontal-element-separator
:value #\space :type character
:documentation
"What to put between horizontally separated elements for plain style.")
(defun vector-component-names (i)
"The name of the ith vector component."
(let ((source (nf-option :components)))
(elt source (mod i (length source)))))
(defmethod nf ((object sequence) &optional (stream *standard-output*))
(when (grid:gridp object)
(nf-grid object stream)))
#+(or)
(format stream "~a~{~a~^ ~})"
(if (vectorp object) "#(" "'(")
(map 'list (lambda (o) (nf-string o)) object))
(defun nf-grid (object &optional (stream *standard-output*))
"Format the grid."
(grid::print-grid-readably
(when (nf-readably) object)
(lambda (s)
(ecase (grid:rank object)
(1 (with-nf-options (:vector-format (if (nf-readably) :horizontal (nf-option :vector-format)))
(if (member (nf-option :vector-format) '(:horizontal :vertical))
(nf-matrix object s)
(nf-vector object s))))
(2 (nf-matrix object s))))
stream)
object)
(defun nf-vector (object &optional (stream *standard-output*))
"Format the one dimensional grid."
;; Note: cannot handle lists yet.
;; This is called from nf-grid, called only when :vector-format is :coordinate-unit-vectors.
(dotimes (i (grid:dim0 object))
;; iterate formatting each element
(with-nf-options
;; If formatting as a linear combination with element labels,
;; force a + sign except for the first element
;; to make a mathematical expression.
(print-sign
(and (eq (nf-option :vector-format) :coordinate-unit-vectors)
(not (zerop i))))
;; format the element itself
(nf (grid:aref object i) stream)
;; append either the element label or the separator
(princ
(if (nf-readably)
#\space
(if texstyle
(case (nf-option :vector-format)
(:coordinate-unit-vectors (format nil "\\unitvec{~a}" (vector-component-names i)))
(:vertical "\\\\")
(:horizontal " "))
(case (nf-option :vector-format)
(:coordinate-unit-vectors (vector-component-names i))
(:vertical #\newline)
(:horizontal #\space))))
stream))))
(defun parenstyle (outer)
"Parentheses should be used in this case."
(and outer
(or (member (nf-option :style) '(:readable))
(numberp (nf-option :style)))))
(defun nf-matrix (object &optional (stream *standard-output*))
"Format the two dimensional grid, or the one dimensional grid horizontally or vertically."
(flet ((element (i j)
(if (grid:dim1 object)
(grid:aref object i j)
(case (nf-option :vector-format)
(:vertical (grid:aref object i))
(:horizontal (grid:aref object j))))))
(let ((dim1 (or (grid:dim1 object)
(if (eq (nf-option :vector-format) :vertical)
1
(grid:dim0 object))))
(dim0 (if (or (grid:dim1 object) (eq (nf-option :vector-format) :vertical))
(grid:dim0 object)
1)))
(when texstyle
(format stream "\\left[\\begin{array}{~a}~&"
(if (nf-option :tex-decimal-align)
(reduce (alexandria:curry #'concatenate 'string)
(make-list dim1 :initial-element "r@{.}l"))
(make-string dim1 :initial-element #\r))))
(when (parenstyle t) (princ #\( stream)) ; open paren for whole array
(dotimes (i dim0)
(when (parenstyle (grid:dim1 object)) (princ #\( stream)) ; open paren for a row
(dotimes (j dim1)
(if (and texstyle (nf-option :tex-decimal-align))
(princ
(substitute #\& #\. (nf-string (element i j)))
stream)
(nf (element i j) stream))
(when (< j (1- dim1))
(if texstyle
(princ " & " stream)
(princ (nf-option :horizontal-element-separator) stream))))
(when (parenstyle (grid:dim1 object)) (princ #\) stream)) ; close paren for a row
(when (< i (1- dim0))
(if texstyle
(princ (nf-option :tex-element-separator) stream)
(princ (nf-option :vertical-element-separator) stream))))
;; close out TeX array
(when texstyle (format stream "~&\\end{array}\\right]"))
(when (parenstyle t) (princ #\) stream)))) ; close paren for whole array
nil)
;; Global/local parameters to pass to functions
;; Liam Healy 2013-02-16 20:51:14HST variable-metadata.lisp
;; Time-stamp: <2014-01-08 22:26:33EST parameters.lisp>
;; Copyright 2011, 2013, 2014 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; 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/>.
(in-package :antik)
(export '(make-parameters-from-table))
;;;;****************************************************************************
;;;; Make parameters
;;;;****************************************************************************
;;; This function is designed to read an org-mode table that is parsed and passed to CL by org-babel.
;;; See the file input-output/org-mode.lisp for documentation and examples
(defun make-parameters-from-table
(table
&key (headerp t) (category (first *parameters*)) (type grid::*default-element-type*) (prefix :par))
"From the list of lists, define the parameters. The optional header should have column names. These column names include 'category 'name 'value 'type 'description ('value and 'default mean the same thing). Any column names not specified will receive a default value. Any values in the cells that are empty will receive a default value. Any columns given with a header not on the list will be ignored. Category must already exist."
(let* ((header (when headerp (first table)))
(tbl (if headerp (rest table) table))
(catpos (position :category header :test 'string-equal))
(nampos (position :name header :test 'string-equal))
(valpos (or (position :default header :test 'string-equal)
(position :value header :test 'string-equal)))
(typepos (position :type header :test 'string-equal))
(descpos (position :description header :test 'string-equal))
(counter 0))
;; Should the type be
(dolist (row tbl)
(incf counter)
(let ((valtype
(find-symbol
(string-upcase
(if (and typepos (stringp (nth typepos row)) (plusp (length (nth typepos row))))
(nth typepos row)
type)))))
(make-parameter
;; Category
(alexandria:make-keyword
(string-upcase
(if (and catpos (stringp (nth catpos row)) (plusp (length (nth catpos row))))
(nth catpos row)
category)))
;; Name
(alexandria:make-keyword
(if (and nampos (stringp (nth nampos row)) (plusp (length (nth nampos row))))
(string-upcase (nth nampos row))
(alexandria:symbolicate prefix (format nil "~4,'0,d" counter))))
:value ; (default, or initial)
(let ((val (when (and valpos (not (equal (nth valpos row) ""))) (nth valpos row))))
(etypecase val
(number val)
(string (read-from-string val))
(null (antik:coerce grid::*default-numerical-value* valtype))))
:type valtype
:documentation
(if (and descpos (plusp (length (nth descpos row))))
(nth descpos row)
"No documentation."))))))
;; Format numerical output
;; Liam Healy Wed Dec 11 2002 - 16:37
;; Time-stamp: <2013-05-26 18:46:55EDT format-output.lisp>
;; Time-stamp: <2014-01-08 23:04:11EST format-output.lisp>
;; Copyright 2011, 2013 Liam M. Healy
;; Copyright 2011, 2013, 2014 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -67,10 +67,7 @@
(defgeneric nf (object &optional stream)
(:documentation "Format output for numerical objects. If stream is nil, use *standard-output*.")
(:method ((object t) &optional (stream *standard-output*))
(if (grid:gridp object)
(nf-grid object stream)
;; by default, just print to stream
(princ object stream))))
(princ object stream)))
(defun nf-string (object)
"Format output for numerical objects to a new string."
......@@ -123,148 +120,9 @@
;;; More in float.lisp
;;;;****************************************************************************
;;;; Sequences nf
;;;; Readable format and re-creation of object as it is formatted
;;;;****************************************************************************
(define-parameter nf :vector-format
:value :horizontal :type (member :horizontal :vertical :coordinate-unit-vectors)
:documentation
"Rank-1 grids (vectors) are formatted as rows, columns or as linear
combination of coordinate unit vectors.")
(define-parameter nf :components
:value '("I" "J" "K") :type list
:documentation
"Names of vector components to use :vector-format is :coordinate-unit-vectors.")
(define-parameter nf :tex-element-separator
:value (format nil " \\\\~%") :type string
:documentation
"What to put between vertically separated elements for LaTeX.")
(define-parameter nf :tex-decimal-align
:value t :type boolean
:documentation
"Align columns of numbers on decimal point in LaTeX.")
(define-parameter nf :vertical-element-separator
:value #\Newline :type character
:documentation
"What to put between vertically separated elements for plain style.")
(define-parameter nf :horizontal-element-separator
:value #\space :type character
:documentation
"What to put between horizontally separated elements for plain style.")
(defun vector-component-names (i)
"The name of the ith vector component."
(let ((source (nf-option :components)))
(elt source (mod i (length source)))))
(defmethod nf ((object sequence) &optional (stream *standard-output*))
(when (grid:gridp object)
(nf-grid object stream)))
#+(or)
(format stream "~a~{~a~^ ~})"
(if (vectorp object) "#(" "'(")
(map 'list (lambda (o) (nf-string o)) object))
(defun nf-grid (object &optional (stream *standard-output*))
"Format the grid."
(grid::print-grid-readably
(when (nf-readably) object)
(lambda (s)
(ecase (grid:rank object)
(1 (with-nf-options (:vector-format (if (nf-readably) :horizontal (nf-option :vector-format)))
(if (member (nf-option :vector-format) '(:horizontal :vertical))
(nf-matrix object s)
(nf-vector object s))))
(2 (nf-matrix object s))))
stream)
object)
(defun nf-vector (object &optional (stream *standard-output*))
"Format the one dimensional grid."
;; Note: cannot handle lists yet.
;; This is called from nf-grid, called only when :vector-format is :coordinate-unit-vectors.
(dotimes (i (grid:dim0 object))
;; iterate formatting each element
(with-nf-options
;; If formatting as a linear combination with element labels,
;; force a + sign except for the first element
;; to make a mathematical expression.
(print-sign
(and (eq (nf-option :vector-format) :coordinate-unit-vectors)
(not (zerop i))))
;; format the element itself
(nf (grid:aref object i) stream)
;; append either the element label or the separator
(princ
(if (nf-readably)
#\space
(if texstyle
(case (nf-option :vector-format)
(:coordinate-unit-vectors (format nil "\\unitvec{~a}" (vector-component-names i)))
(:vertical "\\\\")
(:horizontal " "))
(case (nf-option :vector-format)
(:coordinate-unit-vectors (vector-component-names i))
(:vertical #\newline)
(:horizontal #\space))))
stream))))
(defun parenstyle (outer)
"Parentheses should be used in this case."
(and outer
(or (member (nf-option :style) '(:readable))
(numberp (nf-option :style)))))
(defun nf-matrix (object &optional (stream *standard-output*))
"Format the two dimensional grid, or the one dimensional grid horizontally or vertically."
(flet ((element (i j)
(if (grid:dim1 object)
(grid:aref object i j)
(case (nf-option :vector-format)
(:vertical (grid:aref object i))
(:horizontal (grid:aref object j))))))
(let ((dim1 (or (grid:dim1 object)
(if (eq (nf-option :vector-format) :vertical)
1
(grid:dim0 object))))
(dim0 (if (or (grid:dim1 object) (eq (nf-option :vector-format) :vertical))
(grid:dim0 object)
1)))
(when texstyle
(format stream "\\left[\\begin{array}{~a}~&"
(if (nf-option :tex-decimal-align)
(reduce (alexandria:curry #'concatenate 'string)
(make-list dim1 :initial-element "r@{.}l"))
(make-string dim1 :initial-element #\r))))
(when (parenstyle t) (princ #\( stream)) ; open paren for whole array
(dotimes (i dim0)
(when (parenstyle (grid:dim1 object)) (princ #\( stream)) ; open paren for a row
(dotimes (j dim1)
(if (and texstyle (nf-option :tex-decimal-align))
(princ
(substitute #\& #\. (nf-string (element i j)))
stream)
(nf (element i j) stream))
(when (< j (1- dim1))
(if texstyle
(princ " & " stream)
(princ (nf-option :horizontal-element-separator) stream))))
(when (parenstyle (grid:dim1 object)) (princ #\) stream)) ; close paren for a row
(when (< i (1- dim0))
(if texstyle
(princ (nf-option :tex-element-separator) stream)
(princ (nf-option :vertical-element-separator) stream))))
;; close out TeX array
(when texstyle (format stream "~&\\end{array}\\right]"))
(when (parenstyle t) (princ #\) stream)))) ; close paren for whole array
nil)
(defun object-as-nf (object)
"Define a new object exactly as the current nf options print an existing one. This function can be used for example to define a number exactly as the rounded print format of another one."
(read-from-string
......
;; Global/local parameters to pass to functions
;; Liam Healy 2013-02-16 20:51:14HST variable-metadata.lisp
;; Time-stamp: <2013-09-21 18:43:45EDT parameters.lisp>
;; Time-stamp: <2014-01-08 22:28:46EST parameters.lisp>
;; Copyright 2011, 2013 Liam M. Healy
;; Copyright 2011, 2013, 2014 Liam M. Healy
;; Distributed under the terms of the GNU General Public License
;;
;; This program is free software: you can redistribute it and/or modify
......@@ -253,55 +253,3 @@
(format-list (mapcar 'symbol-name (parameter-list category)) nil)))
(format stream "~&Parameter categories: ~a"
(format-list (category-list) nil))))
;;;;****************************************************************************
;;;; Make parameters
;;;;****************************************************************************
;;; This function is designed to read an org-mode table that is parsed and passed to CL by org-babel.
;;; See the file input-output/org-mode.lisp for documentation and examples
(defun make-parameters-from-table
(table
&key (headerp t) (category (first *parameters*)) (type grid::*default-element-type*) (prefix :par))
"From the list of lists, define the parameters. The optional header should have column names. These column names include 'category 'name 'value 'type 'description ('value and 'default mean the same thing). Any column names not specified will receive a default value. Any values in the cells that are empty will receive a default value. Any columns given with a header not on the list will be ignored. Category must already exist."
(let* ((header (when headerp (first table)))
(tbl (if headerp (rest table) table))
(catpos (position :category header :test 'string-equal))
(nampos (position :name header :test 'string-equal))
(valpos (or (position :default header :test 'string-equal)
(position :value header :test 'string-equal)))
(typepos (position :type header :test 'string-equal))
(descpos (position :description header :test 'string-equal))
(counter 0))
;; Should the type be
(dolist (row tbl)
(incf counter)
(let ((valtype
(find-symbol
(string-upcase
(if (and typepos (stringp (nth typepos row)) (plusp (length (nth typepos row))))
(nth typepos row)
type)))))
(make-parameter
;; Category
(alexandria:make-keyword
(string-upcase
(if (and catpos (stringp (nth catpos row)) (plusp (length (nth catpos row))))
(nth catpos row)
category)))
;; Name
(alexandria:make-keyword
(if (and nampos (stringp (nth nampos row)) (plusp (length (nth nampos row))))
(string-upcase (nth nampos row))
(alexandria:symbolicate prefix (format nil "~4,'0,d" counter))))
:value ; (default, or initial)
(let ((val (when (and valpos (not (equal (nth valpos row) ""))) (nth valpos row))))
(etypecase val
(number val)
(string (read-from-string val))
(null (antik:coerce grid::*default-numerical-value* valtype))))
:type valtype
:documentation
(if (and descpos (plusp (length (nth descpos row))))
(nth descpos row)
"No documentation."))))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment