← Back to branch summary

~registry/texmacs/trunk

« back to all changes in this revision

Viewing changes to src/plugins/maxima/lisp/texmacs-maxima-5.9.0.lisp

  • Committer: mgubi
  • Date: 2009-06-04 15:13:41 UTC
  • Revision ID: svn-v4:64cb5145-927a-446d-8aed-2fb7b4773692:trunk:2717
Support for X11 TeXmacs.app on Mac

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/plugins/maxima/lisp/texmacs-maxima-5.9.0.lisp
1
 
(in-package "MAXIMA")
2
 
 
3
 
(DEFUN MAIN-PROMPT ()
4
 
  (FORMAT () "(~A~D) "
5
 
    (STRIPDOLLAR $INCHAR) $LINENUM))
6
 
 
7
 
;(DEFUN BREAK-PROMPT ()
8
 
;  (declare (special $prompt))
9
 
;  (format nil "~A" (STRIPDOLLAR $PROMPT)))
10
 
 
11
 
(DEFMFUN DISPLA (FORM &aux #+kcl(form form))
12
 
  (IF (OR (NOT #.TTYOFF) #.WRITEFILEP)
13
 
      (cond #+Franz ($typeset (apply #'$photot (list form)))
14
 
            ((eq $display2d '$texmacs) (latex form))
15
 
            ($DISPLAY2D
16
 
             (LET ((DISPLAYP T)
17
 
                   (LINEARRAY (IF DISPLAYP (MAKE-array 80.) LINEARRAY))
18
 
                   (MRATP (CHECKRAT FORM))
19
 
                   (#.WRITEFILEP #.WRITEFILEP)
20
 
                   (MAXHT     1) (MAXDP   0) (WIDTH   0)
21
 
                   (HEIGHT    0) (DEPTH   0) (LEVEL   0) (SIZE   2)
22
 
                   (BREAK     0) (RIGHT   0) (LINES   1) BKPT
23
 
                   (BKPTWD    0) (BKPTHT  1) (BKPTDP  0) (BKPTOUT 0)
24
 
                   (BKPTLEVEL 0) IN-P
25
 
                   (MOREFLUSH D-MOREFLUSH)
26
 
                   MORE-^W
27
 
                   (MOREMSG D-MOREMSG))
28
 
               (UNWIND-PROTECT
29
 
                (PROGN (SETQ FORM (DIMENSION FORM
30
 
                                             NIL 'MPAREN 'MPAREN 0 0))
31
 
                       (CHECKBREAK FORM WIDTH)
32
 
                       (OUTPUT FORM (IF (AND (NOT $LEFTJUST) (= 2 LINES))
33
 
                                        (f- LINEL (f- WIDTH BKPTOUT))
34
 
                                        0))
35
 
                       (IF (AND SMART-TTY (NOT (AND SCROLLP (NOT $CURSORDISP)))
36
 
                                (> (CAR (CURSORPOS)) (f- TTYHEIGHT 3)))
37
 
                           (LET (#.writefilep) (MTERPRI))))
38
 
             ;; make sure the linearray gets cleared out.
39
 
             (CLEAR-LINEARRAY))))
40
 
            (T (LINEAR-DISPLA FORM)))))
41
 
 
42
 
(defun break-dbm-loop (at)
43
 
  (let* (
44
 
         (*quit-tags* (cons (cons *break-level* *quit-tag*) *quit-tags*))
45
 
         (*break-level* (if (not at) *break-level* (cons t *break-level*)))
46
 
         (*quit-tag* (cons nil nil))
47
 
         (*break-env* *break-env*)
48
 
         (*mread-prompt* "")
49
 
         (*diff-bindlist* nil)
50
 
         (*diff-mspeclist* nil)
51
 
         val
52
 
         )
53
 
    (declare (special *mread-prompt* ))
54
 
    (and (consp at) (set-env at))
55
 
    (cond ((null at)
56
 
           ($frame 0 nil)))
57
 
    (catch 'step-continue
58
 
      (catch *quit-tag*
59
 
        (unwind-protect
60
 
            (do () (())
61
 
                (format *debug-io*
62
 
                    "~@[(~a:~a) ~]"  (unless (stringp at) "dbm")
63
 
                    (length *quit-tags*))
64
 
                (setq val
65
 
                      (catch 'macsyma-quit
66
 
                        (let ((res (dbm-read *debug-io*  nil *top-eof* t)))
67
 
                          (declare (special *mread-prompt*))
68
 
                          (cond ((and (consp res) (keywordp (car res)))
69
 
                                 (let ((value (break-call (car res)
70
 
                                                          (cdr res) 'break-command)))
71
 
                                   (cond ((eq value :resume) (return)))
72
 
                                   ))
73
 
                                (t
74
 
                                 (setq $__ (nth 2 res))
75
 
                                 (setq $% (meval* $__))
76
 
                                 (SETQ $_ $__)
77
 
                                 (displa $%)
78
 
                                 ))
79
 
                          nil
80
 
                          )))
81
 
                (and (eql val 'top)
82
 
                     (throw-macsyma-top))
83
 
                      )
84
 
         (restore-bindings)
85
 
        )))))
86
 
 
87
 
(DEFMFUN $ENTERMATRIX (ROWS COLUMNS)
88
 
       (PROG (ROW COLUMN VECTOR MATRIX SYM SYMVECTOR)
89
 
             (COND ((OR (NOT (FIXNUMP ROWS))
90
 
                        (NOT (FIXNUMP COLUMNS)))
91
 
                    (MERROR "ENTERMATRIX called with non-integer arguments")))
92
 
             (SETQ ROW 0)
93
 
             (COND ((NOT (= ROWS COLUMNS)) (SETQ SYM NIL) (GO OLOOP)))
94
 
        QUEST(PRINC "Is the matrix  1. Diagonal  2. Symmetric  3. Antisymmetric  4. General
95
 
Answer 1, 2, 3 or 4 : ")           (SETQ SYM (RETRIEVE NIL NIL))
96
 
             (COND ((NOT (zl-MEMBER SYM '(1 2 3 4))) (GO QUEST)))
97
 
        OLOOP(COND ((> (SETQ ROW (f1+ ROW)) ROWS)
98
 
                    (format t "~%Matrix entered.~%")
99
 
                    (RETURN (CONS '($MATRIX) (MXC MATRIX)))))
100
 
             (COND ((EQUAL SYM 1)
101
 
                    (SETQ COLUMN ROW)
102
 
                    (PRINC "Row ") (PRINC ROW) (PRINC " Column ")
103
 
                    (PRINC COLUMN) (PRINC ":  ") 
104
 
                    (SETQ MATRIX
105
 
                     (NCONC MATRIX
106
 
                      (NCONS (ONEN ROW COLUMNS (MEVAL (RETRIEVE NIL NIL)) 0))))
107
 
                    (GO OLOOP))
108
 
                   ((EQUAL SYM 2)
109
 
                    (SETQ COLUMN (f1- ROW))
110
 
                    (COND ((EQUAL ROW 1) (GO ILOOP)))
111
 
                    (SETQ SYMVECTOR 
112
 
                           (CONS (NTHCDR COLUMN VECTOR) SYMVECTOR)
113
 
                          VECTOR (NREVERSE (MAPCAR 'CAR SYMVECTOR))
114
 
                          SYMVECTOR (MAPCAR 'CDR SYMVECTOR))
115
 
                    (GO ILOOP))
116
 
                   ((EQUAL SYM 3)
117
 
                    (SETQ COLUMN ROW)
118
 
                    (COND ((EQUAL ROW 1) (SETQ VECTOR (NCONS 0)) (GO ILOOP)))
119
 
                    (SETQ SYMVECTOR
120
 
                          (CONS (MAPCAR 'NEG
121
 
                                        (NTHCDR (f1- COLUMN) VECTOR))
122
 
                                SYMVECTOR)
123
 
                          VECTOR (NRECONC (MAPCAR 'CAR SYMVECTOR) (NCONS 0))
124
 
                          SYMVECTOR (MAPCAR 'CDR SYMVECTOR))
125
 
                    (GO ILOOP)))                
126
 
             (SETQ COLUMN 0 VECTOR NIL)
127
 
        ILOOP(COND ((> (SETQ COLUMN (f1+ COLUMN)) COLUMNS)
128
 
                    (SETQ MATRIX (NCONC MATRIX (NCONS VECTOR)))
129
 
                    (GO OLOOP)))
130
 
             (PRINC "Row ") (PRINC ROW) (PRINC " Column ")
131
 
             (PRINC COLUMN) (PRINC ":  ") 
132
 
             (SETQ VECTOR (NCONC VECTOR (NCONS (MEVAL (RETRIEVE NIL NIL)))))
133
 
             (GO ILOOP)))
134
 
 
135
 
(setq $display2d '$texmacs)
136
 
 
137
 
;; TeX-printing
138
 
;; (c) copyright 1987, Richard J. Fateman
139
 
;; Small changes for interfacing with TeXmacs: Andrey Grozin, 2001-2003
140
 
 
141
 
(declare-top
142
 
         (special lop rop ccol $gcprint $inchar)
143
 
         (*expr tex-lbp tex-rbp))
144
 
(defconstant texport *standard-output*)
145
 
 
146
 
(defun tex-atom (x l r) ;; atoms: note: can we lose by leaving out {}s ?
147
 
  (append l 
148
 
          (list (cond ((numberp x) (texnumformat x))
149
 
                      ((and (symbolp x) (get x 'texword)))
150
 
                      ((stringp x) (tex-string x))
151
 
                      ((characterp x) (tex-char x))
152
 
                      (t (tex-stripdollar x))))
153
 
          
154
 
          r))
155
 
 
156
 
(defun tex-string (x)
157
 
  (cond ((equal x "") "")
158
 
    ((eql (elt x 0) #\\) x)
159
 
    (t (concatenate 'string "\\mbox{{}" x "{}}"))))
160
 
 
161
 
(defun tex-char (x)
162
 
  (if (eql x #\|) "\\mbox{\\verb/|/}"
163
 
    (concatenate 'string "\\mbox{\\verb|" (string x) "|}")))
164
 
 
165
 
(defun tex-stripdollar (sym)
166
 
  (or (symbolp sym) (return-from tex-stripdollar sym))
167
 
  (let* ((name (symbol-name sym))
168
 
      (pname (if (memq (elt name 0) '(#\$ #\&)) (subseq name 1) name))
169
 
      (l (length pname)))
170
 
    (cond
171
 
      ((eql l 1) pname)
172
 
      (t (concatenate 'string "\\mathrm{" pname "}")))))
173
 
 
174
 
(defprop mprog "\\mathbf{block}\\;" texword)
175
 
 
176
 
(defprop mtimes "\\*" texsym)
177
 
 
178
 
(defun tex-int (x l r)
179
 
  (let ((s1 (tex (cadr x) nil nil 'mparen 'mparen));;integrand delims / & d
180
 
        (var (tex (caddr x) nil nil 'mparen rop))) ;; variable
181
 
       (cond((= (length x) 3)
182
 
             (append l `("\\int {" ,@s1 "}{\\;d" ,@var "}") r))
183
 
            (t ;; presumably length 5
184
 
               (let ((low (tex (nth 3 x) nil nil 'mparen 'mparen))
185
 
                     ;; 1st item is 0
186
 
                     (hi (tex (nth 4 x) nil nil 'mparen 'mparen)))
187
 
                    (append l `("\\int_{" ,@low "}^{" ,@hi "}{" ,@s1 "\\;d" ,@var "}") r))))))
188
 
 
189
 
(defun tex-choose (x l r)
190
 
  `(,@l 
191
 
    "\\pmatrix{" 
192
 
    ,@(tex (cadr x) nil nil 'mparen 'mparen)
193
 
    "\\\\"
194
 
    ,@(tex (caddr x) nil nil 'mparen 'mparen)
195
 
    "}"
196
 
    ,@r))
197
 
 
198
 
(defun tex-mcond (x l r)
199
 
  (append l
200
 
    (tex (cadr x) '("\\mathbf{if}\\;")
201
 
      '("\\;\\mathbf{then}\\;") 'mparen 'mparen)
202
 
    (if (eql (fifth x) '$false)
203
 
      (tex (caddr x) nil r 'mcond rop)
204
 
      (append (tex (caddr x) nil nil 'mparen 'mparen)
205
 
        (tex (fifth x) '("\\;\\mathbf{else}\\;") r 'mcond rop)))))
206
 
 
207
 
(defun tex-mdo (x l r)
208
 
  (tex-list (texmdo x) l r "\\;"))
209
 
 
210
 
(defun tex-mdoin (x l r)
211
 
  (tex-list (texmdoin x) l r "\\;"))
212
 
 
213
 
(defprop mtext tex-mtext tex)
214
 
(defprop text-string tex-mtext tex)
215
 
(defprop mlable tex-mlable tex)
216
 
(defprop spaceout tex-spaceout tex)
217
 
 
218
 
(defun tex-mtext (x l r) (tex-list (cdr x) l r ""))
219
 
 
220
 
(defun tex-mlable (x l r)
221
 
  (tex (caddr x)
222
 
    (append l
223
 
      (if (cadr x)
224
 
        (list (format nil "\\mbox{\\tt\\red(~A) \\black}" (stripdollar (cadr x))))
225
 
        nil))
226
 
    r 'mparen 'mparen))
227
 
 
228
 
(defun tex-spaceout (x l r)
229
 
  (append l (list "\\mbox{\\verb|" (make-string (cadr x) :initial-element #\space) "|}") r))
230
 
 
231
 
(defun latex (x)
232
 
  (let ((ccol 1))
233
 
    (mapc #'myprinc
234
 
      (if (and (listp x) (cdr x) (equal (cadr x) "Is  "))
235
 
        (tex x '("$\\displaystyle ") '("$ ") 'mparen 'mparen)
236
 
        (tex x '("latex:$\\displaystyle ") '("$
237
 
") 'mparen 'mparen)))))