home *** CD-ROM | disk | FTP | other *** search
/ Shareware Overload / ShartewareOverload.cdr / games / misc_lsp.zip / ZOOM.LSP < prev   
Lisp/Scheme  |  1987-01-30  |  4KB  |  74 lines
  1.  
  2. ;      ZOOM to the extents of the virtual screen
  3.  
  4. (defun C:ZE ()
  5.    (command "ZOOM" "W" (getvar "VSMIN") (getvar "VSMAX"))
  6. )
  7.  
  8. ;      ZOOM Window like ZOOM Dynamic except done on current display
  9. ;      doesn't handle keyboard except space, return and arrow keys
  10.  
  11. (defun drawbox ()                        ; draw the box
  12.    (grdraw ll ul -1)  (grdraw ul ur -1)
  13.    (grdraw ur lr -1)  (grdraw lr ll -1)
  14.    (if (= mode 0) (cenx) (arrow))
  15. )
  16. (defun cenx ()                           ; draw center X
  17.    (grdraw x1 x2 -1)  (grdraw x3 x4 -1)
  18. )
  19. (defun arrow ()                          ; draw sizing arrow
  20.    (grdraw a1 a4 -1)  (grdraw a2 a4 -1)  (grdraw a3 a4 -1)
  21. )
  22. (defun defbox ()                         ; redefine box parameters & draw
  23.    (setq deltay (* deltax aspect))       ; assume deltax & center were
  24.    (setq xcen (car center) ycen (cadr center))  ; reset in higher level
  25.    (setq lx (- xcen deltax) ux (+ xcen deltax)) ; lower/upper X/Y for box
  26.    (setq ly (- ycen deltay) uy (+ ycen deltay))
  27.    (setq ll (list lx ly) ul (list lx uy))  ; corners of box
  28.    (setq ur (list ux uy) lr (list ux ly))
  29.    (setq yp (+ ycen arm) ym (- ycen arm))  ; upper/lower Y for cross and arrow
  30.    (setq a1 (list (- ux arm) yp) a2 (list (- ux arm) ym)) ; left arrow tips
  31.    (setq a3 (list (- ux arm arm) ycen))  ; arrow tail
  32.    (setq a4 (list ux ycen))              ; right end of all three
  33.    (setq x1 (list (- xcen arm) ym) x2 (list (+ xcen arm) yp))  ; ends of X
  34.    (setq x3 (list (- xcen arm) yp) x4 (list (+ xcen arm) ym))
  35.    (drawbox)
  36. )
  37. (defun C:ZW (/ arm aspect center deltax inp loop mode prev pt source)
  38.    (setq center (getvar "VIEWCTR"))      ; start at screen center
  39.    (setvar "LASTPOINT" (setq prev center)) ; try to re-center cursor
  40.    (setq aspect (/ (cadr (setq aspect (getvar "SCREENSIZE"))) (car aspect)))
  41.    (setq deltax (* 0.25 (getvar "VIEWSIZE")))  ; use 1/4 screen box
  42.    (setq arm (* 0.1 deltax) mode 0 loop T) ; initially in box move mode
  43.    (defbox)
  44.    (while loop
  45.       (setq inp (grread T))              ; get input, tracking
  46.       (setq source (car inp) pt (cadr inp))  ; isolate source and # or point
  47.       (cond ((= source 3)                ; "pick" button?
  48.                (cenx) (arrow)            ; erase old & draw new or vice versa
  49.                (setq mode (- 1 mode))    ; toggle box mode
  50.                (setvar "LASTPOINT" center)) ; try to re-center cursor
  51.             ((= source 5)                ; tracking point?
  52.                (if (or (/= (car  prev) (car  pt)) ; if it moved
  53.                        (/= (cadr prev) (cadr pt)))
  54.                (progn                    ; change or move box
  55.                   (if (= mode 0)
  56.                      (setq center pt)
  57.                      (setq deltax (+ deltax (- (car pt) (car prev)))))
  58.                   (setq prev pt)
  59.                   (drawbox)              ; erase old box
  60.                   (defbox)               ; set new center/size and draw
  61.                )))
  62.             ((or (and (= source 6) (= pt 0))     ; button 1, or
  63.                  (and (= source 2)               ; keyboard and
  64.                       (or (= pt 13) (= pt 32)))) ; CR or blank?
  65.                (drawbox)                 ; erase old box
  66.                (command "ZOOM" "W" ll ur)
  67.                (setq loop nil))          ; exit
  68.             (T                           ; any other grread value
  69.                (drawbox)                 ; erase old box
  70.                (setq loop nil a " ^cancel ")) ; exit
  71.       )
  72.    )
  73. )
  74.