xemacs: shared/motion4.el comparison

comparison shared/motion4.el @ 0:107d592c5f4a

DICE versions, used by pers/common, recursive, I think/hope

author	Henry S. Thompson <ht@inf.ed.ac.uk>
date	Mon, 08 Feb 2021 11:44:37 +0000
parents
children

comparison

equal deleted inserted replaced

--1:000000000000
+:107d592c5f4a
+;;; Copyright (C) 1991 Christopher J. Love
+;;;
+;;; This file is for use with Epoch, a modified version of GNU Emacs.
+;;; Requires Epoch 4.0 or later.
+;;;
+;;; This code is distributed in the hope that it will be useful,
+;;; bute WITHOUT ANY WARRANTY. No author or distributor accepts
+;;; responsibility to anyone for the consequences of using this code
+;;; or for whether it serves any particular purpose or works at all,
+;;; unless explicitly stated in a written agreement.
+;;;
+;;; Everyone is granted permission to copy, modify and redistribute
+;;; this code, but only under the conditions described in the
+;;; GNU Emacs General Public License, except the original author nor his
+;;; agents are bound by the License in their use of this code.
+;;; (These special rights for the author in no way restrict the rights of
+;;;  others given in the License or this prologue)
+;;; A copy of this license is supposed to have been given to you along
+;;; with Epoch so you can know your rights and responsibilities.
+;;; It should be in a file named COPYING.  Among other things, the
+;;; copyright notice and this notice must be preserved on all copies.
+;;;
+;;; $Revision: 1.2 $
+;;; $Source: /home/user5/ht/emacs/shared/RCS/motion4.el,v $
+;;; $Date: 1992/03/18 21:44:10 $
+;;; $Author: ht $
+;;;
+;;; motion.el - provide draggin/hi-lighting of primary selection
+;;;
+;;; Original version by Alan Carroll
+;;; Epoch 4.0 modifications by Chris Love
+;;; Abort-isearch and other ideas from Ken Laprade and others.
+;;;
+(provide 'motion)
+(redisplay-screen) ; fix epoch4.0a race bug?
+(require 'zone)
+(require 'mouse)
+;;; ------------------------------------------------------------------------
+;;; Interface values
+(defvar horizontal-drag-inc 5
+"Number of columns to scroll when the pointer is to the left or right of the window")
+(defvar vertical-drag-inc 2
+"Number of lines to scroll when the pointer is above or below the edge of the window")
+(defvar mouse::downp nil "State variable for mouse dragging internals")
+(defvar mouse::last-point -1 "Last location of a motion event")
+(setq epoch::zones-modify-buffer nil)
+(defvar motion::style nil "style used by drag zones")
+(defvar drag-zone nil
+"Epoch zone to be used for hilighting selected text region."
+)
+(setq-default drag-zone nil)
+(setq-default mouse-down-marker nil)
+;;; ------------------------------------------------------------------------
+;;; Set window-setup-hook to call motion::init(), which sets default
+;;; style for zone dragging.  Default style is underlining; can be changed
+;;; in .emacs file.
+(epoch-add-setup-hook 'motion::init)
+(defun motion::init ()
+(and (not motion::style) (setq motion::style (make-style)))
+(set-style-foreground motion::style (foreground))
+(set-style-background motion::style (background))
+(set-style-underline motion::style (foreground))
+;; enable the handler
+(push-event 'motion 'motion::handler)
+;; set up hints on all the current screens
+(dolist (s (screen-list t)) (epoch::set-motion-hints t s))
+;; enable hints on future screens
+(push '(motion-hints t) epoch::screen-properties)
+)
+;;; ------------------------------------------------------------------------
+(defun set-mouse-marker (&optional location)
+(if (null mouse-down-marker)
+(setq mouse-down-marker (make-marker))
+)
+(set-marker mouse-down-marker (or location (point)))
+)
+;;; --------------------------------------------------------------------------
+;;; Functions to provide dragging & hilighting.
+;;; arg is a list of ( POINT BUFFER WINDOW SCREEN )
+(defun end-mouse-drag (arg)
+(setq mouse::last-point -1)		;always do this cleanup
+(when mouse::downp
+(setq mouse::downp nil)
+(mouse::copy-zone drag-zone)
+(let (
+	(s (and drag-zone (zone-start drag-zone)))
+	(e (and drag-zone (zone-end drag-zone)))
+)
+(if (null s) (setq s 1))
+(if (null e) (setq e 1))
+(if (zonep drag-zone)
+	(if (<= (point) s)
+	  (progn
+	    (push-mark e t)
+	    (goto-char s)
+	  )
+	;; ELSE point is past drag zone start
+	  (progn
+	    (push-mark s t)
+	    (goto-char e)
+	  )
+	)
+)
+)
+)
+)
+(defun start-mouse-drag (arg)
+(when arg
+(setq mouse::downp 'start)
+;    (message "%s" arg)
+(mouse::set-point arg)
+(abort-isearch)
+(set-mouse-marker)
+(setq mouse::last-point (point))
+(if drag-zone
+(progn
+	(message "ddz")
+	(delete-zone drag-zone)
+	(setq drag-zone nil)
+	(redisplay-screen)
+)
+)
+)
+)
+(defun extend-mouse-drag (arg)
+(setq mouse::downp 'extend)
+(let
+(
+(m1 (and drag-zone (zone-start drag-zone)))
+(m2 (and drag-zone (zone-end drag-zone)))
+(spot (car arg))			;point of the mouse click.
+)
+(if (null m1) (setq m1 0))
+(if (null m2) (setq m2 0))
+(cond
+((or (null drag-zone) (null mouse-down-marker))
+	(setq drag-zone (add-zone (point) spot motion::style) )
+	(set-zone-transient drag-zone t)
+	(set-mouse-marker)
+)
+((<= spot m1)
+	(setq drag-zone (move-zone drag-zone spot m2) )
+	(set-mouse-marker m2)
+)
+((>= spot m2)
+	(setq drag-zone (move-zone drag-zone m1 spot) )
+	(set-mouse-marker m1)
+)
+((<= mouse-down-marker spot)
+	(setq drag-zone (move-zone drag-zone m1 spot) )
+	(set-mouse-marker m1)
+)
+(t
+	(setq drag-zone (move-zone drag-zone spot m2) )
+	(set-mouse-marker m2)
+)
+)
+(epoch::redisplay-screen)
+(setq mouse::last-point (point))
+)
+)
+;;; ------------------------------------------------------------------------
+;;; Define the handler for dragging, etc.
+(defun motion::handler (type value scr)
+(if (null mouse-down-marker) (set-mouse-marker))
+(if (and (boundp 'mouse::downp) mouse::downp)
+(mouse-sweep-update)
+)
+)
+;;;
+(defun mouse-sweep-update()
+(let*
+(
+drag-m1
+drag-m2
+pnt
+pos
+x
+y
+(w (selected-window))
+(out-of-bounds t)
+(epoch::event-handler-abort nil)
+(w-edges (window-pixedges w))
+(left (car w-edges))
+(top (elt w-edges 1))
+(right (- (elt w-edges 2) left 1))
+(bottom (- (elt w-edges 4) top 1))
+)
+(while
+(and
+	out-of-bounds
+	(setq pos (query-pointer))
+	(/= 0 (logand mouse-any-mask (elt pos 2)))
+)
+;;convert to window relative co-ordinates
+(setq x (- (car pos) left))
+(setq y (- (elt pos 1) top))
+(setq out-of-bounds
+	(not (and (<= 0 y) (<= y bottom) (<= 0 x) (<= x right)))
+)
+;; scrolling conditions
+(condition-case errno
+	(progn
+	  (if (< y 0) (scroll-down vertical-drag-inc))
+	  (if (> y bottom) (scroll-up vertical-drag-inc))
+	)
+	(error )			;nothing, just catch it
+)
+;; Disable horizontal scrolling.
+;      (if (< x left) (scroll-right horizontal-drag-inc))
+;      (if (> x right) (scroll-left horizontal-drag-inc))
+(setq y (max 1 (min bottom y)))
+(setq x (max 0 (min right x)))
+(setq pnt (car (epoch::coords-to-point (+ x left) (+ y top))))
+(when (/= mouse::last-point pnt)
+	    (if (> mouse-down-marker pnt)
+		(progn
+		  (setq drag-m1 pnt)
+		  (setq drag-m2 (marker-position mouse-down-marker))
+		  )
+	      (progn
+		(setq drag-m1 (marker-position mouse-down-marker))
+		(setq drag-m2 (1+ pnt))
+		)
+	      )
+	    ;; moved this in here so that zone won't get made if
+	    ;; only motion is jitter within a single character
+	    ;; this fixes a bunch of bogus (often empty)
+	    ;; entries in the kill ring
+	    (if drag-zone
+		(move-zone drag-zone drag-m1 drag-m2)
+	      (progn (setq drag-zone
+			   (add-zone drag-m1 drag-m2 motion::style )
+			   )
+		     (set-zone-transient drag-zone t)
+		     )
+	      )
+	    (redisplay-screen)
+	    )
+(setq mouse::last-point pnt)
+)
+)
+)
+;;; ------------------------------------------------------------------------
+;;; Code for selecting lines using motion events. Assumes that the line is
+;;; left unmarked on zone up
+(defvar mouse::line-zone nil "Zone for selected line")
+;;;
+(defun mouse-select-line-start (arg)
+(mouse::set-point arg)		;go there
+(setq mouse::last-point (point))
+(let ( bol )
+(save-excursion
+(beginning-of-line)
+(setq bol (point))
+(end-of-line)
+(setq mouse::line-zone (add-zone bol (point) motion::style))
+)
+)
+(push-event 'motion 'mouse-select-line-update)
+)
+;;;
+(defun mouse-select-line-end (arg)
+(setq mouse::last-point -1)
+(when mouse::line-zone (delete-zone mouse::line-zone))
+(pop-event 'motion)
+)
+;;;
+(defun mouse-select-line-update (type value scr)
+(let*
+(
+y
+pos
+bol
+(out-of-bounds t)
+(epoch::event-handler-abort nil)
+(w-edges (window-pixedges (selected-window)))
+(top (elt w-edges 1))
+(bottom (- (elt w-edges 4) top 1))
+max-vscroll
+)
+(while
+(and
+	out-of-bounds
+	(setq pos (query-pointer))
+	(/= 0 (logand mouse-any-mask (elt pos 2)))
+)
+;;convert to window relative co-ordinates
+(setq y (- (elt pos 1) top))
+(setq out-of-bounds (not (and (<= 0 y) (<= y bottom))))
+;; Scrolling hard, because of possibly shrink-wrapped windows.
+;; set max-vscroll to be the most we could scroll down and not have
+;; empty lines at the bottom
+(save-excursion
+	(move-to-window-line bottom)	;go to the last line in the window
+	(setq max-vscroll
+	  (- vertical-drag-inc (forward-line vertical-drag-inc))
+	)
+	(if (and (> max-vscroll 0) (eobp) (= 0 (current-column)))
+	  (decf max-vscroll)
+	)
+)
+(condition-case errno
+	(progn
+	  (if (< y 0) (scroll-down vertical-drag-inc))
+	  (if (> y bottom) (scroll-up (min max-vscroll vertical-drag-inc)))
+	)
+	;; CONDITIONS
+	(error)				;nothing, just want to catch it
+)
+(setq y (max 0 (min bottom y)))
+;;move to the new point
+(move-to-window-line y)
+(beginning-of-line) (setq bol (point))
+(end-of-line)
+(when (/= mouse::last-point (point))
+	(move-zone mouse::line-zone bol (point))
+	(epoch::redisplay-screen)
+)
+(setq mouse::last-point (point))
+)
+)
+)
+;;; --------------------------------------------------------------------------
+;; Stolen from AMC
+(defun mouse::buffer-line (marg)
+"Show the line number and buffer of the mouse EVENT"
+;; marg is (point buffer window screen)
+;; Pop over to the clicked buffer
+(save-excursion (set-buffer (cadr marg))
+;; Figure out how far down the mouse point is
+(let ((n (count-lines (point-min) (car marg))))
+;; display it. Include the buffer name for good measure.
+(message (format "Line %d in %s" n (buffer-name (cadr marg))))
+)))
+;; Blow out of any current isearch
+(defun abort-isearch () "Abort any isearch in progress."
+(condition-case err
+(throw 'search-done t)
+(no-catch nil)))
+;;; --------------------------------------------------------------------------
+;;; install all our various handlers
+(global-set-mouse mouse-left mouse-down 'start-mouse-drag)
+(global-set-mouse mouse-left mouse-shift 'mouse::buffer-line)
+(global-set-mouse mouse-left mouse-up 'end-mouse-drag)
+(global-set-mouse mouse-right mouse-down 'extend-mouse-drag)
+(global-set-mouse mouse-right mouse-up 'end-mouse-drag)
+(global-set-mouse mouse-middle mouse-down 'mouse::paste-cut-buffer)
+(defun mouse-set-spot (arg)
+"Set point at mouse.  With double-click, set mark there as well.
+Blinks matching paren if sitting after one.  Intended to be bound
+to a window down button."
+(start-mouse-drag arg)
+(let ((buf (current-buffer))
+(p (point)))
+(mouse::set-point arg)
+(if (and (equal p (point))
+(equal buf (current-buffer)))
+(if (and (= mouse::clicks 1)
+(not (eq (mark) (point))))
+(push-mark))
+(setq mouse::clicks 0))
+(if (eq (char-syntax (preceding-char)) ?\))
+(blink-matching-open)))
+(abort-isearch))

Mercurial > hg > xemacs

comparison shared/motion4.el @ 0:107d592c5f4a