Documentation, compile, and initialization cleanup.
[CommonLispStat.git] / external / clem / src / print.lisp
blob8dfa637f0571f22675d70e745cfff0672e976e8c
1 ;;; print.lisp
2 ;;; macros, functions and methods for matrix element access
3 ;;;
4 ;;; Copyright (c) 2004-2006 Cyrus Harmon (ch-lisp@bobobeach.com)
5 ;;; All rights reserved.
6 ;;;
7 ;;; Redistribution and use in source and binary forms, with or without
8 ;;; modification, are permitted provided that the following conditions
9 ;;; are met:
10 ;;;
11 ;;; * Redistributions of source code must retain the above copyright
12 ;;; notice, this list of conditions and the following disclaimer.
13 ;;;
14 ;;; * Redistributions in binary form must reproduce the above
15 ;;; copyright notice, this list of conditions and the following
16 ;;; disclaimer in the documentation and/or other materials
17 ;;; provided with the distribution.
18 ;;;
19 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
20 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
21 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
22 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
23 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
24 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
25 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
26 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
27 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
28 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
29 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
30 ;;;
32 (in-package :clem)
34 (defparameter *print-matrix-newlines* t)
35 (defparameter *print-matrix-float-format* nil)
36 (defparameter *matrix-print* t)
37 (defparameter *matrix-print-row-limit* 8)
38 (defparameter *matrix-print-col-limit* 8)
40 (defgeneric print-range (m startr endr startc endc &optional stream))
41 (defmethod print-range ((m matrix)
42 (startr fixnum) (endr fixnum)
43 (startc fixnum) (endc fixnum)
44 &optional (stream t))
45 (let ((val-format-spec (if *print-matrix-float-format*
46 *print-matrix-float-format*
47 (val-format (class-of m)))))
48 (format stream "[")
49 (do ((i startr (1+ i)))
50 ((> i endr))
51 (unless (= i startr)
52 (princ "; " stream)
53 (if *print-matrix-newlines*
54 (progn
55 (format stream "~&~1,0T"))))
56 (do ((j startc (1+ j)))
57 ((> j endc))
58 (format stream (if (= j startc)
59 val-format-spec
60 (concatenate 'string " " val-format-spec)) (mref m i j))))
61 (format stream "]")))
63 (defgeneric print-matrix (m))
64 (defmethod print-matrix ((m matrix))
65 (destructuring-bind (endr endc) (mapcar #'1- (dim m))
66 (print-range m 0 endr 0 endc))
69 (defun print-matrix-line (obj stream val-format-spec i startc endc lastcol)
70 (do ((j startc (1+ j)))
71 ((> j endc))
72 (format stream (if (= j startc)
73 val-format-spec
74 (concatenate 'string " " val-format-spec)) (mref obj i j)))
75 (cond ((>= lastcol (1- *matrix-print-col-limit*))
76 (if (= lastcol (1- *matrix-print-col-limit*))
77 (format stream (concatenate 'string " " val-format-spec) (mref obj i lastcol))
78 (format stream (concatenate 'string " ... " val-format-spec) (mref obj i lastcol))))))
80 (defmethod print-object ((obj matrix) stream)
81 (print-unreadable-object (obj stream :type t :identity (not *matrix-print*))
82 (when *matrix-print*
83 (cond ((= (length (matrix-dimensions obj)) 2)
84 (let ((startr 0) (endr (min (1- (rows obj)) (- *matrix-print-row-limit* 2)))
85 (startc 0) (endc (min (1- (cols obj)) (- *matrix-print-col-limit* 2))))
86 (let ((val-format-spec (if *print-matrix-float-format*
87 *print-matrix-float-format*
88 (val-format (class-of obj))))
89 (lastrow (1- (rows obj)))
90 (lastcol (1- (cols obj))))
91 (format stream "[")
92 (do ((i startr (1+ i)))
93 ((> i endr))
94 (unless (= i startr)
95 (princ "; " stream)
96 (if *print-matrix-newlines*
97 (progn
98 (format stream "~&~1,0T"))))
99 (print-matrix-line obj stream val-format-spec i startc endc lastcol))
100 (cond ((>= lastrow (1- *matrix-print-row-limit*))
101 (if (= lastrow (1- *matrix-print-row-limit*))
102 (format stream (concatenate 'string ";~&~1,0T"))
103 (format stream (concatenate 'string ";~& ... ~&~1,0T")))
104 (print-matrix-line obj stream val-format-spec lastrow startc endc lastcol)))
105 (format stream "]"))))
106 (t (format stream "of dimensions ~A" (matrix-dimensions obj)))))))