archive/src/iffun.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 ;;;transformation funtions - part of the PLOT package
  11
  12 (declare-top(special logbas cosang sinang))
  13
  14 (setq logbas (log 10.0))
  15
  16 (defun $clog (xf) (// (cond ((= 0.0 xf) -90.0) (t (log (abs xf)))) logbas))
  17
  18 (defun $polarx (xf yf) (*$ yf (cos xf)))
  19
  20 (defun $polary (xf yf) (*$ yf (sin xf)))
  21
  22 (defun $reflect (xf) (-$ xf))
  23
  24 (defun $ytox (xf yf) xf yf)
  25
  26 (defun $xtoy (xf yf) yf xf)
  27
  28 (defun $ztoy (xf yf zf) xf yf zf zf)
  29
  30 (defun $ztox (xf yf zf) xf yf zf)
  31
  32 (declare-top(special cosang sinang))
  33
  34 (defun $initrotate (ang) (setq cosang (cos ang) sinang (sin ang)) nil)
  35
  36 ($initrotate (atan 1. 0.))
  37
  38 (defun $rotatex (xf yf) (-$ (*$ xf cosang) (*$ yf sinang)))
  39
  40 (defun $rotatey (xf yf) (+$ (*$ xf sinang) (*$ yf cosang)))
  41
  42 (declare-top (special ex ey ez cosal cosbe cosga singa2 x0 z0))
  43
  44 (defun $initperspec (xf yf zf xf1 yf1 zf1) xf
  45        ((lambda (ax ay az dx dy dz d r)
  46                 (setq ax xf ay yf az zf ex xf1 ey yf1 ez zf1
  47                       dx (-$ xf xf1) dy (-$ yf yf1) dz (-$ zf zf1)
  48                       d (sqrt (+$ (*$ dx dx) (*$ dy dy) (*$ dz dz)))
  49                       cosal (// dx d) cosbe (// dy d) cosga (// dz d)
  50                       singa2 (-$ 1.0 (*$ cosga cosga))
  51                       x0 (// ex ey) z0 (// ez ey)
  52                       r
  53                       (or (car (errset  (// (sqrt (-$ 1.0 (*$ cosga cosga))))))
  54                           1.0d40)
  55                       ) ;;Some big number??
  56                 nil)
  57         0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
  58
  59 (comment
  60 (defun $p3dx (xf yf zf)
  61        ((lambda (q)
  62                 (*$ (-$ (*$ (+$ ex (*$ q (-$ xf ex)) (-$ ax)) cosbe)
  63                         (*$ (+$ ey (*$ q (-$ yf ey)) (-$ ay)) cosal))
  64                     r))
  65         (// d (+$ (*$ (-$ xf ex) cosal) (*$ (-$ yf ey) cosbe) (*$ (-$ zf ez) cosga)))))
  66
  67 (defun $p3dy (xf yf zf)
  68        ((lambda (q)
  69                 (*$ (+$ ez (*$ q (-$ zf ez)) (-$ az)) r))
  70         (// d (+$ (*$ (-$ xf ex) cosal) (*$ (-$ yf ey) cosbe) (*$ (-$ zf ez) cosga)))))
  71 )  ;;end of comment
  72
  73 (defun $p3dx (xf yf zf)
  74        (setq xf (-$ xf ex) yf (-$ yf ey))
  75        (// (-$ (*$ xf cosbe) (*$ yf cosal))
  76             (+$ (*$ xf cosal) (*$ yf cosbe) (*$ (-$ zf ez) cosga))))
  77
  78 (defun $p3dy (xf yf zf)
  79        (setq zf (-$ zf ez))
  80        (// zf (+$ (*$ (-$ xf ex) cosal) (*$ (-$ yf ey) cosbe) (*$ zf cosga))))
  81
  82 (defun $p3dxr (xf yf zf) (-$ ($p3dx xf yf zf)))
  83
  84 (setf (symbol-function  '$p3dyr)  #'$p3dy)
  85
  86 (defun $howclose3d (xf yf zf)
  87        (setq xf (-$ xf ex) yf (-$ yf ey) zf (-$ zf ez))
  88        (sqrt (+$ (*$ xf xf) (*$ yf yf) (*$ zf zf))))
  89
  90 (defun $np3dx (xf yf) (-$ (*$ cosbe xf) (*$ cosal yf)))
  91
  92 (defun $np3dy (xf yf zf)
  93        (-$ (*$ singa2 zf) (*$ cosga (+$ (*$ cosbe yf) (*$ cosal xf)))))
  94
  95 (defun $np3dxr (xf yf) (-$ ($np3dx xf yf)))
  96
  97 (setf (symbol-function  '$np3dyr)  #'$np3dy)
  98
  99 (defun $howclosenp3d (xf yf zf) (+$ (*$ xf cosal) (*$ yf cosbe) (*$ zf cosga)))
 100
 101 (defun $old3dx (xf yf) (// (-$ xf ex) (-$ yf ey)))
 102 (defun $old3dy (xf yf zf) xf (// (-$ zf ez) cosbe (-$ yf ey)))
 103 (defun $old3dxr (xf yf) (-$ ($old3dx xf yf)))
 104
 105 (setf (symbol-function  '$old3dyr)  #'$old3dy)
 106
 107 (setf (symbol-function  '$howcloseold3d)  #'$howclose3d)
 108
 109 (defun $oldnp3dx (xf yf) (*$ cosbe (-$ xf (*$ yf x0))))
 110 (defun $oldnp3dy (xf yf zf) xf (-$ zf (*$ yf z0)))
 111 (defun $oldnp3dxr (xf yf) (-$ ($oldnp3dx xf yf)))
 112
 113 (setf (symbol-function  '$oldnp3dyr)  #'$oldnp3dy)
 114
 115 (defun $howcloseoldnp3d (xf yf zf) (*$ cosbe (+$ (*$ x0 xf) yf (*$ z0 zf))))
 116