home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / infsup.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  31.1 KB  |  842 lines
  1. ;;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:cptfont -*-
  2. ;;;
  3. ;;; (C) Copyright 1982-1985 Massachusetts Institute of Technology
  4. ;;;
  5. ;;; Permission to use, copy, modify, distribute, and sell this software
  6. ;;; and its documentation for any purpose is hereby granted without fee,
  7. ;;; provided that the above copyright notice appear in all copies and that
  8. ;;; both that copyright notice and this permission notice appear in
  9. ;;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;;; advertising or publicity pertaining to distribution of the software
  11. ;;; without specific, written prior permission.  M.I.T. makes no
  12. ;;; representations about the suitability of this software for any
  13. ;;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;;
  15. ;;;
  16. ;;; This file is part of the BOXER system.
  17. ;;;
  18. ;;; This file contains low-level code which deals with the inferior/superior
  19. ;;; relations between primitive Boxer objects. These relations include the
  20. ;;; connection/disconnection of primitive Boxer objects from their superiors
  21. ;;; and from groups of co-inferiors.
  22.  
  23.  
  24.  
  25.  
  26. ;;; Rows have a fairly hairy scheme for keeping track of their chas, the order
  27. ;;; they are in etc. The main data structure used to implement this scheme is
  28. ;;; the CHAS-ARRAY. Chas-Arrays are just what their name says, arrays of chas.
  29. ;;; In addition chas-arrays keep track of all the BPs that point to the chas
  30. ;;; in them so that whenever there is a change to a chas-array, those bps can
  31. ;;; be updated to account for the change. One way of thinking of chas-arrays
  32. ;;; is as Lispm Strings which are just arrays of Lispm character codes.
  33.  
  34. (DEFVAR *CHAS-ARRAY-DEFAULT-SIZE* 30.)
  35. (DEFVAR *CHAS-ARRAY-DEFUALT-SIZE-QUANTUM* 10.)
  36.  
  37. (DEFSTRUCT (CHAS-ARRAY (:TYPE :NAMED-ARRAY-LEADER)
  38.                (:MAKE-ARRAY (:DIMENSIONS *CHAS-ARRAY-DEFAULT-SIZE*)
  39.                     (:TYPE 'ART-Q))
  40.                :CONC-NAME)
  41.   (ACTIVE-LENGTH 0)
  42.   (BPS NIL)
  43.   )
  44.  
  45. (DEFTYPE-CHECKING-MACROS CHAS-ARRAY "a chas-array")
  46.  
  47. (DEFUN CHECK-CHAS-ARRAY-OLD-CHA-NO-ARG (CHAS-ARRAY ARG)
  48.   (CHECK-CHAS-ARRAY-ARG CHAS-ARRAY)
  49.   (LET ((ACTIVE-LENGTH (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY)))
  50.     (COND ((AND (FIXNUMP ARG) (>= ARG 0) (< ARG ACTIVE-LENGTH)))
  51.       (T
  52.        (BARF 'SI:WRONG-TYPE-ARGUMENT)))))
  53.  
  54. (DEFUN CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG (CHAS-ARRAY ARG)
  55.   (CHECK-CHAS-ARRAY-ARG CHAS-ARRAY)
  56.   (LET ((ACTIVE-LENGTH (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY)))
  57.     (COND ((AND (FIXNUMP ARG) (>= ARG 0) (<= ARG ACTIVE-LENGTH)))
  58.       (T
  59.        (BARF 'SI:WRONG-TYPE-ARGUMENT)))))
  60.  
  61. (DEFSUBST CHAS-ARRAY-GET-CHA (CHAS-ARRAY CHA-NO)
  62.   (AREF CHAS-ARRAY CHA-NO))
  63.  
  64. (DEFSUBST CHAS-ARRAY-SET-CHA (CHAS-ARRAY CHA-NO NEW-VALUE)
  65.   (ASET NEW-VALUE CHAS-ARRAY CHA-NO))
  66.  
  67. (DEFSUBST CHAS-ARRAY-ROOM (CHAS-ARRAY)
  68.   #-LMITI(ARRAY-DIMENSION-N 1 CHAS-ARRAY)
  69.   #+LMITI(ARRAY-DIMENSION CHAS-ARRAY 0)
  70.   )
  71.  
  72. (DEFUN CHAS-ARRAY-ADJUST-ROOM (CHAS-ARRAY DELTA-ROOM)
  73.   (LET ((OLD-ROOM (CHAS-ARRAY-ROOM CHAS-ARRAY)))
  74.     (ADJUST-ARRAY-SIZE CHAS-ARRAY (+ OLD-ROOM DELTA-ROOM))))
  75.  
  76. (DEFUN CHAS-ARRAY-ASSURE-ROOM (CHAS-ARRAY REQUIRED-ROOM)
  77.   (LET ((DELTA-ROOM (- REQUIRED-ROOM (CHAS-ARRAY-ROOM CHAS-ARRAY))))
  78.     (IF (PLUSP DELTA-ROOM)
  79.     (CHAS-ARRAY-ADJUST-ROOM CHAS-ARRAY DELTA-ROOM)
  80.     CHAS-ARRAY)))
  81.  
  82.  
  83.  
  84. ;;; CHAS-ARRAY-SLIDE-CHAS the primitive function that functions which need to
  85. ;;; slide chas around in a chas-array should call. This function takes care of
  86. ;;; adjusting the BPs that point to the chas-array to compensate for the slide.
  87. ;;; This function also takes care of assuring that there is enough room in the
  88. ;;; chas-array to perform the slide. Like all functions which may need to make
  89. ;;; a new chas-array, chas-array-slide-chas always returns the (new) chas-array.
  90.  
  91. (DEFUN CHAS-ARRAY-SLIDE-CHAS (CHAS-ARRAY STRT-CHA-NO DISTANCE)
  92.   (LET ((OLD-ACTIVE-LENGTH (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY)))
  93.     (CHAS-ARRAY-ASSURE-ROOM CHAS-ARRAY (+ OLD-ACTIVE-LENGTH DISTANCE))
  94.     (COND ((PLUSP DISTANCE)
  95.        (CHAS-ARRAY-SLIDE-CHAS-POS CHAS-ARRAY STRT-CHA-NO
  96.                       DISTANCE OLD-ACTIVE-LENGTH))
  97.       ((MINUSP DISTANCE)
  98.        (CHAS-ARRAY-SLIDE-CHAS-NEG CHAS-ARRAY STRT-CHA-NO
  99.                       DISTANCE OLD-ACTIVE-LENGTH)))
  100.     (CHAS-ARRAY-SLIDE-BPS CHAS-ARRAY STRT-CHA-NO DISTANCE)))
  101.  
  102. (DEFUN CHAS-ARRAY-SLIDE-CHAS-POS (CHAS-ARRAY STRT-CHA-NO
  103.                   DISTANCE OLD-ACTIVE-LENGTH)
  104.   (DO ((ORIG-CHA-NO (- OLD-ACTIVE-LENGTH 1) (- ORIG-CHA-NO 1)))
  105.       ((< ORIG-CHA-NO STRT-CHA-NO))
  106.     (CHAS-ARRAY-SET-CHA
  107.       CHAS-ARRAY (+ ORIG-CHA-NO DISTANCE) (CHAS-ARRAY-GET-CHA
  108.                         CHAS-ARRAY ORIG-CHA-NO))))
  109.  
  110. (DEFUN CHAS-ARRAY-SLIDE-CHAS-NEG (CHAS-ARRAY STRT-CHA-NO
  111.                   DISTANCE OLD-ACTIVE-LENGTH)
  112.   (DO ((ORIG-CHA-NO STRT-CHA-NO (+ ORIG-CHA-NO 1)))
  113.       ((>= ORIG-CHA-NO OLD-ACTIVE-LENGTH))
  114.     (CHAS-ARRAY-SET-CHA
  115.       CHAS-ARRAY (+ ORIG-CHA-NO DISTANCE) (CHAS-ARRAY-GET-CHA
  116.                         CHAS-ARRAY ORIG-CHA-NO))))
  117.  
  118. (DEFUN CHAS-ARRAY-SLIDE-BPS (CHAS-ARRAY STRT-CHA-NO DISTANCE)
  119.   (DOLIST (BP (CHAS-ARRAY-BPS CHAS-ARRAY))
  120.     (COND ((OR (> (BP-CHA-NO BP) STRT-CHA-NO)
  121.            (AND (= (BP-CHA-NO BP) STRT-CHA-NO) (EQ (BP-TYPE BP) ':MOVING)))
  122.        (INCF (BP-CHA-NO BP) DISTANCE)))))
  123.  
  124.  
  125.  
  126. ;;; CHAS-ARRAY-INSERT-CHA-1 is an internal function used by all of the
  127. ;;; functions which insert chas into a chas-array. Functions which want
  128. ;;; to call this function must have taken care of sliding the chas from
  129. ;;; the insert position on out of the way, and must alos take care of
  130. ;;; updating the chas-array's active-length. This exists as a seperate
  131. ;;; function so that functions which do multiple insert-chas can avoid
  132. ;;; multiple calls to chas-array-slide-chas
  133.  
  134. (DEFSUBST CHAS-ARRAY-INSERT-CHA-1 (INTO-CHAS-ARRAY CHA-NO CHA)
  135.   (CHAS-ARRAY-SET-CHA INTO-CHAS-ARRAY CHA-NO CHA))
  136.  
  137. ;;; CHAS-ARRAY-INSERT-CHA is the correct function to call to insert a
  138. ;;; cha into a chas array. It does everything that needs to be done,
  139. ;;; specifically:
  140. ;;;  - It type checks the chas-array and the cha-no.
  141. ;;;  - It slides the chas following the insert point out
  142. ;;;    of the way.
  143. ;;;  - It makes the correct call to chas-array-insert-cha-1.
  144. ;;;  - It icrements the chas-array's active length.
  145.  
  146. (DEFUN CHAS-ARRAY-INSERT-CHA (INTO-CHAS-ARRAY CHA-NO CHA)
  147.   (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG INTO-CHAS-ARRAY CHA-NO)
  148.   (CHAS-ARRAY-SLIDE-CHAS INTO-CHAS-ARRAY CHA-NO 1)
  149.   (CHAS-ARRAY-INSERT-CHA-1 INTO-CHAS-ARRAY CHA-NO CHA)
  150.   (INCF (CHAS-ARRAY-ACTIVE-LENGTH INTO-CHAS-ARRAY) 1))
  151.  
  152. ;;; CHAS-ARRAY-DELETE-CHA is the correct function to call to delete a
  153. ;;; cha from a chas-array. It does everything that needs to be done,
  154. ;;; specifically:
  155. ;;;  - It type checks the chas-array, and the cha-no.
  156. ;;;  - It slides the chas following the delete point over
  157. ;;;    to delete that cha.
  158. ;;;  - It tells the cha about its new-superior-row.
  159. ;;;  - It decrements the chas-array's active-length.
  160.  
  161. (DEFUN CHAS-ARRAY-DELETE-CHA (FROM-CHAS-ARRAY CHA-NO)
  162.   (CHECK-CHAS-ARRAY-OLD-CHA-NO-ARG FROM-CHAS-ARRAY CHA-NO)
  163.   (CHAS-ARRAY-SLIDE-CHAS FROM-CHAS-ARRAY (+ CHA-NO 1) -1)
  164.   (DECF (CHAS-ARRAY-ACTIVE-LENGTH FROM-CHAS-ARRAY) 1))
  165.  
  166.  
  167.  
  168. ;;; CHAS-ARRAY-MOVE-CHAS is the fundamental function used to move chas
  169. ;;; from one chas-array to another chas-array. This function takes care
  170. ;;; of doing everything that needs to be done when moving groups of chas
  171. ;;; from one chas-array to another chas-array, specifically:
  172. ;;;  - It type checks both chas-arrays, and the cha-nos
  173. ;;;    in those arrays.
  174. ;;;  - It takes care of moving the chas, and adjusting the
  175. ;;;    active-lengths of the two chas-arrays.
  176. ;;;  - It takes care of moving and adjusting the BPs that
  177. ;;;    pointed to the moved chas.
  178.  
  179. (DEFUN CHAS-ARRAY-MOVE-CHAS (FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STRT-CHA-NO
  180.                  INTO-CHAS-ARRAY INTO-CHAS-ARRAY-STRT-CHA-NO
  181.                  NO-OF-CHAS-TO-MOVE SUPERIOR-ROW)
  182.   (LET ((FROM-CHAS-ARRAY-STOP-CHA-NO (+ FROM-CHAS-ARRAY-STRT-CHA-NO NO-OF-CHAS-TO-MOVE)))
  183.     ;; First we be real good and check all our args like we promised.
  184.     (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STRT-CHA-NO)
  185.     (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STOP-CHA-NO)
  186.     (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG INTO-CHAS-ARRAY INTO-CHAS-ARRAY-STRT-CHA-NO)
  187.     
  188.     (CHAS-ARRAY-SLIDE-CHAS
  189.       INTO-CHAS-ARRAY INTO-CHAS-ARRAY-STRT-CHA-NO NO-OF-CHAS-TO-MOVE)
  190.     (DOTIMES (CHA-NO NO-OF-CHAS-TO-MOVE)
  191.       (LET ((FROM-CHA-NO (+ FROM-CHAS-ARRAY-STRT-CHA-NO CHA-NO))
  192.         (INTO-CHA-NO (+ INTO-CHAS-ARRAY-STRT-CHA-NO CHA-NO)))
  193.     (CHAS-ARRAY-INSERT-CHA-1 INTO-CHAS-ARRAY
  194.                  INTO-CHA-NO
  195.                  (CHAS-ARRAY-GET-CHA FROM-CHAS-ARRAY FROM-CHA-NO))))
  196.     (CHAS-ARRAY-SLIDE-CHAS
  197.       FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STOP-CHA-NO (- NO-OF-CHAS-TO-MOVE))
  198.     
  199.     (INCF (CHAS-ARRAY-ACTIVE-LENGTH INTO-CHAS-ARRAY) NO-OF-CHAS-TO-MOVE)
  200.     (DECF (CHAS-ARRAY-ACTIVE-LENGTH FROM-CHAS-ARRAY) NO-OF-CHAS-TO-MOVE)
  201.     
  202.     (DOLIST (BP (CHAS-ARRAY-BPS FROM-CHAS-ARRAY))
  203.       (LET ((BP-CHA-NO (BP-CHA-NO BP)))
  204.     (COND ((OR (AND (>  BP-CHA-NO FROM-CHAS-ARRAY-STRT-CHA-NO)
  205.             (<  BP-CHA-NO (- FROM-CHAS-ARRAY-STOP-CHA-NO 1)))
  206.            (AND (=  BP-CHA-NO FROM-CHAS-ARRAY-STRT-CHA-NO)
  207.             (EQ (BP-TYPE BP) ':MOVING)))
  208.            (MOVE-BP-1 BP SUPERIOR-ROW (+ INTO-CHAS-ARRAY-STRT-CHA-NO
  209.                          (- BP-CHA-NO
  210.                         FROM-CHAS-ARRAY-STRT-CHA-NO)))))))))
  211.  
  212.  
  213.  
  214. ;;; Methods that support the interaction between rows and BP's.
  215.  
  216. (DEFMETHOD (ROW :BPS) ()
  217.   (CHAS-ARRAY-BPS CHAS-ARRAY))
  218.  
  219. (DEFMETHOD (ROW :SET-BPS) (NEW-VALUE)
  220.   (CHECK-ARG NEW-VALUE '(LAMBDA (X) (AND (LISTP X) (EVERY X 'BP?))) "A list of Boxer BP's")
  221.   (SETF (CHAS-ARRAY-BPS CHAS-ARRAY) NEW-VALUE))
  222.  
  223. (DEFMETHOD (ROW :ADD-BP) (BP)
  224.   (CHECK-BP-ARG BP)
  225.   (UNLESS (MEMQ BP (CHAS-ARRAY-BPS CHAS-ARRAY))
  226.       (PUSH BP (CHAS-ARRAY-BPS CHAS-ARRAY))))
  227.  
  228. (DEFMETHOD (ROW :DELETE-BP) (BP)
  229.   (CHECK-BP-ARG BP)
  230.   (SETF (CHAS-ARRAY-BPS CHAS-ARRAY) (DELETE BP (CHAS-ARRAY-BPS CHAS-ARRAY))))
  231.  
  232.  
  233.  
  234. ;;; These are the messages (to rows) that other sections of code may call to find
  235. ;;; out about or modify the connection structure of rows and chas:
  236. ;;;
  237. ;;; :LENGTH-IN-CHAS
  238. ;;; :CHA-AT-CHA-NO
  239. ;;; :CHA-CHA-NO
  240. ;;; 
  241. ;;; :CHAS
  242. ;;; 
  243. ;;; :INSERT-CHA-AT-CHA-NO
  244. ;;; :INSERT-ROW-CHAS-AT-CHA-NO
  245. ;;; :DELETE-CHA-AT-CHA-NO
  246. ;;; :DELETE-CHAS-BETWEEN-CHA-NOS
  247. ;;; :KILL-CHAS-AT-CHA-NO
  248. ;;; 
  249. ;;; :INSERT-CHA-BEFORE-CHA
  250. ;;; :INSERT-CHA-AFTER-CHA
  251. ;;; :INSERT-ROW-CHAS-BEFORE-CHA
  252. ;;; :INSERT-ROW-CHAS-AFTER-CHA
  253. ;;; :DELETE-CHA
  254. ;;; :DELETE-BETWEEN-CHAS
  255. ;;; :KILL-CHA
  256. ;;;
  257. ;;; In additions the macro DO-ROW-CHAS ((<var> <row>) <body>) is defined to be used
  258. ;;; by other sections of code to iterate through a row's chas.
  259.  
  260. (DEFGET-METHOD (ROW :CHAS-ARRAY) CHAS-ARRAY)
  261. (DEFSET-METHOD (ROW :SET-CHAS-ARRAY) CHAS-ARRAY)
  262.  
  263. (DEFMACRO DO-ROW-CHAS (((VAR ROW) . OTHER-DO-VARS) &BODY BODY)
  264.   `(LET* ((.CHAS-ARRAY. (TELL ,ROW :CHAS-ARRAY))
  265.       (.ACTIVE-LENGTH. (CHAS-ARRAY-ACTIVE-LENGTH .CHAS-ARRAY.)))
  266.      (LET ((,VAR NIL))                           ;Note that there is a
  267.        (DO ((.CHA-NO. 0 (+ .CHA-NO. 1))                   ;good reason for using
  268.         . ,OTHER-DO-VARS)                       ;this weird 
  269.        ((>= .CHA-NO. .ACTIVE-LENGTH.))            ;(LET ((,VAR NIL))
  270.      (SETQ ,VAR (CHAS-ARRAY-GET-CHA .CHAS-ARRAY. .CHA-NO.))    ;(SETQ ,VAR <foo>)
  271.      . ,BODY))))                           ;form, it makes it look
  272.                                    ;more like a real DO.
  273. (DEFMETHOD (ROW :LENGTH-IN-CHAS) ()
  274.   (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))
  275.   
  276. (DEFMETHOD (ROW :CHA-AT-CHA-NO) (N)
  277.   (COND ((OR (< N 0) (>= N (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) NIL)
  278.     (T (CHAS-ARRAY-GET-CHA CHAS-ARRAY N))))
  279.  
  280. ;;; this is useful for changing case and fonts and such
  281. (DEFMETHOD (ROW :CHANGE-CHA-AT-CHA-NO) (N NEW-CHA)
  282.   (COND ((OR (< N 0) (>= N (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) NIL)
  283.     (T (SETF (CHAS-ARRAY-GET-CHA CHAS-ARRAY N) NEW-CHA)
  284.        (TELL SELF :MODIFIED))))
  285.  
  286. (DEFMETHOD (ROW :CHA-CHA-NO) (CHA-TO-GET-CHA-NO-OF)
  287.   (DO-ROW-CHAS ((CHA SELF)
  288.         (CHA-NO 0 (+ CHA-NO 1)))
  289.     (COND ((EQ CHA CHA-TO-GET-CHA-NO-OF)
  290.        (RETURN CHA-NO)))))
  291.  
  292. (DEFMETHOD (ROW :CHAS) ()
  293.   (OR CACHED-CHAS (TELL SELF :CACHE-CHAS)))
  294.  
  295. (DEFMETHOD (ROW :CACHE-CHAS) ()
  296.   (SETQ CACHED-CHAS (WITH-COLLECTION (DO-ROW-CHAS ((CHA SELF)) (COLLECT CHA)))))
  297.  
  298. (DEFMETHOD (ROW :CHAS-BETWEEN-CHA-NOS) (START &OPTIONAL (STOP (TELL SELF :LENGTH-IN-CHAS)))
  299.   (LOOP FOR CHA-NO = START THEN (1+ CHA-NO) UNTIL (= CHA-NO STOP)
  300.     COLLECTING (TELL SELF :CHA-AT-CHA-NO CHA-NO)))
  301.  
  302. (DEFMETHOD (ROW :BOXES-IN-ROW) ()
  303.   (WITH-COLLECTION
  304.     (DO-ROW-CHAS ((CHA SELF))
  305.       (WHEN (BOX? CHA) (COLLECT CHA)))))
  306.  
  307. ;(DEFMETHOD (ROW :ADD-A-BOX) (BOX-TO-BE-ADDED)
  308. ;  (PUSH BOX-TO-BE-ADDED BOXES))
  309.  
  310. ;(DEFMETHOD (ROW :ADD-BOXES) (LIST-OF-BOXES)
  311. ;  (SETQ BOXES (APPEND BOXES LIST-OF-BOXES)))
  312.  
  313. (DEFMETHOD (ROW :BOXES-BETWEEN-CHA-NOS) (STRT-CHA-NO STOP-CHA-NO)
  314.   (WITH-COLLECTION
  315.     (DO* ((INDEX STRT-CHA-NO (+ INDEX 1))
  316.       (CHA (TELL SELF :CHA-AT-CHA-NO INDEX)
  317.            (TELL SELF :CHA-AT-CHA-NO INDEX)))
  318.      ((= INDEX STOP-CHA-NO))
  319.       (IF (BOX? CHA)
  320.       (COLLECT CHA)))))
  321.  
  322.  
  323.  
  324. (DEFMETHOD (ROW :INSERT-CHA-AT-CHA-NO) (CHA CHA-NO)
  325.   (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY CHA-NO CHA)
  326.   (WHEN (BOX? CHA)
  327.     (TELL CHA :SET-SUPERIOR-ROW SELF)
  328.     (tell cha :insert-self-action))
  329.   (TELL SELF :MODIFIED))
  330.  
  331.  
  332. (defmethod (row :insert-list-of-chas-at-cha-no) (list-of-chas cha-no)
  333.   (do ((remaining-chas list-of-chas (cdr remaining-chas))
  334.        (present-cha-no cha-no (1+ present-cha-no)))
  335.       ((null remaining-chas))
  336.     (tell self :insert-cha-at-cha-no (car remaining-chas) present-cha-no)))
  337.  
  338. (DEFMETHOD (ROW :DELETE-CHA-AT-CHA-NO) (CHA-NO)
  339.   (LET ((CHA (TELL SELF :CHA-AT-CHA-NO CHA-NO)))
  340.     (CHAS-ARRAY-DELETE-CHA CHAS-ARRAY CHA-NO)
  341.     (WHEN (BOX? CHA)
  342.       (tell cha :delete-self-action))
  343.     (TELL SELF :MODIFIED)))
  344.  
  345. (DEFMETHOD (ROW :INSERT-ROW-CHAS-AT-CHA-NO) (ROW CHA-NO)
  346.   (LET ((ROW-CHAS-ARRAY (TELL ROW :CHAS-ARRAY))
  347.     (NEW-BOXES (TELL ROW :BOXES-IN-ROW)))
  348.     (CHAS-ARRAY-MOVE-CHAS ROW-CHAS-ARRAY 0
  349.               CHAS-ARRAY CHA-NO
  350.               (CHAS-ARRAY-ACTIVE-LENGTH ROW-CHAS-ARRAY)
  351.               SELF)
  352.     (DOLIST (NEW-BOX NEW-BOXES)
  353.       (TELL NEW-BOX :SET-SUPERIOR-ROW SELF)
  354.     (tell new-box :insert-self-action)))
  355.   (TELL SELF :MODIFIED))
  356.  
  357. (DEFMETHOD (ROW :DELETE-CHAS-BETWEEN-CHA-NOS) (STRT-CHA-NO STOP-CHA-NO)
  358.   (LET* ((RETURN-ROW (MAKE-INITIALIZED-ROW))
  359.      (RETURN-ROW-CHAS-ARRAY (TELL RETURN-ROW :CHAS-ARRAY)))
  360.     (CHAS-ARRAY-MOVE-CHAS
  361.       CHAS-ARRAY STRT-CHA-NO RETURN-ROW-CHAS-ARRAY
  362.       0 (- STOP-CHA-NO STRT-CHA-NO) RETURN-ROW)
  363.     (TELL SELF :MODIFIED)
  364.     (TELL RETURN-ROW :MODIFIED)
  365.     (dolist (box (tell return-row :boxes-in-row))
  366.       (tell box :delete-self-action)
  367.       (tell box :set-superior-row return-row))
  368.     RETURN-ROW))
  369.  
  370. (DEFMETHOD (ROW :KILL-CHAS-AT-CHA-NO) (STRT-CHA-NO)
  371.   (LET ((STOP-CHA-NO (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY)))
  372.     (TELL SELF :DELETE-CHAS-BETWEEN-CHA-NOS STRT-CHA-NO STOP-CHA-NO)))
  373.  
  374.  
  375. (DEFMETHOD (ROW :INSERT-CHA-BEFORE-CHA) (CHA BEFORE-CHA)
  376.   (LET ((BEFORE-CHA-CHA-NO (TELL SELF :CHA-CHA-NO BEFORE-CHA)))
  377.     (TELL SELF :INSERT-CHA-AT-CHA-NO BEFORE-CHA-CHA-NO CHA)))
  378.  
  379. (DEFMETHOD (ROW :INSERT-CHA-AFTER-CHA) (CHA AFTER-CHA)
  380.   (LET ((AFTER-CHA-CHA-NO (TELL SELF :CHA-CHA-NO AFTER-CHA)))
  381.     (TELL SELF :INSERT-CHA-AT-CHA-NO CHA (+ AFTER-CHA-CHA-NO 1))))
  382.  
  383. (DEFMETHOD (ROW :DELETE-CHA) (CHA)
  384.   (LET ((CHA-CHA-NO (TELL SELF :CHA-CHA-NO CHA)))
  385.     (UNLESS (NULL CHA-CHA-NO)
  386.       (TELL SELF :DELETE-CHA-AT-CHA-NO CHA-CHA-NO))))
  387.  
  388. (DEFMETHOD (ROW :APPEND-CHA) (CHA)
  389.   (TELL SELF :INSERT-CHA-AT-CHA-NO CHA (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY)))
  390.  
  391. (defmethod (row :append-list-of-chas)(list-of-chas)
  392.   (tell self :insert-list-of-chas-at-cha-no list-of-chas
  393.     (chas-array-active-length chas-array)))
  394.  
  395.  
  396.  
  397. ;;; Box rows are kept a doubly linked list. The box points to its first row,
  398. ;;; and each row has pointers to its next and previous rows. The first row in
  399. ;;; a box has  a previous-row pointer of nil, and the last row in a box has a
  400. ;;; next row pointer of nil.
  401.  
  402. (DEFGET-METHOD (ROW :PREVIOUS-ROW) PREVIOUS-ROW)
  403. (DEFSET-METHOD (ROW :SET-PREVIOUS-ROW) PREVIOUS-ROW)
  404.  
  405. (DEFGET-METHOD (ROW :NEXT-ROW) NEXT-ROW)
  406. (DEFSET-METHOD (ROW :SET-NEXT-ROW) NEXT-ROW)
  407.  
  408. (DEFGET-METHOD (BOX :FIRST-INFERIOR-ROW) FIRST-INFERIOR-ROW)
  409. (DEFSET-METHOD (BOX :SET-FIRST-INFERIOR-ROW) FIRST-INFERIOR-ROW)
  410.  
  411. ;;; These are the messages (to boxs) that other sections of code may call to find
  412. ;;; out about or modify the connection structure of boxs and rows:
  413. ;;;
  414. ;;; :LENGTH-IN-ROWS
  415. ;;; :LENGTH-IN-CHAS
  416. ;;; :ROW-AT-ROW-NO
  417. ;;; :ROW-ROW-NO
  418. ;;; 
  419. ;;; :ROWS
  420. ;;; 
  421. ;;; :INSERT-ROW-AT-ROW-NO
  422. ;;; :INSERT-BOX-ROWS-AT-ROW-NO
  423. ;;; :DELETE-ROW-AT-ROW-NO
  424. ;;; :DELETE-ROWS-BETWEEN-ROW-NOS
  425. ;;; :KILL-ROWS-AT-ROW-NO
  426. ;;; 
  427. ;;; :INSERT-ROW-BEFORE-ROW
  428. ;;; :INSERT-ROW-AFTER-ROW
  429. ;;; :INSERT-BOX-ROWS-BEFORE-ROW
  430. ;;; :INSERT-BOX-ROWS-AFTER-ROW
  431. ;;; :DELETE-ROW
  432. ;;; :DELETE-BETWEEN-ROWS
  433. ;;; :KILL-ROW
  434. ;;;
  435. ;;; In additions the macro DO-BOX-ROWS ((<var> <box>) <body>) is defined to be used
  436. ;;; by other sections of code to iterate through a box's rows.
  437.  
  438.  
  439. (DEFGET-METHOD (ROW :SUPERIOR-BOX) SUPERIOR-BOX)
  440. (DEFSET-METHOD (ROW :SET-SUPERIOR-BOX) SUPERIOR-BOX)
  441.  
  442. (DEFMACRO DO-BOX-ROWS (((VAR BOX) . OTHER-DO-VARS) &BODY BODY)
  443.   `(DO ((,VAR (TELL ,BOX :FIRST-INFERIOR-ROW) (TELL ,VAR :NEXT-ROW))
  444.     . ,OTHER-DO-VARS)
  445.        ((NULL ,VAR))
  446.      . ,BODY))
  447.  
  448. (DEFMETHOD (BOX :LENGTH-IN-ROWS) ()
  449.   (DO ((ROW FIRST-INFERIOR-ROW (TELL ROW :NEXT-ROW))
  450.        (LENGTH 0 (+ LENGTH 1)))
  451.       ((NULL ROW) LENGTH)))
  452.  
  453. (DEFMETHOD (BOX :LAST-INFERIOR-ROW) ()
  454.   (CAR (LAST (TELL SELF :ROWS))))
  455.  
  456. (DEFMETHOD (BOX :LENGTH-IN-CHAS) ()
  457.   (WITH-SUMMATION
  458.     (DO-BOX-ROWS ((ROW SELF)) (SUM (TELL ROW :LENGTH-IN-CHAS)))))
  459.  
  460. (DEFMETHOD (BOX :ROW-AT-ROW-NO) (ROW-NO)
  461.   (UNLESS (MINUSP ROW-NO)
  462.     (DO ((ROW FIRST-INFERIOR-ROW (TELL ROW :NEXT-ROW))
  463.      (I ROW-NO (- I 1)))
  464.     ((OR (NULL ROW) (< I 1)) ROW))))
  465.  
  466. (DEFMETHOD (BOX :ROW-ROW-NO) (ROW)
  467.   (DO ((INF-ROW  (TELL SELF :FIRST-INFERIOR-ROW) (TELL INF-ROW :NEXT-ROW))
  468.        (ROW-NO 0 (+ ROW-NO 1)))
  469.       ((NULL INF-ROW))
  470.     (WHEN (EQ INF-ROW ROW)
  471.       (RETURN ROW-NO))))
  472.  
  473. (DEFMETHOD (BOX :ROWS) ()
  474.   (OR CACHED-ROWS (TELL SELF :CACHE-ROWS)))
  475.  
  476. (DEFMETHOD (BOX :CACHE-ROWS) ()
  477.   (SETQ CACHED-ROWS (WITH-COLLECTION (DO-BOX-ROWS ((ROW SELF)) (COLLECT ROW)))))
  478.  
  479. (DEFMETHOD (BOX :INSERT-ROW-AT-ROW-NO) (ROW ROW-NO)
  480.   (LET ((ROW-AT-ROW-NO (TELL SELF :ROW-AT-ROW-NO ROW-NO))
  481.     (ROW-BEFORE-ROW-NO (TELL SELF :ROW-AT-ROW-NO (- ROW-NO 1))))
  482.     (TELL ROW :SET-SUPERIOR-BOX SELF)
  483.     (TELL ROW :SET-PREVIOUS-ROW ROW-BEFORE-ROW-NO)
  484.     (TELL ROW :SET-NEXT-ROW ROW-AT-ROW-NO)
  485.     (IF (NULL ROW-BEFORE-ROW-NO)
  486.     (TELL SELF :SET-FIRST-INFERIOR-ROW ROW)
  487.     (TELL ROW-BEFORE-ROW-NO :SET-NEXT-ROW ROW))
  488.     (TELL-CHECK-NIL ROW-AT-ROW-NO :SET-PREVIOUS-ROW ROW)))
  489.  
  490. (DEFMETHOD (BOX :DELETE-ROW-AT-ROW-NO) (POS)
  491.   ;; It is really convenient to be able to assume
  492.   ;; that each box has at least one row in it.
  493.   (UNLESS (= (TELL SELF :LENGTH-IN-ROWS) 1)
  494.     (LET* ((ROW (TELL SELF :ROW-AT-ROW-NO POS))
  495.        (ROW-PREV-ROW (TELL-CHECK-NIL ROW :PREVIOUS-ROW))
  496.        (ROW-NEXT-ROW (TELL-CHECK-NIL ROW :NEXT-ROW)))
  497.       (TELL-CHECK-NIL ROW :SET-SUPERIOR-BOX NIL)
  498.       (TELL-CHECK-NIL ROW :SET-PREVIOUS-ROW NIL)
  499.       (TELL-CHECK-NIL ROW :SET-NEXT-ROW NIL)
  500.       (IF (EQ ROW FIRST-INFERIOR-ROW)
  501.       (SETQ FIRST-INFERIOR-ROW ROW-NEXT-ROW)
  502.       (TELL-CHECK-NIL ROW-PREV-ROW :SET-NEXT-ROW ROW-NEXT-ROW))
  503.       (TELL-CHECK-NIL ROW-NEXT-ROW :SET-PREVIOUS-ROW ROW-PREV-ROW))))
  504.  
  505. (DEFMETHOD (BOX :INSERT-BOX-ROWS-AT-ROW-NO) (BOX ROW-NO)
  506.   (LET ((BOX-FIRST-ROW (TELL BOX :KILL-ROW (TELL BOX :FIRST-ROW))))
  507.     (UNLESS (NULL BOX-FIRST-ROW)
  508.       (LET ((ROW-AT-ROW-NO (TELL SELF :ROW-AT-ROW-NO ROW-NO))
  509.         (ROW-BF-ROW-NO (TELL SELF :ROW-AT-ROW-NO (- ROW-NO 1)))
  510.         (BOX-LAST-ROW (DO* ((NEXT-BOX-ROW (TELL BOX-FIRST-ROW :NEXT-ROW)
  511.                           (TELL BOX-ROW :NEXT-ROW))
  512.                 (BOX-ROW BOX-FIRST-ROW NEXT-BOX-ROW))
  513.                    (())
  514.                 (TELL BOX-ROW :SET-SUPERIOR-BOX SELF)
  515.                 (IF (NULL NEXT-BOX-ROW) (RETURN BOX-ROW)))))
  516.     (TELL BOX-FIRST-ROW :SET-PREVIOUS-ROW ROW-BF-ROW-NO)
  517.     (TELL BOX-LAST-ROW :SET-NEXT-ROW ROW-AT-ROW-NO)
  518.     (TELL-CHECK-NIL ROW-BF-ROW-NO :SET-NEXT-ROW BOX-FIRST-ROW)
  519.     (TELL-CHECK-NIL ROW-AT-ROW-NO :SET-PREVIOUS-ROW BOX-LAST-ROW)))))
  520.  
  521. (DEFMETHOD (BOX :DELETE-ROWS-BETWEEN-ROW-NOS) (STRT-ROW-NO STOP-ROW-NO)
  522.   (LET* ((STRT-ROW (TELL SELF :ROW-AT-ROW-NO STRT-ROW-NO))
  523.      (STOP-ROW (TELL SELF :ROW-AT-ROW-NO STOP-ROW-NO))
  524.      (STRT-ROW-PREV-ROW (TELL-CHECK-NIL STRT-ROW :PREVIOUS-ROW))
  525.      (STOP-ROW-NEXT-ROW (TELL-CHECK-NIL STOP-ROW :NEXT-ROW))
  526.      (RETURN-BOX (MAKE-INITIALIZED-BOX)))
  527.     (DO ((ROW STRT-ROW (TELL ROW :NEXT-ROW)))
  528.     ((NULL ROW))
  529.       (TELL ROW :SET-SUPERIOR-BOX NIL))
  530.     (TELL STRT-ROW :SET-PREVIOUS-ROW NIL)
  531.     (TELL STRT-ROW :SET-NEXT-ROW NIL)
  532.     (IF (NULL STRT-ROW-PREV-ROW)
  533.     (TELL SELF :SET-FIRST-INFERIOR-ROW STOP-ROW-NEXT-ROW)
  534.     (TELL STRT-ROW-PREV-ROW :SET-NEXT-ROW STOP-ROW-NEXT-ROW))
  535.     (TELL-CHECK-NIL STOP-ROW-NEXT-ROW :SET-PREVIOUS-ROW STRT-ROW-PREV-ROW)
  536.     (TELL RETURN-BOX :APPEND-ROW STRT-ROW)
  537.     RETURN-BOX))
  538.  
  539. (DEFMETHOD (BOX :DELETE-BETWEEN-ROWS) (STRT-ROW STOP-ROW)
  540.   (LET ((STRT-ROW-PREV-ROW (TELL-CHECK-NIL STRT-ROW :PREVIOUS-ROW))
  541.     (STOP-ROW-NEXT-ROW (TELL-CHECK-NIL STOP-ROW :NEXT-ROW))
  542.     (RETURN-BOX (MAKE-INITIALIZED-BOX)))
  543.     (DO ((ROW STRT-ROW (TELL ROW :NEXT-ROW)))
  544.     ((EQ ROW STOP-ROW-NEXT-ROW))
  545.       (TELL ROW :SET-SUPERIOR-BOX NIL))
  546.     (TELL STRT-ROW :SET-PREVIOUS-ROW NIL)
  547.     (TELL STOP-ROW :SET-NEXT-ROW NIL)
  548.     (IF (NULL STRT-ROW-PREV-ROW)
  549.     (TELL SELF :SET-FIRST-INFERIOR-ROW STOP-ROW-NEXT-ROW)
  550.     (TELL STRT-ROW-PREV-ROW :SET-NEXT-ROW STOP-ROW-NEXT-ROW))
  551.     (TELL-CHECK-NIL STOP-ROW-NEXT-ROW :SET-PREVIOUS-ROW STRT-ROW-PREV-ROW)
  552.     (TELL RETURN-BOX :SET-FIRST-INFERIOR-ROW STRT-ROW)
  553.     RETURN-BOX))
  554.  
  555. (DEFMETHOD (BOX :KILL-ROWS-AT-ROW-NO) (STRT-ROW-NO)
  556.   (LET ((STOP-ROW-NO (TELL SELF :LENGTH-IN-ROWS)))
  557.     (TELL SELF :DELETE-ROWS-BETWEEN-ROW-NOS STRT-ROW-NO STOP-ROW-NO)))
  558.  
  559.  
  560.  
  561. ;;; Operations that take existing box rows as position specifiers. These
  562. ;;; operations are built on top of the operations that take row positions
  563. ;;; as position specifiers.
  564.  
  565. (DEFMETHOD (BOX :INSERT-ROW-BEFORE-ROW) (ROW BEFORE-ROW)
  566.   (LET ((BEFORE-ROW-ROW-NO (TELL SELF :ROW-NO-OF-INFERIOR-ROW BEFORE-ROW)))
  567.     (TELL SELF :INSERT-ROW-AT-ROW-NO ROW BEFORE-ROW-ROW-NO)))
  568.  
  569. (DEFMETHOD (BOX :INSERT-ROW-AFTER-ROW) (ROW AFTER-ROW)
  570.   (LET ((AFTER-ROW-ROW-NO (TELL SELF :ROW-ROW-NO AFTER-ROW)))
  571.     (TELL SELF :INSERT-ROW-AT-ROW-NO ROW (+ AFTER-ROW-ROW-NO 1))))
  572.  
  573. (DEFMETHOD (BOX :APPEND-ROW) (ROW)
  574.   (TELL SELF :INSERT-ROW-AT-ROW-NO ROW (TELL SELF :LENGTH-IN-ROWS)))
  575.  
  576. (DEFMETHOD (BOX :DELETE-ROW) (ROW)
  577.   (LET ((ROW-ROW-NO (TELL SELF :ROW-ROW-NO ROW)))
  578.     (UNLESS (NULL ROW-ROW-NO)
  579.       (TELL SELF :DELETE-ROW-AT-ROW-NO ROW-ROW-NO))))
  580.  
  581. (DEFMETHOD (BOX :KILL-ROW) (ROW)
  582.   (TELL SELF :KILL-ROWS-AT-ROW-NO (TELL SELF :ROW-ROW-NO ROW)))
  583.  
  584.  
  585.  
  586. (DEFMACRO ACTION-AT-BP-INTERNAL (&BODY DO-ACTION-FORM)
  587.   `(LET ((OLD-BP-TYPE (BP-TYPE BP)))
  588.      (UNWIND-PROTECT
  589.        (PROGN (SETF (BP-TYPE BP) (IF FORCE-BP-TYPE FORCE-BP-TYPE OLD-BP-TYPE))
  590.           . ,DO-ACTION-FORM)
  591.        (SETF (BP-TYPE BP) OLD-BP-TYPE))))
  592.  
  593. (DEFUN INSERT-CHA (BP CHA &OPTIONAL (FORCE-BP-TYPE NIL))
  594.   (ACTION-AT-BP-INTERNAL
  595.     (TELL (BP-ROW BP) :INSERT-CHA-AT-CHA-NO CHA (BP-CHA-NO BP))))
  596.  
  597. (DEFUN INSERT-ROW-CHAS (BP ROW &OPTIONAL (FORCE-BP-TYPE NIL))
  598.   (ACTION-AT-BP-INTERNAL
  599.     (TELL (BP-ROW BP) :INSERT-ROW-CHAS-AT-CHA-NO ROW (BP-CHA-NO BP))))
  600.  
  601. (DEFUN INSERT-ROW (BP ROW &OPTIONAL (FORCE-BP-TYPE NIL))
  602.   (ACTION-AT-BP-INTERNAL
  603.     (LET* ((BP-BOX (BP-BOX BP))
  604.        (BP-ROW (BP-ROW BP))
  605.        (BP-ROW-ROW-NO (TELL BP-BOX :ROW-ROW-NO BP-ROW))
  606.        (TEMP-ROW (DELETE-CHAS-TO-END-OF-ROW BP FORCE-BP-TYPE)))
  607.       (TELL BP-BOX :INSERT-ROW-AT-ROW-NO ROW (+ BP-ROW-ROW-NO 1))
  608.       (MOVE-POINT (ROW-LAST-BP-VALUES ROW))
  609.       (INSERT-ROW-CHAS BP TEMP-ROW :FIXED))))
  610.  
  611.  
  612.  
  613. (DEFUN SIMPLE-DELETE-CHA (BP &OPTIONAL (FORCE-BP-TYPE NIL))
  614.   (ACTION-AT-BP-INTERNAL
  615.     (TELL (BP-ROW BP) :DELETE-CHA-AT-CHA-NO (BP-CHA-NO BP))))
  616.  
  617. (DEFUN RUBOUT-CHA (BP &OPTIONAL (FORCE-BP-TYPE NIL))
  618.   (ACTION-AT-BP-INTERNAL
  619.     (LET* ((ROW (BP-ROW BP))
  620.        (ROW-NO (TELL-CHECK-NIL (BP-BOX BP) :ROW-ROW-NO ROW))
  621.        (CHA-NO (BP-CHA-NO BP))
  622.        (CHA-TO-DELETE (UNLESS (= CHA-NO 0)
  623.                 (TELL ROW :CHA-AT-CHA-NO (1- CHA-NO)))))
  624.       (COND ((> CHA-NO 0)
  625.          (TELL ROW :DELETE-CHA-AT-CHA-NO (- CHA-NO 1)))
  626.         ((or (name-row? row) (ZEROP ROW-NO)))
  627.         (T
  628.          (LET* ((BOX (BP-BOX BP))
  629.             (PREVIOUS-ROW (TELL BOX :ROW-AT-ROW-NO (- ROW-NO 1)))
  630.             (PREVIOUS-ROW-LENGTH-IN-CHAS (TELL PREVIOUS-ROW :LENGTH-IN-CHAS)))
  631.            (TELL BOX :DELETE-ROW-AT-ROW-NO ROW-NO)
  632.            (TELL PREVIOUS-ROW
  633.              :INSERT-ROW-CHAS-AT-CHA-NO ROW PREVIOUS-ROW-LENGTH-IN-CHAS))))
  634.       CHA-TO-DELETE)))    
  635.  
  636. (DEFUN DELETE-CHA (BP &OPTIONAL (FORCE-BP-TYPE NIL))
  637.   (ACTION-AT-BP-INTERNAL
  638.     (LET* ((ROW (BP-ROW BP))
  639.        (ROW-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS))
  640.        (CHA-NO (BP-CHA-NO BP)))
  641.       (COND ((< CHA-NO ROW-LENGTH-IN-CHAS)
  642.          (TELL ROW :DELETE-CHA-AT-CHA-NO CHA-NO))
  643.         ((TELL ROW :NEXT-ROW)
  644.          (LET* ((BOX (BP-BOX BP))
  645.             (ROW-ROW-NO (TELL BOX :ROW-ROW-NO ROW))
  646.             (ROW-NEXT-ROW (TELL BOX :ROW-AT-ROW-NO (+ ROW-ROW-NO 1))))
  647.            (TELL BOX :DELETE-ROW-AT-ROW-NO (+ ROW-ROW-NO 1))
  648.            (TELL ROW :INSERT-ROW-CHAS-AT-CHA-NO ROW-NEXT-ROW ROW-LENGTH-IN-CHAS)))))))
  649.  
  650. (DEFUN DELETE-CHAS-TO-END-OF-ROW (BP &OPTIONAL (FORCE-BP-TYPE NIL))
  651.   (ACTION-AT-BP-INTERNAL
  652.     (LET ((ROW (BP-ROW BP))
  653.       (CHA-NO (BP-CHA-NO BP)))
  654.       (TELL ROW :KILL-CHAS-AT-CHA-NO CHA-NO))))
  655.  
  656. (DEFUN DELETE-ROWS-TO-END-OF-BOX (BP &OPTIONAL (FORCE-BP-TYPE NIL))
  657.   (ACTION-AT-BP-INTERNAL
  658.     (LET ((BOX (BP-BOX BP))
  659.       (ROW (BP-ROW BP)))
  660.       (UNLESS (NULL BOX)
  661.     (TELL BOX :KILL-ROWS-AT-ROW-NO (+ (TELL BOX :ROW-ROW-NO ROW) 1))))))
  662.  
  663.  
  664.  
  665. ;;;; FIND-LOWEST-COMMON-SUPERIOR-BOX
  666. ;;; This function takes two boxes as its inputs and find the lowest box
  667. ;;; which is a superior of both of those boxes. It is slightly bummed
  668. ;;; for speed since it gets called a fair amount, and I liked the way
  669. ;;; I bummed it.
  670.  
  671. (DEFUN FIND-LOWEST-COMMON-SUPERIOR-BOX (BOX1 BOX2)
  672.   (LET ((MARK-THIS-PASS (GENSYM)))
  673.     (DO ((BOX1 BOX1 (TELL BOX1 :SUPERIOR-BOX))
  674.      (BOX2 BOX2 (TELL BOX2 :SUPERIOR-BOX)))
  675.     (())
  676.       (COND ((EQ BOX1 BOX2)
  677.          (RETURN BOX1))
  678.         ((EQ (TELL BOX1 :GET ':LOWEST-COMMON-SUPERIOR-MARK) MARK-THIS-PASS)
  679.          (RETURN BOX1))
  680.         ((EQ (TELL BOX2 :GET ':LOWEST-COMMON-SUPERIOR-MARK) MARK-THIS-PASS)
  681.          (RETURN BOX2))
  682.         (T
  683.          (TELL BOX1 :PUTPROP MARK-THIS-PASS ':LOWEST-COMMON-SUPERIOR-MARK)
  684.          (TELL BOX2 :PUTPROP MARK-THIS-PASS ':LOWEST-COMMON-SUPERIOR-MARK))))))
  685.  
  686. (DEFUN OBJ-CONTAINS-OBJ? (OUTER INNER)
  687.   (DO ((INNER INNER (TELL INNER :SUPERIOR-OBJ)))
  688.       ((NULL INNER) NIL)
  689.     (COND ((EQ INNER OUTER)
  690.        (RETURN T)))))
  691.  
  692. (DEFUN BOX-CONTAINS-BOX? (OUTER-BOX INNER-BOX)
  693.   (DO ((INNER (TELL INNER-BOX :SUPERIOR-BOX) (TELL INNER :SUPERIOR-BOX)))
  694.       ((NULL INNER) NIL)
  695.     (AND (EQ INNER OUTER-BOX)
  696.      (RETURN T))))
  697.  
  698. (DEFUN LEVEL-OF-SUPERIORITY (OUTER-BOX INNER-BOX)
  699.   (DO ((I 0 (1+ I))
  700.        (BOX INNER-BOX (TELL BOX :SUPERIOR-BOX)))
  701.       ((OR (NULL BOX) (EQ BOX OUTER-BOX)) I)))
  702.  
  703. (DEFUN NTH-SUPERIOR-BOX (BOX N)
  704.   (DO ((I 0 (1+ I))
  705.        (SUPERIOR BOX (TELL SUPERIOR :SUPERIOR-BOX)))
  706.       ((NULL SUPERIOR) NIL)
  707.     (AND (= I N) (RETURN SUPERIOR))))
  708.  
  709.  
  710. ;;;;FIND-PATH
  711.  
  712. ;; The FIND-PATH function is used to find the "path" between two boxes.
  713. ;; It returns two values
  714. ;;  first value   --   Box to throw to
  715. ;;  second value  --   Chain of boxes to enter
  716. ;; Note that either of these values can be NIL.
  717. ;;
  718. ;; Example:
  719. ;;
  720. ;; +-------------------------------------------------+
  721. ;; | call this box TOP                               |
  722. ;; |                                                 |
  723. ;; | +------------------+     +------------------+   |
  724. ;; | | call this box A1 |     | call this box B1 |   |
  725. ;; | |                  |     |                  |   |
  726. ;; | | +--------------+ |     | +--------------+ |   |
  727. ;; | | |call this A2  | |     | | call this B2 | |   |
  728. ;; | | |              | |     | |              | |   |
  729. ;; | | | +----------+ | |     | | +----------+ | |   |
  730. ;; | | | | this A3  | | |     | | | this B3  | | |   |
  731. ;; | | | |          | | |     | | |          | | |   |
  732. ;; | | | +----------+ | |     | | +----------+ | |   |
  733. ;; | | +--------------+ |     | +--------------+ |   |
  734. ;; | +------------------+     +------------------+   |
  735. ;; +-------------------------------------------------+
  736. ;;
  737. ;; (FIND-PATH A3 TOP)  -->  TOP  NIL
  738. ;; (FIND-PATH TOP A3)  -->  NIL  (A1 A2 A3)
  739. ;; (FIND-PATH A3 B3)   -->  TOP  (B1 B2 B3)
  740. ;; (FIND-PATH A3 A3)   -->  NIL  NIL
  741.  
  742. (DEFUN FIND-PATH (FROM-BOX TO-BOX)
  743.   (DECLARE (VALUES BOX-TO-THROW-TO DOWNWARD-ENTRY-CHAIN))
  744.   (COND ((EQ FROM-BOX TO-BOX)
  745.      (VALUES NIL
  746.          NIL))
  747.     ((BOX-CONTAINS-BOX? TO-BOX FROM-BOX)
  748.      (VALUES TO-BOX
  749.          NIL))
  750.     ((BOX-CONTAINS-BOX? FROM-BOX TO-BOX)
  751.      (VALUES NIL
  752.          (FIND-PATH-FROM-SUPERIOR-TO-INFERIOR FROM-BOX TO-BOX)))
  753.     (T
  754.      (LET ((LOWEST-COMMON-SUPERIOR-BOX (FIND-LOWEST-COMMON-SUPERIOR-BOX FROM-BOX TO-BOX)))
  755.        (VALUES LOWEST-COMMON-SUPERIOR-BOX
  756.            (FIND-PATH-FROM-SUPERIOR-TO-INFERIOR LOWEST-COMMON-SUPERIOR-BOX TO-BOX))))))
  757.  
  758. (DEFUN FIND-PATH-FROM-SUPERIOR-TO-INFERIOR (SUPERIOR-BOX INFERIOR-BOX)
  759.   (NREVERSE
  760.     (WITH-COLLECTION
  761.       (DO ((BOX INFERIOR-BOX (TELL BOX :SUPERIOR-BOX)))
  762.       ((EQ BOX SUPERIOR-BOX))
  763.     (COLLECT BOX)))))
  764.  
  765. (DEFUN SEND-EXIT-MESSAGES (DESTINATION-BOX DESTINATION-SCREEN-BOX &optional(one-step-up? nil))
  766.   (LET ((CURRENT-BOX (POINT-BOX)))
  767.     (COND ((EQ (FIND-LOWEST-COMMON-SUPERIOR-BOX CURRENT-BOX DESTINATION-BOX)
  768.            CURRENT-BOX)
  769.        NIL)
  770.       ((TELL DESTINATION-SCREEN-BOX :SUPERIOR? (POINT-SCREEN-BOX)) NIL)
  771.       (T (TELL CURRENT-BOX :EXIT 
  772.            (tell (BP-SCREEN-BOX *POINT*) :superior-screen-box)
  773.            (tell current-box :superior-box)
  774.            one-step-up?)
  775.          (SEND-EXIT-MESSAGES DESTINATION-BOX DESTINATION-SCREEN-BOX)))))
  776.   
  777.  
  778.  
  779. ;; Needs these to keep reDisplay code alive.
  780.  
  781. (DEFMETHOD (ROW :FIRST-INFERIOR-OBJ) ()
  782.   (TELL SELF :CHA-AT-CHA-NO 0))
  783.  
  784. (DEFMETHOD (CHA :NEXT-OBJ) ()
  785.   (TELL SUPERIOR-ROW :CHA-AT-CHA-NO (+ (TELL SUPERIOR-ROW :CHA-CHA-NO SELF) 1)))
  786.  
  787. (DEFMETHOD (BOX :FIRST-INFERIOR-OBJ) ()
  788.   FIRST-INFERIOR-ROW)
  789.  
  790. (DEFMETHOD (ROW :NEXT-OBJ) ()
  791.   NEXT-ROW)
  792.  
  793. ;;;these are messages to boxes which are used for moving up and down levels
  794. ;;;in box structures
  795.  
  796. (DEFMETHOD (BOX :EXIT) (&OPTIONAL (NEW-SCREEN-BOX (TELL (POINT-SCREEN-BOX)
  797.                             :SUPERIOR-SCREEN-BOX))
  798.                   (NEW-ACTUAL-BOX (TELL SELF :SUPERIOR-BOX))
  799.                   IGNORE)
  800.   (COND ((AND (EQ SELF (OUTERMOST-BOX))(NOT (NULL SHRINK-PROOF?))))
  801.     ((EQ SELF (OUTERMOST-BOX))
  802.      (COM-COLLAPSE-BOX SELF)
  803.      (MOVE-POINT (BOX-SELF-BP-VALUES (BOX-SCREEN-POINT-IS-IN)))
  804.      (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*))
  805.      (SET-POINT-SCREEN-BOX NEW-SCREEN-BOX)
  806.      (TELL NEW-ACTUAL-BOX :ENTER (not (eq (tell self :superior-box) 
  807.                           new-actual-box))))
  808.     (T
  809.      (MOVE-POINT (BOX-SELF-BP-VALUES (BOX-SCREEN-POINT-IS-IN)))
  810.      (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*))
  811.      (SET-POINT-SCREEN-BOX NEW-SCREEN-BOX)
  812.      (TELL NEW-ACTUAL-BOX :ENTER (not (eq (tell self :superior-box)
  813.                           new-actual-box))))))
  814.  
  815. (DEFMETHOD (BOX :AFTER :EXIT) (&OPTIONAL IGNORE IGNORE ONE-STEP-UP?)
  816.   (WHEN (SPRITE-BOX? (TELL SELF :SUPERIOR-BOX))
  817.     (TELL SELF :EXIT-FROM-SPRITE-INSTANCE-VAR))
  818.   (COND ((AND (NAME-ROW? NAME) (NULL (GET-BOX-NAME NAME)))
  819.      ;; get rid of the name row if there are no more characters in it
  820.      (tell name :update-bindings) (SETQ NAME NIL) (TELL SELF :MODIFIED))
  821.     ((NAME-ROW? NAME)
  822.      ;; if there is a name row with stuff in it, make sure the binding info is updated
  823.      (TELL NAME :UPDATE-BINDINGS)))
  824.   (when (and one-step-up? (eq exit-trigger-flag 'enabled))
  825.        (tell self :do-trigger-exit-stuff)))
  826.  
  827. (DEFMETHOD (LL-BOX :BEFORE :EXIT) (&rest ignore)
  828.   (LET* ((SUPERIOR-BOX (TELL SELF :SUPERIOR-BOX))
  829.      (BINDING (RASSQ SELF (TELL SUPERIOR-BOX :GET-STATIC-VARIABLES-ALIST))))
  830.     (UNLESS (EQ (CAR BINDING) *EXPORTING-BOX-MARKER*)
  831.       (TELL SUPERIOR-BOX :ADD-STATIC-VARIABLE-PAIR *EXPORTING-BOX-MARKER* SELF))))
  832.  
  833. (DEFMETHOD (POP-UP-BOX-MIXIN :AFTER :EXIT) (&REST IGNORE)
  834.   (TELL (TELL SELF :SUPERIOR-ROW) :DELETE-CHA SELF))    ;Make the box go away
  835.  
  836. (DEFMETHOD (BOX :GET-SHRINK-PROOF?)()
  837.   SHRINK-PROOF?)
  838.  
  839. (DEFMETHOD (BOX :SET-SHRINK-PROOF?)(VAL)
  840.   (SETQ SHRINK-PROOF? VAL))
  841.  
  842.