(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL)) READTABLE "XCL" BASE 10) (IL:FILECREATED "13-Jul-2023 14:28:53" IL:|{WMEDLEY}SEDIT-WINDOW.;6| 87869 :EDIT-BY IL:|rmk| :CHANGES-TO (IL:FNS BUTTONEVENTFN) :PREVIOUS-DATE "13-Jul-2023 14:06:39" IL:|{WMEDLEY}SEDIT-WINDOW.;5|) ; Copyright (c) 1986-1988, 1990-1992, 2018 by Venue & Xerox Corporation. (IL:PRETTYCOMPRINT IL:SEDIT-WINDOWCOMS) (IL:RPAQQ IL:SEDIT-WINDOWCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-WINDOW) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-WINDOW) (IL:LOCALVARS . T) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILES IL:SEDIT-DECLS)) (IL:BITMAPS ICON ICON-MASK) (IL:VARS ICON-TITLE-REGION (TITLED-ICON (IL:CREATE IL:TITLEDICON IL:ICON IL:_ ICON IL:MASK IL:_ ICON-MASK IL:TITLEREG IL:_ ICON-TITLE-REGION)) (KEEP-WINDOW-REGION T)) (IL:DECLARE\: IL:DONTCOPY (IL:MACROS IN-TITLE-BAR TRACK-BAR-IN-TRACK-SELECT)) (IL:FUNCTIONS SELECT-NODE-SEGMENT) (IL:FNS BUILD-WINDOW BUTTONEVENTFN CHECK-SELECTION CHECK-SELECTION-SHIFT CLOSEFN CONFLICTING-SELECTION? DISPLAY-SELECTION DRAW-HIGHLIGHT DRAW-OUTLINE DRAW-UNDERLINE EXPANDFN EXPANDREGIONFN EXTEND-SELECTION FINALIZE-MOUSE-SELECTION FIND-LINE-START FIND-NODE GET-DESTINATION-CONTEXT GRAY GROW-CLICK? GROW-SELECTION GROW-SELECTION-DEFAULT HIGHLIGHT-SELECTION ICON-COPYFN LESS-PROMPT-WINDOW NORMALIZE-SELECTION OUTLINE-SELECTION PENDING-DELETE PLACE-CARET-AND-SELECTION PUNT-SET-POINT PUNT-SET-SELECTION REPAINTFN RESHAPEFN SCAN-FOR-BOUNDS SELECT-NODE SELECT-SEGMENT SELECT-SEGMENT-DEFAULT SELECTION-DOWN SELECTION-UP SET-POINT SET-POINT-NOWHERE SET-POINT-UNKNOWN SET-SELECTION SET-SELECTION-ME SET-SELECTION-NOWHERE SHIFT-DOWN SHOW-CARET SHRINKFN STRING-OFFSET TRACK-EXTEND TRACK-SELECT UNDERLINE-SELECTION UPDATE-TITLE))) (IL:PUTPROPS IL:SEDIT-WINDOW IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-WINDOW IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT (:USE IL:LISP IL:XCL )))) (IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY (IL:LOCALVARS . T) ) (IL:DECLARE\: IL:DONTCOPY IL:DOEVAL@COMPILE (IL:FILESLOAD IL:SEDIT-DECLS) ) (IL:RPAQQ ICON #*(140 60)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@N@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@O@@@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@MH@@LAH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LL@@LC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LF@@LC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LAH@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@L@L@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OON@LF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@OOO@LFAKF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@LCAKF@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@LC@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@LAH@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FMHFC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@FMHLC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@LC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@AHC@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@L@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@C@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@ ) (IL:RPAQQ ICON-MASK #*(140 60)OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOH@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOL@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOON@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@OOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOOO@ ) (IL:RPAQQ ICON-TITLE-REGION (5 16 130 24)) (IL:RPAQ TITLED-ICON (IL:CREATE IL:TITLEDICON IL:ICON IL:_ ICON IL:MASK IL:_ ICON-MASK IL:TITLEREG IL:_ ICON-TITLE-REGION)) (IL:RPAQQ KEEP-WINDOW-REGION T) (IL:DECLARE\: IL:DONTCOPY (IL:DECLARE\: IL:EVAL@COMPILE (IL:PUTPROPS IN-TITLE-BAR IL:MACRO ((WINDOW) (NOT (IL:INSIDEP (IL:DSPCLIPPINGREGION NIL WINDOW) (IL:LASTMOUSEX WINDOW) (IL:LASTMOUSEY WINDOW))))) (IL:PUTPROPS TRACK-BAR-IN-TRACK-SELECT IL:MACRO (NIL (WHEN (OR (IL:NEQ POINT? (IL:|fetch| POINT-TYPE IL:|of| PENDING-CARET) ) (IL:NEQ BAR-X (IL:|fetch| POINT-X IL:|of| PENDING-CARET )) (IL:NEQ BAR-LINE (IL:|fetch| POINT-LINE IL:|of| PENDING-CARET ))) (WHEN POINT? (IL:BLTSHADE IL:BLACKSHADE WINDOW BAR-X BAR-Y 1 BAR-HEIGHT 'IL:INVERT)) (WHEN (IL:SETQ POINT? (IL:|fetch| POINT-TYPE IL:|of| PENDING-CARET )) (IL:SETQ BAR-X (IL:|fetch| POINT-X IL:|of| PENDING-CARET) ) (IL:SETQ BAR-LINE (IL:|fetch| POINT-LINE IL:|of| PENDING-CARET )) (IL:SETQ BAR-HEIGHT (IL:IPLUS (IL:|fetch| LINE-ASCENT IL:|of| BAR-LINE) (IL:|fetch| LINE-DESCENT IL:|of| BAR-LINE))) (IL:SETQ BAR-Y (IL:IDIFFERENCE (IL:|fetch| YCOORD IL:|of| BAR-LINE) (IL:IPLUS (IL:|fetch| LINE-SKIP IL:|of| BAR-LINE) BAR-HEIGHT))) (IL:BLTSHADE IL:BLACKSHADE WINDOW BAR-X BAR-Y 1 BAR-HEIGHT 'IL:INVERT))))) ) ) (DEFUN SELECT-NODE-SEGMENT (CONTEXT NODE &OPTIONAL (START 1) END) (IL:* IL:|;;;| "set the current selection to be a segment under this node") (LET ((SELECTION (IL:FETCH SELECTION IL:OF CONTEXT)) (POINT (IL:FETCH CARET-POINT IL:OF CONTEXT))) (IL:|replace| SELECT-NODE IL:|of| SELECTION IL:|with| NODE) (IL:|replace| SELECT-START IL:|of| SELECTION IL:|with| START) (IL:|replace| SELECT-END IL:|of| SELECTION IL:|with| END) (SELECT-SEGMENT SELECTION CONTEXT NODE) (IL:* IL:|;;| "set point to be the selection. This should really be done by select-segment but it doesn't because it expects finalization code to be run after it cause it's generally called from the mouse tracking code which finalizes.") (PENDING-DELETE POINT SELECTION))) (IL:DEFINEQ (BUILD-WINDOW (IL:LAMBDA (CONTEXT) (IL:* IL:\; "Edited 2-Apr-92 10:59 by jds") (IL:* IL:|;;;| "create a new window to edit in. called from setup.new.context when an sedit is started. ") (LET ((ENVIRONMENT (IL:|fetch| ENVIRONMENT IL:|of| CONTEXT)) (DISPLAY-WINDOW (IL:CREATEW (LESS-PROMPT-WINDOW (GET-WINDOW-REGION CONTEXT :CREATE (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)) IL:DEFAULTFONT) (IL:CONCAT EDITOR-NAME " parsing " (OR (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) ""))))) (IL:WINDOWPROP DISPLAY-WINDOW 'EDIT-CONTEXT CONTEXT) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:SCROLLEXTENTUSE '(- . +)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:WINDOWENTRYFN (IL:FUNCTION BUTTONEVENTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:BUTTONEVENTFN (IL:FUNCTION BUTTONEVENTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:RIGHTBUTTONFN (IL:FUNCTION BUTTONEVENTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:EXPANDREGIONFN (IL:FUNCTION EXPANDREGIONFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:CLOSEFN (IL:FUNCTION CLOSEFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:SHRINKFN (IL:FUNCTION SHRINKFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:EXPANDFN (IL:FUNCTION EXPANDFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:RESHAPEFN (IL:FUNCTION RESHAPEFN)) (IL:* IL:|;;|  "get the prompt window after setting up all the window fn, so the'll be in the proper order") (IL:GETPROMPTWINDOW DISPLAY-WINDOW 1 IL:DEFAULTFONT) (IL:|replace| DISPLAY-WINDOW IL:|of| CONTEXT IL:|with| DISPLAY-WINDOW) (IL:WYOFFSET (IL:SUB1 (IL:WINDOWPROP DISPLAY-WINDOW 'IL:HEIGHT)) DISPLAY-WINDOW) (IL:* IL:|;;| "These window fns go AFTER the promptwindow setup, so we don't try to repaint the window in the course of adding the prompt window. This fixes AR 11376") (IL:WINDOWPROP DISPLAY-WINDOW 'IL:REPAINTFN (IL:FUNCTION REPAINTFN)) (IL:WINDOWPROP DISPLAY-WINDOW 'IL:SCROLLFN (IL:FUNCTION IL:SCROLLBYREPAINTFN)) (IL:|replace| WINDOW-LEFT IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:LEFT) IL:|of| ( IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW ))) (IL:|replace| WINDOW-BOTTOM IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:BOTTOM) IL:|of| (IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW))) (IL:|replace| WINDOW-RIGHT IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:RIGHT) IL:|of| ( IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW ))) (IL:|replace| WINDOW-TOP IL:|of| CONTEXT IL:|with| (IL:|fetch| (IL:REGION IL:TOP) IL:|of| ( IL:DSPCLIPPINGREGION NIL DISPLAY-WINDOW ))) (IL:DSPLINEFEED (IL:IMINUS (IL:IPLUS (IL:FONTPROP (IL:|fetch| DEFAULT-FONT IL:|of| ENVIRONMENT) 'IL:HEIGHT) (IL:|fetch| DEFAULT-LINE-SKIP IL:|of| ENVIRONMENT) )) DISPLAY-WINDOW) (IL:* IL:|;;| "set the window's right margin big enough that things won't be wrapped on us. this is sort of gross -- there should be a way to completely disable wrap") (IL:DSPRIGHTMARGIN 64000 DISPLAY-WINDOW)))) (BUTTONEVENTFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 13-Jul-2023 14:27 by rmk") (IL:* IL:\; "Edited 20-Jun-2023 21:10 by rmk") (IL:* IL:\; "Edited 17-Jun-2023 19:59 by rmk") (IL:* IL:\; "Edited 23-Apr-2018 09:37 by rmk:") (IL:* IL:|;;| "called by the window system whenever the user hits a mouse button in an SEdit window. allows selection and setting the caret point") (LET* ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT)) (LOCK (AND CONTEXT (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT))) (SHIFT-DOWN (SHIFT-DOWN))) (COND ((IL:LASTMOUSESTATE IL:UP) (IL:* IL:|;;| "oops, no mouse buttons down. what are we doing here?") NIL) ((NOT (AND CONTEXT (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (IL:* IL:|;;| "this context or process is dead. make it a dead SEdit.") (IL:|printout| (IL:GETPROMPTWINDOW WINDOW) T "This SEdit is dead.") (IL:WINDOWPROP WINDOW 'IL:REPAINTFN NIL) (IL:WINDOWPROP WINDOW 'IL:RESHAPEFN 'IL:DON\'T) (IL:WINDOWPROP WINDOW 'IL:SHRINKFN 'IL:DON\'T) (AND (IL:LASTMOUSESTATE IL:RIGHT) (IL:DOWINDOWCOM WINDOW))) ((AND (IL:LASTMOUSESTATE IL:RIGHT) (IN-TITLE-BAR WINDOW)) (IL:* IL:|;;| "right buttoning the title bar or window border gives the default menu of window commands. Not interlocked because want to be able to move window under a break that has the lock.") (IL:\\CARET.DOWN) (IL:DOWINDOWCOM WINDOW)) ((AND (NOT (IL:TTY.PROCESSP (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (NOT SHIFT-DOWN)) (IL:* IL:|;;| "just grab the tty and don't change state") (IL:TOTOPW WINDOW) (IL:TTY.PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS))) ((AND (EQ SHIFT-DOWN 'COPY) (IL:MOUSESTATE IL:LEFT) (IN-TITLE-BAR WINDOW)) (IL:* IL:|;;| "RMK: copy-select in the title bar: return the thing being edited. Previous attempt was too immediate, did not conform to usual mouse-up conventions.") (IL:WHILE (EQ 'COPY (SHIFT-DOWN))) (IL:GETMOUSESTATE) (WHEN (IN-TITLE-BAR WINDOW) (LET ((NAME (IL:LISTGET (IL:WINDOWPROP WINDOW 'TITLE-INFO) :|name|))) (WHEN NAME (IL:* IL:\;  "Not sure about FLG and RDTBL") (IL:COPYINSERT NAME))))) ((OR (EQ SHIFT-DOWN 'COPY) (IL:OBTAIN.MONITORLOCK LOCK T)) (IL:* IL:|;;| "at this point we must have the lock, unless we're shift selecting (Copy only: Move and Delete are non-passive operation and must lock)") (IL:\\CARET.DOWN) (IL:TOTOPW WINDOW) (COND ((AND (IN-TITLE-BAR WINDOW) (OR (IL:LASTMOUSESTATE IL:MIDDLE) (AND (IL:LASTMOUSESTATE IL:LEFT) (IL:KEYDOWNP 'IL:CTRL)))) (IL:* IL:|;;| "popup help command menu here.") (IL:* IL:|;;| "RMK: CTRL-LEFT = MIDDLE") (HELPMENU CONTEXT)) (T (WITH-PROFILE (IL:|fetch| PROFILE IL:|of| CONTEXT) (PROG NIL (CLOSE-OPEN-NODE CONTEXT) (IL:* IL:|;;| "record that we're busy making a selection in this window, and make sure that variables we use for recording our temporary state are all ready for action. note that these are global vars, and hence all this code is nonrentrant. shouldn't be a problem, since there's only one mouse") (IL:SETQ SELECTION-PENDING? CONTEXT) (IL:SETQ PENDING-LAST-X (IL:|fetch| LAST-MOUSE-X IL:|of| CONTEXT)) (IL:SETQ PENDING-LAST-Y (IL:|fetch| LAST-MOUSE-Y IL:|of| CONTEXT)) (IL:SETQ PENDING-TYPE (IL:|fetch| LAST-MOUSE-TYPE IL:|of| CONTEXT)) (IL:SETQ PENDING-SHIFT SHIFT-DOWN) (IL:|replace| SELECT-NODE IL:|of| PENDING-SELECTION IL:|with| NIL) (WHEN (NOT PENDING-SHIFT) (IL:* IL:|;;|  "if they're setting a new selection take down the main selection") (SELECTION-DOWN CONTEXT)) (IL:SETQ LAST-MOVE-CLOCK NIL) (IL:SETQ BUTTON-STRING-NODE NIL) MOUSE-BUTTON-DOWN (IF (IL:LASTMOUSESTATE IL:RIGHT) (TRACK-EXTEND CONTEXT WINDOW) (TRACK-SELECT CONTEXT WINDOW)) (IL:|until| (CHECK-SELECTION-SHIFT CONTEXT T) IL:|do| (WHEN (NOT (IL:MOUSESTATE IL:UP)) (GO MOUSE-BUTTON-DOWN)) (WHEN (IL:IN/SCROLL/BAR? WINDOW IL:LASTMOUSEX IL:LASTMOUSEY ) (IL:* IL:\;  "let them scroll while making a selection") (IL:SCROLL.HANDLER WINDOW)) (IL:BLOCK)) (IL:SETQ SELECTION-PENDING? NIL) (IL:* IL:\;  "figure out what we should do") (FINALIZE-MOUSE-SELECTION CONTEXT WINDOW))))) (OR (EQ SHIFT-DOWN 'COPY) (IL:RELEASE.MONITORLOCK LOCK))))))) (check-selection (il:lambda (selection point) (il:* il:\; "Edited 27-Jun-88 15:47 by woz") (il:* il:|;;;| "called from update each time through. check the selection for dead node, and for pending delete inconsistency.") (let ((node (il:|fetch| select-node il:|of| selection)) (start (il:|fetch| select-start il:|of| selection)) (end (il:|fetch| select-end il:|of| selection)) subnode) (when (and node (dead-node? node)) (il:replace select-node il:of selection il:with nil)) (cond ((eq (il:|fetch| point-node il:|of| point) selection) (cond ((null node) (il:replace point-node il:of point il:with nil)) ((not (il:fetch pending-delete? il:of selection)) (il:shouldnt "pending delete inconsistency")))) ((and node (il:|fetch| pending-delete? il:|of| selection)) (il:shouldnt "pending delete inconsistency"))) (il:* il:|;;| "try to simplify the selection. if it's a single node structure segment (single subnode selected), select the subnode directly instead.") (when (and node (eq (il:|fetch| select-type il:|of| selection) 'structure) (not (il:|fetch| pending-delete? il:|of| selection)) start (or (null end) (eql start end)) (il:|type?| edit-node (setq subnode (nth start (il:fetch sub-nodes il:of node))))) (il:|replace| select-node il:|of| selection il:|with| subnode) (il:|replace| select-start il:|of| selection il:|with| nil) (il:|replace| select-end il:|of| selection il:|with| nil))))) (check-selection-shift (il:lambda (context let-go) (il:* il:\; "Edited 7-Jul-87 13:00 by DCB") (il:* il:|;;;| "check for modifier keys being held down during this selection and update the display if they have changed. if let.go is true, and there are no modifier keys down, the selection is completed and return T to wake up the buttoneventfn") (let ((new-shift (shift-down))) (cond ((and let-go (null new-shift)) (il:* il:\; "no mouse buttons, and no modifier keys -- we're done") t) (t (when (il:neq new-shift pending-shift) (il:\\caret.down) (when (eq pending-shift (quote move)) (il:* il:|;;| "since move selection requires two keys (at least on my keyboard) we give it a little hysteresis so you don't have to release both keys at *exactly* the same time") (il:setq last-move-clock (il:clock 0))) (il:* il:\; "change the selection display") (display-selection pending-selection (il:fetch display-window il:of context) pending-shift) (display-selection pending-selection (il:fetch display-window il:of context) new-shift) (il:* il:\; "make the new shift type current") (il:setq pending-shift new-shift)) nil)))) ) (CLOSEFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 5-Dec-90 18:07 by woz") (IL:* IL:|;;;| "to be called by the window system when SEdit windows are closed. if there's a process, wake it up with a complete command. otherwise just trash the context. grab the lock here, because it wasn't yet grabbed by the buttoneventfn.") (LET ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT))) (WHEN CONTEXT (COND ((IL:OBTAIN.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) T) (IL:RELEASE.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT)) (IL:* IL:\;  "release before waking sedit") (IL:* IL:|;;|  "if there's a stupid attached menu, close it first so we'll release the correct region") (WHEN (IL:WINDOWPROP WINDOW 'MENU) (IL:CLOSEW (IL:WINDOWPROP WINDOW 'MENU))) (COND ((IL:WINDOWPROP WINDOW 'IL:PROCESS) (COND ((EQ (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:NAME) 'IL:MOUSE) (IL:* IL:|;;| "if we're running under the mouse, just wake up the SEdit process and let it close the window. That way all completion happens under the command process, not under the mouse.") (AWAKE-COMMAND-PROCESS CONTEXT '(COMPLETE NIL :CLOSE)) 'IL:DON\'T) (T (SAVE-WINDOW-REGION CONTEXT :CLOSE (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT) (IL:WINDOWREGION WINDOW))))) (T (IL:* IL:|;;| "We take this branch when an sedit icon is closed. The process is already dead, but we still have the context to junk. Also, This case CAN HAPPEN IF SOMEBODY RETFROMs sedit or some process involved in cleanup gets an error so the sedit dies.") (SAVE-WINDOW-REGION CONTEXT :CLOSE-ICON (AND CONTEXT (IL:|fetch| ICON-TITLE IL:|of| CONTEXT)) (AND CONTEXT (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT)) (IL:WINDOWREGION WINDOW)) (DISINTEGRATE-CONTEXT CONTEXT)))) (T (FORMAT (GET-PROMPT-WINDOW CONTEXT) "~%Can't close. SEdit is busy") 'IL:DON\'T)))))) (conflicting-selection? (il:lambda (context destination-context) (il:* il:\; "Edited 7-Jul-87 13:00 by DCB") (il:* il:|;;| "determine if the pending selection conflicts with the main selection in context. there is a conflict for pending selections which get deleted (Delete or Move) because the deletion can mess up the main selection. In the case of Move, if the destination is the same SEdit and the main selection is pending delete, then this parks the point for the move, so leave it up; the copy meshod will worry about overlaps.") (let ((selection (il:fetch selection il:of context))) (when (il:fetch select-node il:of selection) (or (eq pending-shift (quote delete)) (and (eq pending-shift (quote move)) (il:neq context destination-context)))))) ) (display-selection (il:lambda (selection window type) (il:* il:\; "Edited 7-Jul-87 13:01 by DCB") (il:* il:|;;;| "display the current selection with the appropriate markings (outline or underline, gray or black)") (when (il:fetch select-node il:of selection) (cond ((dead-node? (il:fetch select-node il:of selection)) (il:replace select-node il:of selection il:with nil)) (t (il:selectq type (nil (il:* il:|;;| "normal selection -- black underline, or pending delete selection -- black outline") (if (il:fetch pending-delete? il:of selection) (outline-selection selection window il:blackshade) (underline-selection selection window il:blackshade))) (copy (il:* il:\; "copy selection -- gray underline") (underline-selection selection window (gray window))) (move (il:* il:\; "move selection -- gray outline") (outline-selection selection window (gray window))) (delete (il:* il:\; "delete selection -- inverted") (highlight-selection selection window il:blackshade)) (il:shouldnt "unknown selection display type")) t)))) ) (draw-highlight (il:lambda (x-1 x-2 x-3 w y-1 h-1 y-2 h-2 window shade) (il:* il:\; "Edited 17-Nov-87 11:21 by DCB") (il:* il:|;;;| "inverts the selection. x1 is the left edge of the region, x2 is the left edge of the first line (which may be indented) x3 is right edge of the last line, w is the width, y1 is the top, h1 is the height of the first line, y2 is the top of the last line, and h2 is its height. the region will be painted with the specified shade in invert mode") (il:setq x-3 (il:add1 x-3)) (il:setq w (il:add1 w)) (cond ((eq (il:setq y-1 (il:add1 y-1)) (il:setq y-2 (il:add1 y-2))) (il:bltshade shade window x-2 (il:idifference y-1 h-1) (il:idifference x-3 x-2) h-1 (quote il:invert))) (t (when (il:neq x-1 x-2) (il:setq y-1 (il:idifference y-1 h-1)) (il:bltshade shade window x-2 y-1 (il:idifference (il:iplus x-1 w) x-2) h-1 (quote il:invert))) (if (il:neq x-3 (il:iplus x-1 w)) (il:bltshade shade window x-1 (il:idifference y-2 h-2) (il:idifference x-3 x-1) h-2 (quote il:invert)) (il:setq y-2 (il:idifference y-2 h-2))) (il:bltshade shade window x-1 y-2 w (il:idifference y-1 y-2) (quote il:invert))))) ) (draw-outline (il:lambda (x-1 x-2 x-3 w y-1 h-1 y-2 h-2 window shade) (il:* il:\; "Edited 17-Nov-87 11:21 by DCB") (il:* il:|;;;| "outline the selection. arguments are the same as draw.highlight. the selection will be surrounded by a 1 pixel wide border in the specified shade") (il:setq h-1 (il:idifference y-1 h-1)) (il:setq h-2 (il:idifference y-2 h-2)) (il:setq w (il:iplus x-1 w)) (when (eq y-1 y-2) (il:setq x-1 x-2) (il:setq w x-3)) (cond ((eq x-1 x-2) (il:bltshade shade window (il:sub1 x-1) h-2 1 (il:idifference y-1 h-2) (quote il:invert))) (t (il:bltshade shade window (il:sub1 x-1) h-2 1 (il:idifference h-1 h-2) (quote il:invert)) (il:bltshade shade window (il:sub1 x-1) h-1 (il:idifference x-2 x-1) 1 (quote il:invert)) (il:bltshade shade window (il:sub1 x-2) h-1 1 (il:idifference y-1 h-1) (quote il:invert)))) (il:bltshade shade window (il:sub1 x-2) y-1 (il:idifference (il:iplus 2 w) x-2) 1 (quote il:invert)) (il:bltshade shade window x-1 h-2 (il:idifference x-3 x-1) 1 (quote il:invert)) (cond ((eq x-3 w) (il:bltshade shade window x-3 h-2 1 (il:idifference y-1 h-2) (quote il:invert))) (t (il:bltshade shade window x-3 h-2 1 (il:idifference y-2 h-2) (quote il:invert)) (il:bltshade shade window x-3 y-2 (il:idifference w x-3) 1 (quote il:invert)) (il:bltshade shade window w y-2 1 (il:idifference y-1 y-2) (quote il:invert))))) ) (draw-underline (il:lambda (startx first endx last window shade) (il:* il:\; "Edited 17-Jul-87 10:10 by DCB") (il:* il:|;;;| "underline the selection. first and last are the first and last lines, and startx and endx are the x coordinates of the ends of the selection on those lines. the selection will be underlined with a 2 pixel wide line of the specified shade") (il:until (eq first last) il:do (il:bltshade shade window startx (il:fetch next-line-y il:of first) (il:idifference (il:fetch line-length il:of first) startx) 2 (quote il:invert)) (il:setq first (car (il:fetch next-line il:of first))) (il:setq startx (il:fetch indent il:of first))) (il:bltshade shade window startx (il:fetch next-line-y il:of first) (il:idifference endx startx) 2 (quote il:invert))) ) (EXPANDFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 19-Aug-87 15:39 by drc:") (IL:* IL:|;;;| "called by the window system when SEdit window icons are expanded. start a new command process for the window") (LET ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT))) (WHEN (NOT (IL:WINDOWPROP WINDOW 'IL:PROCESS)) (IL:|replace| EVAL-IN-PROCESS IL:|of| CONTEXT IL:|with| (EVAL-IN-PROCESS)) (START-PROCESS CONTEXT))))) (expandregionfn (il:lambda (window) (il:* il:\; "Edited 8-Jan-88 17:49 by woz") (il:* il:|;;;| "calculates a new region for this window as it is expanded. Return NIL if don't want to reshape the window. remember the region manager gives a region including the prompt window, so subtract it before handing the region to the main window.") (let* ((context (il:windowprop window (quote edit-context))) (region (get-window-region context :expand (il:|fetch| icon-title il:|of| context) (il:|fetch| edit-type il:|of| context)))) (and region (less-prompt-window region il:defaultfont)))) ) (extend-selection (il:lambda (selection context x y) (il:* il:\; "Edited 24-Nov-87 09:53 by DCB") (il:* il:|;;;| "expand the given selection to include the point (x,y)") (let (node index offset line linear) (when (and (il:insidep (il:dspclippingregion nil (il:fetch display-window il:of context)) x y) (il:setq line (find-line-start y context)) (il:setq linear (find-node x line context))) (il:* il:|;;| "we've found the linear item they're pointing at. figure out what node it belongs to, what its index in the linear form is, and how far into the item the position is") (il:setq node (il:fetch destination il:of (cdr (last linear)))) (il:setq index (il:for i il:from 1 il:as (x il:_ (il:fetch linear-form il:of node)) il:by (cdr x) il:thereis (eq x linear))) (il:setq offset (if (il:type? line-start (car linear)) (if (eq 0 (il:fetch \\x il:of context)) 1 -1) (il:idifference x (il:fetch \\x il:of context)))) (cond ((and (il:fetch select-start il:of selection) (eq (il:fetch select-node il:of selection) node)) (il:* il:|;;| "easy case -- the current selection's node is the one to handle it") (select-segment selection context node nil index offset (car linear))) (t (il:* il:|;;| "harder. we've got to figure out the lowest common subnode and get it to do the work. this could (and should) be simplified and sped up now that we store depth information. its is currently so ugly that it's not even worth trying to explain") (prog ((a (il:fetch select-node il:of selection)) (b node) t-0 t-1 t-2) loopb (when (not (il:fetch super-node il:of a)) (go loopa)) (il:setq t-2 a) (il:setq a (il:fetch super-node il:of a)) (il:setq t-1 node) (il:setq t-0 t-1) loopb-2 (when (eq t-0 a) (go done)) (when (eq t-0 b) (go loopa)) (il:setq t-1 t-0) (il:setq t-0 (il:fetch super-node il:of t-0)) (go loopb-2) loopa (when (not (il:fetch super-node il:of b)) (go loopb)) (il:setq t-2 b) (il:setq b (il:fetch super-node il:of b)) (il:setq t-1 (il:fetch select-node il:of selection)) (il:setq t-0 t-1) loopa-2 (when (eq t-0 b) (go done)) (when (eq t-0 a) (go loopb)) (il:setq t-1 t-0) (il:setq t-0 (il:fetch super-node il:of t-0)) (go loopa-2) done (cond ((eq (il:fetch select-node il:of selection) t-0) (if (il:fetch select-start il:of selection) (select-segment selection context t-0 t-2 nil offset (car linear)) (select-segment selection context (il:fetch super-node il:of t-0) t-0 t-0 nil offset (car linear)))) ((eq node t-0) (select-segment selection context node t-2 index offset (car linear))) (t (select-segment selection context t-0 t-1 t-2 nil offset (car linear)))))))))) ) (FINALIZE-MOUSE-SELECTION (IL:LAMBDA (CONTEXT WINDOW) (IL:* IL:\; "Edited 7-Jul-87 13:03 by DCB") (IL:* IL:|;;| "all mouse buttons and modifier keys have been released, so the selection's completed. figure out just what it was that was selected, and if it's a copy, move, or delete, do it") (LET ((SELECTION (IL:|fetch| SELECTION IL:|of| CONTEXT))) (COND (PENDING-SHIFT (IL:* IL:\; "some action required") (WHEN (IL:|fetch| SELECT-NODE IL:|of| PENDING-SELECTION) (LET ((DESTINATION-CONTEXT (GET-DESTINATION-CONTEXT)) DESTINATION-POINT) (IL:\\CARET.DOWN) (IL:* IL:\;  "need this here because get.destination.context lets the caret flash again.") (WHEN (IL:NEQ PENDING-SHIFT 'COPY) (IL:* IL:\; "for Move or Delete") (SELECTION-DOWN CONTEXT)) (IL:* IL:|;;| "take down the pending (shift) selection") (DISPLAY-SELECTION PENDING-SELECTION WINDOW PENDING-SHIFT) (WHEN (AND LAST-MOVE-CLOCK (IL:ILESSP (IL:CLOCK 0) (IL:IPLUS LAST-MOVE-CLOCK 250))) (IL:* IL:|;;|  "if they release the two keys within a quarter second, we'll assume it was a move") (IL:SETQ PENDING-SHIFT 'MOVE)) (WHEN (CONFLICTING-SELECTION? CONTEXT DESTINATION-CONTEXT) (IL:* IL:|;;| "if the selection conflicts then waste it.") (SET-SELECTION-NOWHERE SELECTION)) (COND ((EQ PENDING-SHIFT 'DELETE) (DELETE-NODES (IL:|fetch| SELECT-NODE IL:|of| PENDING-SELECTION) CONTEXT (IL:|fetch| SELECT-START IL:|of| PENDING-SELECTION) (IL:|fetch| SELECT-END IL:|of| PENDING-SELECTION) (IL:|fetch| CARET-POINT IL:|of| CONTEXT) (IL:|fetch| SELECT-STRING IL:|of| PENDING-SELECTION)) (UPDATE CONTEXT) (IL:TTY.PROCESS (IL:WINDOWPROP WINDOW 'IL:PROCESS))) (T (IL:* IL:|;;| "copy or move -- figure out whether it's going into an SEdit, or to an unknown sink (in which case we print it)") (WHEN DESTINATION-CONTEXT (IL:* IL:\;  "it's going to an SEdit. prepare it") (IL:\\CARET.DOWN (IL:|fetch| DISPLAY-WINDOW IL:|of| DESTINATION-CONTEXT )) (SELECTION-DOWN DESTINATION-CONTEXT) (CLOSE-OPEN-NODE DESTINATION-CONTEXT) (IL:SETQ DESTINATION-POINT (IL:|fetch| CARET-POINT IL:|of| DESTINATION-CONTEXT))) (COPY-SELECTION PENDING-SELECTION CONTEXT DESTINATION-CONTEXT DESTINATION-POINT (EQ PENDING-SHIFT 'MOVE)) (WHEN (IL:NEQ CONTEXT DESTINATION-CONTEXT) (COND ((EQ PENDING-SHIFT 'MOVE) (UPDATE CONTEXT)) ((IL:OBTAIN.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT) T) (IL:* IL:|;;|  "for Copy select, only display the selection if this is a non-busy sedit") (SELECTION-UP CONTEXT) (IL:RELEASE.MONITORLOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT))))) (WHEN DESTINATION-CONTEXT (IL:* IL:|;;|  "just wake up the destination and let it update itself.") (AWAKE-COMMAND-PROCESS DESTINATION-CONTEXT))))))) (T (IL:* IL:|;;| "just setting the current selection, and maybe the caret. it is all displayed from when it was pending, so mark it as displayed now") (IL:|replace| SELECTION-DISPLAYED? IL:|of| CONTEXT IL:|with| T) (IL:* IL:|;;| "and make it the main selection and point") (SMASH-USING EDIT-SELECTION SELECTION PENDING-SELECTION) (IL:|replace| LAST-MOUSE-X IL:|of| CONTEXT IL:|with| PENDING-LAST-X) (IL:|replace| LAST-MOUSE-Y IL:|of| CONTEXT IL:|with| PENDING-LAST-Y) (IL:|replace| LAST-MOUSE-TYPE IL:|of| CONTEXT IL:|with| PENDING-TYPE) (WHEN (IL:|fetch| PENDING-DELETE? IL:|of| PENDING-SELECTION) (IL:|replace| POINT-NODE IL:|of| PENDING-CARET IL:|with| SELECTION) (IL:|replace| POINT-TYPE IL:|of| PENDING-CARET IL:|with| (IL:|fetch| SELECT-TYPE IL:|of| PENDING-SELECTION))) (SMASH-USING EDIT-POINT (IL:|fetch| CARET-POINT IL:|of| CONTEXT) PENDING-CARET) (SHOW-CARET CONTEXT)))))) (find-line-start (il:lambda (y context) (il:* il:\; "Edited 17-Nov-87 11:22 by DCB") (il:* il:|;;;| "find the line including a given y coordinate. very dumb -- we just linear search through them -- but does the job") (il:bind (line il:_ (il:fetch linear-form il:of (il:fetch root il:of context))) next-line il:first (when (or (il:ileq y (il:fetch il:bottom il:of (il:windowprop (il:fetch display-window il:of context) (quote il:extent)))) (il:igreaterp y 0)) (il:* il:\; "above or below the structure") (return nil)) il:do (if (and (il:setq next-line (il:fetch next-line il:of (car line))) (il:igeq (il:fetch ycoord il:of (car next-line)) y)) (il:setq line next-line) (return line)))) ) (find-node (il:lambda (x linear-pointer context) (il:* il:\; "Edited 17-Nov-87 11:22 by DCB") (il:* il:|;;;| "sort of a dubious name. we're actually trying to find the linear item on this line which corresponds to the given x position. linear.pointer is the line. as an added bonus, set the \\X field of context to the x coordinate of this linear item. this is a hack; we really want to return multiple values, but there's no clean way to do that in interlisp") (prog (linear-item) (when (il:ilessp x 0) (il:* il:|;;| "to the left of the whole structure -- nothing there! (i don't think this should ever happen)") (return nil)) (il:setq linear-item (car linear-pointer)) (when (il:igeq x (il:fetch line-length il:of linear-item)) (il:* il:|;;| "past the right edge of this line; say we're before the next line") (il:replace \\x il:of context il:with 1) (return (il:fetch next-line il:of linear-item))) (il:bind (current-x il:_ 0) (nextx il:_ (il:fetch indent il:of linear-item)) il:while (il:ileq nextx x) il:do (il:setq current-x nextx) (il:setq linear-pointer (next-linear-item (cdr linear-pointer))) (il:setq nextx (il:iplus nextx (linear-item-width (car linear-pointer)))) il:finally (il:replace \\x il:of context il:with current-x)) (return linear-pointer))) ) (get-destination-context (il:lambda nil (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;;| "used under shift selections. if the destination is an SEdit, return its context, otherwise NIL. It is considered a valid (ready for shift selection) SEdit if the process is waiting under getkey") (let ((destination (il:processprop (il:tty.process) (quote il:window)))) (and destination (il:setq destination (il:windowprop destination (quote edit-context))) (il:process.eval (il:tty.process) (quote (il:stkpos (quote getkey))) t) destination))) ) (gray (il:lambda (window) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "due to a misfeature of the window system, we have to adjust the gray texture depending on how much the window's been scrolled. bleah") (il:* il:|;;| "DEdit's SHADEFIXER handles the more general case") (if (eq (evenp (il:dspxoffset nil window)) (evenp (il:dspyoffset nil window))) 23130 42405)) ) (grow-click? (il:lambda (context point-type window) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;| "the left or middle mouse button is down. decide if this is part of a multi-click, i.e. the mouse stays in the same position as the previous click. if so, we just grow the selection. return T if that's what happened") (when (and (cond ((il:fetch select-node il:of pending-selection) (il:* il:\; "you can't grow a selection if you've already extended it") (not (il:fetch select-end il:of pending-selection))) (t (and (not pending-shift) (il:fetch select-node il:of (il:fetch selection il:of context)) (not (il:fetch select-end il:of (il:fetch selection il:of context)))))) (eq pending-type point-type) (il:ileq (abs (il:idifference (il:lastmousex window) pending-last-x)) 2) (il:ileq (abs (il:idifference (il:lastmousey window) pending-last-y)) 2)) (il:* il:|;;| "it looks like we've got a grow click. display the grown selection, and wait until the mouse button goes up") (cond ((il:fetch select-node il:of pending-selection) (il:* il:\; "turn off the previous selection") (display-selection pending-selection window pending-shift)) (t (smash-using edit-selection pending-selection (il:fetch selection il:of context)))) (grow-selection pending-selection context) (when (and (il:fetch select-node il:of pending-selection) (null (il:fetch select-start-x il:of pending-selection))) (compute-selection-position pending-selection context)) (display-selection pending-selection window pending-shift) (set-point-nowhere pending-caret) (il:do (il:* il:|;;| "keep watching for new modifier keys, until the mouse buttons come up *or* the cursor is moved, which cancels the grow") (check-selection-shift context) (il:block) il:repeatuntil (or (il:mousestate (or il:up il:right)) (il:igreaterp (abs (il:idifference (il:lastmousex window) pending-last-x)) 2) (il:igreaterp (abs (il:idifference (il:lastmousey window) pending-last-y)) 2))) (il:mousestate (or il:up il:right)))) ) (grow-selection (il:lambda (selection context) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "compute the new selection which results from growing this one") (funcall (il:fetch grow-selection il:of (il:fetch node-type il:of (il:fetch select-node il:of selection))) selection context (il:fetch select-node il:of selection))) ) (grow-selection-default (il:lambda (selection context node) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "a default method for GrowSelection. if we're not the top node in the tree (i.e. our super isn't the root) then select our super") (when (il:fetch super-node il:of (il:fetch super-node il:of node)) (punt-set-selection selection context node))) ) (highlight-selection (il:lambda (selection window shade) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "highlight this selection. draw.highlight does all the work, once we've figured out the bounds") (outline-selection selection window shade (il:function draw-highlight))) ) (icon-copyfn (il:lambda (il:window) (il:* il:\; "Edited 8-Jan-88 09:00 by DCB") (il:* il:|;;;| "BKSYSBUFs the title of the SEdit window (as a structure if it is one)") (let ((name (il:listget (il:windowprop (il:windowprop il:window (quote il:iconfor)) (quote title-info)) :|name|))) (if name (il:bksysbuf name t) (il:bksysbuf " " nil)))) ) (less-prompt-window (il:lambda (region font) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:createregion (il:fetch (il:region il:left) il:of region) (il:fetch (il:region il:bottom) il:of region) (il:fetch (il:region il:width) il:of region) (il:idifference (il:fetch (il:region il:height) il:of region) (il:heightifwindow (il:fontprop font (quote il:height)))))) ) (normalize-selection (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;;| "if the current selection isn't visible in the window, scroll until it is. we only worry about vertical position; this could be extended to handle horizontal scrolling too, should there prove any need. since we're usually getting called after just setting the selection to be normalized, we have to compute the position first, in order to know how to center it.") (let ((selection (il:fetch selection il:of context)) (region (il:dspclippingregion nil (il:fetch display-window il:of context))) first-line) (compute-selection-position selection context) (il:setq first-line (il:fetch select-start-line il:of selection)) (when (or (il:ilessp (il:fetch next-line-y il:of first-line) (il:fetch (il:region il:bottom) il:of region)) (il:igreaterp (il:fetch ycoord il:of first-line) (il:fetch (il:region il:top) il:of region))) (il:* il:|;;| "the selection isn't completely visible. scroll so that the top of it is 1/3 of the way from the top of the window. it might still not be completely visible, but it's good enough") (il:scrollw (il:fetch display-window il:of context) 0 (il:idifference (il:fetch (il:region il:top) il:of region) (il:imin 0 (il:iplus (il:fetch ycoord il:of first-line) (il:iquotient (il:fetch (il:region il:height) il:of region) 3)))))))) ) (outline-selection (il:lambda (selection window shade fn) (il:* il:\; "Edited 17-Nov-87 11:23 by DCB") (il:* il:|;;;| "highlight this selection. draw.outline does all the work, once we've figured out the bounds. we also share this code with highlight.selection, via a functional parameter") (il:bind (minx il:_ (il:fetch select-start-x il:of selection)) (maxx il:_ (il:fetch select-end-x il:of selection)) (line il:_ (il:fetch select-start-line il:of selection)) (endline il:_ (il:fetch select-end-line il:of selection)) il:while (il:neq line endline) il:do (il:setq maxx (il:imax maxx (il:fetch line-length il:of line))) (il:setq line (car (il:fetch next-line il:of line))) (il:setq minx (il:imin minx (il:fetch indent il:of line))) il:finally (funcall (or fn (il:function draw-outline)) minx (il:fetch select-start-x il:of selection) (il:fetch select-end-x il:of selection) (il:idifference maxx minx) (il:fetch ycoord il:of (il:fetch select-start-line il:of selection)) (il:fetch line-height il:of (il:fetch select-start-line il:of selection)) (il:fetch ycoord il:of endline) (il:fetch line-height il:of endline) window shade))) ) (pending-delete (il:lambda (point selection) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (when (il:fetch select-node il:of selection) (il:replace pending-delete? il:of selection il:with t) (il:replace point-node il:of point il:with selection) (il:replace point-type il:of point il:with (il:fetch select-type il:of selection)))) ) (place-caret-and-selection (il:lambda (caret selection context x y type) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;;| "compute the new location of the caret and current selection, given the coordintes of the mouse and the type of selection being made") (let (line linear node index offset) (cond ((and (il:insidep (il:dspclippingregion nil (il:fetch display-window il:of context)) x y) (il:setq line (find-line-start y context)) (il:setq linear (find-node x line context))) (il:* il:|;;| "we've found the linear item they're pointing at. figure out what node it belongs to, what its index in the linear form is, and how far into the item the position is") (il:setq node (il:fetch destination il:of (cdr (last linear)))) (il:setq index (il:for i il:from 1 il:as (x il:_ (il:fetch linear-form il:of node)) il:by (cdr x) il:thereis (eq x linear))) (il:setq offset (if (il:type? line-start (car linear)) (if (eq 0 (il:fetch \\x il:of context)) 1 -1) (il:idifference x (il:fetch \\x il:of context)))) (il:* il:|;;| "call the appropriate methods to place the point and selection") (when caret (set-point caret context node index offset (car linear) type t)) (set-selection selection context node index offset (car linear) type) (when (and (il:fetch select-node il:of selection) (null (il:fetch select-start-x il:of selection))) (compute-selection-position selection context))) (t (il:* il:|;;| "the mouse isn't pointing at anything -- cancel the point and selection") (when caret (set-point-nowhere caret)) (set-selection-nowhere selection))))) ) (punt-set-point (il:lambda (point context node which-end compute-location?) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;| "there's no place to put the point in this node; try letting the supernode put it immediately before or after this node -- before if which.end is NIL, after if it's T") (set-point point context (il:fetch super-node il:of node) (il:fetch sub-node-index il:of node) which-end node (quote structure) compute-location?)) ) (punt-set-selection (il:lambda (selection context node) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;;| "this node can't handle the selection; ask its supernode to try") (set-selection selection context (il:fetch super-node il:of node) (il:for i il:from 1 il:as (x il:_ (il:fetch linear-form il:of (il:fetch super-node il:of node))) il:by (cdr x) il:thereis (eq x (il:fetch linear-thread il:of node))) nil node (quote structure))) ) (repaintfn (il:lambda (window region) (il:* il:\; "Edited 7-Jul-87 13:03 by DCB") (il:* il:|;;| "called by the window system when it needs some or all of the window to be repainted (based on region)") (let ((context (il:windowprop window (quote edit-context)))) (when context (with-profile (il:fetch profile il:of context) (let (start line) (when (il:setq start (find-line-start (il:fetch (il:region il:top) il:of region) context)) (il:setq line (car start)) (il:* il:|;;| "here we have to lie about the selection. it may have been displayed, but now the region has been cleared, so that part of the selection is no longer on the screen. setting the flag NIL will force it to be redisplayed on the way out.") (il:replace selection-displayed? il:of context il:with nil) (repaint context (il:fetch indent il:of line) (il:fetch base-line-y il:of line) (cdr start) (il:fetch (il:region il:bottom) il:of region)) (when (eq selection-pending? context) (il:* il:|;;| "they're in the process of making a selection in this window -- probably scrolling to extend the selection") (il:* il:\; "(fix.caret.position)") (display-selection pending-selection window pending-shift)) (il:* il:|;;| "now that we're done, try to bring back the main selection.") (selection-up context))))))) ) (reshapefn (il:lambda (window old-image old-image-region old-screen-region) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;| "called by the window system when the window's size changes. if the width is exactly the same we'll just reuse as much of the image as possible and repaint the rest. if the width has changed, we'll have to completely reformat") (let* ((context (il:windowprop window (quote edit-context))) (new-region (il:dspclippingregion nil window)) (old-bottom (il:fetch (il:region il:bottom) il:of new-region))) (il:wyoffset (il:idifference (il:fetch (il:region il:height) il:of new-region) (il:fetch (il:region il:height) il:of old-image-region)) window) (compute-comment-column context window) (il:with.monitor (il:fetch context-lock il:of context) (cond ((eq (il:fetch (il:region il:width) il:of old-image-region) (il:fetch (il:region il:width) il:of new-region)) (il:* il:\; "reuse the old bits") (il:bitblt old-image (il:fetch (il:region il:left) il:of old-image-region) (il:fetch (il:region il:bottom) il:of old-image-region) window (il:fetch (il:region il:left) il:of new-region) old-bottom (il:fetch (il:region il:width) il:of old-image-region) (il:fetch (il:region il:height) il:of old-image-region)) (when (il:igreaterp (il:fetch (il:region il:height) il:of new-region) (il:fetch (il:region il:height) il:of old-image-region)) (il:* il:|;;| "if the new one is smaller, we're done. otherwise we have to repaint the extra space") (let ((blank-region (il:create il:region il:using new-region il:height il:_ (il:idifference (il:fetch (il:region il:height) il:of new-region) (il:fetch (il:region il:height) il:of old-image-region))))) (il:resetlst (il:resetsave nil (list (quote il:dspclippingregion) (il:dspclippingregion blank-region window) window)) (il:* il:|;;| "clip to area to repaint, and make sure clipping region gets reset on the way out.") (repaintfn window blank-region))))) (t (il:* il:|;;| "the new window is a different width. reformat and repaint from scratch. we also cancel any horizontal scrolling") (with-profile (il:fetch profile il:of context) (il:wxoffset (il:fetch (il:region il:left) il:of new-region) window) (il:* il:|;;| "atom.change.relinearize is just a convenient way to close up sedit structure and relinearize from scratch.") (atom-change-relinearize context))))))) ) (scan-for-bounds (il:lambda (start end line initialize) (il:* il:\; "Edited 11-Apr-88 15:26 by woz") (il:* il:|;;;| "we have to recompute the ascent and descent of this line. scan the linear form from start to end (or the next line start, which ever comes first) and compute the maximum ascent and descent. we also fix up the first and last line fields of any nodes we notice, and compute and return the width of the section of linear form we examine") (il:|bind| item item-node (line-start il:_ (car line)) max-ascent max-descent (x il:_ 0) il:|first| (cond (initialize (il:setq max-ascent 0) (il:setq max-descent 0)) (t (il:setq max-ascent (il:|fetch| line-ascent il:|of| line-start)) (il:setq max-descent (il:|fetch| line-descent il:|of| line-start)))) il:|do| (when (eq start end) (when (null start) (il:|replace| next-line il:|of| line-start il:|with| nil)) (go il:$$out)) (cond ((il:listp start) (il:setq item (car start)) (cond ((il:|type?| weak-link item) (setq item-node (il:|fetch| destination il:|of| item)) (il:|replace| first-line il:|of| item-node il:|with| line-start) (il:setq start (il:|fetch| linear-form il:|of| item-node))) ((il:|type?| line-start item) (il:|replace| prev-line il:|of| item il:|with| line) (il:|replace| next-line il:|of| line-start il:|with| start) (go il:$$out)) (t (cond ((il:fixp item) (il:setq x (il:iplus x item))) ((il:|type?| string-item item) (il:setq x (il:iplus x (il:|fetch| width il:|of| item))) (il:setq item (il:|fetch| font il:|of| item)) (il:setq max-ascent (il:imax max-ascent (il:fontprop item (quote il:ascent)))) (il:setq max-descent (il:imax max-descent (il:fontprop item (quote il:descent))))) (t (il:setq max-ascent (il:imax max-ascent (il:idifference (il:bitmapheight (cdr item)) (car item)))) (il:setq max-descent (il:imax max-descent (il:iminus (car item)))) (il:setq x (il:iplus x (il:bitmapwidth (cdr item)))))) (il:setq start (cdr start))))) (t (il:setq start (il:|fetch| destination il:|of| start)) (il:* il:\; "used to replace LastLineLinear of start with line") (il:|replace| last-line il:|of| start il:|with| line-start) (il:setq start (cdr (il:|fetch| linear-thread il:|of| start))))) il:|finally| (il:|replace| line-ascent il:|of| line-start il:|with| max-ascent) (il:|replace| line-descent il:|of| line-start il:|with| max-descent) (when (il:|type?| weak-link start) (il:* il:\; "used to replace LastLineLinear of (fetch Destination of start) with line") (il:|replace| last-line il:|of| (il:|fetch| destination il:|of| start) il:|with| (car line))) (return x))) ) (select-node (il:lambda (context node set-point? where) (il:* il:\; "Edited 3-Dec-87 12:15 by DCB") (set-selection-me (il:fetch selection il:of context) context node) (il:replace pending-delete? il:of (il:fetch selection il:of context) il:with nil) (when set-point? (set-point (il:fetch caret-point il:of context) context node nil where nil (quote structure) t))) ) (select-segment (il:lambda (selection context node subnode index offset item) (il:* il:\; "Edited 17-Nov-87 11:24 by DCB") (il:* il:|;;;| "apply the appropriate SelectSegment method to set this selection") (il:replace delete-ok? il:of selection il:with t) (il:replace pending-delete? il:of selection il:with t) (funcall (il:fetch select-segment il:of (il:fetch node-type il:of node)) selection context node subnode index offset item)) ) (select-segment-default (il:lambda (selection context node subnode index offset item) (il:* il:\; "Edited 11-Apr-88 15:26 by woz") (il:* il:|;;;| "a default SelectSegment method for aggregate types. selects the sequence of subnodes bounded by the selected items") (let (start end) (cond (subnode (il:setq start (il:setq end (il:|fetch| sub-node-index il:|of| subnode)))) (t (il:setq start (il:|fetch| select-start il:|of| selection)) (il:setq end (or (il:|fetch| select-end il:|of| selection) start)))) (cond ((null index) (il:setq start (il:imin start (il:|fetch| select-start il:|of| selection))) (il:setq end (il:imax end (il:|fetch| select-end il:|of| selection)))) ((il:|type?| edit-node index) (cond ((il:ilessp (il:setq index (il:|fetch| sub-node-index il:|of| index)) start) (il:setq start index)) ((il:igreaterp index end) (il:setq end index)))) (t (il:|for| linear-item il:|in| (il:|fetch| linear-form il:|of| node) il:|as| linear-index il:|from| 1 il:|bind| last-subnode-index take-next linear-item-node il:|do| (when (il:|type?| weak-link linear-item) (setq linear-item-node (il:|fetch| destination il:|of| linear-item)) (cond (take-next (return (il:setq start (il:imin start (il:|fetch| sub-node-index il:|of| linear-item-node))))) (t (il:setq last-subnode-index (il:|fetch| sub-node-index il:|of| linear-item-node)) (when (eq linear-index index) (cond ((il:ilessp last-subnode-index start) (il:setq start last-subnode-index)) ((il:igreaterp last-subnode-index end) (il:setq end last-subnode-index))) (return))))) (when (eq linear-index index) (if (and last-subnode-index (il:igeq last-subnode-index start)) (return (il:setq end (il:imax end last-subnode-index))) (il:setq take-next t)))))) (il:|replace| select-node il:|of| selection il:|with| node) (il:|replace| select-start il:|of| selection il:|with| start) (il:|replace| select-end il:|of| selection il:|with| end) (il:|replace| select-start-x il:|of| selection il:|with| nil) (il:|replace| select-type il:|of| selection il:|with| (quote structure)))) ) (selection-down (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "turn off the display of the current selection -- we're going to change the window. displaly.se") (when (il:fetch selection-displayed? il:of context) (display-selection (il:fetch selection il:of context) (il:fetch display-window il:of context)) (il:replace selection-displayed? il:of context il:with nil))) ) (selection-up (il:lambda (context) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "make sure the selection is displayed. if it's not, and displaying it works, then mark it as displayed.") (when (and (not (il:fetch selection-displayed? il:of context)) (display-selection (il:fetch selection il:of context) (il:fetch display-window il:of context))) (il:replace selection-displayed? il:of context il:with t))) ) (set-point (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "apply the appropriate SetPoint method to set this point. these methods must be able to handle 3 cases:") (il:* il:|;;;| "case 1: index is index into linear form of cursor, offset is offset into that item, item is the item") (il:* il:|;;;| "case 2: (set point at beginning or end of this node) : index is NIL, offset is NIL for beginning, T for end") (il:* il:|;;;| "case 3: (set point before or after subnode) : index is subnode index, offset is before/after, item is subnode") (funcall (il:fetch set-point il:of (il:fetch node-type il:of node)) point context node index offset item type compute-location?)) ) (set-point-nowhere (il:lambda (point) (il:* il:\; "Edited 17-Nov-87 11:25 by DCB") (il:* il:|;;;| "a SetPoint method for types that have nowhere to insert") (il:replace point-node il:of point il:with nil) (il:replace point-type il:of point il:with nil)) ) (set-point-unknown (il:lambda (point context node index offset item type compute-location?) (il:* il:\; "Edited 17-Nov-87 11:25 by DCB") (il:* il:|;;;| "the SetPoint method for type unknown, and anyone else doesn't allow insertions but whose super might. ask the super to except input before or after this node, based on which is closer. note that the calculation for which is closer assumes that the node is displayed inline, so this method won't work for anyone that doesn't") (punt-set-point point context node (if index (il:igeq offset (il:half (il:fetch inline-width il:of node))) offset) compute-location?)) ) (set-selection (il:lambda (selection context node index offset item type) (il:* il:\; "Edited 17-Nov-87 11:25 by DCB") (il:* il:|;;;| "apply the appropriate SetSelection method to set this selection") (il:replace delete-ok? il:of selection il:with t) (il:replace pending-delete? il:of selection il:with nil) (funcall (il:fetch set-selection il:of (il:fetch node-type il:of node)) selection context node index offset item type)) ) (set-selection-me (il:lambda (selection context node) (il:* il:\; "Edited 17-Nov-87 11:26 by DCB") (il:* il:|;;;| "set the current selection to be this node") (il:|replace| select-node il:|of| selection il:|with| node) (il:|replace| select-start il:|of| selection il:|with| nil) (il:|replace| select-end il:|of| selection il:|with| nil) (il:* il:|;;| "we use to compute the selection position, but (a) this causes problems because some of these values might not be computed yet, and (b) ComputeSelectionPosition should be called anyway. Here's the old code:") (il:* il:|;;| "(replace SelectStartX of selection with (fetch StartX of node)) ") (il:* il:|;;| "(replace SelectStartLine of selection with (fetch FirstLine of node)) ") (il:* il:|;;| "(replace SelectEndX of selection with (IPLUS (fetch StartX of node) ") (il:* il:|;;| "(fetch ActualLLength of node))) ") (il:* il:|;;| "(replace SelectEndLine of selection with (fetch LastLine of node))") (il:|replace| select-start-x il:|of| selection il:|with| nil) (il:|replace| select-type il:|of| selection il:|with| (quote structure))) ) (set-selection-nowhere (il:lambda (selection) (il:* il:\; "Edited 17-Nov-87 11:27 by DCB") (il:* il:|;;;| "there is no current selection") (il:replace select-node il:of selection il:with nil)) ) (shift-down (il:lambda nil (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;| "check which selection modifer keys are held down, and return one of the atoms Move, Copy, Delete, or NIL. The META key is not considered a \"selection modifer\". It is used to popup the command menu.") (cond ((il:keydownp (quote il:move)) (quote move)) ((il:keydownp (quote il:copy)) (quote copy)) ((il:shiftdownp (quote il:shift)) (if (il:shiftdownp (quote il:ctrl)) (quote move) (quote copy))) ((il:shiftdownp (quote il:ctrl)) (quote delete)))) ) (show-caret (il:lambda (context compute-pos? scroll?) (il:* il:\; "Edited 13-Jun-88 18:59 by Snow") (il:* il:|;;;| "COMMAND is the command name run prior to this update. Normalize the caret if: the user is inside a structure (point-type not STRUCTURE), or we're specifically told to scroll. ") (let ((caret-point (il:|fetch| caret-point il:|of| context))) (when (il:|fetch| point-node il:|of| caret-point) (when compute-pos? (compute-point-position caret-point context)) (il:|freplace| caret il:|of| context il:|with| (il:\\caret.create (if (eq (il:|ffetch| point-type il:|of| caret-point) 'structure) structure-caret atom-caret))) (when (or (not (eq (il:|ffetch| point-type il:|of| caret-point) 'structure)) scroll?) (il:* il:|;;| "AUTO SCROLL: check for caret off screen.") (let* ((window (il:|ffetch| display-window il:|of| context)) (region (il:dspclippingregion nil window)) selection caret-x caret-y x-amount y-amount) (il:* il:|;;|  "if its a pending delete point, get the location out of the selection") (cond ((il:type? edit-selection (setq selection (il:ffetch point-node il:of caret-point))) (setq caret-x (il:ffetch select-start-x il:of selection)) (setq caret-y (il:fetch base-line-y il:of (il:ffetch select-start-line il:of selection)) )) (t (setq caret-x (il:ffetch point-x il:|of| caret-point)) (setq caret-y (il:fetch base-line-y il:|of| (il:ffetch point-line il:|of| caret-point))))) (il:* il:|;;| "with the fancy formatting of sedit, you can end up off the screen in two dimensions at once, so check horizontally and vertically separately, then do the scroll if need be.") (cond ((plusp (setq x-amount (- caret-x (il:ffetch (il:region il:right) il:|of| region)))) (il:* il:|;;| "fell off right edge") (setq x-amount (- (floor (il:ffetch (il:region il:width) il:|of| region) -2) x-amount))) ((minusp (setq x-amount (- caret-x (il:ffetch (il:region il:left) il:|of| region)))) (il:* il:|;;| "fell off left edge, scroll right") (setq x-amount (- (floor (il:ffetch (il:region il:width) il:|of| region) 2) x-amount))) (t (setq x-amount 0))) (cond ((minusp (setq y-amount (- caret-y (il:ffetch (il:region il:bottom) il:|of| region)))) (il:* il:|;;| "fell off bottom edge") (setq y-amount (- (floor (il:ffetch (il:region il:height) il:|of| region) 2) y-amount))) ((plusp (setq y-amount (- caret-y (il:ffetch (il:region il:top) il:|of| region)))) (il:* il:|;;| "fell off top edge") (setq y-amount (- (floor (il:ffetch (il:region il:height) il:|of| region) -2) y-amount))) (t (setq y-amount 0))) (when (or (not (zerop x-amount)) (not (zerop y-amount))) (il:scrollw window x-amount y-amount)))))))) (SHRINKFN (IL:LAMBDA (WINDOW) (IL:* IL:\; "Edited 5-Dec-90 17:29 by woz") (IL:* IL:|;;| "called by the window system when an SEdit window is shrunk. if it doesn't already have one, give it a pretty icon with an appropriate title. also make sure the command process notices that it should die. grab the context lock here, because it wasn't grabbed by the buttoneventfn.") (LET* ((CONTEXT (IL:WINDOWPROP WINDOW 'EDIT-CONTEXT)) (LOCK (IL:|fetch| CONTEXT-LOCK IL:|of| CONTEXT))) (COND ((IL:EQMEMB :CLOSE-ON-COMPLETION (IL:|fetch| EDIT-OPTIONS IL:|of| CONTEXT)) (IL:* IL:|;;| "can't shrink, because must be a one-time edit") (IL:|printout| (GET-PROMPT-WINDOW CONTEXT) T "Can't shrink this SEdit. Must close when done editing.") 'IL:DON\'T) ((IL:OBTAIN.MONITORLOCK LOCK T) (IL:RELEASE.MONITORLOCK LOCK) (IL:* IL:\;  "release before waking sedit") (COND ((EQ (IL:PROCESSPROP (IL:THIS.PROCESS) 'IL:NAME) 'IL:MOUSE) (IL:* IL:|;;| "under the mouse, restart the completion under SEdit") (AWAKE-COMMAND-PROCESS CONTEXT '(COMPLETE NIL :SHRINK)) 'IL:DON\'T) (T (SAVE-WINDOW-REGION CONTEXT :SHRINK (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) (IL:|fetch| EDIT-TYPE IL:|of| CONTEXT) (IL:WINDOWREGION WINDOW)) (WHEN (NOT (IL:WINDOWPROP WINDOW 'IL:ICON)) (IL:WINDOWPROP WINDOW 'IL:ICON (LET ((SHRUNKW (IL:TITLEDICONW TITLED-ICON (IL:|fetch| ICON-TITLE IL:|of| CONTEXT) NIL T))) (IL:WINDOWPROP SHRUNKW 'IL:COPYFN 'ICON-COPYFN) SHRUNKW)))))) (T (IL:|printout| (GET-PROMPT-WINDOW CONTEXT) T "Can't shrink. SEdit is busy.") 'IL:DON\'T))))) (string-offset (il:lambda (string start end font string? point-or-selection startx) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "compute the x coordinate of a point or selection in a litatom or string. for a point, start is NIL and end is the number of characters before the point. for a selection, start is the number of characters before the start of the selection, and end is the number of characters before the last character of the selection. string? specifies that we have to account for string quotes.") (il:for j il:from 1 il:to end il:bind (offset il:_ 0) (esc il:_ (escape-char)) k il:first (when string? (il:setq offset (il:charwidth (il:charcode il:\") font))) il:do (when (eq j start) (il:replace select-start-x il:of point-or-selection il:with (il:iplus offset startx))) (il:setq k (il:nthcharcode string j)) (il:setq offset (il:iplus (cond ((and string? (or (eq k (il:charcode il:\")) (eq k esc))) (il:iplus (il:charwidth esc font) (il:charwidth k font))) ((and string? (il:ilessp k (il:charcode il:space))) (il:iplus (il:charwidth (il:charcode il:^ font) font) (il:charwidth (il:iplus k 64) font))) (t (il:charwidth k font))) offset)) il:finally (if start (il:replace select-end-x il:of point-or-selection il:with (il:iplus offset startx)) (il:replace point-x il:of point-or-selection il:with (il:iplus offset startx))))) ) (track-extend (il:lambda (context window) (il:* il:\; "Edited 24-Nov-87 09:53 by DCB") (il:* il:|;;;| "we're extending a selection with the right mouse button. display the resulting selection until the user accepts it by releasing the button. we use smash.using to copy the contents of one selection into another") (il:first (il:setq pending-type nil) (il:* il:|;;| "extending a selection cancels the point") (set-point-nowhere pending-caret) (cond ((il:fetch select-node il:of pending-selection) (smash-using edit-selection initial-selection pending-selection)) ((il:fetch select-node il:of (il:fetch selection il:of context)) (smash-using edit-selection initial-selection (il:fetch selection il:of context))) (t (il:* il:|;;| "there's no selection to extend, so nothing happens. wait until the mouse button comes up. this could be changed; i think it would be more convenient if you could extend from a point as well as a selection") (il:untilmousestate (not il:right)) (return))) il:do (smash-using edit-selection scratch-selection initial-selection) (il:* il:\; "compute the extended selection") (extend-selection scratch-selection context (il:lastmousex window) (il:lastmousey window)) (when (or (il:neq (il:fetch select-node il:of pending-selection) (il:fetch select-node il:of scratch-selection)) (il:neq (il:fetch select-start il:of pending-selection) (il:fetch select-start il:of scratch-selection)) (il:neq (il:fetch select-end il:of pending-selection) (il:fetch select-end il:of scratch-selection))) (il:* il:\; "if it's different from the last extended selection, fix the display") (display-selection pending-selection window pending-shift) (when (null (il:fetch select-start-x il:of scratch-selection)) (compute-selection-position scratch-selection context)) (display-selection scratch-selection window pending-shift) (smash-using edit-selection pending-selection scratch-selection)) (il:* il:\; "keep watching for changes in modifier keys") (check-selection-shift context) (il:block) il:repeatuntil (il:mousestate (not il:right)))) ) (track-select (il:lambda (context window) (il:* il:\; "Edited 24-Nov-87 09:54 by DCB") (il:* il:|;;| "we're making a selection with the left or middle mouse button. display the resulting selection until the user accepts it by releasing the button") (il:bind (point-type il:_ (cond ((il:lastmousestate il:left) (il:* il:|;;| "left button select within an atom") (quote atom)) (t (il:* il:|;;| "middle button selects structures") (quote structure)))) point? bar-x bar-y bar-line bar-height il:first (when (grow-click? context point-type window) (il:* il:|;;| "if this can be parsed as part of a multi-click sequence to grow the current selection, do it") (when (and (not pending-shift) (il:fetch select-node il:of pending-selection)) (set-point pending-caret context (il:fetch select-node il:of pending-selection) nil t) (when (il:fetch point-node il:of pending-caret) (compute-point-position pending-caret context))) (return)) (smash-using edit-selection scratch-selection pending-selection) il:do (il:* il:|;;| "decide where the new point and selection will be") (place-caret-and-selection (and (null pending-shift) pending-caret) pending-selection context (il:lastmousex window) (il:lastmousey window) point-type) (when pending-shift (il:* il:|;;| "if modifier keys are down we won't set the caret point") (set-point-nowhere pending-caret)) (il:* il:|;;| "show a vertical bar where the caret will be placed") (track-bar-in-track-select) (when (or (il:neq (il:fetch select-node il:of pending-selection) (il:fetch select-node il:of scratch-selection)) (il:neq (il:fetch select-start il:of pending-selection) (il:fetch select-start il:of scratch-selection)) (il:neq (il:fetch select-end il:of pending-selection) (il:fetch select-end il:of scratch-selection))) (il:* il:|;;| "if this is a new selection, display it") (display-selection scratch-selection window pending-shift) (display-selection pending-selection window pending-shift) (smash-using edit-selection scratch-selection pending-selection)) (check-selection-shift context) (il:block) il:repeatuntil (il:mousestate (or il:up il:right)) il:finally (when point? (il:* il:|;;| "take down the vertical bar at the caret position") (il:bltshade il:blackshade window bar-x bar-y 1 bar-height (quote il:invert))) (il:* il:|;;| "remember where the mouse is, so that we can detect multi-click sequences") (il:setq pending-last-x (il:lastmousex window)) (il:setq pending-last-y (il:lastmousey window)) (il:setq pending-type point-type))) ) (underline-selection (il:lambda (selection window shade) (il:* il:\; "Edited 17-Nov-87 11:27 by DCB") (il:* il:|;;;| "use draw.underline to underline the this selection with the specified shade") (draw-underline (il:fetch select-start-x il:of selection) (il:fetch select-start-line il:of selection) (il:fetch select-end-x il:of selection) (il:fetch select-end-line il:of selection) window shade)) ) (update-title (il:lambda (context window always?) (il:* il:\; "Edited 7-Jul-87 13:04 by DCB") (il:* il:|;;;| "MUST BE CALLED UNDER SEDIT'S PROFILE: Expects *PACKAGE* to be bound properly. Update the window title to reflect the state of the edit. toggle the asterisk that means \"unsaved changes\", fixup the current package...") (il:* il:|;;;| "The OR to test if any field has changed is okay because only one thing can happen at a time, and so only one of the or clauses can be true on any call to this function.") (let ((title-info (il:windowprop window (quote title-info))) (changed-structure (il:fetch changed-structure? il:of context)) (name (il:fetch icon-title il:of context))) (when (or (when (il:neq changed-structure (il:listget title-info :|ChangedStructure?|)) (il:listput title-info :|ChangedStructure?| changed-structure) t) (when (il:neq *package* (il:listget title-info :|package|)) (il:listput title-info :|package| *package*) t) (when (il:neq name (il:listget title-info :|name|)) (il:listput title-info :|name| name) t) always?) (il:windowprop window (quote il:title) (il:concat (if changed-structure "* " "") editor-name " " (or name "") " Package: " (package-name *package*)))))) ) ) (IL:PUTPROPS IL:SEDIT-WINDOW IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990 1991 1992 2018)) (IL:DECLARE\: IL:DONTCOPY (IL:FILEMAP (NIL (11430 12334 (SELECT-NODE-SEGMENT 11430 . 12334)) (12335 87731 (BUILD-WINDOW 12348 . 18188) (BUTTONEVENTFN 18190 . 24733) (CHECK-SELECTION 24735 . 26775) (CHECK-SELECTION-SHIFT 26777 . 27900) (CLOSEFN 27902 . 30905) (CONFLICTING-SELECTION? 30907 . 31668) (DISPLAY-SELECTION 31670 . 32697 ) (DRAW-HIGHLIGHT 32699 . 33829) (DRAW-OUTLINE 33831 . 35186) (DRAW-UNDERLINE 35188 . 35963) (EXPANDFN 35965 . 36472) (EXPANDREGIONFN 36474 . 37064) (EXTEND-SELECTION 37066 . 39643) ( FINALIZE-MOUSE-SELECTION 39645 . 46191) (FIND-LINE-START 46193 . 46884) (FIND-NODE 46886 . 48161) ( GET-DESTINATION-CONTEXT 48163 . 48715) (GRAY 48717 . 49104) (GROW-CLICK? 49106 . 51091) ( GROW-SELECTION 51093 . 51436) (GROW-SELECTION-DEFAULT 51438 . 51809) (HIGHLIGHT-SELECTION 51811 . 52104) (ICON-COPYFN 52106 . 52450) (LESS-PROMPT-WINDOW 52452 . 52821) (NORMALIZE-SELECTION 52823 . 54189) (OUTLINE-SELECTION 54191 . 55329) (PENDING-DELETE 55331 . 55665) (PLACE-CARET-AND-SELECTION 55667 . 57227) (PUNT-SET-POINT 57229 . 57687) (PUNT-SET-SELECTION 57689 . 58138) (REPAINTFN 58140 . 59418) (RESHAPEFN 59420 . 61758) (SCAN-FOR-BOUNDS 61760 . 64303) (SELECT-NODE 64305 . 64675) ( SELECT-SEGMENT 64677 . 65117) (SELECT-SEGMENT-DEFAULT 65119 . 67146) (SELECTION-DOWN 67148 . 67558) ( SELECTION-UP 67560 . 67986) (SET-POINT 67988 . 68747) (SET-POINT-NOWHERE 68749 . 69008) ( SET-POINT-UNKNOWN 69010 . 69631) (SET-SELECTION 69633 . 70066) (SET-SELECTION-ME 70068 . 71160) ( SET-SELECTION-NOWHERE 71162 . 71360) (SHIFT-DOWN 71362 . 71903) (SHOW-CARET 71905 . 77463) (SHRINKFN 77465 . 80200) (STRING-OFFSET 80202 . 81562) (TRACK-EXTEND 81564 . 83620) (TRACK-SELECT 83622 . 86111) (UNDERLINE-SELECTION 86113 . 86515) (UPDATE-TITLE 86517 . 87729))))) IL:STOP