;;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Base:10.; Fonts:cptfont -*- ;;; ;;; (C) Copyright 1982-1985 Massachusetts Institute of Technology ;;; ;;; Permission to use, copy, modify, distribute, and sell this software ;;; and its documentation for any purpose is hereby granted without fee, ;;; provided that the above copyright notice appear in all copies and that ;;; both that copyright notice and this permission notice appear in ;;; supporting documentation, and that the name of M.I.T. not be used in ;;; advertising or publicity pertaining to distribution of the software ;;; without specific, written prior permission. M.I.T. makes no ;;; representations about the suitability of this software for any ;;; purpose. It is provided "as is" without express or implied warranty. ;;; ;;; ;;; This file is part of the BOXER system. ;;; ;;; This file contains low-level code which deals with the inferior/superior ;;; relations between primitive Boxer objects. These relations include the ;;; connection/disconnection of primitive Boxer objects from their superiors ;;; and from groups of co-inferiors. ;;; Rows have a fairly hairy scheme for keeping track of their chas, the order ;;; they are in etc. The main data structure used to implement this scheme is ;;; the CHAS-ARRAY. Chas-Arrays are just what their name says, arrays of chas. ;;; In addition chas-arrays keep track of all the BPs that point to the chas ;;; in them so that whenever there is a change to a chas-array, those bps can ;;; be updated to account for the change. One way of thinking of chas-arrays ;;; is as Lispm Strings which are just arrays of Lispm character codes. (DEFVAR *CHAS-ARRAY-DEFAULT-SIZE* 30.) (DEFVAR *CHAS-ARRAY-DEFUALT-SIZE-QUANTUM* 10.) (DEFSTRUCT (CHAS-ARRAY (:TYPE :NAMED-ARRAY-LEADER) (:MAKE-ARRAY (:DIMENSIONS *CHAS-ARRAY-DEFAULT-SIZE*) (:TYPE 'ART-Q)) :CONC-NAME) (ACTIVE-LENGTH 0) (BPS NIL) ) (DEFTYPE-CHECKING-MACROS CHAS-ARRAY "a chas-array") (DEFUN CHECK-CHAS-ARRAY-OLD-CHA-NO-ARG (CHAS-ARRAY ARG) (CHECK-CHAS-ARRAY-ARG CHAS-ARRAY) (LET ((ACTIVE-LENGTH (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) (COND ((AND (FIXNUMP ARG) (>= ARG 0) (< ARG ACTIVE-LENGTH))) (T (BARF 'SI:WRONG-TYPE-ARGUMENT))))) (DEFUN CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG (CHAS-ARRAY ARG) (CHECK-CHAS-ARRAY-ARG CHAS-ARRAY) (LET ((ACTIVE-LENGTH (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) (COND ((AND (FIXNUMP ARG) (>= ARG 0) (<= ARG ACTIVE-LENGTH))) (T (BARF 'SI:WRONG-TYPE-ARGUMENT))))) (DEFSUBST CHAS-ARRAY-GET-CHA (CHAS-ARRAY CHA-NO) (AREF CHAS-ARRAY CHA-NO)) (DEFSUBST CHAS-ARRAY-SET-CHA (CHAS-ARRAY CHA-NO NEW-VALUE) (ASET NEW-VALUE CHAS-ARRAY CHA-NO)) (DEFSUBST CHAS-ARRAY-ROOM (CHAS-ARRAY) #-LMITI(ARRAY-DIMENSION-N 1 CHAS-ARRAY) #+LMITI(ARRAY-DIMENSION CHAS-ARRAY 0) ) (DEFUN CHAS-ARRAY-ADJUST-ROOM (CHAS-ARRAY DELTA-ROOM) (LET ((OLD-ROOM (CHAS-ARRAY-ROOM CHAS-ARRAY))) (ADJUST-ARRAY-SIZE CHAS-ARRAY (+ OLD-ROOM DELTA-ROOM)))) (DEFUN CHAS-ARRAY-ASSURE-ROOM (CHAS-ARRAY REQUIRED-ROOM) (LET ((DELTA-ROOM (- REQUIRED-ROOM (CHAS-ARRAY-ROOM CHAS-ARRAY)))) (IF (PLUSP DELTA-ROOM) (CHAS-ARRAY-ADJUST-ROOM CHAS-ARRAY DELTA-ROOM) CHAS-ARRAY))) ;;; CHAS-ARRAY-SLIDE-CHAS the primitive function that functions which need to ;;; slide chas around in a chas-array should call. This function takes care of ;;; adjusting the BPs that point to the chas-array to compensate for the slide. ;;; This function also takes care of assuring that there is enough room in the ;;; chas-array to perform the slide. Like all functions which may need to make ;;; a new chas-array, chas-array-slide-chas always returns the (new) chas-array. (DEFUN CHAS-ARRAY-SLIDE-CHAS (CHAS-ARRAY STRT-CHA-NO DISTANCE) (LET ((OLD-ACTIVE-LENGTH (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) (CHAS-ARRAY-ASSURE-ROOM CHAS-ARRAY (+ OLD-ACTIVE-LENGTH DISTANCE)) (COND ((PLUSP DISTANCE) (CHAS-ARRAY-SLIDE-CHAS-POS CHAS-ARRAY STRT-CHA-NO DISTANCE OLD-ACTIVE-LENGTH)) ((MINUSP DISTANCE) (CHAS-ARRAY-SLIDE-CHAS-NEG CHAS-ARRAY STRT-CHA-NO DISTANCE OLD-ACTIVE-LENGTH))) (CHAS-ARRAY-SLIDE-BPS CHAS-ARRAY STRT-CHA-NO DISTANCE))) (DEFUN CHAS-ARRAY-SLIDE-CHAS-POS (CHAS-ARRAY STRT-CHA-NO DISTANCE OLD-ACTIVE-LENGTH) (DO ((ORIG-CHA-NO (- OLD-ACTIVE-LENGTH 1) (- ORIG-CHA-NO 1))) ((< ORIG-CHA-NO STRT-CHA-NO)) (CHAS-ARRAY-SET-CHA CHAS-ARRAY (+ ORIG-CHA-NO DISTANCE) (CHAS-ARRAY-GET-CHA CHAS-ARRAY ORIG-CHA-NO)))) (DEFUN CHAS-ARRAY-SLIDE-CHAS-NEG (CHAS-ARRAY STRT-CHA-NO DISTANCE OLD-ACTIVE-LENGTH) (DO ((ORIG-CHA-NO STRT-CHA-NO (+ ORIG-CHA-NO 1))) ((>= ORIG-CHA-NO OLD-ACTIVE-LENGTH)) (CHAS-ARRAY-SET-CHA CHAS-ARRAY (+ ORIG-CHA-NO DISTANCE) (CHAS-ARRAY-GET-CHA CHAS-ARRAY ORIG-CHA-NO)))) (DEFUN CHAS-ARRAY-SLIDE-BPS (CHAS-ARRAY STRT-CHA-NO DISTANCE) (DOLIST (BP (CHAS-ARRAY-BPS CHAS-ARRAY)) (COND ((OR (> (BP-CHA-NO BP) STRT-CHA-NO) (AND (= (BP-CHA-NO BP) STRT-CHA-NO) (EQ (BP-TYPE BP) ':MOVING))) (INCF (BP-CHA-NO BP) DISTANCE))))) ;;; CHAS-ARRAY-INSERT-CHA-1 is an internal function used by all of the ;;; functions which insert chas into a chas-array. Functions which want ;;; to call this function must have taken care of sliding the chas from ;;; the insert position on out of the way, and must alos take care of ;;; updating the chas-array's active-length. This exists as a seperate ;;; function so that functions which do multiple insert-chas can avoid ;;; multiple calls to chas-array-slide-chas (DEFSUBST CHAS-ARRAY-INSERT-CHA-1 (INTO-CHAS-ARRAY CHA-NO CHA) (CHAS-ARRAY-SET-CHA INTO-CHAS-ARRAY CHA-NO CHA)) ;;; CHAS-ARRAY-INSERT-CHA is the correct function to call to insert a ;;; cha into a chas array. It does everything that needs to be done, ;;; specifically: ;;; - It type checks the chas-array and the cha-no. ;;; - It slides the chas following the insert point out ;;; of the way. ;;; - It makes the correct call to chas-array-insert-cha-1. ;;; - It icrements the chas-array's active length. (DEFUN CHAS-ARRAY-INSERT-CHA (INTO-CHAS-ARRAY CHA-NO CHA) (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG INTO-CHAS-ARRAY CHA-NO) (CHAS-ARRAY-SLIDE-CHAS INTO-CHAS-ARRAY CHA-NO 1) (CHAS-ARRAY-INSERT-CHA-1 INTO-CHAS-ARRAY CHA-NO CHA) (INCF (CHAS-ARRAY-ACTIVE-LENGTH INTO-CHAS-ARRAY) 1)) ;;; CHAS-ARRAY-DELETE-CHA is the correct function to call to delete a ;;; cha from a chas-array. It does everything that needs to be done, ;;; specifically: ;;; - It type checks the chas-array, and the cha-no. ;;; - It slides the chas following the delete point over ;;; to delete that cha. ;;; - It tells the cha about its new-superior-row. ;;; - It decrements the chas-array's active-length. (DEFUN CHAS-ARRAY-DELETE-CHA (FROM-CHAS-ARRAY CHA-NO) (CHECK-CHAS-ARRAY-OLD-CHA-NO-ARG FROM-CHAS-ARRAY CHA-NO) (CHAS-ARRAY-SLIDE-CHAS FROM-CHAS-ARRAY (+ CHA-NO 1) -1) (DECF (CHAS-ARRAY-ACTIVE-LENGTH FROM-CHAS-ARRAY) 1)) ;;; CHAS-ARRAY-MOVE-CHAS is the fundamental function used to move chas ;;; from one chas-array to another chas-array. This function takes care ;;; of doing everything that needs to be done when moving groups of chas ;;; from one chas-array to another chas-array, specifically: ;;; - It type checks both chas-arrays, and the cha-nos ;;; in those arrays. ;;; - It takes care of moving the chas, and adjusting the ;;; active-lengths of the two chas-arrays. ;;; - It takes care of moving and adjusting the BPs that ;;; pointed to the moved chas. (DEFUN CHAS-ARRAY-MOVE-CHAS (FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STRT-CHA-NO INTO-CHAS-ARRAY INTO-CHAS-ARRAY-STRT-CHA-NO NO-OF-CHAS-TO-MOVE SUPERIOR-ROW) (LET ((FROM-CHAS-ARRAY-STOP-CHA-NO (+ FROM-CHAS-ARRAY-STRT-CHA-NO NO-OF-CHAS-TO-MOVE))) ;; First we be real good and check all our args like we promised. (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STRT-CHA-NO) (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STOP-CHA-NO) (CHECK-CHAS-ARRAY-NEW-CHA-NO-ARG INTO-CHAS-ARRAY INTO-CHAS-ARRAY-STRT-CHA-NO) (CHAS-ARRAY-SLIDE-CHAS INTO-CHAS-ARRAY INTO-CHAS-ARRAY-STRT-CHA-NO NO-OF-CHAS-TO-MOVE) (DOTIMES (CHA-NO NO-OF-CHAS-TO-MOVE) (LET ((FROM-CHA-NO (+ FROM-CHAS-ARRAY-STRT-CHA-NO CHA-NO)) (INTO-CHA-NO (+ INTO-CHAS-ARRAY-STRT-CHA-NO CHA-NO))) (CHAS-ARRAY-INSERT-CHA-1 INTO-CHAS-ARRAY INTO-CHA-NO (CHAS-ARRAY-GET-CHA FROM-CHAS-ARRAY FROM-CHA-NO)))) (CHAS-ARRAY-SLIDE-CHAS FROM-CHAS-ARRAY FROM-CHAS-ARRAY-STOP-CHA-NO (- NO-OF-CHAS-TO-MOVE)) (INCF (CHAS-ARRAY-ACTIVE-LENGTH INTO-CHAS-ARRAY) NO-OF-CHAS-TO-MOVE) (DECF (CHAS-ARRAY-ACTIVE-LENGTH FROM-CHAS-ARRAY) NO-OF-CHAS-TO-MOVE) (DOLIST (BP (CHAS-ARRAY-BPS FROM-CHAS-ARRAY)) (LET ((BP-CHA-NO (BP-CHA-NO BP))) (COND ((OR (AND (> BP-CHA-NO FROM-CHAS-ARRAY-STRT-CHA-NO) (< BP-CHA-NO (- FROM-CHAS-ARRAY-STOP-CHA-NO 1))) (AND (= BP-CHA-NO FROM-CHAS-ARRAY-STRT-CHA-NO) (EQ (BP-TYPE BP) ':MOVING))) (MOVE-BP-1 BP SUPERIOR-ROW (+ INTO-CHAS-ARRAY-STRT-CHA-NO (- BP-CHA-NO FROM-CHAS-ARRAY-STRT-CHA-NO))))))))) ;;; Methods that support the interaction between rows and BP's. (DEFMETHOD (ROW :BPS) () (CHAS-ARRAY-BPS CHAS-ARRAY)) (DEFMETHOD (ROW :SET-BPS) (NEW-VALUE) (CHECK-ARG NEW-VALUE '(LAMBDA (X) (AND (LISTP X) (EVERY X 'BP?))) "A list of Boxer BP's") (SETF (CHAS-ARRAY-BPS CHAS-ARRAY) NEW-VALUE)) (DEFMETHOD (ROW :ADD-BP) (BP) (CHECK-BP-ARG BP) (UNLESS (MEMQ BP (CHAS-ARRAY-BPS CHAS-ARRAY)) (PUSH BP (CHAS-ARRAY-BPS CHAS-ARRAY)))) (DEFMETHOD (ROW :DELETE-BP) (BP) (CHECK-BP-ARG BP) (SETF (CHAS-ARRAY-BPS CHAS-ARRAY) (DELETE BP (CHAS-ARRAY-BPS CHAS-ARRAY)))) ;;; These are the messages (to rows) that other sections of code may call to find ;;; out about or modify the connection structure of rows and chas: ;;; ;;; :LENGTH-IN-CHAS ;;; :CHA-AT-CHA-NO ;;; :CHA-CHA-NO ;;; ;;; :CHAS ;;; ;;; :INSERT-CHA-AT-CHA-NO ;;; :INSERT-ROW-CHAS-AT-CHA-NO ;;; :DELETE-CHA-AT-CHA-NO ;;; :DELETE-CHAS-BETWEEN-CHA-NOS ;;; :KILL-CHAS-AT-CHA-NO ;;; ;;; :INSERT-CHA-BEFORE-CHA ;;; :INSERT-CHA-AFTER-CHA ;;; :INSERT-ROW-CHAS-BEFORE-CHA ;;; :INSERT-ROW-CHAS-AFTER-CHA ;;; :DELETE-CHA ;;; :DELETE-BETWEEN-CHAS ;;; :KILL-CHA ;;; ;;; In additions the macro DO-ROW-CHAS (( ) ) is defined to be used ;;; by other sections of code to iterate through a row's chas. (DEFGET-METHOD (ROW :CHAS-ARRAY) CHAS-ARRAY) (DEFSET-METHOD (ROW :SET-CHAS-ARRAY) CHAS-ARRAY) (DEFMACRO DO-ROW-CHAS (((VAR ROW) . OTHER-DO-VARS) &BODY BODY) `(LET* ((.CHAS-ARRAY. (TELL ,ROW :CHAS-ARRAY)) (.ACTIVE-LENGTH. (CHAS-ARRAY-ACTIVE-LENGTH .CHAS-ARRAY.))) (LET ((,VAR NIL)) ;Note that there is a (DO ((.CHA-NO. 0 (+ .CHA-NO. 1)) ;good reason for using . ,OTHER-DO-VARS) ;this weird ((>= .CHA-NO. .ACTIVE-LENGTH.)) ;(LET ((,VAR NIL)) (SETQ ,VAR (CHAS-ARRAY-GET-CHA .CHAS-ARRAY. .CHA-NO.)) ;(SETQ ,VAR ) . ,BODY)))) ;form, it makes it look ;more like a real DO. (DEFMETHOD (ROW :LENGTH-IN-CHAS) () (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY)) (DEFMETHOD (ROW :CHA-AT-CHA-NO) (N) (COND ((OR (< N 0) (>= N (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) NIL) (T (CHAS-ARRAY-GET-CHA CHAS-ARRAY N)))) ;;; this is useful for changing case and fonts and such (DEFMETHOD (ROW :CHANGE-CHA-AT-CHA-NO) (N NEW-CHA) (COND ((OR (< N 0) (>= N (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) NIL) (T (SETF (CHAS-ARRAY-GET-CHA CHAS-ARRAY N) NEW-CHA) (TELL SELF :MODIFIED)))) (DEFMETHOD (ROW :CHA-CHA-NO) (CHA-TO-GET-CHA-NO-OF) (DO-ROW-CHAS ((CHA SELF) (CHA-NO 0 (+ CHA-NO 1))) (COND ((EQ CHA CHA-TO-GET-CHA-NO-OF) (RETURN CHA-NO))))) (DEFMETHOD (ROW :CHAS) () (OR CACHED-CHAS (TELL SELF :CACHE-CHAS))) (DEFMETHOD (ROW :CACHE-CHAS) () (SETQ CACHED-CHAS (WITH-COLLECTION (DO-ROW-CHAS ((CHA SELF)) (COLLECT CHA))))) (DEFMETHOD (ROW :CHAS-BETWEEN-CHA-NOS) (START &OPTIONAL (STOP (TELL SELF :LENGTH-IN-CHAS))) (LOOP FOR CHA-NO = START THEN (1+ CHA-NO) UNTIL (= CHA-NO STOP) COLLECTING (TELL SELF :CHA-AT-CHA-NO CHA-NO))) (DEFMETHOD (ROW :BOXES-IN-ROW) () (WITH-COLLECTION (DO-ROW-CHAS ((CHA SELF)) (WHEN (BOX? CHA) (COLLECT CHA))))) ;(DEFMETHOD (ROW :ADD-A-BOX) (BOX-TO-BE-ADDED) ; (PUSH BOX-TO-BE-ADDED BOXES)) ;(DEFMETHOD (ROW :ADD-BOXES) (LIST-OF-BOXES) ; (SETQ BOXES (APPEND BOXES LIST-OF-BOXES))) (DEFMETHOD (ROW :BOXES-BETWEEN-CHA-NOS) (STRT-CHA-NO STOP-CHA-NO) (WITH-COLLECTION (DO* ((INDEX STRT-CHA-NO (+ INDEX 1)) (CHA (TELL SELF :CHA-AT-CHA-NO INDEX) (TELL SELF :CHA-AT-CHA-NO INDEX))) ((= INDEX STOP-CHA-NO)) (IF (BOX? CHA) (COLLECT CHA))))) (DEFMETHOD (ROW :INSERT-CHA-AT-CHA-NO) (CHA CHA-NO) (CHAS-ARRAY-INSERT-CHA CHAS-ARRAY CHA-NO CHA) (WHEN (BOX? CHA) (TELL CHA :SET-SUPERIOR-ROW SELF) (tell cha :insert-self-action)) (TELL SELF :MODIFIED)) (defmethod (row :insert-list-of-chas-at-cha-no) (list-of-chas cha-no) (do ((remaining-chas list-of-chas (cdr remaining-chas)) (present-cha-no cha-no (1+ present-cha-no))) ((null remaining-chas)) (tell self :insert-cha-at-cha-no (car remaining-chas) present-cha-no))) (DEFMETHOD (ROW :DELETE-CHA-AT-CHA-NO) (CHA-NO) (LET ((CHA (TELL SELF :CHA-AT-CHA-NO CHA-NO))) (CHAS-ARRAY-DELETE-CHA CHAS-ARRAY CHA-NO) (WHEN (BOX? CHA) (tell cha :delete-self-action)) (TELL SELF :MODIFIED))) (DEFMETHOD (ROW :INSERT-ROW-CHAS-AT-CHA-NO) (ROW CHA-NO) (LET ((ROW-CHAS-ARRAY (TELL ROW :CHAS-ARRAY)) (NEW-BOXES (TELL ROW :BOXES-IN-ROW))) (CHAS-ARRAY-MOVE-CHAS ROW-CHAS-ARRAY 0 CHAS-ARRAY CHA-NO (CHAS-ARRAY-ACTIVE-LENGTH ROW-CHAS-ARRAY) SELF) (DOLIST (NEW-BOX NEW-BOXES) (TELL NEW-BOX :SET-SUPERIOR-ROW SELF) (tell new-box :insert-self-action))) (TELL SELF :MODIFIED)) (DEFMETHOD (ROW :DELETE-CHAS-BETWEEN-CHA-NOS) (STRT-CHA-NO STOP-CHA-NO) (LET* ((RETURN-ROW (MAKE-INITIALIZED-ROW)) (RETURN-ROW-CHAS-ARRAY (TELL RETURN-ROW :CHAS-ARRAY))) (CHAS-ARRAY-MOVE-CHAS CHAS-ARRAY STRT-CHA-NO RETURN-ROW-CHAS-ARRAY 0 (- STOP-CHA-NO STRT-CHA-NO) RETURN-ROW) (TELL SELF :MODIFIED) (TELL RETURN-ROW :MODIFIED) (dolist (box (tell return-row :boxes-in-row)) (tell box :delete-self-action) (tell box :set-superior-row return-row)) RETURN-ROW)) (DEFMETHOD (ROW :KILL-CHAS-AT-CHA-NO) (STRT-CHA-NO) (LET ((STOP-CHA-NO (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) (TELL SELF :DELETE-CHAS-BETWEEN-CHA-NOS STRT-CHA-NO STOP-CHA-NO))) (DEFMETHOD (ROW :INSERT-CHA-BEFORE-CHA) (CHA BEFORE-CHA) (LET ((BEFORE-CHA-CHA-NO (TELL SELF :CHA-CHA-NO BEFORE-CHA))) (TELL SELF :INSERT-CHA-AT-CHA-NO BEFORE-CHA-CHA-NO CHA))) (DEFMETHOD (ROW :INSERT-CHA-AFTER-CHA) (CHA AFTER-CHA) (LET ((AFTER-CHA-CHA-NO (TELL SELF :CHA-CHA-NO AFTER-CHA))) (TELL SELF :INSERT-CHA-AT-CHA-NO CHA (+ AFTER-CHA-CHA-NO 1)))) (DEFMETHOD (ROW :DELETE-CHA) (CHA) (LET ((CHA-CHA-NO (TELL SELF :CHA-CHA-NO CHA))) (UNLESS (NULL CHA-CHA-NO) (TELL SELF :DELETE-CHA-AT-CHA-NO CHA-CHA-NO)))) (DEFMETHOD (ROW :APPEND-CHA) (CHA) (TELL SELF :INSERT-CHA-AT-CHA-NO CHA (CHAS-ARRAY-ACTIVE-LENGTH CHAS-ARRAY))) (defmethod (row :append-list-of-chas)(list-of-chas) (tell self :insert-list-of-chas-at-cha-no list-of-chas (chas-array-active-length chas-array))) ;;; Box rows are kept a doubly linked list. The box points to its first row, ;;; and each row has pointers to its next and previous rows. The first row in ;;; a box has a previous-row pointer of nil, and the last row in a box has a ;;; next row pointer of nil. (DEFGET-METHOD (ROW :PREVIOUS-ROW) PREVIOUS-ROW) (DEFSET-METHOD (ROW :SET-PREVIOUS-ROW) PREVIOUS-ROW) (DEFGET-METHOD (ROW :NEXT-ROW) NEXT-ROW) (DEFSET-METHOD (ROW :SET-NEXT-ROW) NEXT-ROW) (DEFGET-METHOD (BOX :FIRST-INFERIOR-ROW) FIRST-INFERIOR-ROW) (DEFSET-METHOD (BOX :SET-FIRST-INFERIOR-ROW) FIRST-INFERIOR-ROW) ;;; These are the messages (to boxs) that other sections of code may call to find ;;; out about or modify the connection structure of boxs and rows: ;;; ;;; :LENGTH-IN-ROWS ;;; :LENGTH-IN-CHAS ;;; :ROW-AT-ROW-NO ;;; :ROW-ROW-NO ;;; ;;; :ROWS ;;; ;;; :INSERT-ROW-AT-ROW-NO ;;; :INSERT-BOX-ROWS-AT-ROW-NO ;;; :DELETE-ROW-AT-ROW-NO ;;; :DELETE-ROWS-BETWEEN-ROW-NOS ;;; :KILL-ROWS-AT-ROW-NO ;;; ;;; :INSERT-ROW-BEFORE-ROW ;;; :INSERT-ROW-AFTER-ROW ;;; :INSERT-BOX-ROWS-BEFORE-ROW ;;; :INSERT-BOX-ROWS-AFTER-ROW ;;; :DELETE-ROW ;;; :DELETE-BETWEEN-ROWS ;;; :KILL-ROW ;;; ;;; In additions the macro DO-BOX-ROWS (( ) ) is defined to be used ;;; by other sections of code to iterate through a box's rows. (DEFGET-METHOD (ROW :SUPERIOR-BOX) SUPERIOR-BOX) (DEFSET-METHOD (ROW :SET-SUPERIOR-BOX) SUPERIOR-BOX) (DEFMACRO DO-BOX-ROWS (((VAR BOX) . OTHER-DO-VARS) &BODY BODY) `(DO ((,VAR (TELL ,BOX :FIRST-INFERIOR-ROW) (TELL ,VAR :NEXT-ROW)) . ,OTHER-DO-VARS) ((NULL ,VAR)) . ,BODY)) (DEFMETHOD (BOX :LENGTH-IN-ROWS) () (DO ((ROW FIRST-INFERIOR-ROW (TELL ROW :NEXT-ROW)) (LENGTH 0 (+ LENGTH 1))) ((NULL ROW) LENGTH))) (DEFMETHOD (BOX :LAST-INFERIOR-ROW) () (CAR (LAST (TELL SELF :ROWS)))) (DEFMETHOD (BOX :LENGTH-IN-CHAS) () (WITH-SUMMATION (DO-BOX-ROWS ((ROW SELF)) (SUM (TELL ROW :LENGTH-IN-CHAS))))) (DEFMETHOD (BOX :ROW-AT-ROW-NO) (ROW-NO) (UNLESS (MINUSP ROW-NO) (DO ((ROW FIRST-INFERIOR-ROW (TELL ROW :NEXT-ROW)) (I ROW-NO (- I 1))) ((OR (NULL ROW) (< I 1)) ROW)))) (DEFMETHOD (BOX :ROW-ROW-NO) (ROW) (DO ((INF-ROW (TELL SELF :FIRST-INFERIOR-ROW) (TELL INF-ROW :NEXT-ROW)) (ROW-NO 0 (+ ROW-NO 1))) ((NULL INF-ROW)) (WHEN (EQ INF-ROW ROW) (RETURN ROW-NO)))) (DEFMETHOD (BOX :ROWS) () (OR CACHED-ROWS (TELL SELF :CACHE-ROWS))) (DEFMETHOD (BOX :CACHE-ROWS) () (SETQ CACHED-ROWS (WITH-COLLECTION (DO-BOX-ROWS ((ROW SELF)) (COLLECT ROW))))) (DEFMETHOD (BOX :INSERT-ROW-AT-ROW-NO) (ROW ROW-NO) (LET ((ROW-AT-ROW-NO (TELL SELF :ROW-AT-ROW-NO ROW-NO)) (ROW-BEFORE-ROW-NO (TELL SELF :ROW-AT-ROW-NO (- ROW-NO 1)))) (TELL ROW :SET-SUPERIOR-BOX SELF) (TELL ROW :SET-PREVIOUS-ROW ROW-BEFORE-ROW-NO) (TELL ROW :SET-NEXT-ROW ROW-AT-ROW-NO) (IF (NULL ROW-BEFORE-ROW-NO) (TELL SELF :SET-FIRST-INFERIOR-ROW ROW) (TELL ROW-BEFORE-ROW-NO :SET-NEXT-ROW ROW)) (TELL-CHECK-NIL ROW-AT-ROW-NO :SET-PREVIOUS-ROW ROW))) (DEFMETHOD (BOX :DELETE-ROW-AT-ROW-NO) (POS) ;; It is really convenient to be able to assume ;; that each box has at least one row in it. (UNLESS (= (TELL SELF :LENGTH-IN-ROWS) 1) (LET* ((ROW (TELL SELF :ROW-AT-ROW-NO POS)) (ROW-PREV-ROW (TELL-CHECK-NIL ROW :PREVIOUS-ROW)) (ROW-NEXT-ROW (TELL-CHECK-NIL ROW :NEXT-ROW))) (TELL-CHECK-NIL ROW :SET-SUPERIOR-BOX NIL) (TELL-CHECK-NIL ROW :SET-PREVIOUS-ROW NIL) (TELL-CHECK-NIL ROW :SET-NEXT-ROW NIL) (IF (EQ ROW FIRST-INFERIOR-ROW) (SETQ FIRST-INFERIOR-ROW ROW-NEXT-ROW) (TELL-CHECK-NIL ROW-PREV-ROW :SET-NEXT-ROW ROW-NEXT-ROW)) (TELL-CHECK-NIL ROW-NEXT-ROW :SET-PREVIOUS-ROW ROW-PREV-ROW)))) (DEFMETHOD (BOX :INSERT-BOX-ROWS-AT-ROW-NO) (BOX ROW-NO) (LET ((BOX-FIRST-ROW (TELL BOX :KILL-ROW (TELL BOX :FIRST-ROW)))) (UNLESS (NULL BOX-FIRST-ROW) (LET ((ROW-AT-ROW-NO (TELL SELF :ROW-AT-ROW-NO ROW-NO)) (ROW-BF-ROW-NO (TELL SELF :ROW-AT-ROW-NO (- ROW-NO 1))) (BOX-LAST-ROW (DO* ((NEXT-BOX-ROW (TELL BOX-FIRST-ROW :NEXT-ROW) (TELL BOX-ROW :NEXT-ROW)) (BOX-ROW BOX-FIRST-ROW NEXT-BOX-ROW)) (()) (TELL BOX-ROW :SET-SUPERIOR-BOX SELF) (IF (NULL NEXT-BOX-ROW) (RETURN BOX-ROW))))) (TELL BOX-FIRST-ROW :SET-PREVIOUS-ROW ROW-BF-ROW-NO) (TELL BOX-LAST-ROW :SET-NEXT-ROW ROW-AT-ROW-NO) (TELL-CHECK-NIL ROW-BF-ROW-NO :SET-NEXT-ROW BOX-FIRST-ROW) (TELL-CHECK-NIL ROW-AT-ROW-NO :SET-PREVIOUS-ROW BOX-LAST-ROW))))) (DEFMETHOD (BOX :DELETE-ROWS-BETWEEN-ROW-NOS) (STRT-ROW-NO STOP-ROW-NO) (LET* ((STRT-ROW (TELL SELF :ROW-AT-ROW-NO STRT-ROW-NO)) (STOP-ROW (TELL SELF :ROW-AT-ROW-NO STOP-ROW-NO)) (STRT-ROW-PREV-ROW (TELL-CHECK-NIL STRT-ROW :PREVIOUS-ROW)) (STOP-ROW-NEXT-ROW (TELL-CHECK-NIL STOP-ROW :NEXT-ROW)) (RETURN-BOX (MAKE-INITIALIZED-BOX))) (DO ((ROW STRT-ROW (TELL ROW :NEXT-ROW))) ((NULL ROW)) (TELL ROW :SET-SUPERIOR-BOX NIL)) (TELL STRT-ROW :SET-PREVIOUS-ROW NIL) (TELL STRT-ROW :SET-NEXT-ROW NIL) (IF (NULL STRT-ROW-PREV-ROW) (TELL SELF :SET-FIRST-INFERIOR-ROW STOP-ROW-NEXT-ROW) (TELL STRT-ROW-PREV-ROW :SET-NEXT-ROW STOP-ROW-NEXT-ROW)) (TELL-CHECK-NIL STOP-ROW-NEXT-ROW :SET-PREVIOUS-ROW STRT-ROW-PREV-ROW) (TELL RETURN-BOX :APPEND-ROW STRT-ROW) RETURN-BOX)) (DEFMETHOD (BOX :DELETE-BETWEEN-ROWS) (STRT-ROW STOP-ROW) (LET ((STRT-ROW-PREV-ROW (TELL-CHECK-NIL STRT-ROW :PREVIOUS-ROW)) (STOP-ROW-NEXT-ROW (TELL-CHECK-NIL STOP-ROW :NEXT-ROW)) (RETURN-BOX (MAKE-INITIALIZED-BOX))) (DO ((ROW STRT-ROW (TELL ROW :NEXT-ROW))) ((EQ ROW STOP-ROW-NEXT-ROW)) (TELL ROW :SET-SUPERIOR-BOX NIL)) (TELL STRT-ROW :SET-PREVIOUS-ROW NIL) (TELL STOP-ROW :SET-NEXT-ROW NIL) (IF (NULL STRT-ROW-PREV-ROW) (TELL SELF :SET-FIRST-INFERIOR-ROW STOP-ROW-NEXT-ROW) (TELL STRT-ROW-PREV-ROW :SET-NEXT-ROW STOP-ROW-NEXT-ROW)) (TELL-CHECK-NIL STOP-ROW-NEXT-ROW :SET-PREVIOUS-ROW STRT-ROW-PREV-ROW) (TELL RETURN-BOX :SET-FIRST-INFERIOR-ROW STRT-ROW) RETURN-BOX)) (DEFMETHOD (BOX :KILL-ROWS-AT-ROW-NO) (STRT-ROW-NO) (LET ((STOP-ROW-NO (TELL SELF :LENGTH-IN-ROWS))) (TELL SELF :DELETE-ROWS-BETWEEN-ROW-NOS STRT-ROW-NO STOP-ROW-NO))) ;;; Operations that take existing box rows as position specifiers. These ;;; operations are built on top of the operations that take row positions ;;; as position specifiers. (DEFMETHOD (BOX :INSERT-ROW-BEFORE-ROW) (ROW BEFORE-ROW) (LET ((BEFORE-ROW-ROW-NO (TELL SELF :ROW-NO-OF-INFERIOR-ROW BEFORE-ROW))) (TELL SELF :INSERT-ROW-AT-ROW-NO ROW BEFORE-ROW-ROW-NO))) (DEFMETHOD (BOX :INSERT-ROW-AFTER-ROW) (ROW AFTER-ROW) (LET ((AFTER-ROW-ROW-NO (TELL SELF :ROW-ROW-NO AFTER-ROW))) (TELL SELF :INSERT-ROW-AT-ROW-NO ROW (+ AFTER-ROW-ROW-NO 1)))) (DEFMETHOD (BOX :APPEND-ROW) (ROW) (TELL SELF :INSERT-ROW-AT-ROW-NO ROW (TELL SELF :LENGTH-IN-ROWS))) (DEFMETHOD (BOX :DELETE-ROW) (ROW) (LET ((ROW-ROW-NO (TELL SELF :ROW-ROW-NO ROW))) (UNLESS (NULL ROW-ROW-NO) (TELL SELF :DELETE-ROW-AT-ROW-NO ROW-ROW-NO)))) (DEFMETHOD (BOX :KILL-ROW) (ROW) (TELL SELF :KILL-ROWS-AT-ROW-NO (TELL SELF :ROW-ROW-NO ROW))) (DEFMACRO ACTION-AT-BP-INTERNAL (&BODY DO-ACTION-FORM) `(LET ((OLD-BP-TYPE (BP-TYPE BP))) (UNWIND-PROTECT (PROGN (SETF (BP-TYPE BP) (IF FORCE-BP-TYPE FORCE-BP-TYPE OLD-BP-TYPE)) . ,DO-ACTION-FORM) (SETF (BP-TYPE BP) OLD-BP-TYPE)))) (DEFUN INSERT-CHA (BP CHA &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (TELL (BP-ROW BP) :INSERT-CHA-AT-CHA-NO CHA (BP-CHA-NO BP)))) (DEFUN INSERT-ROW-CHAS (BP ROW &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (TELL (BP-ROW BP) :INSERT-ROW-CHAS-AT-CHA-NO ROW (BP-CHA-NO BP)))) (DEFUN INSERT-ROW (BP ROW &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (LET* ((BP-BOX (BP-BOX BP)) (BP-ROW (BP-ROW BP)) (BP-ROW-ROW-NO (TELL BP-BOX :ROW-ROW-NO BP-ROW)) (TEMP-ROW (DELETE-CHAS-TO-END-OF-ROW BP FORCE-BP-TYPE))) (TELL BP-BOX :INSERT-ROW-AT-ROW-NO ROW (+ BP-ROW-ROW-NO 1)) (MOVE-POINT (ROW-LAST-BP-VALUES ROW)) (INSERT-ROW-CHAS BP TEMP-ROW :FIXED)))) (DEFUN SIMPLE-DELETE-CHA (BP &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (TELL (BP-ROW BP) :DELETE-CHA-AT-CHA-NO (BP-CHA-NO BP)))) (DEFUN RUBOUT-CHA (BP &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (LET* ((ROW (BP-ROW BP)) (ROW-NO (TELL-CHECK-NIL (BP-BOX BP) :ROW-ROW-NO ROW)) (CHA-NO (BP-CHA-NO BP)) (CHA-TO-DELETE (UNLESS (= CHA-NO 0) (TELL ROW :CHA-AT-CHA-NO (1- CHA-NO))))) (COND ((> CHA-NO 0) (TELL ROW :DELETE-CHA-AT-CHA-NO (- CHA-NO 1))) ((or (name-row? row) (ZEROP ROW-NO))) (T (LET* ((BOX (BP-BOX BP)) (PREVIOUS-ROW (TELL BOX :ROW-AT-ROW-NO (- ROW-NO 1))) (PREVIOUS-ROW-LENGTH-IN-CHAS (TELL PREVIOUS-ROW :LENGTH-IN-CHAS))) (TELL BOX :DELETE-ROW-AT-ROW-NO ROW-NO) (TELL PREVIOUS-ROW :INSERT-ROW-CHAS-AT-CHA-NO ROW PREVIOUS-ROW-LENGTH-IN-CHAS)))) CHA-TO-DELETE))) (DEFUN DELETE-CHA (BP &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (LET* ((ROW (BP-ROW BP)) (ROW-LENGTH-IN-CHAS (TELL ROW :LENGTH-IN-CHAS)) (CHA-NO (BP-CHA-NO BP))) (COND ((< CHA-NO ROW-LENGTH-IN-CHAS) (TELL ROW :DELETE-CHA-AT-CHA-NO CHA-NO)) ((TELL ROW :NEXT-ROW) (LET* ((BOX (BP-BOX BP)) (ROW-ROW-NO (TELL BOX :ROW-ROW-NO ROW)) (ROW-NEXT-ROW (TELL BOX :ROW-AT-ROW-NO (+ ROW-ROW-NO 1)))) (TELL BOX :DELETE-ROW-AT-ROW-NO (+ ROW-ROW-NO 1)) (TELL ROW :INSERT-ROW-CHAS-AT-CHA-NO ROW-NEXT-ROW ROW-LENGTH-IN-CHAS))))))) (DEFUN DELETE-CHAS-TO-END-OF-ROW (BP &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (LET ((ROW (BP-ROW BP)) (CHA-NO (BP-CHA-NO BP))) (TELL ROW :KILL-CHAS-AT-CHA-NO CHA-NO)))) (DEFUN DELETE-ROWS-TO-END-OF-BOX (BP &OPTIONAL (FORCE-BP-TYPE NIL)) (ACTION-AT-BP-INTERNAL (LET ((BOX (BP-BOX BP)) (ROW (BP-ROW BP))) (UNLESS (NULL BOX) (TELL BOX :KILL-ROWS-AT-ROW-NO (+ (TELL BOX :ROW-ROW-NO ROW) 1)))))) ;;;; FIND-LOWEST-COMMON-SUPERIOR-BOX ;;; This function takes two boxes as its inputs and find the lowest box ;;; which is a superior of both of those boxes. It is slightly bummed ;;; for speed since it gets called a fair amount, and I liked the way ;;; I bummed it. (DEFUN FIND-LOWEST-COMMON-SUPERIOR-BOX (BOX1 BOX2) (LET ((MARK-THIS-PASS (GENSYM))) (DO ((BOX1 BOX1 (TELL BOX1 :SUPERIOR-BOX)) (BOX2 BOX2 (TELL BOX2 :SUPERIOR-BOX))) (()) (COND ((EQ BOX1 BOX2) (RETURN BOX1)) ((EQ (TELL BOX1 :GET ':LOWEST-COMMON-SUPERIOR-MARK) MARK-THIS-PASS) (RETURN BOX1)) ((EQ (TELL BOX2 :GET ':LOWEST-COMMON-SUPERIOR-MARK) MARK-THIS-PASS) (RETURN BOX2)) (T (TELL BOX1 :PUTPROP MARK-THIS-PASS ':LOWEST-COMMON-SUPERIOR-MARK) (TELL BOX2 :PUTPROP MARK-THIS-PASS ':LOWEST-COMMON-SUPERIOR-MARK)))))) (DEFUN OBJ-CONTAINS-OBJ? (OUTER INNER) (DO ((INNER INNER (TELL INNER :SUPERIOR-OBJ))) ((NULL INNER) NIL) (COND ((EQ INNER OUTER) (RETURN T))))) (DEFUN BOX-CONTAINS-BOX? (OUTER-BOX INNER-BOX) (DO ((INNER (TELL INNER-BOX :SUPERIOR-BOX) (TELL INNER :SUPERIOR-BOX))) ((NULL INNER) NIL) (AND (EQ INNER OUTER-BOX) (RETURN T)))) (DEFUN LEVEL-OF-SUPERIORITY (OUTER-BOX INNER-BOX) (DO ((I 0 (1+ I)) (BOX INNER-BOX (TELL BOX :SUPERIOR-BOX))) ((OR (NULL BOX) (EQ BOX OUTER-BOX)) I))) (DEFUN NTH-SUPERIOR-BOX (BOX N) (DO ((I 0 (1+ I)) (SUPERIOR BOX (TELL SUPERIOR :SUPERIOR-BOX))) ((NULL SUPERIOR) NIL) (AND (= I N) (RETURN SUPERIOR)))) ;;;;FIND-PATH ;; The FIND-PATH function is used to find the "path" between two boxes. ;; It returns two values ;; first value -- Box to throw to ;; second value -- Chain of boxes to enter ;; Note that either of these values can be NIL. ;; ;; Example: ;; ;; +-------------------------------------------------+ ;; | call this box TOP | ;; | | ;; | +------------------+ +------------------+ | ;; | | call this box A1 | | call this box B1 | | ;; | | | | | | ;; | | +--------------+ | | +--------------+ | | ;; | | |call this A2 | | | | call this B2 | | | ;; | | | | | | | | | | ;; | | | +----------+ | | | | +----------+ | | | ;; | | | | this A3 | | | | | | this B3 | | | | ;; | | | | | | | | | | | | | | ;; | | | +----------+ | | | | +----------+ | | | ;; | | +--------------+ | | +--------------+ | | ;; | +------------------+ +------------------+ | ;; +-------------------------------------------------+ ;; ;; (FIND-PATH A3 TOP) --> TOP NIL ;; (FIND-PATH TOP A3) --> NIL (A1 A2 A3) ;; (FIND-PATH A3 B3) --> TOP (B1 B2 B3) ;; (FIND-PATH A3 A3) --> NIL NIL (DEFUN FIND-PATH (FROM-BOX TO-BOX) (DECLARE (VALUES BOX-TO-THROW-TO DOWNWARD-ENTRY-CHAIN)) (COND ((EQ FROM-BOX TO-BOX) (VALUES NIL NIL)) ((BOX-CONTAINS-BOX? TO-BOX FROM-BOX) (VALUES TO-BOX NIL)) ((BOX-CONTAINS-BOX? FROM-BOX TO-BOX) (VALUES NIL (FIND-PATH-FROM-SUPERIOR-TO-INFERIOR FROM-BOX TO-BOX))) (T (LET ((LOWEST-COMMON-SUPERIOR-BOX (FIND-LOWEST-COMMON-SUPERIOR-BOX FROM-BOX TO-BOX))) (VALUES LOWEST-COMMON-SUPERIOR-BOX (FIND-PATH-FROM-SUPERIOR-TO-INFERIOR LOWEST-COMMON-SUPERIOR-BOX TO-BOX)))))) (DEFUN FIND-PATH-FROM-SUPERIOR-TO-INFERIOR (SUPERIOR-BOX INFERIOR-BOX) (NREVERSE (WITH-COLLECTION (DO ((BOX INFERIOR-BOX (TELL BOX :SUPERIOR-BOX))) ((EQ BOX SUPERIOR-BOX)) (COLLECT BOX))))) (DEFUN SEND-EXIT-MESSAGES (DESTINATION-BOX DESTINATION-SCREEN-BOX &optional(one-step-up? nil)) (LET ((CURRENT-BOX (POINT-BOX))) (COND ((EQ (FIND-LOWEST-COMMON-SUPERIOR-BOX CURRENT-BOX DESTINATION-BOX) CURRENT-BOX) NIL) ((TELL DESTINATION-SCREEN-BOX :SUPERIOR? (POINT-SCREEN-BOX)) NIL) (T (TELL CURRENT-BOX :EXIT (tell (BP-SCREEN-BOX *POINT*) :superior-screen-box) (tell current-box :superior-box) one-step-up?) (SEND-EXIT-MESSAGES DESTINATION-BOX DESTINATION-SCREEN-BOX))))) ;; Needs these to keep reDisplay code alive. (DEFMETHOD (ROW :FIRST-INFERIOR-OBJ) () (TELL SELF :CHA-AT-CHA-NO 0)) (DEFMETHOD (CHA :NEXT-OBJ) () (TELL SUPERIOR-ROW :CHA-AT-CHA-NO (+ (TELL SUPERIOR-ROW :CHA-CHA-NO SELF) 1))) (DEFMETHOD (BOX :FIRST-INFERIOR-OBJ) () FIRST-INFERIOR-ROW) (DEFMETHOD (ROW :NEXT-OBJ) () NEXT-ROW) ;;;these are messages to boxes which are used for moving up and down levels ;;;in box structures (DEFMETHOD (BOX :EXIT) (&OPTIONAL (NEW-SCREEN-BOX (TELL (POINT-SCREEN-BOX) :SUPERIOR-SCREEN-BOX)) (NEW-ACTUAL-BOX (TELL SELF :SUPERIOR-BOX)) IGNORE) (COND ((AND (EQ SELF (OUTERMOST-BOX))(NOT (NULL SHRINK-PROOF?)))) ((EQ SELF (OUTERMOST-BOX)) (COM-COLLAPSE-BOX SELF) (MOVE-POINT (BOX-SELF-BP-VALUES (BOX-SCREEN-POINT-IS-IN))) (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*)) (SET-POINT-SCREEN-BOX NEW-SCREEN-BOX) (TELL NEW-ACTUAL-BOX :ENTER (not (eq (tell self :superior-box) new-actual-box)))) (T (MOVE-POINT (BOX-SELF-BP-VALUES (BOX-SCREEN-POINT-IS-IN))) (MOVE-POINT (BP-FORWARD-CHA-VALUES *POINT*)) (SET-POINT-SCREEN-BOX NEW-SCREEN-BOX) (TELL NEW-ACTUAL-BOX :ENTER (not (eq (tell self :superior-box) new-actual-box)))))) (DEFMETHOD (BOX :AFTER :EXIT) (&OPTIONAL IGNORE IGNORE ONE-STEP-UP?) (WHEN (SPRITE-BOX? (TELL SELF :SUPERIOR-BOX)) (TELL SELF :EXIT-FROM-SPRITE-INSTANCE-VAR)) (COND ((AND (NAME-ROW? NAME) (NULL (GET-BOX-NAME NAME))) ;; get rid of the name row if there are no more characters in it (tell name :update-bindings) (SETQ NAME NIL) (TELL SELF :MODIFIED)) ((NAME-ROW? NAME) ;; if there is a name row with stuff in it, make sure the binding info is updated (TELL NAME :UPDATE-BINDINGS))) (when (and one-step-up? (eq exit-trigger-flag 'enabled)) (tell self :do-trigger-exit-stuff))) (DEFMETHOD (LL-BOX :BEFORE :EXIT) (&rest ignore) (LET* ((SUPERIOR-BOX (TELL SELF :SUPERIOR-BOX)) (BINDING (RASSQ SELF (TELL SUPERIOR-BOX :GET-STATIC-VARIABLES-ALIST)))) (UNLESS (EQ (CAR BINDING) *EXPORTING-BOX-MARKER*) (TELL SUPERIOR-BOX :ADD-STATIC-VARIABLE-PAIR *EXPORTING-BOX-MARKER* SELF)))) (DEFMETHOD (POP-UP-BOX-MIXIN :AFTER :EXIT) (&REST IGNORE) (TELL (TELL SELF :SUPERIOR-ROW) :DELETE-CHA SELF)) ;Make the box go away (DEFMETHOD (BOX :GET-SHRINK-PROOF?)() SHRINK-PROOF?) (DEFMETHOD (BOX :SET-SHRINK-PROOF?)(VAL) (SETQ SHRINK-PROOF? VAL))