share/contrib/mcclim/formula.lisp

   1 ;; A simple proof-of-concept CLIM formatter for math formulae.
   2 ;; Magic fudge factors abound.
   3
   4 ;; FIXME: This is all a big hack.
   5
   6 (defparameter *text-size* 75)
   7
   8 (defgeneric display-formula (stream form))
   9 (defgeneric display-function (stream name))
  10 (defgeneric display-compound-form (form operator operands))
  11
  12
  13 (defmethod display-formula (stream form)
  14   (princ form stream))
  15
  16 (defmethod display-formula (stream (form list))
  17   (display-compound-form stream (first form) (rest form)))
  18
  19 (defmethod display-function (stream name)
  20   (princ name stream))
  21
  22 (defmethod display-compound-form (stream operator operands)
  23   (display-function stream operator)
  24   (write-char #\( stream)
  25   (loop for exp in operands and idx from 0 by 1 do
  26         (progn
  27           (unless (zerop idx)
  28             (write-string ", " stream))
  29           (display-formula stream exp)))
  30   (write-char #\) stream))
  31
  32 (defun connect-addition-operands (a b stream)
  33   "Print connecting operator between A and B, and present B (A should already have been printed)"
  34   (unless (and (listp b)
  35                (eq (first b) '-)
  36                (= (length b) 2))
  37     (write-string "+" stream))
  38   (display-formula stream b))
  39
  40 (defun print-in-parens (stream fn)
  41   (write-string "(" stream)
  42   (funcall fn)
  43   (write-string ")" stream))
  44
  45 (defmacro with-parens ((stream) &body body)
  46   `(print-in-parens ,stream (lambda () ,@body)))
  47
  48
  49 (defun connect-subtraction-operands (a b stream)
  50   "Print connecting operator between A and B, and present B (A should already have been printed)"
  51   (let ((outer (if (and (listp b)
  52                         (eq (first b) '-)
  53                         (= (length b) 2))
  54                    #'print-in-parens
  55                    #'funcall)))
  56     (write-string "-" stream)
  57     (funcall outer (lambda () (display-formula stream b)))))
  58
  59 (defun dopairs (fn list args)
  60   (when (and list (> (length list) 1))
  61     (apply fn (first list) (second list) args)
  62     (dopairs fn (rest list) args)))
  63
  64
  65
  66 (defmethod display-compound-form (stream (operator (eql '+)) operands)
  67   (when operands
  68     (display-formula stream (first operands))
  69     (dopairs #'connect-addition-operands operands (list stream))))
  70
  71 (defmethod display-compound-form (stream (operator (eql '-)) operands)
  72   (cond ((zerop (length operands))
  73          (error "No arguments to subtraction operator"))
  74         ((= 1 (length operands))
  75          (write-string "-" stream)
  76          (display-formula stream (first operands)))
  77         (t (display-formula stream (first operands))
  78            (dopairs #'connect-subtraction-operands operands (list stream)))))
  79
  80 (defun connect-multiplication-operands (a b stream)
  81   (write-string "*" stream)
  82   (display-formula stream b))
  83
  84 (defmethod display-compound-form (stream (operator (eql '*)) operands)
  85   (cond ((zerop (length operands))
  86          (error "No arguments to multiplication operator"))
  87         (t (display-formula stream (first operands))
  88            (dopairs #'connect-multiplication-operands operands (list stream)))))
  89
  90 (defun connect-division-operands (a b stream)
  91   (write-string "/" stream)
  92   (display-formula stream b))
  93
  94 (defmethod display-compound-form (stream (operator (eql '/)) operands)
  95   (cond ((zerop (length operands))
  96          (error "No arguments to division operator"))
  97         ((= 1 (length operands))
  98          (write-string "1/" stream)
  99          (display-formula stream (first operands)))
 100         (t (display-formula stream (first operands))
 101            (dopairs #'connect-division-operands operands (list stream)))))
 102
 103 (defmethod display-compound-form (stream (operator (eql 'expt)) operands)
 104   (display-formula stream (first operands))
 105   (write-string "^" stream)
 106   (display-formula stream (second operands)))
 107
 108 ;; Magic CLIM bits
 109
 110 (defmethod display-compound-form ((stream clim:extended-output-stream) (operator (eql '/)) operands)
 111   (cond ((zerop (length operands))
 112          (error "No arguments to division operator"))
 113         ((= 1 (length operands))  ;; FIXME
 114          (write-string "1/" stream)
 115          (display-formula stream (first operands)))
 116         ((= 2 (length operands)) ;; This is the pretty case which we should normalize toward.
 117          (multiple-value-bind (cx cy)  (clim:stream-cursor-position stream)
 118            (let* ((dividend-or (clim:with-output-to-output-record (stream)
 119                                  (display-formula stream (first operands))))
 120                   (divisor-or (clim:with-output-to-output-record (stream)
 121                                 (display-formula stream (second operands))))
 122                   (width (* 1.15 (max (clim:bounding-rectangle-width dividend-or)
 123                                       (clim:bounding-rectangle-width divisor-or))))
 124                   (sum-height (+ (clim:bounding-rectangle-height dividend-or)
 125                                  (clim:bounding-rectangle-height divisor-or)))
 126                   (split 1/4)
 127                   (thickness-ratio 0.65)
 128                   (size (* 0.04 sum-height))
 129                   (thickness (* thickness-ratio size))
 130                   (y0 (clim:bounding-rectangle-height dividend-or))
 131                   (y1 (+ y0 (* split size)))
 132                   (y2 (+ y0 size))
 133                   (combined-or (clim:with-output-to-output-record (stream)
 134                                  (setf (clim:output-record-position dividend-or)
 135                                        (values (/ (- width (clim:bounding-rectangle-width dividend-or)) 2)
 136                                                0)
 137                                        (clim:output-record-position divisor-or)
 138                                        (values (/ (- width (clim:bounding-rectangle-width divisor-or)) 2)
 139                                                y2))
 140                                  (clim:stream-add-output-record stream dividend-or)
 141                                  (clim:draw-line* stream 0 y1 width y1
 142                                                   :line-thickness thickness
 143                                                   :line-cap-shape :round)
 144                                  (clim:stream-add-output-record stream divisor-or))))
 145              (setf (clim:output-record-position combined-or)
 146                    (values cx
 147                            (- cy 3 (clim:bounding-rectangle-height dividend-or)
 148                               (- (/ (clim:text-style-height (clim:medium-text-style stream) stream) 2))))
 149                    #+NIL (clim:stream-cursor-position stream) #+NIL
 150                    (values (+ cx (clim:bounding-rectangle-width combined-or))
 151                            cy))
 152              (clim:stream-add-output-record stream combined-or)
 153              (clim:stream-close-text-output-record stream)
 154              #+NIL (clim:replay-output-record combined-or stream))))
 155         (t (display-formula stream (first operands))
 156            (dopairs #'connect-division-operands operands (list stream)))))
 157
 158 (defun superscript-text-size (size)
 159   (assert (numberp size))
 160   (max 10 (round (* 0.6 size))))  ;; FIXME stream
 161
 162 (defmethod display-compound-form ((stream clim:extended-output-stream) (operator (eql 'expt)) operands)
 163   (unless (= (length operands) 2)
 164     (error "EXPT requires 2 operands"))
 165   (let ((base-or (clim:with-new-output-record (stream)
 166                    (display-formula stream (first operands)))))
 167     (multiple-value-bind (cx cy)  (clim:stream-cursor-position stream)
 168       (let* ((*text-size* (superscript-text-size (clim:text-style-size (clim:medium-text-style stream))))
 169              (exponent-or (clim:with-output-to-output-record (stream)
 170                             (display-formula stream (second operands))))
 171              (h0 (clim:bounding-rectangle-height exponent-or))
 172              (h1 (clim:bounding-rectangle-height base-or))
 173              (dy (max 0.0 (- h0 (* 0.4 h1)))))
 174         (setf (clim:output-record-position exponent-or)
 175               (values cx (- cy dy)))
 176         (clim:stream-add-output-record stream exponent-or)
 177         (clim:stream-close-text-output-record stream)))))
 178
 179
 180 ;; This :around method is where most of the CLIM magic occurs (output is captured into
 181 ;; presentations, and some formatting kludgery occurs)
 182 (defmethod display-formula :around ((stream clim:extended-output-stream) form)
 183   (clim:with-text-size (stream *text-size*)
 184     (multiple-value-bind (cx cy)  (clim:stream-cursor-position stream)
 185       (let ((record (clim:with-output-to-output-record (stream) ;; FIXME why are forms seemingly not presented?
 186                       (clim:with-output-as-presentation (stream form (if (listp form) 'form (clim:presentation-type-of form))) ;; this is suspect..
 187                         (call-next-method stream form)))))
 188         (clim:with-bounding-rectangle* (x0 y0 x1 y1) record
 189            (setf (clim:output-record-position record) (values (+ x0 1 cx) (+ y0 cy))))
 190         (clim:stream-add-output-record stream record)
 191         (clim:stream-close-text-output-record stream)
 192         (multiple-value-bind (nx ny)  (clim:stream-cursor-position stream)
 193           (setf (clim:stream-cursor-position stream)
 194                 (values (+ cx 3 (clim:bounding-rectangle-width record)) cy)))
 195         #+NIL
 196         (clim:with-bounding-rectangle* (x0 y0 x1 y1) record
 197            (hef:debugf x0 y0 x1 y1)
 198            (clim:draw-rectangle* stream x0 y0 x1 y1 :filled nil :ink clim:+blue+))
 199         (when (clim:stream-drawing-p stream)
 200           (clim:replay-output-record record stream))))))
 201
 202 (defun foof ()
 203   (display-formula *standard-output*
 204                    '(+ 12.3 (* 2 pi) (- 2) (- 4 5) (/ (* 3 a b) (* 2 x)) (log 2) (fn 2 a b) (expt 2 x))))
 205
 206 (defun bar ()
 207   (display-formula *standard-output*
 208                    '(/ 1 (expt 2 (+ 1 (expt 3 (expt x x)))))))
 209
 210 (defun baz ()
 211   (display-formula *standard-output*
 212                    '(/ (/ (expt 2 (expt 2 x)) (/ (+ 1 (expt 2 x)) x))
 213                        (+ (expt 2 (expt 2 x)) (/ (+ 1 (expt 2 x)) x)))))
 214
 215
 216 (with-open-file (out "/home/hefner/maff.ps"
 217                      :direction :output
 218                      :if-exists :supersede)
 219     (CLIM:WITH-OUTPUT-TO-POSTSCRIPT-STREAM (*standard-output* out
 220                                             :multi-page t
 221                                             :scale-to-fit nil)
 222       (clim:with-room-for-graphics (*standard-output* :first-quadrant nil)
 223         (clim:with-text-family (*standard-output* :serif)
 224           (dotimes (i 10) (terpri))
 225           (baz) ))))