home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / coms1.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  64.4 KB  |  1,805 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:8. ; Fonts:cptfont, cptfontb -*-
  2.  
  3. #|
  4.             Copyright 1985 Massachusetts Institute of Technology
  5.  
  6.  Permission to use, copy, modify, distribute, and sell this software
  7.  and its documentation for any purpose is hereby granted without fee,
  8.  provided that the above copyright notice appear in all copies and that
  9.  both that copyright notice and this permission notice appear in
  10.  supporting documentation, and that the name of M.I.T. not be used in
  11.  advertising or publicity pertaining to distribution of the software
  12.  without specific, written prior permission.  M.I.T. makes no
  13.  representations about the suitability of this software for any
  14.  purpose.  It is provided "as is" without express or implied warranty.
  15.  
  16.  
  17.                                          +-Data--+
  18.                 This file is part of the | BOXER | system
  19.                                          +-------+
  20.  
  21.  
  22.  This file contains top level definitions for BOXER Editor Commands 
  23.  
  24.  
  25. |#
  26.  
  27. ;;;; The basics
  28.  
  29. (DEFBOXER-COMMAND COM-ABORT ()
  30.   "aborts any editing in progress.  flushes
  31. numeric arguments and removes the current
  32. region. "
  33.   ;; if there is a region, get rid of it
  34.   (LET ((REGION-TO-FLUSH (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  35.     (UNLESS (NULL REGION-TO-FLUSH)
  36.       (FLUSH-REGION REGION-TO-FLUSH)))
  37.   (BOXER-EDITOR-ERROR "Editor Top Level")
  38.   (WITH-MULTIPLE-EXECUTION            ;this is here so that numeric args are flushed
  39.     (*THROW 'BOXER-EDITOR-TOP-LEVEL NIL)))
  40.  
  41. (DEFBOXER-COMMAND COM-INCREMENT-NUMERIC-ARG ()
  42.   "specifies part of the next command's numeric argument. "
  43.   (IF *EDITOR-NUMERIC-ARGUMENT*
  44.       (SET-EDITOR-NUMERIC-ARG (+ (* 10. *EDITOR-NUMERIC-ARGUMENT*)
  45.                      (NUMBER-CODE BU:*KEY-CODE-BEING-HANDLED*)))
  46.       (SET-EDITOR-NUMERIC-ARG (NUMBER-CODE BU:*KEY-CODE-BEING-HANDLED*))))
  47.  
  48. ;This uses only the global value of bu:*key-code-being-handled*.
  49. ;You can't bind it from boxer.
  50. (DEFBOXER-COMMAND COM-SELF-INSERT ()
  51.   "inserts the last character typed.
  52. with a numeric argument (n), inserts
  53. the character n times. "
  54.   (WITH-MULTIPLE-EXECUTION
  55.     (INSERT-CHA *POINT*               
  56.         (MAKE-CHA BU:*KEY-CODE-BEING-HANDLED*)
  57.         ':MOVING)))
  58.  
  59. (DEFBOXER-COMMAND COM-QUOTE-SELF-INSERT ()
  60.   "inserts any keyboard character.
  61. with a numeric argument, inserts that
  62. many copies of the character. "
  63.   (LET ((BU:*KEY-CODE-BEING-HANDLED* (TELL TERMINAL-IO :TYI)))
  64.     (COM-SELF-INSERT)))
  65.  
  66. (DEFBOXER-COMMAND COM-SPACE ()
  67.   "inserts a space.  with a numeric
  68. argument (n), inserts n spaces. "
  69.   (WITH-MULTIPLE-EXECUTION
  70.     (INSERT-CHA *POINT*               
  71.         (MAKE-CHA BU:*KEY-CODE-BEING-HANDLED*)
  72.         ':MOVING)))
  73.  
  74. (DEFBOXER-COMMAND COM-RETURN ()
  75.   "inserts a new line into the buffer
  76. at the cursor location.  with a numeric
  77. argument (n), inserts n new lines. When 
  78. in the name portion of a box, enters the
  79. box itself. "
  80.     (COND ((NAME-ROW? (POINT-ROW))
  81.        (COM-EXIT-BOX)
  82.        (COM-BACKWARD-CHA)
  83.        (COM-ENTER-BOX))
  84.       (T 
  85.        (WITH-MULTIPLE-EXECUTION
  86.          (INSERT-ROW *POINT* (MAKE-INITIALIZED-ROW) ':MOVING))))
  87.     (SETQ *COLUMN* 0))
  88.  
  89. (DEFBOXER-COMMAND COM-OPEN-LINE ()
  90.   "inserts a blank line after the cursor.
  91. with a numeric arg (n), inserts n blank lines. "
  92.   (WITH-MULTIPLE-EXECUTION
  93.     (INSERT-ROW *POINT* (MAKE-INITIALIZED-ROW) ':MOVING)
  94.     (MOVE-POINT (BP-BACKWARD-CHA-VALUES *POINT*))))
  95.  
  96.  
  97.  
  98. ;;;; Single Character Commands
  99.  
  100. (DEFBOXER-COMMAND COM-RUBOUT ()
  101.   "Rubs out one character.  with numeric
  102. argument (n), rubs out n characters. "
  103.   (WITH-MULTIPLE-EXECUTION
  104.     (LET ((DELETED-CHA (RUBOUT-CHA *POINT* ':MOVING)))
  105.       (kill-buffer-push deleted-cha ':BACKWARD)
  106.       (SETQ *COLUMN* (BP-CHA-NO *POINT*)))))
  107.  
  108. (DEFBOXER-COMMAND COM-DELETE ()
  109.   "deletes one character.  with numeric
  110. argument (n), delete n characters. "
  111.   (WITH-MULTIPLE-EXECUTION
  112.     (LET ((OLD-ROW (BP-ROW *POINT*))
  113.       (OLD-CHA-NO (BP-CHA-NO *POINT*)))
  114.       (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*))
  115.       (IF (OR (NEQ OLD-ROW (BP-ROW *POINT*))
  116.           (NEQ OLD-CHA-NO (BP-CHA-NO *POINT*)))
  117.       (kill-buffer-push 
  118.         (RUBOUT-CHA *POINT* ':MOVING)
  119.         ':forward)))))
  120.  
  121. (DEFBOXER-COMMAND COM-FORWARD-CHA ()
  122.   "moves forward one character.  with
  123. numeric argument (n), moves forward
  124. n characters. "
  125.   (WITH-MULTIPLE-EXECUTION
  126.     (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*))))
  127.  
  128. (DEFBOXER-COMMAND COM-BACKWARD-CHA ()
  129.   "moves backward one character.  with
  130. numeric argument (n), moves backward
  131. n characters. "
  132.   (WITH-MULTIPLE-EXECUTION
  133.     (MOVE-POINT (BP-BACKWARD-CHA-VALUES *POINT*))))
  134.  
  135.  
  136.  
  137. ;;;; Cursor Movement
  138.  
  139. (DEFBOXER-COMMAND COM-BEGINNING-OF-ROW ()
  140.   "moves to the beginning of the row. "
  141.    (MOVE-POINT (ROW-FIRST-BP-VALUES (BP-ROW *POINT*))))
  142.  
  143. (DEFBOXER-COMMAND COM-END-OF-ROW ()
  144.   "moves to the end of the row. "
  145.   (MOVE-POINT (ROW-LAST-BP-VALUES (BP-ROW *POINT*))))
  146.  
  147. (DEFBOXER-COMMAND COM-BEGINNING-OF-BOX ()
  148.   "moves to the beginning of the box. "
  149.   (MOVE-POINT (BOX-FIRST-BP-VALUES (BOX-POINT-IS-IN)))
  150.   (dolist (screen-row (tell (box-point-is-in) :screen-objs))
  151.     (tell screen-row :set-scroll-to-actual-row (tell (box-point-is-in) :first-inferior-row))))
  152.  
  153. (DEFBOXER-COMMAND COM-END-OF-BOX ()
  154.   "moves to the end of the box. "
  155.   (MOVE-POINT (BOX-LAST-BP-VALUES (BOX-POINT-IS-IN)))
  156.   (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX)))
  157.  
  158. (DEFBOXER-COMMAND COM-PREVIOUS-ROW ()
  159.   "moves up vertically to the previous
  160. row.  With numeric argument (n), moves
  161. up n rows.  Tries to stay as close as
  162. possible to the original column. "
  163.   (WITH-MULTIPLE-EXECUTION
  164.     (LET* ((ROW (BP-ROW *POINT*))
  165.        (PREVIOUS-ROW (TELL-CHECK-NIL ROW :PREVIOUS-ROW))
  166.        (PREVIOUS-ROW-LENGTH-IN-CHAS
  167.          (TELL-CHECK-NIL PREVIOUS-ROW :LENGTH-IN-CHAS))
  168.        (CHA-NO (BP-CHA-NO *POINT*))
  169.        (CURRENT-ROW-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS)))
  170.       (COND ((NULL PREVIOUS-ROW))
  171.         ((< CHA-NO CURRENT-ROW-LENGTH-IN-CHAS)
  172.          (SETQ *COLUMN* CHA-NO)
  173.          (MOVE-POINT-1 PREVIOUS-ROW
  174.                (MIN PREVIOUS-ROW-LENGTH-IN-CHAS *COLUMN*)))
  175.         ((< *COLUMN* CHA-NO)
  176.          (SETQ *COLUMN* CHA-NO)
  177.          (MOVE-POINT-1 PREVIOUS-ROW
  178.                (MIN PREVIOUS-ROW-LENGTH-IN-CHAS *COLUMN*)))
  179.         (T
  180.          (MOVE-POINT-1 PREVIOUS-ROW
  181.                (MIN PREVIOUS-ROW-LENGTH-IN-CHAS *COLUMN*))))
  182.       (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX)))))
  183.  
  184.  
  185. ;; this one goes to the name row if it's there
  186. (DEFBOXER-COMMAND COM-PREVIOUS-ROW-OR-NAME ()
  187.   "moves up vertically to the previous
  188. row.  With numeric argument (n), moves
  189. up n rows.  Tries to stay as close as
  190. possible to the original column. "
  191.   (WITH-MULTIPLE-EXECUTION
  192.     (LET* ((ROW (BP-ROW *POINT*))
  193.        (PREVIOUS-ROW (TELL-CHECK-NIL ROW :PREVIOUS-ROW))
  194.        (PREVIOUS-ROW-LENGTH-IN-CHAS
  195.          (TELL-CHECK-NIL PREVIOUS-ROW :LENGTH-IN-CHAS))
  196.        (CHA-NO (BP-CHA-NO *POINT*))
  197.        (CURRENT-ROW-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS)))
  198.       (COND ((NULL PREVIOUS-ROW)
  199.          (COM-NAME-BOX))
  200.         ((< CHA-NO CURRENT-ROW-LENGTH-IN-CHAS)
  201.          (SETQ *COLUMN* CHA-NO)
  202.          (MOVE-POINT-1 PREVIOUS-ROW
  203.                (MIN PREVIOUS-ROW-LENGTH-IN-CHAS *COLUMN*)))
  204.         ((< *COLUMN* CHA-NO)
  205.          (SETQ *COLUMN* CHA-NO)
  206.          (MOVE-POINT-1 PREVIOUS-ROW
  207.                (MIN PREVIOUS-ROW-LENGTH-IN-CHAS *COLUMN*)))
  208.         (T
  209.          (MOVE-POINT-1 PREVIOUS-ROW
  210.                (MIN PREVIOUS-ROW-LENGTH-IN-CHAS *COLUMN*))))
  211.       (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX)))))
  212.   
  213.  
  214.  
  215. (DEFBOXER-COMMAND COM-NEXT-ROW ()
  216.     "moves up vertically down the next
  217. row.  With numeric argument (n), moves
  218. down n rows.  Tries to stay as close as
  219. possible to the original column. "
  220.   (WITH-MULTIPLE-EXECUTION
  221.     (LET* ((ROW (BP-ROW *POINT*))
  222.        (NEXT-ROW (TELL-CHECK-NIL ROW :NEXT-ROW))
  223.        (NEXT-ROW-LENGTH-IN-CHAS (TELL-CHECK-NIL NEXT-ROW :LENGTH-IN-CHAS))
  224.        (CHA-NO (BP-CHA-NO *POINT*))
  225.        (CURRENT-ROW-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS)))
  226.       (COND ((NULL NEXT-ROW) 
  227.          (COM-END-OF-ROW)
  228.          (COM-RETURN))
  229.         ((< CHA-NO CURRENT-ROW-LENGTH-IN-CHAS)
  230.          (SETQ *COLUMN* CHA-NO)
  231.          (MOVE-POINT-1 NEXT-ROW (MIN NEXT-ROW-LENGTH-IN-CHAS *COLUMN*))
  232.          (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX) 1))
  233.         ((< *COLUMN* CHA-NO)
  234.          (SETQ *COLUMN* CHA-NO)
  235.          (MOVE-POINT-1 NEXT-ROW (MIN NEXT-ROW-LENGTH-IN-CHAS *COLUMN*))
  236.          (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX) 1))
  237.         (T
  238.          (MOVE-POINT-1 NEXT-ROW (MIN NEXT-ROW-LENGTH-IN-CHAS *COLUMN*))
  239.          (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX) 1))))))
  240.  
  241.  
  242.  
  243. ;;; Generalized movement
  244. ;;; Move the POINT to another (possibly non-local) location specified by BP
  245. ;;; This function performs all of the neccessary zooms, expands and scrolls
  246. ;;; so that the user has some idea of where he is going
  247.  
  248. (DEFUN MOVE-TO-BP (BP &OPTIONAL (MOVING-BP *POINT*))
  249.   (IF (TELL (BP-BOX BP) :SUPERIOR? (BP-BOX MOVING-BP))
  250.       (DOWNWARD-MOVE-TO-BP BP MOVING-BP)
  251.       ;; looks like we are going to have to go up before we can go down
  252.       (UPWARD-MOVE-TO-COMMON-BOX BP MOVING-BP)
  253.       (DOWNWARD-MOVE-TO-BP BP MOVING-BP)))
  254.  
  255. ;;; Move upward until we reach a place where BP is in some inferior of (POINT-BOX)
  256. ;;; We have to march up the screen structure rather than the actual structure because
  257. ;;; we might be inside of a port
  258.  
  259. (DEFUN UPWARD-MOVE-TO-COMMON-BOX (BP &OPTIONAL (MOVING-BP *POINT*))
  260.   (LET  ((BOX (BP-BOX MOVING-BP)))
  261.     (COND ((TELL (BP-BOX BP) :SUPERIOR? BOX))    ;we have arrived
  262.       (T (UNLESS (EQ BOX *INITIAL-BOX*)
  263.            (TELL BOX :EXIT (TELL (BP-SCREEN-BOX MOVING-BP) :SUPERIOR-SCREEN-BOX)
  264.              (TELL BOX :SUPERIOR-BOX) T))
  265.          (UPWARD-MOVE-TO-COMMON-BOX BP MOVING-BP)))))
  266.  
  267. ;;; The destination is in some inferior of the current box
  268. (DEFUN DOWNWARD-MOVE-TO-BP (BP &OPTIONAL (MOVING-BP *POINT*))
  269.   (LET* ((ROW (BP-ROW BP))
  270.      (OLD-ROW (BP-ROW MOVING-BP))
  271.      (SCREEN-ROW (VISIBLE-SCREEN-OBJ-OF-INFERIOR-ACTUAL-OBJ ROW
  272.                                 (BP-SCREEN-BOX MOVING-BP))))
  273.     (COND ((NOT-NULL SCREEN-ROW)
  274.        ;; the destination is visible already
  275.        (MOVE-BP MOVING-BP (BP-VALUES BP))
  276.        (SET-BP-SCREEN-BOX MOVING-BP (TELL SCREEN-ROW :SCREEN-BOX)))
  277.       ((MEMQ ROW (TELL (BP-BOX MOVING-BP) :ROWS))
  278.        ;; the destination is in the current box but is scrolled out of sight
  279.        (MOVE-BP MOVING-BP (BP-VALUES BP))
  280.        (ENSURE-ROW-IS-DISPLAYED (BP-ROW MOVING-BP) (BP-SCREEN-BOX MOVING-BP)
  281.                     (IF (ROW-> ROW OLD-ROW) 1 -1)))
  282.       (T
  283.        (LET* ((PATH (FIND-PATH-FROM-SUPERIOR-TO-INFERIOR (BP-BOX MOVING-BP)
  284.                                  (BP-BOX BP)))
  285.           (NEW-BOX (LOWEST-VISIBLE-BOX (BP-SCREEN-BOX MOVING-BP) PATH)))
  286.          (COND ((NULL PATH)
  287.             (EDITOR-BARF "The BP, ~A, is not in an inferior of ~A" BP
  288.                  (BP-BOX MOVING-BP)))
  289.            ((NULL NEW-BOX)
  290.             ;; the downward chain of boxes is not visible probably because
  291.             ;; we are scrolled to the wrong place in the current screen box
  292.             ;; so we scroll to the correct row, then try again
  293.             (MOVE-BP MOVING-BP (BOX-SELF-BP-VALUES (CAR PATH)))
  294.             (ENSURE-ROW-IS-DISPLAYED (BP-ROW MOVING-BP) (BP-SCREEN-BOX MOVING-BP)
  295.                          (IF (ROW-> (TELL (CAR PATH) :SUPERIOR-ROW)
  296.                             OLD-ROW)
  297.                          1 -1))
  298.             (DOWNWARD-MOVE-TO-BP BP MOVING-BP))
  299.            (T
  300.             ;; move to lowest visible box, zoom, then try again
  301.             (MOVE-BP MOVING-BP (BOX-FIRST-BP-VALUES NEW-BOX))
  302.             (SET-BP-SCREEN-BOX MOVING-BP
  303.               (VISIBLE-SCREEN-OBJ-OF-INFERIOR-ACTUAL-OBJ NEW-BOX
  304.                                      (BP-SCREEN-BOX MOVING-BP)))
  305.               (WHEN (OR (GRAPHICS-BOX? NEW-BOX)
  306.                 (AND (PORT-BOX? NEW-BOX)
  307.                      (GRAPHICS-BOX? (TELL NEW-BOX :PORTS))))
  308.             ;; The chain is in an inferior of a GRAPHICS/GRAPHICS-DATA-BOX
  309.             ;; which is currently in GRAPHICS mode so we have to toggle it
  310.             ;; before we can zoom it up
  311.             (TELL NEW-BOX :TOGGLE-TYPE))
  312.               ;; now we can zoom
  313.               (PUSH *OUTERMOST-SCREEN-BOX* *OUTERMOST-SCREEN-BOX-STACK*)
  314.               (LET ((*BOX-ZOOM-WAITING-TIME* (* *BOX-ZOOM-WAITING-TIME* 2)))
  315.             ;; slow things down a bit
  316.             (SET-OUTERMOST-BOX (BP-BOX MOVING-BP) (BP-SCREEN-BOX MOVING-BP)))
  317.               ;; then try again
  318.               (DOWNWARD-MOVE-TO-BP BP MOVING-BP))))))))
  319.  
  320. (DEFBOXER-COMMAND COM-MOVE-TO-BP (BP)
  321.   "Moves the cursor to the place specified by BP"
  322.   (MOVE-TO-BP BP))
  323.  
  324. ;;;; More movement.  This is primarily for moving to/from port targets although it
  325. ;;; may turn out to be more useful as it has a better idea of what is happening than the
  326. ;;; functions above
  327.  
  328. ;;; This allows you to specify a path of boxes from the top of the world.  This is needed
  329. ;;; for moving to points that are within a port.  Note that we can't use screen structure 
  330. ;;; because it may not exist for arbitrary points in the hierarchy
  331.  
  332. ;;; Paths are organized from the top to the bottom
  333.  
  334. ;; this is like a BP except that instead of a screen box, it relies on a absolute path from
  335. ;; the top of the editor hierarchy.  The reason for this is that screen structure can be
  336. ;; reclaimed.  This is the ONLY reliable way of maintaining a position in the boxer hierarchy
  337. ;; independent of the location of the *point*
  338.  
  339. (defvar *port-zooming-bread-crumbs* nil
  340.   "as we zoom throught ports to their targets, we leave a trail of where we;ve been.")
  341.  
  342. (defvar *port-zooming-pause-time* .5)
  343. (defvar *port-zooming-slowdown-factor* 2)
  344.  
  345. (defstruct (absolute-boxer-pointer :named 
  346.                    (:conc-name abp-)
  347.                    (:predicate abp?)
  348.                    (:constructor %make-abp (row cha-no path)))
  349.   (row nil)
  350.   (cha-no 0)
  351.   (path nil))
  352.  
  353. (DEFUN GET-PATH (BP &optional real-structure?)
  354.   (IF (or real-structure? (NOT (SCREEN-BOX? (BP-SCREEN-BOX BP))))
  355.       ;; either we march up the editor object hierarchy or else
  356.       (nreverse 
  357.     (WITH-COLLECTION
  358.       (DO ((BOX (BP-BOX BP) (TELL BOX :SUPERIOR-BOX)))
  359.           ((NOT (BOX? BOX)))
  360.         (COLLECT BOX))))
  361.       ;; we walk up the screen hierarchy
  362.       (nreverse
  363.     (WITH-COLLECTION
  364.       (DO ((SBOX (BP-SCREEN-BOX BP) (TELL SBOX :SUPERIOR-SCREEN-BOX)))
  365.           ((NOT (SCREEN-BOX? SBOX)))
  366.         (COLLECT (TELL SBOX :ACTUAL-OBJ)))))))
  367.  
  368. (defun make-abp-from-bp (bp)
  369.   (%make-abp (bp-row bp) (bp-cha-no bp) (get-path bp)))
  370.  
  371. (defun abp= (abp1 abp2)
  372.   (and (abp? abp1)
  373.        (abp? abp2)
  374.        (equal (abp-path abp1) (abp-path abp2))
  375.        (eq (abp-row abp1) (abp-row abp2))
  376.        (= (abp-cha-no abp1) (abp-cha-no abp2))))
  377.  
  378. (defun move-point-along-path (row cha-no path)
  379.   (let ((*box-zoom-waiting-time* (* *box-zoom-waiting-time* *port-zooming-slowdown-factor*)))
  380.     ;; first move up to a common superior box
  381.     (do ((box (box-screen-point-is-in) (box-screen-point-is-in)))
  382.     ((or (memq box path)
  383.          (eq box *initial-box*)))
  384.       (tell box :exit (tell (point-screen-box) :superior-screen-box)
  385.         (tell box :superior-box) t))
  386.     ;; now walk down the remainder of the path
  387.     (dolist (box (cdr (memq (box-screen-point-is-in) path)))
  388.       (let ((old-row (point-row))
  389.         (old-screen-box (point-screen-box)))
  390.     ;; move to the next Box in the path
  391.     (move-point (box-self-bp-values box))
  392.     (set-point-screen-box old-screen-box) 
  393.     ;; and make sure that where we moved to is visible
  394.     (ensure-row-is-displayed (point-row) old-screen-box
  395.                  (if (row-> (point-row) old-row) 1 -1))
  396.     (com-enter-box)
  397.     ;; if we have entered a shrunken box, then we should expand it
  398.     (when (eq ':shrunk (tell (point-box) :display-style))
  399.       (com-expand-box)
  400.       (redisplay))
  401.     (when (or (tell (point-screen-box) :x-got-clipped?)
  402.             (tell (point-screen-box) :y-got-clipped?))
  403.         ;; if the box is clipped, then expand it
  404.         (com-expand-box))))
  405.     ;; we are no in the lowest box and all we have to do is to go to the row
  406.     (move-point-1 row cha-no (point-screen-box))))
  407.  
  408. (defun move-to-port-target (port)
  409.   (when (port-box? port)
  410.     (let ((pos (make-abp-from-bp *point*)))
  411.       (unless (abp= (car  *port-zooming-bread-crumbs*) pos)
  412.     (push pos *port-zooming-bread-crumbs*))
  413.       (move-point-along-path (point-row) (point-cha-no) (get-path *point* t)))))
  414.  
  415. (defboxer-command com-move-to-port-target ()
  416.   "Move to the target of the port"
  417.   (if (port-box? (box-screen-point-is-in))
  418.       (move-to-port-target (box-screen-point-is-in))
  419.       (beep)))
  420.  
  421. (defboxer-command com-follow-bread-crumbs ()
  422.   "Move to saved location(s)"
  423.   (let ((pos (pop *port-zooming-bread-crumbs*)))
  424.     (when (abp? pos)
  425.       (move-point-along-path (abp-row pos) (abp-cha-no pos) (abp-path pos)))))
  426.  
  427. (defboxer-function ctrl-meta-space-key com-move-to-port-target)
  428.  
  429. (defboxer-function ctrl-meta-r-key com-follow-bread-crumbs)
  430.  
  431.  
  432.  
  433. ;;;; Word Commands
  434.  
  435. ;;; primitives for word operations
  436.  
  437. (DEFUN BP-OVER-VALUES (BP DIRECTION DELIMITER-CHAS)
  438.   (LET ((NOT-FIRST-CHA? NIL))
  439.     (MAP-OVER-CHAS-IN-LINE (BP DIRECTION)
  440.       (LET ((DELIMITER-CHA? (MEMQ (CHA-CODE CHA) DELIMITER-CHAS)))
  441.     (COND ((AND (NULL CHA)
  442.             (NULL NEXT-OR-PREVIOUS-ROW)) ;end/beginning of the box
  443.            (RETURN (VALUES ROW CHA-NO)))
  444.           ((AND (NULL CHA) NOT-FIRST-CHA?)   ;end/beginning of the line
  445.            (RETURN (VALUES ROW CHA-NO)))
  446.           ((AND NOT-FIRST-CHA? DELIMITER-CHA?)          ;end of the word
  447.            (RETURN (VALUES ROW CHA-NO)))
  448.           ((NOT DELIMITER-CHA?)                         ;beginning of word
  449.            (SETQ NOT-FIRST-CHA? T)))))))
  450.  
  451. (DEFUN BP-FORWARD-WORD-VALUES (BP)
  452.   (BP-OVER-VALUES BP 1 *WORD-DELIMITERS*))
  453.  
  454. (DEFUN BP-BACKWARD-WORD-VALUES (BP)
  455.   (BP-OVER-VALUES BP -1 *WORD-DELIMITERS*))
  456.  
  457. (DEFBOXER-COMMAND COM-FORWARD-WORD ()
  458. "moves forward one word. with numeric
  459. argument (n), moves forward n words. "
  460.   (WITH-MULTIPLE-EXECUTION
  461.     (MOVE-POINT (BP-FORWARD-WORD-VALUES *POINT*))))
  462.  
  463. (DEFBOXER-COMMAND COM-BACKWARD-WORD ()
  464. "moves backward one word. with numeric
  465. argument (n), moves backward n words. "
  466.   (WITH-MULTIPLE-EXECUTION
  467.     (MOVE-POINT (BP-BACKWARD-WORD-VALUES *POINT*))))
  468.  
  469.  
  470.  
  471. (DEFUN RUBOUT-OVER-VALUES (BP DIRECTION DELIMITER-CHAS)
  472.   (LET ((NOT-FIRST-CHA? NIL))
  473.     (MAP-OVER-CHAS-IN-LINE (BP DIRECTION)
  474.       (LET ((DELIMITER-CHA? (MEMQ (CHA-CODE CHA) DELIMITER-CHAS))
  475.         (FORCE-BP-TYPE ':MOVING))
  476.     (COND ((AND (NULL CHA)(NULL NEXT-OR-PREVIOUS-ROW));end/beginning of the box
  477.            (RETURN (VALUES ROW CHA-NO)))
  478.           ((AND NOT-FIRST-CHA? (NULL CHA))           ;end/beginning of the line
  479.            (RETURN (VALUES ROW CHA-NO)))
  480.           ((AND NOT-FIRST-CHA? DELIMITER-CHA?)           ;end of the word
  481.            (RETURN (VALUES ROW CHA-NO)))
  482.           ((NOT DELIMITER-CHA?)                          ;beginning of word
  483.            (SETQ NOT-FIRST-CHA? T)
  484.            (ACTION-AT-BP-INTERNAL
  485.          (increment-key-tick) ;crock
  486.          (kill-buffer-push (tell row :cha-at-cha-no (1- cha-no)) ':backward)
  487.          (TELL ROW :DELETE-CHA-AT-CHA-NO (1- CHA-NO))))
  488.           (T                                        ;delimiter chas before word
  489.            (ACTION-AT-BP-INTERNAL
  490.          (increment-key-tick) ;crock
  491.          (kill-buffer-push (tell row :cha-at-cha-no (1- cha-no)) ':backward)
  492.          (TELL ROW :DELETE-CHA-AT-CHA-NO (1- CHA-NO)))))))))
  493.  
  494. (DEFUN DELETE-OVER-VALUES (BP DELIMITER-CHAS)
  495.   (DO* ((ROW (BP-ROW BP) ROW)
  496.     (NEXT-ROW (TELL-CHECK-NIL ROW :NEXT-ROW)
  497.           (TELL-CHECK-NIL ROW :NEXT-ROW))
  498.     (CHA-NO (BP-CHA-NO BP)
  499.         (BP-CHA-NO BP))
  500.     (CHA (TELL ROW :CHA-AT-CHA-NO CHA-NO)
  501.          (TELL ROW :CHA-AT-CHA-NO CHA-NO))
  502.     (NOT-FIRST-CHA?))
  503.        (NIL)
  504.     (COND ((AND (NULL NOT-FIRST-CHA?)
  505.         (NULL CHA)
  506.         (NOT-NULL NEXT-ROW))
  507.        (SETQ ROW NEXT-ROW
  508.          CHA-NO 0))
  509.       (T (LET ((DELIMITER-CHA? (MEMQ (CHA-CODE CHA) DELIMITER-CHAS))
  510.            (FORCE-BP-TYPE ':MOVING))
  511.            (COND ((AND (NULL CHA) (NULL NEXT-ROW))   ;end/beginning of the box
  512.               (RETURN (VALUES ROW CHA-NO)))
  513.              ((AND NOT-FIRST-CHA? (NULL CHA))    ;end/beginning of the line
  514.               (RETURN (VALUES ROW CHA-NO)))
  515.              ((AND NOT-FIRST-CHA? DELIMITER-CHA?)  ;end of the word
  516.               (RETURN (VALUES ROW CHA-NO)))
  517.              ((NOT DELIMITER-CHA?)                 ;beginning of word
  518.               (SETQ NOT-FIRST-CHA? T)
  519.               (ACTION-AT-BP-INTERNAL
  520.             (kill-buffer-push (tell row :cha-at-cha-no cha-no) ':forward)
  521.             (TELL ROW :DELETE-CHA-AT-CHA-NO CHA-NO )))
  522.              (T                                ;delimiter chas before word
  523.               (ACTION-AT-BP-INTERNAL
  524.             (kill-buffer-push (tell row :cha-at-cha-no cha-no) ':forward)
  525.             (TELL ROW :DELETE-CHA-AT-CHA-NO CHA-NO)))))))))
  526.  
  527.  
  528.  
  529. (DEFUN RUBOUT-WORD (BP)
  530.   (RUBOUT-OVER-VALUES BP -1 *WORD-DELIMITERS*))
  531.  
  532. (DEFBOXER-COMMAND COM-RUBOUT-WORD ()
  533.   "kills backward one word.  with numeric
  534. argument (n), kills backward n words. "
  535.   (WITH-MULTIPLE-EXECUTION
  536.     (MOVE-POINT (RUBOUT-WORD *POINT*))))
  537.  
  538. (DEFUN DELETE-WORD (BP)
  539.   (DELETE-OVER-VALUES BP  *WORD-DELIMITERS*))
  540.  
  541. (DEFBOXER-COMMAND COM-DELETE-WORD ()
  542.   "kills forward one word.  with numeric
  543. argument (n), kills forward n words. "
  544.   (WITH-MULTIPLE-EXECUTION
  545.     (MOVE-POINT (DELETE-WORD *POINT*))))
  546.  
  547.  
  548.  
  549.  
  550. ;;;; Fonts
  551.  
  552. (DEFUN CHANGE-CHAS-OVER-VALUES (BP DIRECTION DELIMITER-CHAS FCN &REST ARGS)
  553.   (LET ((NOT-FIRST-CHA? NIL))
  554.     (MAP-OVER-CHAS-IN-LINE (BP DIRECTION)
  555.       (LET ((DELIMITER-CHA? (MEMQ (CHA-CODE CHA) DELIMITER-CHAS)))
  556.     (COND ((AND (NULL CHA)(NULL NEXT-OR-PREVIOUS-ROW))    ;end/beginning of the box
  557.            (RETURN (VALUES ROW CHA-NO)))
  558.           ((AND NOT-FIRST-CHA? (NULL CHA))    ;end/beginning of the line
  559.            (RETURN (VALUES ROW CHA-NO)))
  560.           ((AND NOT-FIRST-CHA? DELIMITER-CHA?)    ;end of the word
  561.            (RETURN (VALUES ROW CHA-NO)))
  562.           ((NOT DELIMITER-CHA?)        ;beginning of word
  563.            (SETQ NOT-FIRST-CHA? T)
  564.            (TELL ROW :CHANGE-CHA-AT-CHA-NO CHA-NO
  565.              (LEXPR-FUNCALL FCN (TELL ROW :CHA-AT-CHA-NO CHA-NO) ARGS)))
  566.           (T                ;delimiter chas before word
  567.            (TELL ROW :CHANGE-CHA-AT-CHA-NO CHA-NO
  568.              (LEXPR-FUNCALL FCN (TELL ROW :CHA-AT-CHA-NO CHA-NO) ARGS))))))))
  569.  
  570. (DEFUN BP-CHANGE-FONT-FORWARD-WORD-VALUES (BP &OPTIONAL (NEW-FONT-NO 0))
  571.   (CHANGE-CHAS-OVER-VALUES BP 1 *WORD-DELIMITERS* #'SET-FONT-NO NEW-FONT-NO))
  572.  
  573. ;;; These use a losing interface.  We need a better way to input the desired font
  574. (DEFBOXER-COMMAND COM-CHANGE-FONT-WORD (&OPTIONAL (NEW-FONT-NO
  575.                             (OR *EDITOR-NUMERIC-ARGUMENT* 0)))
  576.   "Changes the font of the next word to be whatever the current numeric arg is. "
  577.   (RESET-EDITOR-NUMERIC-ARG)
  578.   (MOVE-POINT (BP-CHANGE-FONT-FORWARD-WORD-VALUES *POINT* NEW-FONT-NO)))
  579.  
  580. (DEFBOXER-COMMAND COM-CHANGE-FONT-CHA (&OPTIONAL (NEW-FONT-NO
  581.                            (OR *EDITOR-NUMERIC-ARGUMENT* 0)))
  582.   "Changes the font of the next character to be whatever the current numeric arg is. "
  583.   (RESET-EDITOR-NUMERIC-ARG)
  584.   (TELL (POINT-ROW) :CHANGE-CHA-AT-CHA-NO
  585.                 (POINT-CHA-NO)
  586.             (SET-FONT-NO (TELL(POINT-ROW) :CHA-AT-CHA-NO (POINT-CHA-NO)) NEW-FONT-NO))
  587.   (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*)))
  588.  
  589.  
  590.  
  591. ;;; These are o.k. for release since you don't have to worry about input for them
  592.  
  593. (DEFBOXER-COMMAND COM-BOLDFACE-FONT-WORD ()
  594.   "Changes the next word to be in boldface. "
  595.   (WITH-MULTIPLE-EXECUTION
  596.     (MOVE-POINT (BP-CHANGE-FONT-FORWARD-WORD-VALUES *POINT* *BOLDFACE-FONT-NO*))))
  597.  
  598. (DEFBOXER-COMMAND COM-BOLDFACE-FONT-CHA ()
  599.   "Change the next character to be in boldface. "
  600.   (WITH-MULTIPLE-EXECUTION
  601.     (TELL (POINT-ROW) :CHANGE-CHA-AT-CHA-NO
  602.       (POINT-CHA-NO)
  603.       (SET-FONT-NO (TELL(POINT-ROW) :CHA-AT-CHA-NO (POINT-CHA-NO))
  604.                *BOLDFACE-FONT-NO*))
  605.     (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*))))
  606.  
  607. (DEFBOXER-COMMAND COM-ITALICS-FONT-WORD ()
  608.   "Changes the next word to be in italics. "
  609.   (WITH-MULTIPLE-EXECUTION
  610.     (MOVE-POINT (BP-CHANGE-FONT-FORWARD-WORD-VALUES *POINT* *ITALICS-FONT-NO*))))
  611.  
  612. (DEFBOXER-COMMAND COM-ITALICS-FONT-CHA ()
  613.   "Change the next character to be in italics. "
  614.   (WITH-MULTIPLE-EXECUTION
  615.     (TELL (POINT-ROW) :CHANGE-CHA-AT-CHA-NO
  616.       (POINT-CHA-NO)
  617.       (SET-FONT-NO (TELL(POINT-ROW) :CHA-AT-CHA-NO (POINT-CHA-NO))
  618.                *ITALICS-FONT-NO*))
  619.     (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*))))
  620.  
  621.  
  622.  
  623. ;;;; Capitalization
  624.  
  625. (DEFUN BP-UPPERCASE-FORWARD-WORD-VALUES (BP)
  626.   (CHANGE-CHAS-OVER-VALUES BP 1 *WORD-DELIMITERS* #'CHAR-UPCASE))
  627.  
  628. (DEFUN BP-LOWERCASE-FORWARD-WORD-VALUES (BP)
  629.   (CHANGE-CHAS-OVER-VALUES BP 1 *WORD-DELIMITERS* #'CHAR-DOWNCASE))
  630.  
  631. (DEFBOXER-COMMAND COM-UPPERCASE-WORD ()
  632.   "Uppercases one or more words forward. "
  633.   (WITH-MULTIPLE-EXECUTION
  634.     (MOVE-POINT (BP-UPPERCASE-FORWARD-WORD-VALUES *POINT*))))
  635.  
  636. (DEFBOXER-COMMAND COM-LOWERCASE-WORD ()
  637.   "Changes one or more words forward to be in lowercase. "
  638.   (WITH-MULTIPLE-EXECUTION
  639.     (MOVE-POINT (BP-LOWERCASE-FORWARD-WORD-VALUES *POINT*))))
  640.  
  641.  
  642.  
  643.  
  644. ;;;; Scrolling
  645.  
  646. (DEFBOXER-COMMAND COM-SCROLL-DN-ONE-SCREEN-BOX ()
  647.   "displays the next box of text. "
  648.   (LET* ((SCREEN-BOXS (TELL-CHECK-NIL (BOX-POINT-IS-IN) :DISPLAYED-SCREEN-OBJS)))
  649.     (DOLIST (SCREEN-BOX SCREEN-BOXS)
  650.       (TELL SCREEN-BOX :SCROLL-DN-ONE-SCREEN-BOX))
  651.     (LET ((NEW-FIRST-ROW
  652.         (SCREEN-OBJ-ACTUAL-OBJ (CAR (TELL (CAR SCREEN-BOXS) :SCREEN-ROWS)))))
  653.       (MOVE-POINT-1 NEW-FIRST-ROW (MIN (TELL NEW-FIRST-ROW :LENGTH-IN-CHAS)
  654.                        (BP-CHA-NO *POINT*))))))
  655.  
  656. (DEFBOXER-COMMAND COM-SCROLL-UP-ONE-SCREEN-BOX ()
  657.   "displays the previous box of text. "
  658.   (LET ((SCREEN-BOXS (TELL-CHECK-NIL (BOX-POINT-IS-IN) :DISPLAYED-SCREEN-OBJS)))
  659.     (DOLIST (SCREEN-BOX SCREEN-BOXS)
  660.       (TELL SCREEN-BOX :SCROLL-UP-ONE-SCREEN-BOX))
  661.     (LET ((NEW-FIRST-ROW
  662.         (SCREEN-OBJ-ACTUAL-OBJ (CAR (TELL (CAR SCREEN-BOXS) :SCREEN-ROWS)))))
  663.       (MOVE-POINT-1 NEW-FIRST-ROW (MIN (TELL NEW-FIRST-ROW :LENGTH-IN-CHAS)
  664.                         (BP-CHA-NO *POINT*))))))
  665.  
  666.  
  667.  
  668. ;;;; Killing Stuff
  669.  
  670. (DEFBOXER-COMMAND COM-KILL-TO-END-OF-ROW ()
  671.   "kills forward to the end of the line. "
  672.   (LET* ((ROW (BP-ROW *POINT*))
  673.      (NEXT-ROW (TELL ROW :NEXT-ROW))
  674.      (ROW-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS))
  675.      (CHA-NO (BP-CHA-NO *POINT*)))
  676.     (COND ((< CHA-NO ROW-LENGTH-IN-CHAS)
  677.        (kill-buffer-push (DELETE-CHAS-TO-END-OF-ROW *POINT* ':FIXED) ':FORWARD))
  678.       ((NULL NEXT-ROW))
  679.       (T (kill-buffer-push ':newline ':forward)
  680.          (TELL (BP-BOX *POINT*) :DELETE-ROW NEXT-ROW)
  681.        (INSERT-ROW-CHAS *POINT* NEXT-ROW ':FIXED)))))
  682.  
  683. (DEFBOXER-COMMAND COM-YANK ()
  684.   "inserts the last piece of text that was killed. "
  685.   (let ((item (kill-buffer-top)))
  686.     (setf (kill-buffer-top) (copy-thing item))
  687.     (insert-list-of-things item)))
  688.  
  689. (DEFBOXER-COMMAND COM-YANK-NO-COPY ()
  690.   "Inserts the last piece of text that was killed and
  691. removes it from the kill buffer.  No copy is made."
  692.   (RESET-EDITOR-NUMERIC-ARG)
  693.   (LET ((ITEM (KILL-BUFFER-TOP)))
  694.     (SETF (KILL-BUFFER-TOP) NIL)
  695.     (INSERT-LIST-OF-THINGS ITEM))
  696.   (COM-ROTATE-KILL-BUFFER))
  697.  
  698. (defun insert-list-of-things (things)
  699.   (if (listp things)
  700.       (dolist (thing things)
  701.     (insert-thing thing))
  702.       (insert-thing things)))
  703.  
  704. ;;;from coms
  705. (defun insert-thing (thing)
  706.   (cond ((null thing))
  707.     ((or (box? thing) (cha? thing)) (insert-cha *point* thing ':moving))
  708.     ((row? thing) (if (zerop (tell thing :length-in-chas))
  709.               (insert-row *point* thing ':moving)
  710.               (INSERT-ROW-CHAS *POINT* thing ':MOVING)))
  711.     ((EDITOR-REGION? THING)
  712.      (YANK-REGION *POINT* THING)
  713.      (UNLESS *HIGHLIGHT-YANKED-REGION*
  714.        (TELL THING :TURN-OFF))
  715.      (SETQ *CURRENT-EDITOR-REGION* THING))
  716.     ((eq thing ':newline) (insert-row *point* (make-initialized-row) ':moving))
  717.     ((listp thing) (insert-list-of-things thing))
  718.     (t (ferror "Unusual object found in boxer kill buffer"))))
  719.  
  720.  
  721.  
  722. (defun kill-buffer-push (item direction)
  723.   (if (= *number-of-non-kill-commands-executed* 1)
  724.       (if (eq direction *kill-buffer-last-direction*)
  725.       (cond ((eq direction ':forward)
  726.          (ensure-list item)
  727.          (ensure-list (car *kill-buffer*))
  728.          (setf (car *kill-buffer*)
  729.                (nconc (car *kill-buffer*) item)))
  730.         ((eq direction ':backward)
  731.          (ENSURE-LIST (car *kill-buffer*))
  732.          (setf (car *kill-buffer*)
  733.                (CONS item (car *kill-buffer*)))))
  734.       (push item *kill-buffer*))
  735.       (push item *kill-buffer*))
  736.   (if (> (length *kill-buffer*) 8.) (setf (nthcdr 8. *kill-buffer*) nil))
  737.   (setq *kill-buffer-last-direction* direction)
  738.   (setq *number-of-non-kill-commands-executed* 0)
  739.   *kill-buffer*)
  740.  
  741. ;for control-meta-y, sort of.
  742. (DEFBOXER-COMMAND COM-ROTATE-KILL-BUFFER ()
  743.   "rotates the kill buffer. "
  744.   (setq *kill-buffer* (nconc (cdr *kill-buffer*) (ncons (car *kill-buffer*)))))
  745.  
  746. ;this function copys things if they're boxer structures that have uniqueness.
  747. ;This should probably return a PRE-BOX but I can't figure out how they work.
  748. (DEFUN COPY-THING (BOXER-THING)
  749.   (COND ((BOX? BOXER-THING) (COPY-TOP-LEVEL-BOX BOXER-THING))
  750.     ((ROW? BOXER-THING) (COPY-ROW BOXER-THING))
  751.     ((CHA? BOXER-THING) BOXER-THING)
  752.     ((EDITOR-REGION? BOXER-THING) (TELL BOXER-THING :COPY))
  753.     ((listp boxer-thing) (mapcar #'copy-thing boxer-thing))
  754.     (T BOXER-THING)))                ;aw, who cares?
  755.  
  756. ;This is called by the function which handles keystrokes every time it executes a command.  If, when we execute
  757. ;a killing/saving command (i.e., call kill-buffer-push) the count is not 1, then the last command wasn't a kill
  758. ;and we should make a new entry into the kill buffer.
  759. (DEFUN INCREMENT-KEY-TICK ()
  760.   (INCF *NUMBER-OF-NON-KILL-COMMANDS-EXECUTED*))
  761.  
  762. ;I don't know what to do abotu writing a new one that works.
  763. ;This is the old, efficient version which would delete your stuff with no hope of getting it back.
  764. ;(DEFUN COM-KILL-TO-END-OF-BOX ()
  765. ;      (DELETE-CHAS-TO-END-OF-ROW *POINT* ':FIXED)
  766. ;      (DELETE-ROWS-TO-END-OF-BOX *POINT* ':moving))
  767.  
  768.  
  769.  
  770. ;;; Lispm interface
  771. (DEFBOXER-COMMAND COM-YANK-FROM-LISP ()
  772.   "Yanks text from the Lisp Machine's Kill Ring. "
  773.   (ZWEI:WITH-EDITOR-STREAM (S :INTERVAL (SEND ZWEI:*KILL-HISTORY* :YANK) :START :BEGINNING)
  774.      (LOOP FOR CHA = (SEND S :TYI)
  775.        UNTIL (NULL CHA)
  776.        DO (IF (CHAR= CHA #\CR)
  777.           (INSERT-ROW *POINT* (MAKE-INITIALIZED-ROW))
  778.           (INSERT-CHA *POINT* CHA)))))
  779.  
  780.  
  781.  
  782. ;;;; Search
  783.  
  784. ;;; Note: This is depending upon the fact that chas in LispM strings are 
  785. ;;; the same as chas in Boxer Rows
  786.  
  787. ;;; Iterates through the characters in the row in the direction specified
  788. ;;; (positive = left-to-right) and returns either NIL if the character is not found
  789. ;;; or, the CHA-NO of the found character, or, if BOX-FIRST? is non-NIL, and a box appears
  790. ;;; before the character, then the box is returned (useful for depth first string searches)
  791. (DEFUN FIND-CHA (CHARACTER ROW DIRECTION START-CHA-NO BOX-FIRST?)
  792.   (LOOP WITH CHAS = (TELL ROW :CHAS)
  793.     WITH ROW-LENGTH = (LENGTH CHAS)
  794.     FOR CHA-NO = START-CHA-NO THEN (+ CHA-NO DIRECTION)
  795.     UNTIL (OR (MINUSP CHA-NO) ( CHA-NO ROW-LENGTH))
  796.     FOR CHA = (NTH CHA-NO CHAS)
  797.     WHEN (AND BOX-FIRST? (BOX? CHA))
  798.       RETURN CHA
  799.     WHEN (AND (NOT (BOX? CHA))
  800.           (OR (CHAR= CHA CHARACTER)
  801.               (AND (NULL *CASE-AFFECTS-STRING-SEARCH*)
  802.                (CHAR= (CHAR-UPCASE CHA) (CHAR-UPCASE CHARACTER)))))
  803.                         
  804.       RETURN CHA-NO))
  805.  
  806. ;;; Loops through in the characters in string and in row (starting at CHA-NO) until 
  807. ;;; either a mismatch occurs and NIL is returned or else the string runs out in which 
  808. ;;; case the CHA-NO of where the string ran out is returned
  809. (DEFUN STRING-MATCH? (STRING ROW STARTING-CHA-NO)
  810.   (LOOP FOR INDEX FROM 0 TO (1- (STRING-LENGTH STRING))
  811.     FOR CHA-NO = (+ INDEX STARTING-CHA-NO)
  812.     FOR SCHA = (AREF STRING INDEX)
  813.     FOR RCHA = (TELL ROW :CHA-AT-CHA-NO CHA-NO)
  814.     WHEN (NULL RCHA)
  815.       RETURN NIL
  816.     UNLESS (AND (NOT (BOX? RCHA))
  817.             (OR (CHAR= RCHA SCHA)
  818.             (AND (NULL *CASE-AFFECTS-STRING-SEARCH*)
  819.                  (CHAR= (CHAR-UPCASE RCHA) (CHAR-UPCASE SCHA)))))
  820.       RETURN NIL
  821.     FINALLY (RETURN CHA-NO)))
  822.  
  823. ;;; Iterates through the characters in the row in the direction specified
  824. ;;; (positive = left-to-right) and returns either NIL if the string is not found
  825. ;;; or, the CHA-NO of the end of the string, or, if BOX-FIRST? is non-NIL, and a box appears
  826. ;;; before the string, then the box is returned (useful for depth first string searches)
  827. (DEFUN STRING-IN-ROW? (STRING ROW &OPTIONAL (DIRECTION 1) BOX-FIRST? START-CHA-NO)
  828.   (LET* ((STARTING-CHA-NO (IF (NUMBERP START-CHA-NO) START-CHA-NO
  829.                   (IF (PLUSP DIRECTION) 0 (1- (TELL ROW :LENGTH-IN-CHAS)))))
  830.      (CHA-NO (FIND-CHA (AREF STRING 0) ROW DIRECTION STARTING-CHA-NO BOX-FIRST?)))
  831.     (COND ((BOX? CHA-NO) CHA-NO)
  832.       ((NULL CHA-NO) NIL)
  833.       ((NUMBERP CHA-NO)
  834.        (LET ((END-CHA-NO (STRING-MATCH? STRING ROW CHA-NO)))
  835.          (IF (NULL END-CHA-NO)
  836.          (STRING-IN-ROW? STRING ROW DIRECTION BOX-FIRST? (+ CHA-NO DIRECTION))
  837.          END-CHA-NO)))
  838.       (T (EDITOR-BARF "Bad value for CHA-NO. ")))))
  839.  
  840.  
  841.  
  842. (DEFUN BOX-ROWS-FOR-SEARCH (BOX DIRECTION)
  843.   (IF (PLUSP DIRECTION)
  844.       (TELL BOX :ROWS)
  845.       (REVERSE (TELL BOX :ROWS))))
  846.  
  847. (DEFUN GET-ROWS-FOR-SEARCH (BP DIRECTION)
  848.   (MEMQ (BP-ROW BP) (BOX-ROWS-FOR-SEARCH (BP-BOX BP) DIRECTION)))
  849.  
  850. (DEFUN GET-BOXES-FOR-SEARCH (BP DIRECTION)
  851.   (IF (PLUSP DIRECTION)
  852.       (SUBSET #'BOX? (NTHCDR (BP-CHA-NO BP) (TELL (BP-ROW BP) :CHAS)))
  853.       (REVERSE (SUBSET #'BOX? (FIRSTN (BP-CHA-NO BP) (TELL (BP-ROW BP) :CHAS))))))
  854.  
  855. (DEFUN FLAT-SEARCH (STRING &OPTIONAL (DIRECTION 1) (BP *POINT*))
  856.   (LET* ((ROWS (GET-ROWS-FOR-SEARCH BP DIRECTION))
  857.      (FIRST-ROW-CHA-NO
  858.        (STRING-IN-ROW? STRING (CAR ROWS) DIRECTION NIL (BP-CHA-NO BP))))
  859.     (IF (NOT-NULL FIRST-ROW-CHA-NO)
  860.     (MAKE-INITIALIZED-BP ':MOVING (CAR ROWS) (1+ FIRST-ROW-CHA-NO))
  861.     (LOOP FOR ROW IN (CDR ROWS)
  862.           FOR VAL = (STRING-IN-ROW? STRING ROW DIRECTION)
  863.           WHEN (NUMBERP VAL)
  864.         RETURN (MAKE-INITIALIZED-BP ':MOVING ROW (1+ VAL))))))
  865.  
  866.  
  867.  
  868. (DEFUN DEEP-SEARCH-ROW (STRING ROW DIRECTION)
  869.   (LET ((CHA-NO (STRING-IN-ROW? STRING ROW DIRECTION T)))
  870.     (COND ((NUMBERP CHA-NO) (MAKE-INITIALIZED-BP ':MOVING ROW (1+ CHA-NO)))
  871.       (T (DOLIST (BOX (IF (PLUSP DIRECTION) (TELL ROW :BOXES-IN-ROW)
  872.                   (REVERSE (TELL ROW :BOXES-IN-ROW))))
  873.            (LET ((VAL (DEEP-SEARCH-BOX STRING
  874.                          (BOX-ROWS-FOR-SEARCH BOX DIRECTION)
  875.                          DIRECTION)))
  876.          (WHEN (BP? VAL)
  877.            (RETURN VAL))))))))
  878.  
  879. (DEFUN DEEP-SEARCH-BOX (STRING ROWS DIRECTION)
  880.   (DOLIST (ROW ROWS)
  881.     (LET ((VAL (DEEP-SEARCH-ROW STRING ROW DIRECTION)))
  882.       (WHEN (BP? VAL)
  883.     (RETURN VAL)))))
  884.  
  885. (DEFUN DEEP-SEARCH (STRING &OPTIONAL (DIRECTION 1) (BP *POINT*))
  886.   (LET* ((ROWS (GET-ROWS-FOR-SEARCH BP DIRECTION))
  887.      (FIRST-ROW-CHA-NO
  888.        (STRING-IN-ROW? STRING (CAR ROWS) DIRECTION T (BP-CHA-NO BP))))
  889.     (COND ((NUMBERP FIRST-ROW-CHA-NO)
  890.        (MAKE-INITIALIZED-BP ':MOVING (CAR ROWS) (1+ FIRST-ROW-CHA-NO)))
  891.       ((DOLIST (BOX (GET-BOXES-FOR-SEARCH BP DIRECTION))
  892.          (LET ((VAL (DEEP-SEARCH-BOX STRING
  893.                      (BOX-ROWS-FOR-SEARCH BOX DIRECTION)
  894.                      DIRECTION)))
  895.            (WHEN (BP? VAL)
  896.          (RETURN VAL)))))
  897.       (T
  898.        (DOLIST (ROW (CDR ROWS))
  899.          (LET ((VAL (DEEP-SEARCH-ROW STRING ROW DIRECTION)))
  900.            (WHEN (BP? VAL)
  901.          (RETURN VAL))))))))
  902.  
  903.  
  904.  
  905. ;;; These don't hack CR's so we'll trunctate after reading the input so we don't get errors
  906. ;;; farther down....
  907.  
  908. (DEFBOXER-COMMAND COM-FORWARD-FLAT-SEARCH ()
  909.     "Moves the cursor forward to 
  910. the location of a specified string 
  911. No CR's are allowed. The search is 
  912. a breadth first one."
  913.   (LET* ((STRING (STRINGIFY (GET-FIRST-ROW
  914.                   (GET-BOXER-INPUT "String to Search Forward For:") T)))
  915.      (NEW-BP (FLAT-SEARCH STRING)))
  916.     (COND ((NULL NEW-BP) (BEEP))
  917.       ((BP? NEW-BP)
  918.        (MOVE-POINT (BP-VALUES NEW-BP))
  919.        ;; clean up
  920.        (TELL (BP-ROW NEW-BP) :DELETE-BP NEW-BP)
  921.        (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX) 1))
  922.       (T (BOXER-EDITOR-ERROR "Search lossage")))))
  923.  
  924. (DEFBOXER-COMMAND COM-BACKWARD-FLAT-SEARCH ()
  925.     "Moves the cursor backward to 
  926. the location of a specified string 
  927. No CR's are allowed. The search is 
  928. a breadth first one."
  929.   (LET* ((STRING (STRINGIFY (GET-FIRST-ROW
  930.                   (GET-BOXER-INPUT "String to Search Backward For:") T)))
  931.      (NEW-BP (FLAT-SEARCH STRING -1)))
  932.     (COND ((NULL NEW-BP) (BEEP))
  933.       ((BP? NEW-BP)
  934.        (MOVE-POINT (BP-VALUES NEW-BP))
  935.        ;; clean up
  936.        (TELL (BP-ROW NEW-BP) :DELETE-BP NEW-BP)
  937.        (ENSURE-ROW-IS-DISPLAYED (POINT-ROW) (POINT-SCREEN-BOX) -1))
  938.       (T (BOXER-EDITOR-ERROR "Search lossage")))))
  939.  
  940. (DEFBOXER-COMMAND COM-FORWARD-DEEP-SEARCH ()
  941.     "Moves the cursor forward to 
  942. the location of a specified string 
  943. No CR's are allowed. The search is 
  944. a depth first one."
  945.   (LET* ((STRING (STRINGIFY (GET-FIRST-ROW
  946.                   (GET-BOXER-INPUT "String to Deep Search Forward For:") T)))
  947.      (NEW-BP (DEEP-SEARCH STRING)))
  948.     (COND ((NULL NEW-BP) (BEEP))
  949.       ((BP? NEW-BP)
  950.        (MOVE-TO-BP NEW-BP)
  951.        ;; clean up
  952.        (TELL (BP-ROW NEW-BP) :DELETE-BP NEW-BP))
  953.       (T (BOXER-EDITOR-ERROR "Search lossage")))))
  954.  
  955. (DEFBOXER-COMMAND COM-BACKWARD-DEEP-SEARCH ()
  956.     "Moves the cursor backward to 
  957. the location of a specified string 
  958. No CR's are allowed. The search is 
  959. a depth first one."
  960.   (LET* ((STRING (STRINGIFY (GET-FIRST-ROW
  961.                   (GET-BOXER-INPUT "String to Deep Search Backward For:") T)))
  962.      (NEW-BP (DEEP-SEARCH STRING -1)))
  963.     (COND ((NULL NEW-BP) (BEEP))
  964.       ((BP? NEW-BP)
  965.        (MOVE-TO-BP NEW-BP)
  966.        ;; clean up
  967.        (TELL (BP-ROW NEW-BP) :DELETE-BP NEW-BP))
  968.       (T (BOXER-EDITOR-ERROR "Search lossage")))))
  969.  
  970.  
  971. ;;;; Random useful things
  972.  
  973. (DEFBOXER-COMMAND COM-NAME-BOX ()
  974.   "edits the name of the box the cursor is
  975. in. places cursor in the name row of the box,
  976. creating one if one does not exist. "
  977.   (IF (OR (EQ (POINT-BOX) *INITIAL-BOX*) (EQ *OUTERMOST-SCREEN-BOX* (SCREEN-BOX-POINT-IS-IN)))
  978.       (BOXER-EDITOR-ERROR  "You cannot name the outermost box")
  979.       (LET* ((BOX-TO-NAME (BOX-SCREEN-POINT-IS-IN))
  980.          (DESTINATION-SCREEN-BOX (SCREEN-BOX-POINT-IS-IN)))
  981.     (UNLESS (ROW? (TELL BOX-TO-NAME :NAME-ROW))
  982.       (TELL BOX-TO-NAME :MAKE-NAME-ROW))
  983.     (MOVE-POINT-1 (TELL BOX-TO-NAME :NAME-ROW) 0 DESTINATION-SCREEN-BOX)
  984.     (TELL BOX-TO-NAME :MODIFIED))))
  985.  
  986. (DEFBOXER-COMMAND COM-FORCE-REDISPLAY ()
  987.   "clears and then redisplays the screen. "
  988.   (FORCE-REDISPLAY))
  989.  
  990. (DEFBOXER-COMMAND COM-BREAK ()
  991.   "enters a LISP breakpoint. "
  992.  (UNWIND-PROTECT
  993.     (BREAK "Boxer")
  994.     (FORCE-REDISPLAY)))
  995.  
  996. (DEFBOXER-COMMAND COM-BUG ()
  997.   "sends a bug report about BOXER. "
  998.   (BUG-BOXER))
  999.  
  1000.  
  1001.  
  1002. ;;;; Box Commands
  1003.  
  1004. (DEFBOXER-COMMAND COM-MAKE-BOX ()
  1005. "makes a DOIT box at the cursor location."
  1006.   (IF (NAME-ROW? (POINT-ROW))
  1007.       (BOXER-EDITOR-ERROR "You cannot make boxes on a name row. ")
  1008.       (LET ((BOX (MAKE-INITIALIZED-BOX)))
  1009.     (INSERT-CHA *POINT* BOX ':FIXED)
  1010.     (REDISPLAY))))
  1011.  
  1012. (DEFBOXER-COMMAND COM-TOGGLE-BOX-TYPE ()
  1013.   "toggles the type of the box that the 
  1014. cursor is in.  Data  Doit or Graphics 
  1015. Graphics-Data.  Ports toggle their targets. "
  1016.   (TELL (BOX-POINT-IS-IN) :TOGGLE-TYPE))
  1017.  
  1018. (DEFBOXER-COMMAND COM-MAKE-DATA-BOX ()
  1019.   "makes a DATA box at the cursor location.
  1020. BEEPs if the cursor is on a NAME row. "
  1021.   (IF (NAME-ROW? (POINT-ROW))
  1022.       (BOXER-EDITOR-ERROR "You cannot make boxes on a name row. ")
  1023.       (LET ((BOX (MAKE-INITIALIZED-BOX)))
  1024.     (TELL BOX :SET-TYPE 'DATA-BOX)
  1025.     (INSERT-CHA *POINT* BOX ':FIXED)
  1026.     (REDISPLAY))))
  1027.  
  1028. (DEFBOXER-COMMAND COM-ENTER-BOX (&OPTIONAL (BOX (BOX-POINT-IS-NEAR))
  1029.                         (SCREEN-BOX (SCREEN-BOX-POINT-IS-NEAR)))
  1030.   "enters the nearest box.  prefers the
  1031. trailing box to the leading one. "
  1032.   (WHEN (BOX? BOX)
  1033.     (when (eq ':shrunk (tell box :display-style))
  1034.       (tell box :unshrink)
  1035.       (tell box :modified))
  1036.     (MOVE-POINT (BOX-FIRST-VISIBLE-BP-VALUES BOX SCREEN-BOX))
  1037.     (SET-POINT-SCREEN-BOX SCREEN-BOX)
  1038.     (TELL BOX :ENTER)))
  1039.  
  1040. (DEFBOXER-COMMAND COM-MAKE-AND-ENTER-BOX ()
  1041.   "Makes a DOIT box where the cursor
  1042. is and places the cursor inside. "
  1043.   (COM-MAKE-BOX)
  1044.   (COM-ENTER-BOX))
  1045.  
  1046. (DEFBOXER-COMMAND COM-MAKE-AND-ENTER-DATA-BOX ()
  1047.   "Makes a Data box where the cursor
  1048. is and places the cursor inside. "
  1049.   (COM-MAKE-DATA-BOX)
  1050.   (COM-ENTER-BOX))
  1051.  
  1052. (DEFBOXER-COMMAND COM-MAKE-AND-NAME-BOX ()
  1053.   "Makes a named DOIT box where the cursor
  1054. is and places the cursor inside the name. "        ;
  1055.   (COM-MAKE-BOX)
  1056.   (COM-ENTER-BOX)
  1057.   (COM-NAME-BOX))
  1058.  
  1059. (DEFBOXER-COMMAND COM-MAKE-AND-NAME-DATA-BOX ()
  1060.   "Makes a Named Data box where the cursor
  1061. is and places the cursor inside the name. "
  1062.   (COM-MAKE-DATA-BOX)
  1063.   (COM-ENTER-BOX)
  1064.   (COM-NAME-BOX))
  1065.  
  1066. (DEFBOXER-COMMAND COM-EXIT-BOX ()
  1067.   "exits the box the cursor is in.
  1068. cursor is placed directly AFTER the
  1069. exited box.  If the box is fullscreen,
  1070. then it is shrunken first. "
  1071.   (LET ((BOX (BOX-SCREEN-POINT-IS-IN)))
  1072.     (UNLESS (EQ BOX *INITIAL-BOX*)
  1073.       (TELL BOX :EXIT (tell (SCREEN-BOX-POINT-IS-IN) :superior-screen-box)
  1074.         (tell box :superior-box) t))))
  1075.  
  1076.  
  1077.  
  1078. ;;;; Shrinking and Expanding
  1079.  
  1080. (DEFBOXER-COMMAND COM-COLLAPSE-BOX (&OPTIONAL (BOX (BOX-SCREEN-POINT-IS-IN)))
  1081.   "shrinks the box the cursor is in. "
  1082.   (LET ((BOX-DISPLAY-STYLE (TELL BOX :DISPLAY-STYLE)))
  1083.     (COND ((EQ BOX *INITIAL-BOX*))
  1084.       ((AND (EQ BOX (OUTERMOST-BOX))
  1085.         (NOT(NULL (TELL (OUTERMOST-BOX) :GET-SHRINK-PROOF?))))
  1086.        NIL)
  1087.       ((EQ BOX (OUTERMOST-BOX))
  1088.        (MULTIPLE-VALUE-BIND (NEW-OUTERMOST-BOX NEW-OUTERMOST-SCREEN-BOX)
  1089.            (GET-PREVIOUS-OUTERMOST-BOX-VALUES)
  1090.          (SET-OUTERMOST-BOX NEW-OUTERMOST-BOX NEW-OUTERMOST-SCREEN-BOX)))
  1091.       ((EQ BOX-DISPLAY-STYLE ':NORMAL)
  1092.        (TELL BOX :SHRINK)
  1093.        (WHEN (EQ BOX (BOX-SCREEN-POINT-IS-IN))
  1094.          (COM-EXIT-BOX))))))
  1095.  
  1096.  
  1097. (DEFBOXER-COMMAND COM-SHRINK-BOX (&OPTIONAL (BOX (BOX-SCREEN-POINT-IS-IN)))
  1098.   "makes the box the cursor is in Tiny and
  1099. then exits. "
  1100.   (LET ((BOX-DISPLAY-STYLE (TELL BOX :DISPLAY-STYLE)))
  1101.     (COND ((OR ;(EQ BOX-DISPLAY-STYLE ':SHRUNK)
  1102.             (EQ BOX *INITIAL-BOX*)
  1103.             (NULL (TELL BOX :SUPERIOR-BOX))))
  1104.  
  1105.       ((AND (EQ BOX (OUTERMOST-BOX))
  1106.         (NOT (NULL (TELL (OUTERMOST-BOX) :GET-SHRINK-PROOF?))))
  1107.        NIL)
  1108.  
  1109.       ((EQ BOX (OUTERMOST-BOX))
  1110.        (TELL BOX :SHRINK)
  1111.        (MULTIPLE-VALUE-BIND (NEW-OUTERMOST-BOX NEW-OUTERMOST-SCREEN-BOX)
  1112.            (GET-PREVIOUS-OUTERMOST-BOX-VALUES)
  1113.          (SET-OUTERMOST-BOX NEW-OUTERMOST-BOX NEW-OUTERMOST-SCREEN-BOX))
  1114.        (WHEN (EQ BOX (BOX-SCREEN-POINT-IS-IN))
  1115.          (COM-EXIT-BOX)))
  1116.       ((EQ BOX-DISPLAY-STYLE ':NORMAL)
  1117.        (TELL BOX :SHRINK)
  1118.        (WHEN (EQ BOX (BOX-SCREEN-POINT-IS-IN))
  1119.          (COM-EXIT-BOX))))))
  1120.  
  1121.  
  1122.  
  1123. (DEFBOXER-COMMAND COM-EXPAND-BOX (&OPTIONAL (BOX (BOX-SCREEN-POINT-IS-IN))
  1124.                          (SCREEN-BOX (SCREEN-BOX-POINT-IS-IN)))
  1125.   "expands the box the cursor is in. "
  1126.   (LET ((BOX-DISPLAY-STYLE (TELL BOX :DISPLAY-STYLE)))
  1127.     (COND ((OR (EQ BOX (OUTERMOST-BOX))
  1128.            (EQ BOX *INITIAL-BOX*)))
  1129.       ((EQ BOX-DISPLAY-STYLE ':NORMAL)
  1130.        ;;store away the old outermost screen box
  1131.        (PUSH *OUTERMOST-SCREEN-BOX* *OUTERMOST-SCREEN-BOX-STACK*)       
  1132.        (SET-OUTERMOST-BOX BOX SCREEN-BOX)
  1133.        (SET-POINT-SCREEN-BOX SCREEN-BOX))
  1134.       (T
  1135.        (TELL BOX :UNSHRINK)
  1136.        (SET-POINT-SCREEN-BOX SCREEN-BOX)))))
  1137.  
  1138. (DEFBOXER-COMMAND COM-MAKE-SHRINK-PROOF-SCREEN ()
  1139.   "makes the outermost box shrink proof. "
  1140.   (TELL (OUTERMOST-BOX) :SET-SHRINK-PROOF? T))
  1141.  
  1142. (DEFBOXER-COMMAND COM-UNSHRINK-PROOF-SCREEN ()
  1143.   "allows the outermost box to be shrunken. "
  1144.   (TELL (OUTERMOST-BOX) :SET-SHRINK-PROOF? NIL))
  1145.  
  1146. (DEFBOXER-COMMAND COM-SET-OUTERMOST-BOX (&OPTIONAL (BOX (BOX-SCREEN-POINT-IS-IN))
  1147.                             (SCREEN-BOX (SCREEN-BOX-POINT-IS-IN)))
  1148.   "makes the box the cursor is in the
  1149. outermost box unless the box is either
  1150. a Graphics-box or a port to one. "
  1151.   (UNLESS (or (GRAPHICS-BOX? BOX) (eq *outermost-screen-box* screen-box)
  1152.           (AND (PORT-BOX? BOX) (GRAPHICS-BOX? (TELL BOX :PORTS))))
  1153.     ;;store away the old outermost screen box
  1154.     (PUSH *OUTERMOST-SCREEN-BOX* *OUTERMOST-SCREEN-BOX-STACK*)
  1155.     (SET-OUTERMOST-BOX BOX SCREEN-BOX)))
  1156.  
  1157.  
  1158.  
  1159. ;;;; Regions
  1160.  
  1161. (DEFBOXER-COMMAND COM-DEFINE-REGION ()
  1162.   "defines a region between the current
  1163. location of the cursor and the cursor. "
  1164.   (LET ((LOCAL-REGION (GET-LOCAL-REGION)))
  1165.     (COND ((NOT-NULL LOCAL-REGION)        ;there already IS a region in the current box
  1166.        (SETQ *REGION-BEING-DEFINED* LOCAL-REGION)
  1167.        ;; we have to decide which BP of the region to replace with *POINT*
  1168.        (IF (BP-< *POINT* (TELL LOCAL-REGION :START-BP))
  1169.            (TELL LOCAL-REGION :SET-START-BP *POINT*)
  1170.            (TELL LOCAL-REGION :SET-STOP-BP  *POINT*)))
  1171.       (T                    ;There is No current region so we make one
  1172.        (SETQ *REGION-BEING-DEFINED*
  1173.          (MAKE-EDITOR-REGION (MAKE-INITIALIZED-BP :FIXED (POINT-ROW) (POINT-CHA-NO))))
  1174.        (TELL *REGION-BEING-DEFINED* :TURN-ON)
  1175.        (PUSH *REGION-BEING-DEFINED* REGION-LIST)))))
  1176.  
  1177. (DEFBOXER-COMMAND COM-INSTALL-REGION ()
  1178.   "installs the current region"
  1179.   (UNLESS (NULL *REGION-BEING-DEFINED*)
  1180.     (LET ((OLD-START-BP (TELL *REGION-BEING-DEFINED* :START-BP))
  1181.       (OLD-STOP-BP  (TELL *REGION-BEING-DEFINED* :STOP-BP)))
  1182.     (MULTIPLE-VALUE-BIND (NEW-START-BP NEW-STOP-BP)    ;make sure the BP's are at the
  1183.     (ORDER-BPS OLD-START-BP OLD-STOP-BP)
  1184.       (TELL *REGION-BEING-DEFINED* :SET-START-BP NEW-START-BP)
  1185.       (TELL *REGION-BEING-DEFINED* :SET-STOP-BP  NEW-STOP-BP)
  1186.       (INSTALL-REGION *REGION-BEING-DEFINED*)
  1187.       (UNLESS (OR (EQ *POINT* OLD-START-BP) (EQ *MOUSE-BP* OLD-START-BP))
  1188.     (TELL (BP-ROW OLD-START-BP) :DELETE-BP OLD-START-BP))
  1189.       (UNLESS (OR (EQ *POINT* OLD-STOP-BP) (EQ *MOUSE-BP* OLD-STOP-BP))
  1190.     (TELL (BP-ROW OLD-STOP-BP) :DELETE-BP OLD-STOP-BP))))))
  1191.  
  1192. (DEFBOXER-COMMAND COM-FLUSH-REGION ()
  1193.   "gets rid of the current region--if it exists. "
  1194.   (LET ((REGION-TO-FLUSH (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1195.     (UNLESS (NULL REGION-TO-FLUSH)
  1196.       (FLUSH-REGION REGION-TO-FLUSH))))
  1197.  
  1198.  
  1199.  
  1200. (DEFBOXER-COMMAND COM-KILL-REGION ()
  1201.   "kills all the characters in the current region. "
  1202.   (LET ((REGION-TO-KILL (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1203.     (IF (NULL REGION-TO-KILL)
  1204.     (BOXER-EDITOR-ERROR "There is no region that I can find. ")
  1205.     (KILL-REGION REGION-TO-KILL)
  1206.     (KILL-BUFFER-PUSH REGION-TO-KILL ':FORWARD)
  1207.     (FLUSH-REGION REGION-TO-KILL))))
  1208.  
  1209. ;;; this is really boxify at *point* for now
  1210. (DEFBOXER-COMMAND COM-BOXIFY-REGION ()
  1211.   "puts all of the characters in the current
  1212. region into a box. "
  1213.   (LET* ((REGION-TO-BOX (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1214.     (UNLESS (NULL REGION-TO-BOX)
  1215.       (KILL-REGION REGION-TO-BOX)
  1216.       (COM-MAKE-BOX)
  1217.       (COM-ENTER-BOX)
  1218.       (YANK-REGION *POINT* REGION-TO-BOX)
  1219.       (FLUSH-REGION REGION-TO-BOX)
  1220.       (SETQ REGION-TO-BOX NIL))))
  1221.  
  1222. (DEFBOXER-COMMAND COM-MARK-ROW ()
  1223.   "marks the current row to be 
  1224. the current region. "
  1225.   (IF (NAME-ROW? (POINT-ROW))
  1226.       (COM-EXIT-BOX)
  1227.       (LET ((START-BP (MAKE-INITIALIZED-BP :FIXED (POINT-ROW) 0))
  1228.         (STOP-BP  (MAKE-INITIALIZED-BP :FIXED
  1229.                        (POINT-ROW)
  1230.                        (TELL (POINT-ROW) :LENGTH-IN-CHAS))))
  1231.     (SETQ *REGION-BEING-DEFINED* (MAKE-EDITOR-REGION START-BP STOP-BP))
  1232.     (TELL *REGION-BEING-DEFINED* :TURN-ON)
  1233.     (PUSH *REGION-BEING-DEFINED* REGION-LIST))))
  1234.  
  1235. (DEFBOXER-COMMAND COM-UNMARK-REGION ()
  1236.   "unmarks the current region. "
  1237.   (LET ((REGION-TO-UNMARK (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1238.     (UNLESS (NULL REGION-TO-UNMARK)
  1239.       (FLUSH-REGION REGION-TO-UNMARK))))
  1240.  
  1241.  
  1242.  
  1243. ;;;; Program Execution
  1244.  
  1245. (DEFBOXER-COMMAND COM-DOIT ()
  1246.   "calls the evaluator on the
  1247. current region.  If there is no
  1248. current region, marks the current
  1249. row instead. "
  1250.   (LET ((REGION (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1251.     (COND ((NOT-NULL REGION)  
  1252.        (DOIT-INTERNAL))    
  1253.       (T
  1254.        (COM-MARK-ROW)))))
  1255.  
  1256. (DEFBOXER-COMMAND com-doit-now-give-lispm-errors ()
  1257.   "calls the evaluator without using the
  1258. BOXER error handler. "
  1259.   (let ((*boxer-error-handler-p* nil))
  1260.     (com-doit-now)))
  1261.  
  1262. (DEFBOXER-COMMAND COM-DOIT-NOW ()
  1263.   "calls the evaluator on the
  1264. current region.  If there is no
  1265. current region, evaluates the
  1266. current row instead. "
  1267.   (LET ((REGION (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1268.     (IF (NULL REGION) (COM-MARK-ROW))
  1269.     (DOIT-INTERNAL)))
  1270.  
  1271. (defun doit-internal ()
  1272.   (LET ((REGION-TO-DO (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1273.     (UNLESS (NULL REGION-TO-DO)
  1274.       (UNWIND-PROTECT
  1275.     (DOIT-PRINT-RETURNED-VALUE
  1276.       (EVAL-REGION-CATCHING-ERRORS REGION-TO-DO))
  1277.     (FLUSH-REGION REGION-TO-DO)))))
  1278.  
  1279. ;;; Look for a | returned-value comment.  If there is one, delete the text
  1280. ;;; to the right of it, and the | too, if the value is not to be printed.
  1281. ;;; If there is no | and the value is to be printed, then make one.
  1282. ;;; If the value is to be printed, print it.
  1283. (DEFUN DOIT-PRINT-RETURNED-VALUE (RETURNED-VALUE)
  1284.   (SETQ RETURNED-VALUE
  1285.     (COND ((MEMQ RETURNED-VALUE *RETURNED-VALUES-NOT-TO-PRINT*)
  1286.            NIL)
  1287.           (T (IF (BOX? RETURNED-VALUE)
  1288.              (COPY-TOP-LEVEL-BOX RETURNED-VALUE)
  1289.            (FORMAT NIL "~A" RETURNED-VALUE)))))
  1290.   (LET* ((BP (MAKE-BP ':MOVING))
  1291.      (ROW (BP-ROW *POINT*))
  1292.      (ROW-CHAS (TELL ROW :CHAS))
  1293.      (EXISTING-VERTICAL-BAR
  1294.        (CAR (MEM #'(LAMBDA (CODE CHA)
  1295.              (EQ CODE (CHA-CODE CHA))) #/| ROW-CHAS))))
  1296.     (COND ((NOT-NULL EXISTING-VERTICAL-BAR)
  1297.        (LET ((EXISTING-VERTICAL-BAR-CHA-NO
  1298.            (TELL ROW :CHA-CHA-NO EXISTING-VERTICAL-BAR)))
  1299.          (DOLIST (BP (TELL ROW :BPS)) 
  1300.            (SETF (BP-CHA-NO BP)
  1301.              (MIN EXISTING-VERTICAL-BAR-CHA-NO
  1302.               (BP-CHA-NO BP))))
  1303.          (MOVE-BP-1 BP ROW (+ EXISTING-VERTICAL-BAR-CHA-NO
  1304.                   (IF (NOT (NULL RETURNED-VALUE)) 1 0)))
  1305.          (DELETE-CHAS-TO-END-OF-ROW BP ':FIXED))
  1306.        (MOVE-BP *POINT* (ROW-LAST-BP-VALUES ROW)))
  1307.       ((NOT (NULL RETURNED-VALUE))
  1308.        (MOVE-BP BP (ROW-LAST-BP-VALUES ROW))
  1309.        (INSERT-ROW-CHAS BP (MAKE-ROW '("   |")) ':MOVING)))
  1310.     (WHEN (NOT (NULL RETURNED-VALUE))
  1311.       (INSERT-ROW-CHAS BP (MAKE-ROW `(,RETURNED-VALUE))))))
  1312.  
  1313.  
  1314. (DEFBOXER-COMMAND COM-EDIT-LOCAL-LIBRARY ()
  1315.   "edits the curretn box's local library. "
  1316.   (LET ((LL (TELL (POINT-BOX) :LOCAL-LIBRARY)))
  1317.     (INSERT-CHA *POINT* LL ':FIXED)
  1318.     ;(REDISPLAY)                  ;make ll-box screen structure
  1319.     (COM-ENTER-BOX)))
  1320.  
  1321. ;; this will lose in the prescence of labels !!!!
  1322. (DEFBOXER-COMMAND COM-PROMPT ()
  1323.   "inserts the argument names of the function
  1324. by the cursor. "
  1325.   (LET ((FUN (FUNCTION-AT-POINT)))
  1326.     (cond ((or (doit-box? fun)
  1327.            (and (symbolp fun) (get fun 'arglist))
  1328.            (and (symbolp fun) (boxer-boundp fun)
  1329.             (boxer-function? (boxer-symeval fun))))
  1330.        (insert-arglist fun))
  1331.       (T (BOXER-EDITOR-ERROR "Can't find a function near the cursor. ")))))
  1332.  
  1333. (defun insert-arglist (fun)
  1334.   (MOVE-POINT-1 (POINT-ROW) (FIND-SYMBOL-END-NO *POINT*) (POINT-SCREEN-BOX))
  1335.   (insert-row-chas *POINT*
  1336.            (make-row (mapcar #'(lambda (u)
  1337.                      (string-append " " u ":"))
  1338.                      (GET-ARG-NAMES-FROM-ARGLIST (BOXER-ARGLIST FUN))))
  1339.            ':MOVING))
  1340.  
  1341.  
  1342.  
  1343. (DEFBOXER-COMMAND COM-GOTO-TOP-LEVEL ()
  1344.   "moves to the top of the WORLD box. "
  1345.   (MOVE-POINT (BOX-FIRST-BP-VALUES *INITIAL-BOX*))
  1346.   (SET-POINT-SCREEN-BOX (CAR (TELL *INITIAL-BOX* :SCREEN-OBJS)))
  1347.   (SETQ *OUTERMOST-SCREEN-BOX-STACK* NIL)
  1348.   (SET-OUTERMOST-BOX *INITIAL-BOX* (CAR (TELL *INITIAL-BOX* :SCREEN-OBJS))))
  1349.  
  1350.  
  1351.  
  1352. (DEFBOXER-COMMAND COM-FIX-BOX-SIZE ()
  1353.   "fixes the size of the box to be the
  1354. current height and width. "
  1355.   (MULTIPLE-VALUE-BIND (CURRENT-WID CURRENT-HEI)
  1356.       (SCREEN-OBJ-SIZE (SCREEN-BOX-POINT-IS-IN))
  1357.     (MULTIPLE-VALUE-BIND (L-WID T-WID R-WID B-WID)
  1358.     (WITH-FONT-MAP-BOUND (*BOXER-PANE*)
  1359.       (SCREEN-BOX-BORDERS-FN ':BORDER-WIDS (SCREEN-BOX-POINT-IS-IN)))
  1360.       (TELL (BOX-SCREEN-POINT-IS-IN) :SET-FIXED-SIZE
  1361.         (- CURRENT-WID L-WID R-WID) (- CURRENT-HEI T-WID B-WID)))))
  1362.  
  1363. (DEFBOXER-COMMAND COM-UNFIX-BOX-SIZE ()
  1364.   "unfixes the size of the box.  "
  1365.   (TELL (BOX-SCREEN-POINT-IS-IN) :SET-FIXED-SIZE NIL NIL)
  1366.   (TELL (BOX-SCREEN-POINT-IS-IN) :MODIFIED NIL))
  1367.  
  1368.  
  1369.  
  1370. ;;;; Ports
  1371.  
  1372. (DEFUN CHECK-FOR-SUPERIOR (BOX1 BOX2)
  1373.   (COND ((NULL BOX1) NIL)
  1374.     ((EQ BOX1 BOX2) T)
  1375.     (T (CHECK-FOR-SUPERIOR (TELL BOX1 :SUPERIOR-BOX) BOX2))))
  1376.  
  1377. (DEFMETHOD (BOX :SUPERIOR?) (ANOTHER-BOX)
  1378.   "is the arg a superior of the box ?"
  1379.   (CHECK-FOR-SUPERIOR SELF ANOTHER-BOX))
  1380.  
  1381. (DEFUN PORT-TO-INTERNAL (BOX)
  1382.   (LET ((NEW-PORT (MAKE-INITIALIZED-BOX :TYPE 'PORT-BOX)))
  1383.     (TELL NEW-PORT :SET-PORT-TO-BOX BOX)
  1384.     NEW-PORT))
  1385.  
  1386.  BEFBOXER-COMMAND COM-MAKE-PORT ()
  1387.   "specifies the current box as the target
  1388. of a port. "
  1389.   (SETQ *COM-MAKE-PORT-CURRENT-PORT* (PORT-TO-INTERNAL (POINT-BOX))))
  1390.  
  1391. (DEFBOXER-COMMAND COM-PLACE-PORT ()
  1392.   "inserts a port to the (previously)
  1393. specified target. "
  1394.   (WHEN (PORT-BOX? *COM-MAKE-PORT-CURRENT-PORT*)
  1395. ;    (COND ((TELL (POINT-BOX) :SUPERIOR?
  1396. ;         (TELL *COM-MAKE-PORT-CURRENT-PORT* :PORTS))
  1397. ;       (FERROR "You are trying to port to a superior of the present box"))
  1398. ;      (T
  1399.        (INSERT-CHA *POINT* *COM-MAKE-PORT-CURRENT-PORT*)
  1400.        (SETQ *COM-MAKE-PORT-CURRENT-PORT* NIL)))
  1401.  
  1402.  
  1403.  
  1404. ;;; graphics boxes
  1405.  
  1406. (DEFBOXER-COMMAND COM-TOGGLE-INTO-GRAPHICS-BOX ()
  1407.   "toggles the current box into a graphics box. "
  1408.   (UNLESS (OUTERMOST-SCREEN-BOX? (SCREEN-BOX-POINT-IS-IN))
  1409.     (COM-FIX-BOX-SIZE)
  1410.     (TELL (BOX-SCREEN-POINT-IS-IN) :SET-FLAVOR 'GRAPHICS-BOX)
  1411.     (COM-EXIT-BOX)))
  1412.  
  1413. (DEFBOXER-COMMAND COM-MAKE-GRAPHICS-BOX ()
  1414.   "inserts a graphics box at the cursor location. "
  1415.   (INSERT-CHA *POINT* (MAKE-GRAPHICS-BOX)))
  1416.  
  1417. (DEFBOXER-COMMAND com-make-graphics-data-box ()
  1418.     "inserts a graphics-data-box at the cursor location. "
  1419.   (insert-cha *point* (make-graphics-data-box)))
  1420.  
  1421. (DEFBOXER-COMMAND com-make-sprite-box ()
  1422.     "inserts a sprite-box at the cursor location. "
  1423.   (insert-cha *point* (make-sprite-box)))
  1424.  
  1425.  
  1426.  
  1427. ;;;; DOCUMENTATION
  1428.  
  1429. ;;; This should use resources or something....
  1430. (DEFUN COPY-HELP-BOX (HELP-BOX)
  1431.   (LET ((COPY (TELL HELP-BOX :COPY)))
  1432.     (WHEN (TELL HELP-BOX :EXIT-TRIGGER-ENABLED?)
  1433.       (TELL COPY :SET-EXIT-TRIGGER (TELL HELP-BOX :EXIT-TRIGGER))
  1434.       (TELL COPY :ENABLE-EXIT-TRIGGER))
  1435.     COPY))
  1436.  
  1437. (DEFBOXER-COMMAND COM-HELP ()
  1438.   "Displays Information About Commands.  It prompts
  1439. for a character which specifies the type of help. 
  1440. Currently valid characters are:
  1441.  
  1442. A  Displays commands whose names contain a given
  1443.    substring.  
  1444. C  Displays the Documentation for a Command."
  1445.   (LET ((HELP-BOX (COPY-HELP-BOX *TOP-LEVEL-HELP-BOX*)))
  1446.     (UNWIND-PROTECT
  1447.     (PROGN
  1448.       (INSERT-CHA *POINT* HELP-BOX ':FIXED)
  1449.       (COM-ENTER-BOX)
  1450.       (REDISPLAY)
  1451.       (COM-END-OF-BOX)
  1452.       (REDISPLAY)
  1453.       (LOOP FOR INPUT = (TELL TERMINAL-IO :ANY-TYI) THEN (TELL TERMINAL-IO :ANY-TYI)
  1454.         WHEN (MEMBER INPUT '(#\A #\a))
  1455.           DO (COM-APROPOS-HELP)
  1456.              (REDISPLAY)
  1457.         WHEN (MEMBER INPUT '(#\c #\C))
  1458.           DO (COM-COMMAND-HELP)
  1459.              (REDISPLAY)
  1460.         UNTIL (MEMBER INPUT '(#/) #\} #/c-})))
  1461.       (COM-EXIT-BOX)
  1462.       (WHEN (MEMQ HELP-BOX (TELL (TELL HELP-BOX :SUPERIOR-ROW) :CHAS))
  1463.         (TELL (TELL HELP-BOX :SUPERIOR-ROW) :DELETE-CHA HELP-BOX))))))
  1464.  
  1465. (DEFBOXER-COMMAND COM-COMMAND-HELP ()
  1466.   "displays documentation for a given command"
  1467.   (LET ((HELP-BOX (COPY-HELP-BOX *COMMAND-DOCUMENTATION-HELP-BOX*)))
  1468.     (UNWIND-PROTECT
  1469.     (PROGN
  1470.       (INSERT-CHA *POINT* HELP-BOX ':FIXED)
  1471.       (COM-ENTER-BOX)
  1472.       (REDISPLAY)
  1473.       (COM-END-OF-BOX)
  1474.       (REDISPLAY)
  1475.       (LET ((KEY-TO-DOCUMENT (LOOKUP-KEY-NAME (TELL TERMINAL-IO :TYI))))
  1476.         (COND ((AND (BOXER-FDEFINED? KEY-TO-DOCUMENT)
  1477.             (FUNCTIONP (BOXER-SYMEVAL KEY-TO-DOCUMENT))
  1478.             (STRINGP (DOCUMENTATION (BOXER-SYMEVAL KEY-TO-DOCUMENT))))
  1479.            ;; it is a standard editor command
  1480.            (INSERT-CHA *POINT*
  1481.                    (MAKE-BOX-FROM-STRING
  1482.                  (STRING-APPEND
  1483.                    (FORMAT NIL "The ~A ~%" KEY-TO-DOCUMENT)
  1484.                    (GET (BOXER-SYMEVAL KEY-TO-DOCUMENT)
  1485.                     'EDITOR-DOCUMENTATION)))))
  1486.           ((AND (BOXER-FDEFINED? KEY-TO-DOCUMENT)
  1487.             (FUNCTIONP (BOXER-SYMEVAL KEY-TO-DOCUMENT)))
  1488.            (INSERT-CHA *POINT*
  1489.                    (MAKE-BOX-FROM-STRING
  1490.                  (STRING-APPEND
  1491.                    (FORMAT NIL "The ~A is~%" KEY-TO-DOCUMENT)
  1492.                    "Undocumented"))))
  1493.           (T
  1494.            (INSERT-CHA *POINT*
  1495.                    (MAKE-BOX-FROM-STRING
  1496.                  (STRING-APPEND
  1497.                    (FORMAT NIL "The ~A is~%" KEY-TO-DOCUMENT)
  1498.                    "Undefined"))))))
  1499.       (TELL HELP-BOX :APPEND-ROW
  1500.         (MAKE-ROW '("Type any character to make this box go away")))
  1501.       (REDISPLAY)
  1502.       (TELL TERMINAL-IO :ANY-TYI))
  1503.       (COM-EXIT-BOX)
  1504.       (WHEN (MEMQ HELP-BOX (TELL (TELL HELP-BOX :SUPERIOR-ROW) :CHAS))
  1505.     (TELL (TELL HELP-BOX :SUPERIOR-ROW) :DELETE-CHA HELP-BOX)))))
  1506.  
  1507. (DEFUN GET-APPROPRIATE-COMMANDS (STRING)
  1508.   (LOOP FOR COM IN *BOXER-EDITOR-COMMANDS*
  1509.     WHEN (STRING-SEARCH STRING COM)
  1510.       COLLECT COM))
  1511.  
  1512. (EVAL-WHEN (LOAD)
  1513.   (TELL *APROPOS-DOCUMENTATION-HELP-BOX* :SET-EXIT-TRIGGER
  1514.     #'(LAMBDA () (THROW 'MINI-COMMAND-LOOP NIL)))
  1515.   (TELL *APROPOS-DOCUMENTATION-HELP-BOX* :ENABLE-EXIT-TRIGGER)
  1516.   )
  1517.  
  1518. (DEFUN STRING-FOR-AVAILABLE-KEYS (COM)
  1519.   (LET* ((KEYS (GET-KEYS-FOR-COMMAND COM))
  1520.      (AVAILABLE-KEYS (LOOP FOR KEY IN KEYS
  1521.                    WHEN (EQ COM (BOXER-SYMEVAL KEY)) COLLECT KEY)))
  1522.     (COND ((NULL KEYS) "is not currently installed on any key. ")
  1523.       ((NULL AVAILABLE-KEYS) "is not available in this box. ")
  1524.       (T (LOOP WITH S = (FORMAT NIL "Invoked by~%")
  1525.            FOR KEY IN KEYS
  1526.            WHEN (EQ COM (BOXER-SYMEVAL KEY))
  1527.            DO (SETQ S (STRING-APPEND S (FORMAT NIL "  the ~A~%" KEY)))
  1528.            FINALLY
  1529.              (RETURN S))))))
  1530.  
  1531. (DEFBOXER-COMMAND COM-APROPOS-HELP ()
  1532.   "Displays all the comands whose names
  1533. contain a given substring. "
  1534.   (LET ((HELP-BOX (COPY-HELP-BOX *APROPOS-DOCUMENTATION-HELP-BOX*)))
  1535.     (UNWIND-PROTECT
  1536.     (*CATCH 'EXIT-FROM-HELP-BOX
  1537.       (INSERT-CHA *POINT* HELP-BOX ':FIXED)
  1538.       (COM-ENTER-BOX)
  1539.       (REDISPLAY)
  1540.       (COM-END-OF-BOX)
  1541.       (LET* ((APROPOS-STRING (STRING (GET-FIRST-ELEMENT
  1542.                        (GET-BOXER-INPUT "Type a String.  then exit"))))
  1543.          (COMS (GET-APPROPRIATE-COMMANDS APROPOS-STRING)))
  1544.         (INSERT-ROW *POINT*
  1545.             (MAKE-ROW
  1546.               (NCONS (FORMAT NIL
  1547.                      "Commands with ~A in their name" APROPOS-STRING))))
  1548.         (LOOP FOR COM IN COMS
  1549.           FOR BOX = (MAKE-BOX-FROM-STRING
  1550.                   (FORMAT NIL "~A~%~A~%~A"
  1551.                       COM
  1552.                       (GET COM 'EDITOR-DOCUMENTATION)
  1553.                       (STRING-FOR-AVAILABLE-KEYS COM)))
  1554.           UNLESS (EQ COM (CAR COMS))
  1555.             ;; shrink all the boxes except the first one
  1556.             DO (TELL BOX :SHRINK)
  1557.           DO (INSERT-ROW *POINT* (MAKE-ROW (NCONS BOX)))))
  1558.       (TELL HELP-BOX :APPEND-ROW
  1559.         (MAKE-ROW '("Exit this box and it will go away")))
  1560.       (REDISPLAY)
  1561.       (MINI-BOXER-COMMAND-LOOP))
  1562.       (WHEN (TELL (POINT-BOX) :SUPERIOR? HELP-BOX)
  1563.     (LET ((NEW-SCREEN-BOX
  1564.         (BP-COMPUTE-NEW-SCREEN-BOX-OUT (POINT-BOX)
  1565.                            HELP-BOX
  1566.                            (POINT-SCREEN-BOX))))
  1567.       (MOVE-POINT (BOX-SELF-BP-VALUES HELP-BOX))
  1568.       (SET-POINT-SCREEN-BOX (TELL NEW-SCREEN-BOX :SUPERIOR-SCREEN-BOX))))
  1569.       (WHEN (MEMQ HELP-BOX (TELL (TELL HELP-BOX :SUPERIOR-ROW) :CHAS))
  1570.     (TELL (TELL HELP-BOX :SUPERIOR-ROW) :DELETE-CHA HELP-BOX)))))
  1571.  
  1572.  
  1573.  
  1574. ;;;; Niceties
  1575.  
  1576. (DEFBOXER-COMMAND COM-HARDCOPY-MENU ()
  1577.   "Pop up the top level hardcopy menu"
  1578.   (LN03:TOP-LEVEL-HARDCOPY-MENU))
  1579.  
  1580. (DEFBOXER-COMMAND COM-HARDCOPY-SCREEN ()
  1581.   "Hardcopy a portion of the screen.  The default values hardcopy the entire window"
  1582.   (LN03:HARDCOPY-SCREEN))
  1583.  
  1584. (DEFBOXER-COMMAND COM-SET-HARDCOPY-OPTIONS ()
  1585.   "Change the Hardcopy Options"
  1586.   (LN03:SET-HARDCOPY-OPTIONS))
  1587.  
  1588. (DEFBOXER-COMMAND COM-BOOT-MACHINE ()
  1589.   "Boot the Lisp Machine"
  1590.   (WHEN (YES-OR-NO-P "Do You REALLY want to boot the machine ? ")
  1591.     (LOGOUT)
  1592.     (SI:HALT (FORMAT NIL "boot~%"))))
  1593.  
  1594. ;;; Install the COMS we just defined
  1595. (DEFBOXER-FUNCTION CTRL-META-H-KEY COM-HARDCOPY-MENU)
  1596. (DEFBOXER-FUNCTION CTRL-META-S-KEY COM-HARDCOPY-SCREEN)
  1597. (DEFBOXER-FUNCTION CTRL-META-O-KEY COM-SET-HARDCOPY-OPTIONS)
  1598. (DEFBOXER-FUNCTION CTRL-META-*-KEY COM-BOOT-MACHINE)
  1599.  
  1600.  
  1601.  
  1602. ;;;; MOUSE-CLICKS
  1603.  
  1604. (DEFUN COM-MOUSE-COLLAPSE-BOX (WINDOW X Y)
  1605.   ;; Note that this is designed to be called in the Boxer process,
  1606.   ;; not in the Mouse Process -- This is important!!!
  1607.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1608.     (LET ((NEW-BOX (BP-BOX MOUSE-BP))
  1609.       (NEW-ROW (BP-ROW MOUSE-BP))
  1610.       (NEW-CHA-NO (BP-CHA-NO MOUSE-BP)))
  1611.       (WHEN (AND (NOT-NULL NEW-ROW) (BOX? NEW-BOX))
  1612.     (SEND-EXIT-MESSAGES NEW-BOX MOUSE-SCREEN-BOX)
  1613.     (MOVE-POINT-1 NEW-ROW NEW-CHA-NO MOUSE-SCREEN-BOX)
  1614.     (COM-COLLAPSE-BOX)))))
  1615.  
  1616. (DEFUN COM-MOUSE-EXPAND-BOX (WINDOW X Y)
  1617.   ;; Note that this is designed to be called in the Boxer process,
  1618.   ;; not in the Mouse Process -- This is important!!!
  1619.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1620.     (LET ((NEW-BOX (BP-BOX MOUSE-BP))
  1621.       (NEW-ROW (BP-ROW MOUSE-BP))
  1622.       (NEW-CHA-NO (BP-CHA-NO MOUSE-BP)))
  1623.       (WHEN (AND (NOT-NULL NEW-ROW) (BOX? NEW-BOX))
  1624.     (SEND-EXIT-MESSAGES NEW-BOX MOUSE-SCREEN-BOX)
  1625.     (MOVE-POINT-1 NEW-ROW NEW-CHA-NO MOUSE-SCREEN-BOX)
  1626.     (TELL NEW-BOX :ENTER)
  1627.     (COM-EXPAND-BOX)))))
  1628.  
  1629. (DEFUN COM-MOUSE-SHRINK-BOX (WINDOW X Y)
  1630.   ;; Note that this is designed to be called in the Boxer process,
  1631.   ;; not in the Mouse Process -- This is important!!!
  1632.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1633.     (LET ((NEW-BOX (BP-BOX MOUSE-BP))
  1634.       (NEW-ROW (BP-ROW MOUSE-BP))
  1635.       (NEW-CHA-NO (BP-CHA-NO MOUSE-BP)))
  1636.       (WHEN (AND (NOT-NULL NEW-ROW) (BOX? NEW-BOX))
  1637.     (SEND-EXIT-MESSAGES NEW-BOX MOUSE-SCREEN-BOX)
  1638.     (MOVE-POINT-1 NEW-ROW NEW-CHA-NO MOUSE-SCREEN-BOX)
  1639.     (COM-SHRINK-BOX)))))
  1640.  
  1641. (DEFUN COM-MOUSE-SET-OUTERMOST-BOX (WINDOW X Y)
  1642.   ;; Note that this is designed to be called in the Boxer process,
  1643.   ;; not in the Mouse Process -- This is important!!!
  1644.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1645.     (LET ((OLD-ACTUAL-BOX (POINT-BOX))
  1646.       (NEW-BOX (BP-BOX MOUSE-BP))
  1647.       (NEW-ROW (BP-ROW MOUSE-BP))
  1648.       (NEW-CHA-NO (BP-CHA-NO MOUSE-BP)))
  1649.       (WHEN (AND (NOT-NULL NEW-ROW) (BOX? NEW-BOX))
  1650.     (SEND-EXIT-MESSAGES NEW-BOX MOUSE-SCREEN-BOX
  1651.                 (eq (tell old-actual-box :superior-box) NEW-BOX))
  1652.     (MOVE-POINT-1 NEW-ROW NEW-CHA-NO MOUSE-SCREEN-BOX)
  1653.     (IF (GRAPHICS-BOX? NEW-BOX)
  1654.         (COM-EXPAND-BOX)
  1655.         (COM-SET-OUTERMOST-BOX))
  1656.     (TELL NEW-BOX :ENTER)))))
  1657.  
  1658. (DEFUN COM-MOUSE-MOVE-POINT (WINDOW X Y)
  1659.   ;; Note that this is designed to be called in the Boxer process,
  1660.   ;; not in the Mouse Process -- This is important!!!
  1661.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1662.     (LET ((OLD-ACTUAL-BOX (POINT-BOX))
  1663.       (NEW-BOX (BP-BOX MOUSE-BP))
  1664.       (NEW-ROW (BP-ROW MOUSE-BP))
  1665.       (NEW-CHA-NO (BP-CHA-NO MOUSE-BP)))
  1666.       (WHEN (AND (NOT-NULL NEW-ROW) (NOT-NULL NEW-CHA-NO) (NOT-NULL NEW-BOX))
  1667.     (SEND-EXIT-MESSAGES NEW-BOX MOUSE-SCREEN-BOX
  1668.                 (eq (tell old-actual-box :superior-box) NEW-BOX))
  1669.     (when (eq ':shrunk (tell new-box :display-style))
  1670.       (tell new-box :unshrink)
  1671.       (tell new-box :modified))
  1672.     (MOVE-POINT-1 NEW-ROW NEW-CHA-NO MOUSE-SCREEN-BOX))
  1673.       (TELL NEW-BOX :ENTER)))
  1674.   (REDISPLAY-CURSOR))
  1675.  
  1676. (DEFUN COM-MOUSE-DEFINE-REGION (WINDOW X Y)
  1677.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1678.     MOUSE-SCREEN-BOX ;the variable was bound but never used....    
  1679.     (LET ((LOCAL-REGION (OR *REGION-BEING-DEFINED* (GET-CURRENT-REGION))))
  1680.       (COND ((NOT-NULL LOCAL-REGION)        ;there already IS a region in the current box
  1681.          (SETQ *REGION-BEING-DEFINED*   LOCAL-REGION
  1682.            *FOLLOWING-MOUSE-REGION* LOCAL-REGION)
  1683.          ;; we have to decide which BP of the region to replace with *POINT*
  1684.          (IF (BP-< MOUSE-BP (TELL LOCAL-REGION :START-BP))
  1685.          (TELL LOCAL-REGION :SET-START-BP *MOUSE-BP*)
  1686.          (TELL LOCAL-REGION :SET-STOP-BP  *MOUSE-BP*)))
  1687.         (T
  1688.          ;; There is No current region so we make one
  1689.          ;; between the *POINT* which is moved to where the mouse is and
  1690.          ;; wherever it is that we let go of the mouse
  1691.          (MOVE-POINT (BP-VALUES  MOUSE-BP))
  1692.          (REDISPLAY-CURSOR)
  1693.          (SETQ *REGION-BEING-DEFINED*
  1694.            (MAKE-EDITOR-REGION *POINT* *MOUSE-BP*)
  1695.            *FOLLOWING-MOUSE-REGION* *REGION-BEING-DEFINED*)
  1696.          (TELL *REGION-BEING-DEFINED* :TURN-ON)
  1697.          (PUSH *REGION-BEING-DEFINED* REGION-LIST))))))
  1698.  
  1699. (DEFUN COM-MOUSE-RELEASE-REGION (WINDOW X Y)
  1700.   "Releases the mouse from the region being created. "
  1701.   (WITH-MOUSE-BP-BOUND (X Y WINDOW)
  1702.     MOUSE-SCREEN-BOX                ;bound but never used...
  1703.     (UNLESS (NULL *REGION-BEING-DEFINED*)
  1704.       (COND ((EQ *MOUSE-BP* (TELL *REGION-BEING-DEFINED* :START-BP))
  1705.          (LET ((NEW-BP (MAKE-BP ':FIXED)))
  1706.            (MOVE-BP NEW-BP (BP-VALUES *MOUSE-BP*))
  1707.            (TELL *REGION-BEING-DEFINED* :SET-START-BP NEW-BP)))
  1708.         ((EQ *MOUSE-BP* (TELL *REGION-BEING-DEFINED* :STOP-BP))
  1709.          (LET ((NEW-BP (MAKE-BP ':FIXED)))
  1710.            (MOVE-BP NEW-BP (BP-VALUES *MOUSE-BP*))
  1711.            (TELL *REGION-BEING-DEFINED* :SET-STOP-BP NEW-BP)))))))
  1712.  
  1713. ;;; If you think you want to use this, then you are probably wrong
  1714. ;;; look at COM-MOUSE-RELEASE-REGION instead
  1715. (DEFUN COM-MOUSE-INSTALL-REGION (WINDOW X Y)
  1716.   WINDOW X Y ;the variables were bound, but never...
  1717.   (UNLESS (NULL *REGION-BEING-DEFINED*)
  1718.     (LET ((OLD-START-BP (TELL *REGION-BEING-DEFINED* :START-BP))
  1719.       (OLD-STOP-BP  (TELL *REGION-BEING-DEFINED* :STOP-BP)))
  1720.       (MULTIPLE-VALUE-BIND (NEW-START-BP NEW-STOP-BP)    ;make sure the BP's are at the
  1721.       (ORDER-BPS OLD-START-BP OLD-STOP-BP)
  1722.     (TELL *REGION-BEING-DEFINED* :SET-START-BP NEW-START-BP)
  1723.     (TELL *REGION-BEING-DEFINED* :SET-STOP-BP  NEW-STOP-BP)
  1724.     (INSTALL-REGION *REGION-BEING-DEFINED*)
  1725.     (UNLESS (OR (EQ *POINT* OLD-START-BP) (EQ *MOUSE-BP* OLD-START-BP))
  1726.       (TELL (BP-ROW OLD-START-BP) :DELETE-BP OLD-START-BP))
  1727.     (UNLESS (OR (EQ *POINT* OLD-STOP-BP) (EQ *MOUSE-BP* OLD-STOP-BP))
  1728.       (TELL (BP-ROW OLD-STOP-BP) :DELETE-BP OLD-STOP-BP))))))
  1729.  
  1730. (DEFUN COM-MOUSE-GRAB-SPRITE (SPRITE)
  1731.   (TELL SPRITE :USURP-MOUSE-WAITING-FOR-BUTTON-RAISE))
  1732.  
  1733. ;;; sprite commands
  1734. (defun com-sprite-right-click (turtle)
  1735.   (let* ((sprite-box (tell turtle :sprite-box))
  1736.      (binding (tell sprite-box
  1737.                :lookup-static-variable-in-box-only
  1738.                'bu:r-click)))
  1739.     (unless (null binding)
  1740.       (boxer-telling (CDR BINDING) sprite-box))))
  1741.  
  1742. (defun com-sprite-middle-click (turtle)
  1743.   (let* ((sprite-box (tell turtle :sprite-box))
  1744.      (binding (tell sprite-box
  1745.                :lookup-static-variable-in-box-only
  1746.                'bu:m-click)))
  1747.     (unless (null binding)
  1748.       (boxer-telling (CDR BINDING) sprite-box))))
  1749.  
  1750. (defun com-sprite-left-click (turtle)
  1751.   (let* ((sprite-box (tell turtle :sprite-box))
  1752.      (binding (tell sprite-box
  1753.                :lookup-static-variable-in-box-only
  1754.                'bu:l-click)))
  1755.     (unless (null binding)
  1756.       (boxer-telling (CDR BINDING) sprite-box))))
  1757.  
  1758. ;;; These are used to direct sprite commands to the appropriate place 
  1759. (defun graphics-box-near (box)
  1760.   (cond ((or (graphics-box? box) (graphics-data-box? box))
  1761.      box)
  1762.     ((eq *initial-box* box) nil)
  1763.     (t (graphics-box-near (tell box :superior-box)))))
  1764.  
  1765. (defun sprite-box-near (box)
  1766.   (cond ((sprite-box? box)
  1767.      box)
  1768.     ((eq *initial-box* box) nil)
  1769.     (t (sprite-box-near (tell box :superior-box)))))
  1770.  
  1771.  
  1772. ;;;; More COMS
  1773.  
  1774. ;;;; commands for transparent boxes
  1775.  
  1776. (defboxer-command com-export-box-names ()
  1777.   "Exports all of the variables in the current 
  1778. box into the surrounding box"
  1779.   (if (port-box? (box-screen-point-is-in))
  1780.       (boxer-editor-error "cant export names from a port")
  1781.       (tell (box-screen-point-is-in) :export-all-variables)))
  1782.  
  1783. (defboxer-command com-embargo-box-names ()
  1784.   "Turns of exporting of Box names"
  1785.   (let ((box (box-screen-point-is-in)))
  1786.     (when (and (not (port-box? box))
  1787.            (not (null (tell box :get-exports))))
  1788.       (tell box :set-exports nil)
  1789.       ;; this ought to just remove the export marker rather than removing everything
  1790.       ;; and then putting the name back but I'm feeling lazy
  1791.       (tell (tell box :superior-box) :remove-all-static-bindings box)
  1792.       (let ((name (tell box :name-row)))
  1793.     (when (name-row? name)
  1794.       (tell name :update-bindings T))))))
  1795.  
  1796. (defboxer-function ctrl-meta-circle-key com-export-box-names)
  1797. (defboxer-function ctrl-meta-e-key      com-embargo-box-names)
  1798.  
  1799. (defboxer-function transparent-box? ((port-to box))
  1800.   (let ((target (get-port-target box)))
  1801.     (boxer-boolean
  1802.       (and (box? target)
  1803.        (not (null (tell target :get-exports)))
  1804.        (memq target (tell (tell target :superior-box) :get-exporting-boxes))))))
  1805.