[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Mouse Blinker

    Date: Thu, 26 Apr 90 12:42 MET
    From: BWILD%fix%iravcl.ira.uka.de@RELAY.CS.NET (Bernd Wild, FZI)

    I am porting an medium scale application from Common Windows (the
    window system of KEE) to plain Dynamic Windows. Unfortunately, 
    there is a feature in CW which I have used extensively but has
    no counterpart in DW: in CW you can freely exchange the mouse
    cursor by an arbitrary bitmap, not only by another mouse character
    like in DW.

This is one of my favorite hacks.  I use it to allow mouse movement of
an image of what's on the screen rather than just an outline.  Below is 
the code.  You can set the blinker image to an arbitrary bitmap (raster
array) by using the SET-DISPLAY method.  Note that if you make a bunch
of these instances, it will eat up a lot of space because of the scratch
pad technique that I used to avoid flicker.  Have fun.    

;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: USER -*-

(in-package 'ui-tools :use '(symbolics-common-lisp))
;;;

(defflavor MOUSE-BITBLT-BLINKER-MIXIN
      ((previous-x-position nil)
       (previous-y-position nil)
       (scratch-pad (make-raster-array (tv:sheet-width tv:main-screen)
				       (tv:sheet-height tv:main-screen)
				       :element-type '(CL:INTEGER 0 (2))
				       :initial-element 0)))
      ()
  :initable-instance-variables
  :readable-instance-variables
  :writable-instance-variables
  (:required-flavors tv:bitblt-blinker)
  )

(defmethod (SET-DISPLAY MOUSE-BITBLT-BLINKER-MIXIN)
	   (new-array new-width new-height &optional (x tv:x-pos) (y tv:y-pos))
  (setq tv:array new-array
	tv:width new-width
	tv:height new-height
	previous-x-position x
	previous-y-position y)
  (let* ((sw (tv:sheet-width tv:sheet))
	 (sh (tv:sheet-height tv:sheet))
	 (w (min (- sw x) tv:width))
	 (h (min (- sh y) tv:height)))
    (when (and (plusp w) (plusp h))
      ;; Draw the blinker on the sheet
      (tv:prepare-sheet (tv:sheet)
	(tv:sheet-bitblt tv:blinker-alu w h tv:array 0 0 nil x y tv:sheet))
      ;; Prepare the scratch pad 
      (multiple-value-call
	#'(lambda (wid hei ignore)
	    (or (if (or (< wid sw) (< hei sh))
		    ;; Make a new (bigger) scratch pad
		    (setf scratch-pad
			  (make-raster-array
			    sw sh :element-type '(cl:integer 0 (2)) :initial-element 0)))
		;; Clear a sheet-sized region on existing scratch pad
		(tv:%draw-rectangle sw sh 0 0 tv:alu-setz scratch-pad)))
	(decode-raster-array scratch-pad))
      ;; Draw the blinker image on the scratch pad
      (bitblt tv:alu-xor w h tv:array 0 0 scratch-pad x y)
      )))

(defmethod (:BLINK MOUSE-BITBLT-BLINKER-MIXIN) ()
  (let* (;; Width and height of target sheet
	 (sw (tv:sheet-width tv:sheet)) (sh (tv:sheet-height tv:sheet))
	 ;; New blinker position
	 (x (+ tv:delta-x tv:x-pos)) (y (+ tv:delta-y tv:y-pos))
	 ;; Width and height of this blinker image
	 (w (min (- sw x) tv:width)) (h (min (- sh y) tv:height)))	 
    (if (and previous-x-position previous-y-position)
	(let* (;; Position of this blink (erase/redraw) 
	       (left (min x previous-x-position)) (top  (min y previous-y-position))
	       ;; Bounding box width and height for this blink (erase/redraw) 
	       (bbw (- (min sw (+ tv:width  (max x previous-x-position))) left))
	       (bbh (- (min sh (+ tv:height (max y previous-y-position))) top)))
	;; Don't draw if the region is zero-sized
	(when (and (plusp bbw) (plusp bbh))
	  ;; Draw blinker image on the scratch pad at new position
	  (bitblt tv:alu-xor w h tv:array 0 0 scratch-pad x y)
	  ;; Erase previous image and display new one in a single screen bitblt
	  (tv:sheet-bitblt tv:blinker-alu bbw bbh scratch-pad
			   left top nil left top tv:sheet)
	  ;; Draw blinker image in the scratch pad at old position (i.e. erase)
	  (bitblt tv:alu-xor tv:width tv:height tv:array 0 0
		  scratch-pad previous-x-position previous-y-position)))
	;; Don't draw if the region is zero-sized
	(when (and (plusp w) (plusp h))
	  ;; Draw blinker image on the scratch pad at new position
	  (bitblt tv:alu-xor w h tv:array 0 0 scratch-pad x y)
	  ;; Display new blinker image 
	  (tv:sheet-bitblt
	    tv:blinker-alu w h scratch-pad x y nil x y tv:sheet)))
    (setq previous-x-position x previous-y-position y)
    ))

;; To prevent wierd breakage:
(defmethod (tv:mouse-blinker-make-cursor MOUSE-BITBLT-BLINKER-MIXIN) (&rest ignore))
(defmethod (tv:mouse-blinker-flush-cursor-cache MOUSE-BITBLT-BLINKER-MIXIN) (&rest ignore))
;;;

(defflavor MOUSE-FOLLOWING-BITBLT-BLINKER ()
	   (tv:mouse-blinker-fast-tracking-mixin mouse-bitblt-blinker-mixin tv:bitblt-blinker)
  )

(compile-flavor-methods mouse-following-bitblt-blinker)

(defparameter
  checkerboard
  (let ((array (make-raster-array 32 2 :element-type '(CL:INTEGER 0 (2)) :initial-element 0)))
    (dotimes (i 2) (dotimes (j 32) (when (evenp (+ i j)) (setf (aref array i j) 1))))
    array
    ))

(tv:mouse-define-blinker-type
  :mouse-bitblt
  #'(lambda (screen)
      (tv:make-blinker screen 'mouse-following-bitblt-blinker
		       :visibility nil :deselected-visibility nil :width 3 :height 3
		       :array checkerboard :previous-x-position nil :previous-y-position nil
		       )))
;;;

; Example usage:
; (tv:mouse-set-blinker-definition :mouse-bitblt 0 0 :on :set-display checkerboard 32 32 tv:mouse-x tv:mouse-y)

;;; End of file