archive/share/trash/world.mac

   1 (declare (special max-x min-x max-y min-y size-x size-y max-xf min-xf
   2                   max-yf min-yf size-xf size-yf scale-x scale-y tty-graphics
   3                   dsk-graphics $fasldisp)
   4          (fixnum x y ox oy)
   5          (fixnum filen ptr (fixin) (binfilen) (mfixin) (access fixnum)
   6                  max-x min-x max-y min-y size-x size-y temp)
   7          (flonum max-xf min-xf max-yf min-yf size-xf size-yf scale-x scale-y
   8                  dist rad)
   9          (notype (setpoint fixnum fixnum) (vector fixnum fixnum) ($entergraph)
  10                  ($screensize fixnum fixnum fixnum fixnum) ($exitgraph)))
  11
  12 (declare (eval (read)))
  13 (setq ibase 8.)
  14
  15 (defun $worldplot (llong hlong llat hlat)
  16        (or (get '$plotmode 'mfexpr*s) (loadfile '(tekplt fasl dsk share) t $fasldisp))
  17        (or (get 'directory 'lsubr) (loadfile '(allfiles fasl com) t $fasldisp))
  18        ((lambda (rad dist temp)
  19                 (setq rad (//$ (atan 0 -1) 180.0)
  20                       dist (cos (*$ rad (//$ (+$ (float hlat) (float llat)) 2.0)))
  21                       rad (//$ (float 400000) 180.0)
  22                       max-xf (*$ (float hlong) rad)
  23                       min-xf (*$ (float llong) rad)
  24                       size-xf (-$ max-xf min-xf)
  25                       max-yf (*$ (float hlat) rad)
  26                       min-yf (*$ (float llat) rad)
  27                       size-yf (-$ max-yf min-yf))
  28                 (cond (dsk-graphics ($screensize 0. 5. 1023. 790.))
  29                       ((eq tty-graphics 'imlac) ($screensize 0. 0. 1023. 1023.))
  30                       ((eq tty-graphics 'tek) ($screensize 0. 5. 1023. 789.))
  31                       (t ($screensize 0. 0. 1023. 1023.)))
  32                 (cond ((> (//$ (*$ size-xf dist) (float size-x))
  33                           (//$ size-yf (float size-y)))
  34                        (setq temp (fix (*$ size-yf (float size-x)
  35                                            (//$ (*$ size-xf dist)))))
  36                        ($screensize min-x
  37                                    (// (- (+ min-y max-y) temp) 2.)
  38                                    max-x
  39                                    (// (+ (+ min-y max-y) temp) 2.)))
  40                       (t (setq temp (fix (*$ size-xf dist (float size-y)
  41                                              (//$ size-yf))))
  42                          ($screensize (// (- (+ min-x max-x) temp) 2.)
  43                                      min-y
  44                                      (// (+ (+ min-x max-x) temp) 2.)
  45                                      max-y))))
  46         0.0 0.0 0)
  47        ($entergraph)
  48        (do ((files '(((dsk maxdmp) world geogra) ((dsk maxdmp) world politi))
  49                    (cdr files))
  50             (file nil (close file))
  51             (filen))
  52            ((null files) ($exitgraph) '$done)
  53            (setq file (open (car files) '(in fixnum)))
  54            (setq filen (caddar (directory (list file) '(words))))
  55            (in file)
  56            (do nil ((not (> filen (filepos file))))
  57                (do ((first t nil)
  58                     (x (in file) (in file))
  59                     (y 0.)
  60                     (ox -1.)
  61                     (oy -1.))
  62                    ((< x 0.))
  63                    (setq y (lsh x -18.)
  64                          x (boole 1. x 777777))
  65                    (cond ((> x 377777) (setq x (- x 1000000))))
  66                    (cond ((> y 177777) (setq y (- y 400000))))
  67                    (setq x (+ min-x (fix (+$ 0.5 (//$ (-$ (float x) min-xf) scale-x))))
  68                          y (+ min-y (fix (+$ 0.5 (//$ (-$ (float y) min-yf) scale-y)))))
  69                    (cond ((and (not first)
  70                                (> (abs (- ox x)) 1000))
  71                           (filepos file (1- (filepos file)))
  72                           (return nil)))
  73                    (cond (first (setpoint x y))
  74                          ((not (and (= x ox) (= y oy)))
  75                           (vector x y)))
  76                    (setq ox x oy y)))))
  77 (declare (eval (read)))
  78 (setq ibase 10.)