external/clem/src/print.lisp

   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 ;;;
  31
  32 (in-package :clem)
  33
  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)
  39
  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 "]")))
  62
  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))
  67   m)
  68
  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))))))
  79
  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)))))))
 107
 108