archive/src/plotll.lisp

   1 ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;     The data in this file contains enhancments.                    ;;;;;
   4 ;;;                                                                    ;;;;;
   5 ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
   6 ;;;     All rights reserved                                            ;;;;;
   7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   8
   9 (in-package "MAXIMA")
  10 ;;; Low level line drawing routines for the MACSYMA plot package on the LISP machine
  11 ;;; THIS NEEDS TO BE FLUSHED SOMEDAY
  12
  13 ;;; Todo:
  14 ;;;   correct pointi
  15 ;;;   finish $PLOT_COMMAND and related functions
  16 ;;;   see how PLOTMODE should affect the scaling
  17 ;;;   see if the clipping in VECTOR can be replaced by the standard methods
  18 ;;;   figure out what pnt-status does and see if it is necessary
  19 ;;;   replace the gross exploden, stripdollar stufff with something more reasonable
  20 ;;;   flush crufty declare specials
  21
  22 (declare-top (special plot-last-hi-y plot-last-lo-y plot-last-hi-x plot-mode
  23                   print-mode $loadprint $values $myoptions plot-opts
  24                   plot-vals char-type $charratio $plotmode dasharray
  25                   print-dasharray print-symbolarray symbolarray
  26                   dashl odashl beamon drawn print-line1 char-width char-height
  27                   min-x max-x min-y max-y last-x last-y size-x size-y pnt-status
  28                   screen-last-x screen-last-y DISPLAY-MODE))
  29
  30 ;;; Macsyma Plot Frames are defined in LMMAX;PLTWIN >
  31
  32 ;;; The default plotting stream is a plot frame.
  33
  34 #+lispm
  35 (DEFVAR PLOT-STREAM (MAKE-PLOT-WINDOW-STREAM))
  36
  37
  38 #+LISPM
  39 (DEFVAR PLOT-FONT FONTS:CPTFONT)                ;maybe Timesroman would be better?
  40
  41 ;;; *** This gets redone when the change options feature gets implemented
  42 (defun plot-startup nil
  43    (setq plot-opts '($clear $wait $plotbell)
  44          plot-vals '(t t t nil))
  45    (mapcar #'(lambda (plotvar plotval)
  46                      (cond ((boundp plotvar)
  47                             (and (memq plotvar $values)
  48                                  (set plotvar (prog2 nil (eval plotvar)
  49                                                      (remvalue plotvar 'PLOT-STARTUP)
  50                                                      (add2lnc plotvar $myoptions)))))
  51                            (t (set plotvar plotval))))
  52
  53            ;; these guys aren't reset by PLOTRESET
  54            (append plot-opts '($plotthick $plotscale $charratio $plotlftmar $plotbotmar))
  55            (append plot-vals '(2. 1.75 2.5 150. 150.)))
  56    t)
  57
  58 (plot-startup)
  59
  60 ;;; **** This should also change the x and y relative scales???
  61
  62 (DEFVAR $PLOTSCALE 1.0)
  63
  64 (defmspec $plotmode (l) (setq l (cdr l))
  65   (SETQ $PLOTMODE NIL DISPLAY-MODE NIL)
  66   (IF (memq '$DISPLAY l)
  67       #+lispm
  68       (setq char-height (font-char-height plot-font)
  69             char-width (font-char-width plot-font)
  70             DISPLAY-MODE T)
  71       #-lispm nil
  72       )
  73   (IF (memq '$PAPER l)
  74       (setq char-height (fix (+$ 0.5 (//$ 25.0 (float $plotscale))))
  75             char-width (fix (+$ 0.5 (//$ 16.0 (float $plotscale))))))
  76   (setq $plotmode `((mlist) ,@ l)))
  77
  78 (meval '(($plotmode) $DISPLAY))
  79 \f
  80 ;;; Enter and exit graphics mode.  Process commands at the end of plotting.
  81
  82 (declare-top (special graphic-mode $clear $wait
  83                   $plotbell $plotthick $plotscale
  84                   $plotheight $plotlftmar $plotbotmar))
  85
  86 (setq graphic-mode nil)
  87 (defvar $plotnum 20)
  88
  89 (defun $entergraph nil
  90    (if graphic-mode (let (($wait)) ($exitgraph)))
  91    (setq graphic-mode t)
  92    (if $clear (send plot-stream ':clear-screen))
  93    (send plot-stream ':init-for-plotting)
  94    (SETQ screen-last-x 0)
  95    (SETQ screen-last-y 0)
  96    T)
  97
  98 (defun $exitgraph (&AUX (CMD -1))
  99   (SETQ GRAPHIC-MODE NIL)
 100   (if (AND $WAIT DISPLAY-MODE)
 101       (progn
 102        ;        (if $plotbell (FUNCALL TERMINAL-IO ':BEEP))
 103         (SETQ CMD (FUNCALL PLOT-STREAM #+Lispm ':any-TYI #-lispm :tyio))))
 104   (send plot-stream ':end-plotting)
 105   CMD)
 106
 107 (DEFUN GET-PLOTTING-RANGE () (list 0 0 1000 1000)
 108   #+lispm (FUNCALL PLOT-STREAM ':GET-PLOTTING-RANGE))
 109
 110 (DEFUN $INITGRAPH () (FUNCALL PLOT-STREAM ':INIT-FOR-PLOTTING))
 111
 112 (DEFUN $ENDGRAPH () (FUNCALL PLOT-STREAM ':END-PLOTTING))
 113
 114 #+lispm
 115 (progn
 116 (defun $clear () (FUNCALL PLOT-STREAM ':CLEAR-SCREEN))
 117
 118
 119
 120 (defun $hardcopy () (send plot-stream ':hardcopy) '$done)
 121
 122
 123
 124
 125
 126
 127 (defun macsyma-print (v &optional stream) (aformat stream "~:M" v))
 128
 129 (remprop :macsyma-expression 'tv:choose-variable-values-keyword)
 130
 131 (DEFPROP :macsyma-expression
 132          (macsyma-print mread-noprompt nil
 133                         nil nil
 134                         "Click left to input a new macsyma expression from keyboard,middle to edit current value. TERMINATE input with ;"
 135          tv::choose-variable-values-keyword))
 136
 137
 138
 139
 140 (define-user-option-alist *Original-plot-3d-options* Def-plt-3d1)
 141 (defmacro def-plt-3d (var val type description)
 142   `(def-plt-3d1 ,var ,val ,type ,(zl-string description)))
 143
 144 (def-plt-3d *xlow* -2 :number "Plot from x")
 145 (def-plt-3d *xhigh* 2 :number "Plot to x")
 146 (def-plt-3d *ylow* -2 :number "Plot from y")
 147 (def-plt-3d *yhigh* 2 :number "Plot to y")
 148 (def-plt-3d  *expression-to-plot* nil :macsyma-expression
 149              "Expression in x and y or lisp function to plot")
 150 (def-plt-3d $plotscale 1.0 :number "Plot Scale")
 151 ;(def-plt-3d $plotnum (meval* '$plotnum) :macsyma-expression "Number of pts on x axis used")
 152 (def-plt-3d $plotnum0 (meval* '$plotnum0) :macsyma-expression "Number of pts on x axis used")
 153 (def-plt-3d $plotnum1 (meval* '$plotnum1) :macsyma-expression "Number of pts on y axis used")
 154 (DEF-PLT-3d $window (meval* '$WINDOW1) :macsyma-expression "Plot window")
 155 (DEF-plt-3d  $centerplot (meval* '$centerplot1) :Macsyma-expression "Centerplot")
 156 (DEF-PLT-3d $viewpt (meval* '$viewpt1) :macsyma-expression "View point")
 157 (def-plt-3d three-d (meval* '$hide) :macsyma-expression "Hide or contour")
 158 )
 159
 160
 161 (defvar *function-to-plot*)
 162
 163 ; ;
 164 ;;
 165 ;;(defmacro compile-define-function (x-y-expr function-name  &aux varl)
 166 ;;  `(progn
 167 ;;;  (setq x-y-expr (list 'quote (eval ,x-y-expr)))
 168 ;;  (setq varl ($list_variables ,x-y-expr))
 169 ;;             (meval*
 170 ;;               '((MDEFINE )
 171 ;;                 ((,function-name) ,@ (cdr varl))
 172 ;;                 ((MPROGN) (($MODEDECLARE) ,varl $float)
 173 ;;                   x-y-expr)))
 174 ;;             (mfuncall '$compile ',function-name)
 175 ;;             ',function-name))
 176 ;;
 177
 178
 179
 180 ;;(defmacro compile-define-function (x-y-expr function-name &aux varl)
 181 ;;;    (setq x-y-expr (eval x-y-expr))
 182 ;;  (setq  varl ($list_variables x-y-expr))
 183 ;;  `(progn
 184 ;;             (meval*
 185 ;;               '((MDEFINE )
 186 ;;                 ((,function-name) ,@ (cdr varl))
 187 ;;                 ((MPROGN) (($MODEDECLARE) ,varl $float)
 188 ;;                  ,x-y-expr)))
 189 ;;             (mfuncall '$compile ',function-name)
 190 ;;             ',function-name))
 191 ;;
 192
 193
 194
 195 ;(defun plot-3d (&aux ff options ( $replotting t) (expr *expression-to-plot*)
 196 ;               ($viewpt (meval '$viewpt))
 197 ;               ($window (meval '$WINDOW1) )
 198 ;               ($zmin (meval '$zmin) )
 199 ;               ($zmax (meval '$zmax) )
 200 ;               ($ymin (meval '$ymin) )
 201 ;               ($ymax (meval '$ymax) )
 202 ;               ($xmin (meval '$xmin) )
 203 ;               ($xmax (meval '$xmax) )
 204 ;               ($centerplot(meval '$centerplot)))
 205 ;  "Calls up a choice box in which you can enter a macsyma expression in x and y
 206 ; to be graphed, give a range, and have various options.  It compiles the macsyma
 207 ; expression as a function funtoplot(x,y):=.. .  It also accepts a lisp function.
 208 ; Look on the who line for the type of data to input."
 209 ;  (cond ((and (boundp ' $viewpt)(atom $viewpt))
 210 ;        ($plotreset)))
 211 ;  (let ($replotting) (plot-input-choose))
 212 ;  (cond ((null expr) (format plot-stream "No function to plot")))
 213 ;  (setq *function-to-plot*
 214 ;       (cond ((and (atom *expression-to-plot*) (functionp *expression-to-plot*))
 215 ;              *expression-to-plot*)
 216 ;             ((null *expression-to-plot*) (fsignal "need an expression to plot"))
 217 ;             (t
 218 ;              (compile-define-function *expression-to-plot* 'funtoplot)
 219 ;;             (meval*
 220 ;;               `((MDEFINE SIMP)
 221 ;;                 ((funtoplot) $X $Y)
 222 ;;                 ((MPROGN) (($MODEDECLARE) $X $float $Y $float)
 223 ;;                  ,*expression-to-plot*)))
 224 ;;             (let ((*standard-output* plot-stream ))(mfuncall '$compile 'funtoplot))
 225 ;              (setq *function-to-plot* 'funtoplot))))
 226 ;  (setq options nil)
 227 ;;  (mfunction-call $plot3d *function-to-plot* *xlow* *xhigh* *ylow* *yhigh*
 228 ;;          )
 229 ;  (meval* '(($plot3d)    *FUNCTION-TO-PLOT* *XLOW* *XHIGH* *YLOW*
 230 ;                                                *YHIGH*)))
 231
 232
 233 (defun plot-3d (&aux ff options ( $replotting t) (expr *expression-to-plot*))
 234   "Calls up a choice box in which you can enter a macsyma expression in x and y
 235  to be graphed, give a range, and have various options.  It compiles the macsyma
 236  expression as a function funtoplot(x,y):=.. .  It also accepts a lisp function.
 237  Look on the who line for the type of data to input."
 238         (sloop for v in '(      $viewpt
 239                 $window
 240                 $zmin
 241                 $zmax
 242                 $ymin
 243                 $ymax
 244                 $xmin
 245                 $xmax
 246                 $centerplot)
 247               do (set v (meval* v)))
 248
 249 ;  (cond ((and (boundp ' $viewpt)(atom $viewpt))
 250 ;        ($plotreset)))
 251   (let ($replotting) (plot-input-choose))
 252   (cond ((null expr) (format plot-stream "No function to plot")))
 253   (setq *function-to-plot*
 254         (cond ((and (atom *expression-to-plot*) (functionp *expression-to-plot*))
 255                *expression-to-plot*)
 256               ((null *expression-to-plot*) (error "need an expression to plot"))
 257               (t
 258                (compile-define-function *expression-to-plot* 'funtoplot)
 259 ;              (meval*
 260 ;                `((MDEFINE SIMP)
 261 ;                  ((funtoplot) $X $Y)
 262 ;                  ((MPROGN) (($MODEDECLARE) $X $float $Y $float)
 263 ;                   ,*expression-to-plot*)))
 264 ;              (let ((*standard-output* plot-stream ))(mfuncall '$compile 'funtoplot))
 265                (setq *function-to-plot* 'funtoplot))))
 266   (setq options nil)
 267 ;  (mfunction-call $plot3d *function-to-plot* *xlow* *xhigh* *ylow* *yhigh*
 268 ;           )
 269   (meval* '(($plot3d)    *FUNCTION-TO-PLOT* *XLOW* *XHIGH* *YLOW*
 270                                                  *YHIGH*)))
 271
 272 #+lispm
 273 (progn
 274 (DEFINE-USER-OPTION-ALIST *MACSYMA-PLOT-OPTIONS-ALIST* DEF-MC-PLT-OP1)
 275 ;;for those windows wanting zeta lisp strings..
 276 (defmacro def-mc-plt-op (var val type description)
 277   `(def-mc-plt-op1 ,var ,val ,type ,(zl-string description)))
 278
 279 ; These four commented out 11/24/82 by CWH.  $XMIN1, etc are not bound at load time.
 280
 281 (DEFVAR *MACSYMA-PLOT-OPTIONS-ALIST* NIL)
 282 (setq  *MACSYMA-PLOT-OPTIONS-ALIST* NIL)
 283 (DEF-MC-PLT-OP $XMIN (meval* '$XMIN1) :macsyma-expression
 284                "Minimum value for the x range" )
 285 (DEF-MC-PLT-OP $xmax (meval* '$XMAX1) :macsyma-expression
 286                "Maximum value for the x range")
 287 (DEF-MC-PLT-OP $ymin (meval*  '$YMIN1) :macsyma-expression
 288                "Minimum value for the y range")
 289 (DEF-MC-PLT-OP $ymax (meval* '$YMAX1) :macsyma-expression
 290                "Maximum value for the y range")
 291 (def-mc-plt-op 3d  (cond ((boundp ' 3d)
 292                             3d)(t t)) :sexp "3d" )
 293 (def-mc-plt-op Typel (meval* 'typel) :macsyma-expression "Typel"   )
 294 (def-mc-plt-op $xlabel nil :macsyma-expression "Xlabel"   )
 295 (def-mc-plt-op $ylabel nil :macsyma-expression "Ylabel"   )
 296 (def-mc-plt-op $Title (meval* '$title) :macsyma-expression "Title"   )
 297 (def-mc-plt-op $perspective (meval* '$perspective) :boolean "Perspective")
 298 (def-mc-plt-op  $reverse (meval* '$reverse):boolean "reverse")
 299 (def-mc-plt-op    $underside (meval* '$underside) :boolean  "Underside" )
 300 (def-mc-plt-op  $howclose (meval*  '$howclose) :macsyma-expression "howclose"   )
 301 (def-mc-plt-op  $crosshatch (meval* '$crosshatch)  :macsyma-expression "Crosshatch")
 302 (def-mc-plt-op    $zmax (meval* '$zmax1) :macsyma-expression "Zmax")
 303 (def-mc-plt-op  $zmin (meval*  '$zmin1) :macsyma-expression "Zmin")
 304 (def-mc-plt-op $txtype (meval* '$txtype) :macsyma-expression
 305                  "$txtype One of polar, %log, loglin, linlog, lin, special")
 306
 307 (def-mc-plt-op  $labelcontours (meval '$labelcontours) :macsyma-expression "labelcontours"     )
 308 (def-mc-plt-op  $plotnumprec (meval '$plotnumprec) :macsyma-expression "plotnumprec ")
 309 (def-mc-plt-op  $plotnum (meval* '$plotnum) :macsyma-expression "The number of points on an axis used (next time)")
 310 (def-mc-plt-op  $zigzag (meval '$zigzag) :macsyma-expression "Zigzag")
 311 ;(def-mc-plt-op scale-x scale-x :number "scale-x" )
 312  ; (def-mc-plt-op  scale-y  scale-y :number "scale-y" )
 313   ;(def-mc-plt-op  max-xf  max-xf :number "max-xf" )
 314 ;(def-mc-plt-op  min-xf  min-xf :number "max-xf" )
 315   ;(DEF-MC-PLT-OP $zmax 0.0 :NUMBER "Maximum value for the z range")
 316   ;(DEF-MC-PLT-OP $zmin 0.0 :NUMBER "Minimum value for the z range")
 317 (DEF-MC-PLT-OP $window (meval* '$WINDOW1) :macsyma-expression "Plot window")
 318 (DEF-MC-PLT-OP $viewpt (meval* '$viewpt1) :macsyma-expression "View point")
 319 (DEF-MC-PLT-OP  $centerplot (meval* '$centerplot1) :Macsyma-expression "Centerplot")
 320 ;(SETQ *MACSYMA-PLOT-OPTIONS-ALIST* (NREVERSE *MACSYMA-PLOT-OPTIONS-ALIST*))
 321
 322 ;(DEFUN $PLOT_COMMAND (CMD)
 323 ;  (IF (AND (LISTP CMD) (EQ ':MENU (FIRST CMD)) (EQ ':KBD (SECOND (SECOND CMD))))
 324 ;      (SETQ CMD (THIRD (SECOND CMD))))
 325 ;  (CASE CMD
 326 ;    ((#/C #/c #\SPACE) ($ENDGRAPH)
 327 ;     '$DONE)
 328 ;    ((#/O #/o) (FUNCALL TERMINAL-IO ':BEEP) ($ENDGRAPH)
 329 ;     '$DONE)
 330 ;    ((#/H #/h) ':HARDCOPY)
 331 ;    ((#/N #/n) '$DONE)
 332 ;    ((#/V #/v) (TV:CHOOSE-USER-OPTIONS *MACSYMA-PLOT-OPTIONS-ALIST*
 333 ;                                  ':LABEL "Change Macsyma Plot Options")
 334 ;     ':REPLOT)
 335 ;
 336 ;    (OTHERWISE ($ENDGRAPH)
 337 ;               (IF (AND (INTEGERP CMD) (> CMD 0)) (FUNCALL TERMINAL-IO ':UNTYI CMD))
 338 ;               '$DONE))
 339 ;)
 340
 341 (defun plot-options-choose ()
 342                                   (TV:CHOOSE-variable-values *MACSYMA-PLOT-OPTIONS-ALIST*
 343                                            ':LABEL (zl-string "Change Macsyma Plot Options")
 344                                            ':superior plot-stream))
 345 ;;bind these in plot-3d;
 346 ;(defun plot-options-choose ()
 347 ;  (let (($centerplot(meval '$centerplot))
 348 ;       ($viewpt (meval '$viewpt))
 349 ;       ($window (meval '$WINDOW1) )
 350 ;        ($zmin (meval '$zmin) )
 351 ;       ($zmax (meval '$zmax) )
 352 ;       ($ymin (meval '$ymin) )
 353 ;       ($ymax (meval '$ymax) )
 354 ;       ($xmin (meval '$xmin) )
 355 ;       ($xmax (meval '$xmax) )
 356 ;       )
 357 ;    (declare (special $window $zmin))
 358 ;
 359 ;                                 (TV:CHOOSE-variable-values *MACSYMA-PLOT-OPTIONS-ALIST*
 360 ;                                          ':LABEL (zl-string "Change Macsyma Plot Options")
 361 ;                                          ':superior plot-stream)))
 362
 363 (defun plot-input-choose ()
 364   (let (($viewpt (meval '$viewpt))
 365         ($centerplot (meval  '$centerplot))
 366         ($xmin (meval '$xmin))
 367         ($ymin (meval  '$ymin)))
 368
 369                                   (TV:CHOOSE-variable-values  *Original-plot-3d-options*
 370                                            ':LABEL (zl-string "Plot Input Defaults")
 371                                            ':superior plot-stream)))
 372
 373 (defun plot-input-choose ()
 374   (sloop for v in
 375      '( $viewpt
 376         $centerplot
 377         $xmin
 378         $ymin $plotnum0 $plotnum1) do (set v (meval* v)))
 379
 380                                   (TV:CHOOSE-variable-values  *Original-plot-3d-options*
 381                                            ':LABEL (zl-string "Plot Input Defaults")
 382                                            ':superior plot-stream))
 383
 384
 385
 386
 387 (DEFUN $PLOT_COMMAND (CMD)
 388   (cond ((and  (consp cmd)
 389                (eq ':menu (first cmd))
 390                (eq ':value (second (second cmd))))
 391          (setq cmd (second (third (second cmd)))))
 392         (t nil))
 393
 394 ;  (IF (AND (LISTP CMD) (EQ ':MENU (FIRST CMD)) (EQ ':KBD (SECOND (SECOND CMD))))
 395 ;      (SETQ CMD (THIRD (SECOND CMD))))
 396   (and (numberp cmd) (setf cmd (code-char cmd)))
 397   (CASE CMD
 398     ((#\P #\p) (plot-3d) 'continue)
 399     ((#\E #\e #\SPACE) (setq $replotting nil) ($ENDGRAPH)
 400      '$DONE)
 401     ((#\O #\o) (plot-options-choose)
 402      ':replot)
 403     ((#\H #\h) ':HARDCOPY)
 404     ((#\N #\n) '$DONE)
 405     ((#\R #\r) (plot-input-choose) :replot)
 406     ((#\M #\m  #\V #\v #\O #\o) (plot-options-choose)
 407      ':replot)
 408     ((otherwise 'continue))))
 409
 410
 411 )
 412 \f
 413 ;;; drawing primitives
 414
 415 ;;; **** change this back at somepoint.  Do this via definesymbol.
 416 (defun pointi (x y)
 417    (FUNCALL PLOT-STREAM ':plot-POINT X Y)
 418    (setq pnt-status t last-x x last-y y screen-last-x x screen-last-y y))
 419
 420 (defun vectori (x y)
 421   (FUNCALL PLOT-STREAM ':plot-LINE LAST-X LAST-Y X Y)
 422   (setq pnt-status t last-x x last-y y screen-last-x x screen-last-y y))
 423
 424 #|
 425 (DEFUN PLOT-DRAW-CHAR (CHAR X Y)
 426   (MULTIPLE-VALUE-BIND (WIDTH HEIGHT) (FUNCALL PLOT-STREAM ':SIZE)
 427     (FUNCALL PLOT-STREAM ':DRAW-CHAR (FUNCALL PLOT-STREAM ':CURRENT-FONT)
 428              CHAR X (f- HEIGHT Y))))
 429 |#
 430 \f
 431 ;;; Line, Vector, Point primitives
 432
 433 (DEFMACRO CHECKPNT (X Y) `(not (or (< ,x min-x) (> ,x max-x) (< ,y min-y) (> ,y max-y))))
 434
 435 ;;; setpoint
 436
 437 (defun $setpoint (xf yf) (setpoint (plot-x xf) (plot-y yf)))
 438
 439 (defun setpoint (x y)
 440    (IF (checkpnt x y) (setpointi x y)
 441        (setq pnt-status nil last-x x last-y y)))
 442
 443 (defun setpointi (x y)
 444    (IF (NOT (and pnt-status (= screen-last-x x) (= screen-last-y y)))
 445        (setq pnt-status t last-x x last-y y screen-last-x x screen-last-y y)))
 446
 447 ;;; draw point
 448
 449 (defun plot-point (x y)
 450   (IF (checkpnt x y) (pointi x y)
 451       (setq pnt-status nil last-x x last-y y)))
 452
 453 (defun $point (xf yf) (plot-point (plot-x xf) (plot-y yf)))
 454
 455
 456 ;;; vectors
 457
 458 (setq dashl nil odashl nil beamon t drawn 0.
 459       dasharray (zl-make-array 10)
 460       )
 461
 462 ;;; patterned (dashed) vectors
 463
 464 (defun vectord (x y)
 465   (cond ((null dashl) (vectori x y))            ;simple case, solid lines
 466         ((not (eq (ml-typep dashl) 'list)) (setpoint x y))      ;otherwise, just points
 467         (t (let ((save-x last-x) (save-y last-y) (del-xf (float (f- x last-x)))
 468                                  (del-yf (float (f- y last-y))) (lenf 0.0) (len 0.))
 469                 (setq lenf (sqrt (+$ (*$ del-xf del-xf) (*$ del-yf del-yf)))
 470                       len (fix (+$ lenf 0.5))
 471                       lenf (if (= 0 lenf) 1.0 lenf)
 472                       del-xf (//$ del-xf lenf) del-yf (//$ del-yf lenf))
 473                 (do ((runl (f- (car dashl) drawn) (f+ runl (car dashl)))
 474                      (targ-x) (targ-y))
 475                     (nil)
 476                     (setq targ-x (f+ save-x (fix (+$ (*$ (float runl) del-xf) 0.5)))
 477                           targ-y (f+ save-y (fix (+$ (*$ (float runl) del-yf) 0.5))))
 478                     (cond (beamon (cond ((< runl len)
 479                                          (vectori targ-x targ-y)
 480                                          (setq drawn 0. dashl (cdr dashl)
 481                                                beamon nil))
 482                                         (t (vectori x y)
 483                                            (cond ((= runl len)
 484                                                   (setq drawn 0. dashl (cdr dashl)
 485                                                         beamon nil))
 486                                                  (t (setq drawn
 487                                                           (f- (car dashl)
 488                                                              (f- runl len)))))
 489                                            (return nil))))
 490                           (t (cond ((< runl len)
 491                                     (setpoint targ-x targ-y)
 492                                     (setq drawn 0. dashl (cdr dashl) beamon t))
 493                                    (t (setpoint x y)
 494                                       (cond ((= runl len)
 495                                              (setq drawn 0. dashl (cdr dashl)
 496                                                    beamon t))
 497                                             (t (setq drawn (f- (car dashl)
 498                                                               (f- runl len)))))
 499                                       (return nil))))))))))
 500
 501 (defun $definedash (l1 l)
 502        (or (and (integerp l1) (< l1 10.) (> l1 -1.))
 503            (Error  "First arg to DEFINEDASH must lie between 0 and 9: ~A" L1))
 504        (prog2 nil
 505               (list '(mlist simp) l1 l)
 506               (cond ((or (null l) (eq l t) (eq (ml-typep l) 'list))
 507                      (and (eq (ml-typep l) 'list)
 508                           (consp (car l))
 509                           (eq (caar l) 'mlist) (setq l (cdr l)))
 510                      (or (eq l t) (setq l (mapcar 'fix l)))
 511                      (aset l dasharray l1)))))
 512
 513 (defun $changedash (x)
 514    (setq dashl (aref dasharray x) odashl nil drawn 0. beamon t)
 515    (cond ((eq (ml-typep dashl) 'list)
 516           (setq dashl (copy-top-level dashl))
 517           (rplacd (last dashl) dashl)))
 518    nil)
 519
 520 (defun $pushdash nil (setq odashl dashl dashl nil))
 521
 522 (defun $popdash nil (setq dashl odashl odashl nil))
 523
 524 (defun init-dashes nil
 525        ($definedash 1. '(40. 8.)) ($definedash 2. '(15. 8.)) ($definedash 3. '(1. 7.))
 526        ($definedash 4. '(30. 8. 1. 8.)) ($definedash 5. '(30. 8. 1. 8. 1. 8.))
 527        ($definedash 6. '(40. 8. 1. 8. 5. 8. 1. 8.)) ($definedash 7. '(8. 30.))
 528        ($definedash 8. '(1. 20.)) ($definedash 9. t))
 529
 530 (init-dashes)
 531
 532 ;;; Can this be done with the built-in methods?
 533 ;;; ****
 534
 535 ;;; vectors with clipping
 536
 537 (defun maxima-vector (x y)
 538        (cond ((and pnt-status (checkpnt x y)) (vectord x y))
 539              (t (prog (del-x del-y save-x save-y)
 540                       (setq save-x x save-y y del-x (f- x last-x) del-y (f- y last-y))
 541                       (cond ((> last-y max-y)
 542                              (cond ((> y max-y) (go no-vector))
 543                                    (t (setq last-x (intercept last-x last-y del-x del-y max-y)
 544                                             last-y max-y)
 545                                       (cond ((< y min-y)
 546                                              (setq x (intercept x y del-x del-y min-y)
 547                                                    y min-y))))))
 548                             ((< last-y min-y)
 549                              (cond ((< y min-y) (go no-vector))
 550                                    (t (setq last-x (intercept last-x last-y del-x del-y min-y)
 551                                             last-y min-y)
 552                                       (cond ((> y max-y)
 553                                              (setq x (intercept x y del-x del-y max-y)
 554                                                    y max-y))))))
 555                             ((> y max-y)
 556                              (setq x (intercept x y del-x del-y max-y) y max-y))
 557                             ((< y min-y)
 558                              (setq x (intercept x y del-x del-y min-y) y min-y)))
 559                       (cond ((> last-x max-x)
 560                              (cond ((> x max-x) (go no-vector))
 561                                    (t (setq last-y (intercept last-y last-x del-y del-x max-x)
 562                                             last-x max-x)
 563                                       (cond ((< x min-x)
 564                                              (setq y (intercept y x del-y del-x min-x)
 565                                                    x min-x))))))
 566                             ((< last-x min-x)
 567                              (cond ((< x min-x) (go no-vector))
 568                                    (t (setq last-y (intercept last-y last-x del-y del-x min-x)
 569                                             last-x min-x)
 570                                       (cond ((> x max-x)
 571                                              (setq y (intercept y x del-y del-x max-x)
 572                                                    x max-x))))))
 573                             ((> x max-x)
 574                              (setq y (intercept y x del-y del-x max-x) x max-x))
 575                             ((< x min-x)
 576                              (setq y (intercept y x del-y del-x min-x) x min-x)))
 577                       (cond ((not pnt-status) (setpoint last-x last-y)))
 578                       (vectord x y)
 579                       no-vector
 580                       (cond ((not (checkpnt save-x save-y))
 581                              (setq pnt-status nil last-x save-x last-y save-y))))))
 582        nil)
 583
 584 (defun intercept (x y del-x del-y max-y) (f- x (// (f* del-x (f- y max-y)) del-y)))
 585
 586 (defun $vector (xf yf) (maxima-vector (plot-x xf) (plot-y yf)))
 587
 588 ;;; lines
 589
 590 (defun line (x1 y1 x y) (setpoint x1 y1) (maxima-vector x y))
 591
 592 (defun $line (xf1 yf1 xf yf)
 593        (setpoint (plot-x xf1) (plot-y yf1)) (maxima-vector (plot-x xf) (plot-y yf)))
 594
 595 ;;; symbols
 596
 597 (setq symbolarray (zl-make-array 10))
 598
 599 (defun drawsymbol (x y x1)
 600    ($pushdash)
 601    (do ((symbl0 (aref symbolarray x1) (cdr symbl0)) (draw nil (not draw)))
 602        ((cond ((null symbl0)) ((eq symbl0 t) (plot-point x y) t)))
 603        (do ((symbl1 (car symbl0) (cddr symbl1))) ((null (cdr symbl1)))
 604            (cond (draw (maxima-vector (f+ x (car symbl1)) (f+ y (cadr symbl1))))
 605                  (t (setpoint (f+ x (car symbl1)) (f+ y (cadr symbl1)))))))
 606    ($popdash))
 607
 608 (defun $drawsymbol (xf yf x1) (drawsymbol (plot-x xf) (plot-y yf) x1))
 609
 610 (defun $definesymbol (l1 l)
 611        (or (and (integerp l1) (< l1 10.) (> l1 -1.))
 612            (Error "First arg to DEFINESYMBOL must lie between 0 and 9: ~A" L1))
 613        (prog2 nil
 614               (list '(mlist simp) l1 l)
 615               (cond ((or (null l) (eq l t) (eq (ml-typep l) 'list))
 616                      (and (eq (ml-typep l) 'list)
 617                           (consp (car l))
 618                           (eq (caar l) 'mlist) (setq l (cdr l)))
 619                      (or (eq l t)
 620                          (setq l (mapcar #'(lambda (l2) (and (consp (car l2))
 621                                                              (eq (caar l2) 'mlist)
 622                                                              (setq l2 (cdr l2)))
 623                                                    (mapcar 'fix l2))
 624                                          l)))
 625                      (aset l symbolarray l1)))))
 626
 627 (defun init-symbols nil
 628        ($definesymbol 0. nil)
 629        ($definesymbol 1. '((0. 6.) (0. -6.) (-6. 0.) (6. 0.) (0. 0.)))
 630        ($definesymbol 2. '((4. 4.) (-4. -4.) (4. -4.) (-4. 4.) (0. 0.)))
 631        ($definesymbol 3. '((6. 6.) (6. -6. -6. -6. -6. 6. 6. 6.) (0. 0.) (0. 0.)))
 632        ($definesymbol 4. '((8. 0.) (0. -8. -8. 0. 0. 8. 8. 0.) (0. 0.) (0. 0.)))
 633        ($definesymbol 5. '((0. 8.) (6. -4. -6. -4. 0. 8.) (0. 0.) (0. 0.)))
 634        ($definesymbol 6. '((0. -8.) (6. 4. -6. 4. 0. -8.) (0. 0.) (0. 0.)))
 635        ($definesymbol 7. '((8. 0.) (-4. 6. -4. -6. 8. 0.) (0. 0.) (0. 0.)))
 636        ($definesymbol 8. '((-8. 0.) (4. 6. 4. -6. -8. 0.) (0. 0.) (0. 0.)))
 637 ;      ($definesymbol 9. '((0. 9.) (4. -6. -7. 2. 7. 2. -4. -6. 0. 9.) (0. 0.)))
 638        ($definesymbol 9. t))
 639
 640 (init-symbols)
 641
 642 ;;; scaling functions
 643
 644 (declare-top (special min-xf max-xf min-yf max-yf size-xf size-yf scale-x scale-y))
 645
 646 (setq min-xf 0.0 min-yf 0.0 max-xf 1023.0 max-yf 1023.0 size-xf 1023.0 size-yf 1023.0)
 647
 648 (defun $screensize (x1 y1 x y)
 649        (setq min-x x1 min-y y1 max-x x max-y y
 650              size-x (f- max-x min-x) size-y (f- max-y min-y)
 651              scale-x (//$ size-xf (float size-x)) scale-y (//$ size-yf (float size-y))
 652              pnt-status nil last-x min-x last-y min-y)
 653        nil)
 654
 655 ;;; what should this be?****
 656 ($screensize 0. 0. 1023. 1023.)
 657
 658 (defun $screensize1 (x1 y1 x y)
 659        ($size (plot-xf x1) (plot-yf y1) (plot-xf x) (plot-yf y))
 660        ($screensize x1 y1 x y))
 661
 662 (defun $size (xf1 yf1 xf yf)
 663        (setq min-xf xf1 min-yf yf1 max-xf xf max-yf yf
 664              size-xf (-$ max-xf min-xf) size-yf (-$ max-yf min-yf)
 665              scale-x (//$ size-xf (float size-x)) scale-y (//$ size-yf (float size-y)))
 666        nil)
 667
 668 (defun plot-x (xf) (f+ min-x (fix (+$ 0.5 (//$ (-$ xf min-xf) scale-x)))))
 669
 670 (defun plot-y (yf) (f+ min-y (fix (+$ 0.5 (//$ (-$ yf min-yf) scale-y)))))
 671
 672 (defun plot-xf (x) (+$ min-xf (*$ (float (f- x min-x)) scale-x)))
 673
 674 (defun plot-yf (y) (+$ min-yf (*$ (float (f- y min-y)) scale-y)))
 675
 676 (declare-top (special txfun-x txfun-y txfun-x-nargs txfun-y-nargs))
 677
 678 (defun call-x (&optional xf yf zf)
 679        (case txfun-x-nargs
 680                 (0 xf)
 681                 (1 (funcall txfun-x xf))
 682                 (2 (funcall txfun-x xf yf))
 683                 (3 (funcall txfun-x xf yf zf))
 684                 (otherwise
 685                  (Error "Wrong number arguments to x transformation function"))))
 686
 687 (defun call-y (&optional xf yf zf)
 688        (case txfun-y-nargs
 689                 (0 yf)
 690                 (1 (funcall txfun-y xf))
 691                 (2 (funcall txfun-y xf yf))
 692                 (3 (funcall txfun-y xf yf zf))
 693                 (otherwise
 694                  (Error  "Wrong number arguments to y transformation function"))))
 695 (defun call-init (xfun yfun)
 696    (setq txfun-x xfun
 697          txfun-y yfun
 698          txfun-x-nargs (cond #+lispm (xfun (length (arglist xfun)))
 699                              (t 0))
 700          txfun-y-nargs (cond #+lispm (yfun (length (arglist yfun)))
 701                              (t 0))))
 702
 703 (defun $setpoint3 (xf yf zf) ($setpoint (call-x xf yf zf) (call-y xf yf zf)))
 704
 705 (defun $point3 (xf yf zf) ($point (call-x xf yf zf) (call-y xf yf zf)))
 706
 707 (defun $vector3 (xf yf zf) ($vector (call-x xf yf zf) (call-y xf yf zf)))
 708
 709 (defun $line3 (xf1 yf1 zf1 xf yf zf)
 710        ($line (call-x xf1 yf1 zf) (call-y xf1 yf1 zf1)
 711               (call-x xf yf zf) (call-y xf yf zf)))
 712
 713 (defun $drawsymbol3 (xf yf zf x1) ($drawsymbol (call-x xf yf zf) (call-y xf yf zf) x1))
 714 \f
 715 ;;; Character drawing routines
 716 ;;; (this is pretty random and needs to be redone)
 717
 718 (defun gterpri nil (setpoint min-x (f- last-y char-height)))
 719
 720 (defun $gterpri nil (gterpri))
 721
 722 (defun ghprint (l x y a1)
 723        (cond ((atom l) (setq l (exploden l)))
 724              (t (setq l (apply 'append (mapcar 'exploden l)))))
 725        (let ((b1 (f* char-width (length l)))
 726              (uline (> a1 9.)))
 727             (and uline (setq a1 (f- a1 10.)))
 728             (cond ((= a1 0.))
 729                   ((= a1 1.) (setq x (f- x (// b1 2.))))
 730                   ((= a1 2.) (setq x (f- x b1))))
 731             (and (> (f+ x b1) max-x) (setq x (f- max-x b1)))
 732             (and (< x min-x) (setq x min-x))
 733             (and (> (f+ y char-height) max-y) (setq y (f- max-y char-height)))
 734             (and (< y min-y) (setq y min-y))
 735             (do ((l l (cdr l)) (x x (f+ x char-width)) (flg t NIL))
 736                 ((or (null l) (> x (f- max-x char-width))))
 737                 (cond (flg (setpoint x y) (setq pnt-status nil)))
 738                 (send plot-stream ':plot-char (car l) x y))
 739             (if uline (line x (f- y 2.) (f+ x b1) (f- y 2.)))
 740             (setpoint (f+ x b1) y)))
 741
 742 (defun $ghprint (l x y a1)
 743        (setq l (cond ((and (consp l) (consp (car l)) (eq (caar l) 'mlistp))
 744                       (cdr l))
 745                      (t l)))
 746        (ghprint (cond ((atom l) (stripdollar l)) (t (mapcar 'stripdollar l)))
 747                 x y a1))
 748
 749 (defun gvprint (l x y a1)
 750        (cond ((atom l) (setq l (exploden l)))
 751              (t (setq l (apply 'append (mapcar 'exploden l)))))
 752        (let ((b1 (f* char-height (length l))))
 753             (cond ((= a1 0.))
 754                   ((= a1 1.) (setq y (f+ y (// b1 2.))))
 755                   ((= a1 2.) (setq y (f+ y b1))))
 756             (if (< (f- y b1) min-y) (setq y (f+ min-y b1)))
 757             (if (> y max-y) (setq y max-y))
 758             (if (> (f+ x char-width) max-x) (setq x (f- max-x char-width)))
 759             (if (< x min-x) (setq x min-x))
 760             (do ((l l (cdr l)) (y (f- y char-height) (f- y char-height)))
 761                 ((or (null l) (< y min-y)))
 762                 (setpoint x y)(setq pnt-status nil)
 763                 (send plot-stream ':plot-char (car l) x y))
 764             (setpoint y (f- y b1))))
 765
 766 (defun $gvprint (l x y a1)
 767        (setq l (cond ((and (consp l) (consp (car l)) (eq (caar l) 'mlistp))
 768                       (cdr l))
 769                      (t l)))
 770        (gvprint (cond ((atom l) (stripdollar l)) (t (mapcar 'stripdollar l)))
 771                 x y a1))
 772
 773 (defun gmark (x y x1)
 774   (setpoint (f- x (// char-width 2.)) (f- y (// char-height 2.)))
 775   (if pnt-status
 776       (cond ((checkpnt (f+ last-x char-width) (f+ last-y char-height))
 777              (setq pnt-status nil)
 778              (send plot-stream ':plot-char x1 last-x last-y))))
 779   (setpoint x y))
 780
 781 (defun $gmark (xf yf x1) (gmark (plot-x xf) (plot-y yf) x1))
 782