mirror of
https://github.com/PDP-10/its.git
synced 2026-03-04 02:35:00 +00:00
85994ed770
Resolves #284. Commented out uses of time-origin in maxtul; mcldmp (init) until we can figure out why it gives arithmetic overflows under the emulators. Updated the expect script statements in build_macsyma_portion to not attempt to match expected strings, but simply sleep for some time since in some cases the matching appears not to work.
140 lines
5.0 KiB
Common Lisp
140 lines
5.0 KiB
Common Lisp
;;;-*-Lisp-*-
|
|
|
|
; (c) Copyright 1976, 1983 Massachusetts Institute of Technology.
|
|
; All Rights Reserved. Enhancements (c) Copyright 1983 Symbolics Inc.
|
|
; All Rights Reserved.
|
|
;
|
|
; The data and information in the Enhancements is proprietary to, and a
|
|
; valuable trade secret of, SYMBOLICS, INC., a Delaware corporation. It is
|
|
; given in confidence by SYMBOLICS, and may not be used as the basis of
|
|
; manufacture, or be reproduced or copied, or distributed to any other
|
|
; party, in whole or in part, without the prior written consent of SYMBOLICS.
|
|
|
|
|
|
|
|
;;;transformation funtions
|
|
|
|
(declare (special logbas cosang sinang)
|
|
(flonum xf yf logbas
|
|
($clog flonum) ($polarx flonum flonum) ($polary flonum flonum)
|
|
($reflect flonum) ($ytox flonum flonum) ($xtoy flonum flonum)
|
|
($ztox flonum flonum flonum) ($ztoy flonum flonum flonum)
|
|
ang cosang sinang
|
|
($rotatex flonum flonum) ($rotatey flonum flonum))
|
|
(notype ($initrotate flonum)))
|
|
|
|
(setq logbas (log 10.0))
|
|
|
|
(defun $clog (xf) (//$ (cond ((= 0.0 xf) -90.0) (t (log (abs xf)))) logbas))
|
|
|
|
(defun $polarx (xf yf) (*$ yf (cos xf)))
|
|
|
|
(defun $polary (xf yf) (*$ yf (sin xf)))
|
|
|
|
(defun $reflect (xf) (-$ xf))
|
|
|
|
(defun $ytox (xf yf) yf)
|
|
|
|
(defun $xtoy (xf yf) xf)
|
|
|
|
(defun $ztoy (xf yf zf) zf)
|
|
|
|
(defun $ztox (xf yf zf) zf)
|
|
|
|
(declare (special cosang sinang))
|
|
|
|
(defun $initrotate (ang) (setq cosang (cos ang) sinang (sin ang)) nil)
|
|
|
|
($initrotate (atan 1. 0.))
|
|
|
|
(defun $rotatex (xf yf) (-$ (*$ xf cosang) (*$ yf sinang)))
|
|
|
|
(defun $rotatey (xf yf) (+$ (*$ xf sinang) (*$ yf cosang)))
|
|
|
|
(declare (special ex ey ez cosal cosbe cosga singa2 x0 z0)
|
|
(flonum ax ay az ex ey ez dx dy dz d cosal cosbe cosga r singa2 x0 z0)
|
|
(flonum ($p3dx flonum flonum flonum) ($p3dy flonum flonum flonum)
|
|
($p3dxr flonum flonum flonum) ($p3dyr flonum flonum flonum)
|
|
($howclose3d flonum flonum flonum)
|
|
($np3dx flonum flonum) ($np3dy flonum flonum flonum)
|
|
($np3dxr flonum flonum) ($np3dyr flonum flonum flonum)
|
|
($howclosenp3d flonum flonum flonum)
|
|
($old3dx flonum flonum) ($old3dy flonum flonum flonum)
|
|
($old3dxr flonum flonum) ($old3dyr flonum flonum flonum)
|
|
($howcloseold3d flonum flonum flonum)
|
|
($oldnp3dx flonum flonum) ($oldnp3dy flonum flonum flonum)
|
|
($oldnp3dxr flonum flonum) ($oldnp3dyr flonum flonum flonum)
|
|
($howcloseoldnp3d flonum flonum flonum))
|
|
(notype ($initperspec flonum flonum flonum flonum flonum flonum)))
|
|
|
|
(defun $initperspec (xf yf zf xf1 yf1 zf1)
|
|
((lambda (ax ay az dx dy dz d r)
|
|
(setq ax xf ay yf az zf ex xf1 ey yf1 ez zf1
|
|
dx (-$ xf xf1) dy (-$ yf yf1) dz (-$ zf zf1)
|
|
d (sqrt (+$ (*$ dx dx) (*$ dy dy) (*$ dz dz)))
|
|
cosal (//$ dx d) cosbe (//$ dy d) cosga (//$ dz d)
|
|
singa2 (-$ 1.0 (*$ cosga cosga))
|
|
x0 (//$ ex ey) z0 (//$ ez ey)
|
|
r (//$ (sqrt (-$ 1.0 (*$ cosga cosga)))))
|
|
nil)
|
|
0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
|
|
|
|
(comment
|
|
(defun $p3dx (xf yf zf)
|
|
((lambda (q)
|
|
(*$ (-$ (*$ (+$ ex (*$ q (-$ xf ex)) (-$ ax)) cosbe)
|
|
(*$ (+$ ey (*$ q (-$ yf ey)) (-$ ay)) cosal))
|
|
r))
|
|
(//$ d (+$ (*$ (-$ xf ex) cosal) (*$ (-$ yf ey) cosbe) (*$ (-$ zf ez) cosga)))))
|
|
|
|
(defun $p3dy (xf yf zf)
|
|
((lambda (q)
|
|
(*$ (+$ ez (*$ q (-$ zf ez)) (-$ az)) r))
|
|
(//$ d (+$ (*$ (-$ xf ex) cosal) (*$ (-$ yf ey) cosbe) (*$ (-$ zf ez) cosga)))))
|
|
)
|
|
|
|
(defun $p3dx (xf yf zf)
|
|
(setq xf (-$ xf ex) yf (-$ yf ey))
|
|
(//$ (-$ (*$ xf cosbe) (*$ yf cosal))
|
|
(+$ (*$ xf cosal) (*$ yf cosbe) (*$ (-$ zf ez) cosga))))
|
|
(defun $p3dy (xf yf zf)
|
|
(setq zf (-$ zf ez))
|
|
(//$ zf (+$ (*$ (-$ xf ex) cosal) (*$ (-$ yf ey) cosbe) (*$ zf cosga))))
|
|
(defun $p3dxr (xf yf zf) (-$ ($p3dx xf yf zf)))
|
|
#-franz (putprop '$p3dyr (get '$p3dy 'subr) 'subr)
|
|
#-franz (args '$p3dyr (args '$p3dy))
|
|
#+franz (putd '$p3dr (getd '$p3d))
|
|
|
|
(defun $howclose3d (xf yf zf)
|
|
(setq xf (-$ xf ex) yf (-$ yf ey) zf (-$ zf ez))
|
|
(sqrt (+$ (*$ xf xf) (*$ yf yf) (*$ zf zf))))
|
|
|
|
(defun $np3dx (xf yf) (-$ (*$ cosbe xf) (*$ cosal yf)))
|
|
(defun $np3dy (xf yf zf)
|
|
(-$ (*$ singa2 zf) (*$ cosga (+$ (*$ cosbe yf) (*$ cosal xf)))))
|
|
(defun $np3dxr (xf yf) (-$ ($np3dx xf yf)))
|
|
#-franz (putprop '$np3dyr (get '$np3dy 'subr) 'subr)
|
|
#-franz (args '$np3dyr (args '$np3dy))
|
|
#+franz (putd '$np3dyr (getd '$np3dy))
|
|
|
|
(defun $howclosenp3d (xf yf zf) (+$ (*$ xf cosal) (*$ yf cosbe) (*$ zf cosga)))
|
|
|
|
(defun $old3dx (xf yf) (//$ (-$ xf ex) (-$ yf ey)))
|
|
(defun $old3dy (xf yf zf) (//$ (-$ zf ez) cosbe (-$ yf ey)))
|
|
(defun $old3dxr (xf yf) (-$ ($old3dx xf yf)))
|
|
#-franz (putprop '$old3dyr (get '$old3dy 'subr) 'subr)
|
|
#-franz (args '$old3dyr (args '$old3dy))
|
|
#+franz (putd '$old3dyr (getd '$old3dy))
|
|
|
|
(putprop '$howcloseold3d (get '$howclose3d 'subr) 'subr)
|
|
(args '$howcloseold3d (args '$howclose3d))
|
|
|
|
(defun $oldnp3dx (xf yf) (*$ cosbe (-$ xf (*$ yf x0))))
|
|
(defun $oldnp3dy (xf yf zf) (-$ zf (*$ yf z0)))
|
|
(defun $oldnp3dxr (xf yf) (-$ ($oldnp3dx xf yf)))
|
|
#-franz (putprop '$oldnp3dyr (get '$oldnp3dy 'subr) 'subr)
|
|
#-franz (args '$oldnp3dyr (args '$oldnp3dy))
|
|
#+franz (putd '$oldnp3dyr (getd '$oldnp3dy))
|
|
|
|
(defun $howcloseoldnp3d (xf yf zf) (*$ cosbe (+$ (*$ x0 xf) yf (*$ z0 zf))))
|