home *** CD-ROM | disk | FTP | other *** search
/ Eagles Nest BBS 8 / Eagles_Nest_Mac_Collection_Disc_8.TOAST / Developer Environments / AllegroCL11 / Examples / Select-Rectangle.Lisp < prev   
Encoding:
Text File  |  1987-10-27  |  2.0 KB  |  69 lines  |  [TEXT/CCL ]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;;Select-Rectangle.Lisp
  4. ;;
  5. ;;Copyright © 1987, Coral Software Corp
  6. ;;
  7. ;;
  8. ;;  This file has some examples of making trap calls and using window.
  9. ;;
  10. ;;  It implements a function for dragging out a gray rectangle.
  11. ;;  Then it shows how to use this function to create a new class of windows.
  12.  
  13. (eval-when (eval compile)
  14.   (require 'traps)
  15.   (require 'records))
  16.  
  17. ;;;;;;;;;;;;;;;;;;
  18. ;;
  19. ;;select-rectangle
  20. ;;
  21. ;;  returns multiple values giving the two corner points of the
  22. ;;  selected rectangle.
  23. ;;
  24. (defobfun (select-rectangle *window*) ()
  25.   (declare (object-variable wptr))
  26.   (let* ((anchor-point (window-mouse-position))
  27.          (old-mouse (window-mouse-position))
  28.          (new-mouse old-mouse))
  29.     (rlet ((r :rect)
  30.            (old-pen-state :penstate))
  31.       (with-port wptr
  32.         (_GetPenState :ptr old-pen-state)
  33.         (_PenMode :word (position :patxor *pen-modes*))
  34.         (rset wptr window.pnPat *gray-pattern*)
  35.         (_FrameRect :ptr r)
  36.         (loop
  37.           (unless (mouse-down-p) (return))     ;return when the mouse lets up
  38.           (unless (eq old-mouse new-mouse)
  39.             (_FrameRect :ptr r)
  40.             (_pt2rect :long anchor-point
  41.                       :long new-mouse
  42.                       :ptr r)
  43.             (_FrameRect :ptr r)
  44.             (sleep 1/60)
  45.             (setq old-mouse new-mouse))
  46.           (setq new-mouse (window-mouse-position)))
  47.         (_FrameRect :ptr r)
  48.         (_SetPenState :ptr old-pen-state)
  49.         (values (rref r rect.topleft)
  50.                 (rref r rect.bottomright))))))
  51.  
  52.  
  53. ;;;;;;;;;;;;;;;;;;;;
  54. ;;
  55. ;; *rect-window*
  56. ;;
  57. ;;  a class of windows that lets you draw rectangle pictures
  58.  
  59. (defobject *mondrian-window* *window*)
  60.  
  61. (defobfun (window-click-event-handler *mondrian-window*) (where)
  62.   (declare (ignore where))
  63.   (multiple-value-bind (topleft bottomright) (select-rectangle)
  64.     (rlet ((my-rect :rect))
  65.       (rset my-rect rect.topleft topleft)
  66.       (rset my-rect rect.bottomright bottomright)
  67.       (_InverRect :ptr my-rect))))
  68.  
  69. (oneof *mondrian-window*)