Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/boxer/boxer.lha/data.lisp

Text File | 1993-07-17 | 22.0 KB | 638 lines

;-*- SYNTAX: ZETALISP; BASE: 10; MODE: LISP; PACKAGE: BOXER; FONTS: CPTFONT,CPTFONTB -*-

#|
            Copyright 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 the top level definitions for the system supplied Data Manipulation
Primitives for the BOXER System.

They are divided into

INFORMATION

   EMPTY?
   NUMBER-OF <box> <specifier>
   ITEM-NUMBER-OF <box> <item> <occurence>

ACCESSORS

 Item(s) Accessors:
   FIRST <box>
   BUTFIRST <box>
   START <box>
   BUTSTART <box>
   LAST <box>
   BUTLAST <box>
   ITEM <item number> <box>
   BUTITEM <item number> <box>
   GET-NTH <box> <item number>
   RC <row> <column> <box>
   GET-RC <box> <row> <column>
   ITEMS <item numbers> <box>

 Row Accessors:
   FIRST-ROW <box>
   BUTFIRST-ROW <box>
   LAST-ROW <box>
   BUTLAST-ROW <box>
   ROW <row number> <box>
   BUTROW <row number> <box>


CONSTRUCTORS

  MAKE-EMPTY-BOX
  BOXIFY
  JOIN-RIGHT  <box1> <box2>
  JOIN-BOTTOM <box1> <box2>
  BUILD <template box>


MUTATORS

 Item Mutators:
   CHANGE-ITEM <n> <box> <new-item>
   CHANGE-RC   <row> <column> <box> <new-item>
   DELETE-ITEM <n> <box>
   DELETE-RC   <row> <column> <box>
   INSERT-ITEM <n> <box> <new-item>
   INSERT-RC   <row> <column> <box> <new-item>

Row Mutators:
  CHANGE-ROW <row number> <box> <new row>
  DELETE-ROW <row number> <box>
  INSERT-ROW <row number> <box> <new row>

|#



(DEFVAR *TRIM-EMPTY-ROWS?* T)

;;; utilities for data manipulation
;; these handle selecting parts of ports...
;; CONS up new EVROWs with the appropriate elements (i.e. copies or ports)

;; ROW is a list of items.
(DEFUN PROCESS-ROW-FOR-SELECTOR (ROW PORT?)
  (COND ((NULL ROW)
     (MAKE-EMPTY-EVROW))
    ((AND PORT? (LISTP ROW))
     (MAKE-EVROW-FROM-ITEMS (PORT-TO-INFERIORS-IN-LIST ROW t)))
    ((LISTP ROW)                ;;should be frobbing the items here too
     (MAKE-EVROW-FROM-ITEMS ROW))
    (T (FERROR "Don't know how to make a row from ~A " ROW))))

(DEFSUBST GET-ROWS-FOR-SELECTOR (BOX)
  (MAPCAR #'(LAMBDA (ROW) (PROCESS-ROW-FOR-SELECTOR ROW (EVAL-PORT? BOX)))
      (GET-BOX-ROWS BOX T)))

(DEFSUBST GET-FIRST-ROW-FOR-SELECTOR (BOX)
  (PROCESS-ROW-FOR-SELECTOR (GET-FIRST-ROW BOX T) (EVAL-PORT? BOX)))

(DEFSUBST GET-NTH-ROW-FOR-SELECTOR (N BOX)
  (PROCESS-ROW-FOR-SELECTOR (GET-NTH-ROW N BOX) (EVAL-PORT? BOX)))

;;; BUILD and friends use this
;;; returns the next element in the row that is currently being built along with its length
;;; IF there happens to be an UNBOX, then a list of items is handed back to the caller
;;; (presumably PROCESS-ROW-FOR-BUILD) to be spliced in.  If the UNBOX results in multiple
;;; rows, then the other rows are passed back to the caller as a third value
(DEFUN PROCESS-ROW-ELEMENT-FOR-BUILD (EL)
  (DECLARE (VALUES RESULT LENGTH OTHER-ROWS EVALED?))
  (COND ((EVAL-IT-TOKEN? EL)
     (LET ((RESULT (EV-THING (EVAL-IT-TOKEN-ELEMENT EL))))
       (VALUES (cond ((and (eval-box? result)
                   (or (graphics-box? result)
                   (graphics-data-box? result)
                   (sprite-box? result)))
              (copy-box result nil))
             ((AND (OR (EVAL-BOX? RESULT) (EVAL-PORT? RESULT)))
              (COPY-FOR-EVAL RESULT))
             (t RESULT))
           (CHA-LENGTH-OF-EVROW-ITEM RESULT)
           NIL T)))
    ((UNBOX-TOKEN? EL)
     (LET ((ROWS (GET-BOX-ROWS
               (UNBOX-PAIR-ELEMENT (EV-THING EL NIL)) T)))
       (VALUES (CAR ROWS)
           (LOOP FOR R IN ROWS MAXIMIZE (ITEM-LIST-LENGTH-IN-CHAS R))
           (CDR ROWS) T)))
    ((EVAL-PORT? EL)
     (VALUES (SHALLOW-COPY-FOR-EVALUATOR EL) 1 NIL NIL))
    ((EVAL-BOX? EL)
     (MULTIPLE-VALUE-BIND (RESULT E?)
         (BUILD-INTERNAL EL t)
     (VALUES RESULT 1 NIL E?)))
    (T (VALUES EL (CHA-LENGTH-OF-EVROW-ITEM EL)))))

(DEFUN MERGE-UNBOXED-ROWS (CURRENT-ROWS NEW-ROWS CURRENT-LENGTH INC-LENGTH)
  (LOOP FOR INDEX FROM 0 TO (1- (MAX (LENGTH CURRENT-ROWS) (LENGTH NEW-ROWS)))
    FOR CURRENT-ROW = (NTH INDEX CURRENT-ROWS)
    FOR NEW-ROW     = (NTH INDEX NEW-ROWS)
    COLLECTING
      (IF (NULL CURRENT-ROW)
          (APPEND (NCONS (MAKE-SPACES CURRENT-LENGTH))
              NEW-ROW)
          (APPEND CURRENT-ROW            ;what is already there
              ;; fill with spaces so rows will line up
              (NCONS (MAKE-SPACES (- (+ CURRENT-LENGTH INC-LENGTH)
                         (EVROW-LENGTH-IN-CHAS CURRENT-ROW)
                         (EVROW-LENGTH-IN-CHAS NEW-ROW))))
          NEW-ROW))))

;; Remember, one row in a BUILD template may be able to produce several rows in the result
;; due to imbedded !'s and @'s

(DEFUN PROCESS-ROW-FOR-BUILD (ROW)
 "Returns a list of rows to be APPENDed into the final result. "
 (DECLARE (VALUES LIST-OF-ROWS EXCLS-OR-ATSIGNS?))
  (LOOP WITH RETURN-ROW = NIL
    WITH AUX-ROWS = NIL
    WITH CURRENT-LENGTH = 0
    WITH EXCLS-OR-ATSIGNS? = NIL
    FOR ELEMENT IN ROW
    DO (MULTIPLE-VALUE-BIND (RESULT LENGTH OTHER-ROWS EVALED?)
           (PROCESS-ROW-ELEMENT-FOR-BUILD ELEMENT)
         (WHEN (NOT-NULL OTHER-ROWS)
           (SETQ AUX-ROWS
             (MERGE-UNBOXED-ROWS AUX-ROWS OTHER-ROWS CURRENT-LENGTH LENGTH)))
         (SETQ RETURN-ROW (APPEND RETURN-ROW (LIST-OR-LISTIFY RESULT)))
         (INCF CURRENT-LENGTH LENGTH)
         (SETQ EXCLS-OR-ATSIGNS? (OR EXCLS-OR-ATSIGNS? EVALED?))
         (WHEN (NOT-NULL OTHER-ROWS)
           (LET ((TOP-ROW-PAD (- CURRENT-LENGTH (ITEM-LIST-LENGTH-IN-CHAS RETURN-ROW))))
         (WHEN (> TOP-ROW-PAD 0)
           (SETQ RETURN-ROW (ADD-SPACES-TO-RIGHT RETURN-ROW TOP-ROW-PAD))))))
    FINALLY
      (RETURN (VALUES (MAPCAR #'MAKE-EVROW-FROM-ITEMS
                  (APPEND (NCONS RETURN-ROW) AUX-ROWS))
              EXCLS-OR-ATSIGNS?))))

;;; BUILD caching
;; A flag is associated with each box indicating whether there are any !'s or @'s in it's
;; substructure
;; currently, we can only cache builds in the PLIST of a REAL box
;; Un-mutated virtual copies can track back to the parent to access this flag
;; A consequence of this is that BUILD is now a flavor of input because that is the only
;; place where we can get our hands on a real live editor box (i.e. something that is not
;; copied or ported-to). Although in the current shallow copy,
;; the next level of sub-boxes of any "copy" can also be "real" boxes
;; An alternative to this is to copy the build cache (or a flag which
;; specifies whether deep scanning of the box is required) when ever we make a copy of the
;; box.  This will win in more cases but will make the box copies bigger and slower to create.
;; If we encourage pervasive use of BUILD, then this may be the way to go since the current
;; caching scheme only wins at top level or with shallow copies.
;; The current implementation should survive virtual copy for all the wrong reasons

(DEFUN GET-CACHED-BUILD (BOX)
  (AND (BOX? BOX) (TELL BOX :GET 'CACHED-BUILD)))

(DEFUN BUILD-INTERNAL (TEMPLATE &optional name-too)
  (IF (GET-CACHED-BUILD TEMPLATE)
      (COPY-FOR-EVAL TEMPLATE)
      (LOOP WITH ROWS = NIL
        WITH EXCLS-OR-ATSIGNS? = NIL
        FOR ROW IN (GET-BOX-ROWS TEMPLATE)
        DO (MULTIPLE-VALUE-BIND (NEW-ROWS EXS-OR-ATS)
           (PROCESS-ROW-FOR-BUILD ROW)
         (SETQ ROWS              (APPEND ROWS NEW-ROWS)
               EXCLS-OR-ATSIGNS? (OR EXCLS-OR-ATSIGNS? EXS-OR-ATS)))
        FINALLY
          (LET ((RESULT (COND ((EVAL-DOIT? TEMPLATE) (MAKE-EVDOIT ROWS ROWS))
                  ((EVAL-DATA? TEMPLATE) (MAKE-EVDATA ROWS ROWS))
                  (T (FERROR "Don't know how to BUILD ~A's"
                         (TYPEP TEMPLATE))))))
        ;; handle names of inferior objects
        (when (and name-too (not (null (box-name template))))
          (setf (%evbox-name result) (box-name template)))
        (WHEN (AND (NULL EXCLS-OR-ATSIGNS?) (BOX? TEMPLATE))
          (TELL TEMPLATE :PUTPROP T 'CACHED-BUILD))
        (RETURN (VALUES RESULT EXCLS-OR-ATSIGNS?))))))

;; use this to handle the resulting namespace from data selectors

(DEFUN UPDATE-BINDINGS-LIST (UNWANTED BINDINGS)
  (IF (NOT (LISTP UNWANTED)) (DELQ (RASSQ UNWANTED BINDINGS) BINDINGS)
      (LOOP WITH NEW-BINDINGS = BINDINGS
        FOR UNWANTED-BINDING IN UNWANTED
        FOR EXISTING-PAIR = (RASSQ UNWANTED-BINDING NEW-BINDINGS)
        WHEN (NOT-NULL EXISTING-PAIR)
          DO (SETQ NEW-BINDINGS (DELQ EXISTING-PAIR NEW-BINDINGS))
        FINALLY (RETURN NEW-BINDINGS))))



;;;; Accessor primitives
;;;  1 based

(DEFUN ITEM (N BOX)
  "Returns the desired item in a Box.  If N < 1 or > number of elements then an empty box is returned. "
  (COND (( 1 N (GET-BOX-LENGTH-IN-ELEMENTS BOX))
     (MULTIPLE-VALUE-BIND (ROW COL)
         (GET-ROW-AND-COL-NUMBER N BOX)
       (MAKE-EVDATA
         ROWS
         (NCONS (MAKE-EVROW-FROM-ENTRY
              (GET-NTH-ELEMENT-IN-EVROW COL (GET-NTH-ROW-FOR-SELECTOR ROW BOX)))))))
    (T (MAKE-EMPTY-EVBOX))))

(DEFUN BUTITEM (N BOX)
  "Returns a Box with all the same elements as BOX except for element N. "
  (COND ((EVAL-EMPTY? BOX)
     (MAKE-EMPTY-EVBOX))
    (( 1 N (GET-BOX-LENGTH-IN-ELEMENTS BOX))
     (MULTIPLE-VALUE-BIND (ROW-NO COL)
         (GET-ROW-AND-COL-NUMBER N BOX)
       (LET* ((ROWS (GET-ROWS-FOR-SELECTOR BOX))
          (ROW (NTH ROW-NO ROWS)))
         (SETF (NTH ROW-NO ROWS) (GET-BUTNTH-ELEMENT-IN-EVROW COL ROW))
         (MAKE-EVDATA ROWS (IF *TRIM-EMPTY-ROWS?*
                   (TRIM-EMPTY-ROWS ROWS)
                   ROWS)))))
    (T (COPY-FOR-EVAL BOX))))



;;;; Information about data objects...
;;; EMPTY?, NUMBER-OF, and ITEM-NUMBER-OF?

(DEFBOXER-FUNCTION EMPTY? (ITEM)
  (BOXER-BOOLEAN (EVAL-EMPTY? ITEM)))

(DEFBOXER-FUNCTION NUMBER-OF (BOX SPECIFIER)
  (LET ((KEYWORD (GET-FIRST-ELEMENT SPECIFIER)))
    (SELECTQ KEYWORD
      ((BU:ROW BU:ROWS)
       (BOXIFY (GET-BOX-LENGTH-IN-ROWS BOX)))
      ((BU:COL BU:COLUMNS BU:COLS BU:COLUMN)
       (BOXIFY (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
             MAXIMIZE (LENGTH ROW))))
      ((BU:ITEM BU:ITEMS)
       (BOXIFY (GET-BOX-LENGTH-IN-ELEMENTS BOX)))
      ((BU:RC BU:ROWS-COLUMNS)
       (MAKE-EVDATA ROWS
            (NCONS (make-evrow-from-items
                 (list
                   (GET-BOX-LENGTH-IN-ROWS BOX)
                   (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
                     MAXIMIZE (LENGTH ROW)))))))
      (OTHERWISE
       (BOXER-ERROR "Don't know How to find the number of ~A's" KEYWORD)))))

(DEFBOXER-FUNCTION ITEM-NUMBER-OF (BOX ITEM (NUMBERIZE OCCURENCE))
  (LOOP FOR I FROM 1 TO (GET-BOX-LENGTH-IN-ELEMENTS BOX)
    FOR BOX-ITEM = (ITEM I BOX)
    WHEN (BOX-EQUAL? BOX-ITEM ITEM)
      DO (IF (= 1 (NUMBERIZE OCCURENCE))
         (RETURN (BOXIFY I))
         (SETF OCCURENCE (- OCCURENCE 1)))
    FINALLY
      (RETURN (MAKE-EMPTY-EVBOX))))

(DEFBOXER-FUNCTION ITEM-NUMBERS-OF (BOX ITEM)
  (LOOP FOR I FROM 1 TO (GET-BOX-LENGTH-IN-ELEMENTS BOX)
    FOR BOX-ITEM = (ITEM I BOX)
    WHEN (BOX-EQUAL? BOX-ITEM ITEM)
      COLLECT I INTO INOS
    FINALLY
      (RETURN (boxify-list inos))))

;;;; Item Accessors....
;;; FIRST, BUTFIRST, START, BUTSTART, LAST, BUTLAST, ITEM, BUTITEM, GET-NTH, ITEMS
;;; Empty rows are NOT currently ignored

;; this version of FIRST unboxes
(DEFBOXER-FUNCTION FIRST (BOX)
  (ITEM 1 BOX))

(DEFBOXER-FUNCTION BUTFIRST (BOX)
  (BUTITEM 1 BOX))

(DEFBOXER-FUNCTION BU:START (BOX)
  (ITEM 1 BOX))

(DEFBOXER-FUNCTION BUTSTART (BOX)
  (BUTITEM 1 BOX))

(DEFBOXER-FUNCTION LAST (BOX)
  (ITEM (GET-BOX-LENGTH-IN-ELEMENTS BOX) BOX))

(DEFBOXER-FUNCTION BUTLAST (BOX)
  (BUTITEM (GET-BOX-LENGTH-IN-ELEMENTS BOX) BOX))



(DEFBOXER-FUNCTION GET-NTH (BOX (NUMBERIZE N))
  (ITEM N BOX))

;;; the same as get-nth except that the args are in reverse order
(DEFBOXER-FUNCTION ITEM ((NUMBERIZE N) BOX)
  (ITEM N BOX))

(DEFBOXER-FUNCTION BUTITEM ((NUMBERIZE N) BOX)
  (BUTITEM N BOX))

(DEFBOXER-FUNCTION GET-RC (BOX (NUMBERIZE ROW) (NUMBERIZE COL))
  (COND ((> ROW (GET-BOX-LENGTH-IN-ROWS BOX))
     (MAKE-EMPTY-EVBOX))
    (T (LET ((ROW (NTH (1- ROW) (GET-ROWS-FOR-SELECTOR BOX))))
         (COND ((> COL (EVROW-LENGTH-IN-ELEMENTS ROW))
            (MAKE-EMPTY-EVBOX))
           (T (MAKE-EVDATA
            ROWS
            (NCONS (MAKE-EVROW-FROM-ENTRY
                 (GET-NTH-ELEMENT-IN-EVROW (1- COL) ROW))))))))))

(DEFBOXER-FUNCTION RC ((NUMBERIZE ROW) (NUMBERIZE COL) BOX)
  (COND ((> ROW (GET-BOX-LENGTH-IN-ROWS BOX))
     (MAKE-EMPTY-EVBOX))
    (T (LET ((ROW (NTH (1- ROW) (GET-ROWS-FOR-SELECTOR BOX))))
         (COND ((> COL (EVROW-LENGTH-IN-ELEMENTS ROW))
            (MAKE-EMPTY-EVBOX))
           (T (MAKE-EVDATA
            ROWS
            (NCONS (MAKE-EVROW-FROM-ENTRY
                 (GET-NTH-ELEMENT-IN-EVROW (1- COL) ROW))))))))))

;;; several items (by item number)
(DEFBOXER-FUNCTION ITEMS (NOS BOX)
  (LOOP WITH ITEMS = (GET-BOX-ELEMENTS BOX)
    FOR EL IN (GET-BOX-ELEMENTS NOS)
    COLLECTING (NTH (1- EL) ITEMS) INTO RETURN-ROW
    FINALLY (RETURN (MAKE-EVDATA ROWS (NCONS (MAKE-EVROW-FROM-ENTRIES RETURN-ROW))))))



;;; Row accessors
;;; FIRST-ROW, BUTFIRST-ROW, LAST-ROW, BUTLAST-ROW, ROW, BUTROW

(DEFUN ROW (N BOX)
  "Returns a row N of box BOX inside a Box. "
  (IF ( 1 N (GET-BOX-LENGTH-IN-ROWS BOX))
      (MAKE-EVDATA ROWS (NCONS (GET-NTH-ROW-FOR-SELECTOR (1- N) BOX)))
      (MAKE-EMPTY-EVBOX)))

(DEFBOXER-FUNCTION FIRST-ROW (BOX)
  (ROW 1 BOX))

(DEFBOXER-FUNCTION BUTFIRST-ROW (BOX)
  (LET ((ROWS (CDR (GET-ROWS-FOR-SELECTOR BOX))))
    (MAKE-EVDATA ROWS (IF (NULL ROWS) '(()) ROWS))))

(DEFBOXER-FUNCTION LAST-ROW (BOX)
  (ROW (GET-BOX-LENGTH-IN-ROWS BOX) BOX))

(DEFBOXER-FUNCTION BUTLAST-ROW (BOX)
  (LET ((ROWS (BUTLAST (GET-ROWS-FOR-SELECTOR BOX))))
    (MAKE-EVDATA ROWS (IF (NULL ROWS) '(()) ROWS))))

(DEFBOXER-FUNCTION ROW ((NUMBERIZE N) BOX)
  (ROW N BOX))

(DEFBOXER-FUNCTION BUTROW ((NUMBERIZE N) BOX)
  (LET ((ROWS (GET-ROWS-FOR-SELECTOR BOX)))
    (IF (ZEROP N)
    (MAKE-EVDATA ROWS ROWS)
    (MAKE-EVDATA ROWS (APPEND (FIRSTN (1- N) ROWS) (NTHCDR N ROWS))))))

(DEFBOXER-FUNCTION GET-NAMED (NAME BOX)
  (LET* ((SYMBOL (GET-FIRST-ELEMENT NAME))
     (THING (LOOKUP-LOCAL-VARIABLE SYMBOL (GET-LOCAL-ENV BOX))))
    (COND ((NULL THING) (MAKE-EMPTY-EVBOX))
      ((FUNCTIONP THING) (BOXER-ERROR "Trying to boxify a primitive"))
      (T (BOXIFY (IF (EVAL-PORT? BOX) (MAKE-PORT-TO THING) (COPY-FOR-EVAL THING)))))))

(DEFBOXER-FUNCTION GET-LABELLED (LABEL BOX)
  (LET ((SYMBOL (GET-FIRST-ELEMENT LABEL)))
    (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
      FOR LABELS = (SUBSET #'LABEL-PAIR? ROW)
      WHEN (NOT-NULL LABELS)
        DO (LET ((WINNING-PAIR (MEM #'(LAMBDA (X Y) (EQ X (LABEL-PAIR-LABEL Y)))
                    SYMBOL LABELS)))
         (WHEN (NOT-NULL WINNING-PAIR)
           (RETURN (COPY-FOR-EVAL (LABEL-PAIR-ELEMENT (CAR WINNING-PAIR))))))
      FINALLY
        (RETURN (MAKE-EMPTY-EVBOX)))))



;;;; Constructors...
;;; MAKE-EMPTY-BOX, BOXIFY, JOIN-RIGHT, JOIN-BOTTOM, BUILD

(DEFBOXER-FUNCTION MAKE-EMPTY-BOX ()
  (MAKE-EMPTY-EVBOX))

(DEFBOXER-FUNCTION BOXIFY (STUFF)
  (BOXIFY STUFF))

(DEFBOXER-FUNCTION JOIN-RIGHT (BOX1 BOX2)
  (LET ((ROWS1 (GET-ROWS-FOR-SELECTOR BOX1))
    (ROWS2  (GET-ROWS-FOR-SELECTOR BOX2)))
    (LOOP FOR INDEX FROM 0 TO (1- (MAX (LENGTH ROWS1) (LENGTH ROWS2)))
      WITH LEFT-WID = (EVROWS-MAX-LENGTH-IN-CHAS ROWS1)
      FOR ROW1 = (NTH INDEX ROWS1)
      FOR ROW2 = (NTH INDEX ROWS2)
      FOR PADDING = (IF (NULL ROW1) LEFT-WID (- LEFT-WID (EVROW-LENGTH-IN-CHAS ROW1)))
      COLLECT (APPEND-EVROWS ROW1 (MAKE-EMPTY-EVROW PADDING) ROW2) INTO NEW-ROWS
      FINALLY
        (RETURN
          (MAKE-EVDATA ROWS NEW-ROWS
               BINDINGS (APPEND (GET-LOCAL-ENV BOX1) (GET-LOCAL-ENV BOX2)))))))

(DEFBOXER-FUNCTION JOIN-BOTTOM (BOX1 BOX2)
  (MAKE-EVDATA ROWS (APPEND (GET-ROWS-FOR-SELECTOR BOX1) (GET-ROWS-FOR-SELECTOR BOX2))
           BINDINGS (APPEND (GET-LOCAL-ENV BOX1) (GET-LOCAL-ENV BOX2))))

(DEFBOXER-FUNCTION BUILD ((BUILD TEMPLATE))
  TEMPLATE)



;;;; Mutators....
;;; CHANGE, CHANGE-ITEM, CHANGE-ROW, DELETE (?), DELETE-ITEM, DELETE-ROW,
;;; INSERT-ITEM, INSERT-ROW

;; dispatches on the type of value assuming a real box for the first arg
(DEFUN CHANGE-BOX (BOX NEW-VALUE)
  (COND ((OR (SYMBOLP NEW-VALUE) (NUMBERP NEW-VALUE))
     (LET ((ROW (MAKE-ROW `(,NEW-VALUE))))
       (TELL BOX :SET-FIRST-INFERIOR-ROW ROW)
       (TELL ROW :SET-SUPERIOR-BOX BOX)
       (TELL BOX :SET-STATIC-VARIABLES-ALIST NIL)
       (TELL BOX :MODIFIED)
       (TELL BOX :EXIT-FROM-SPRITE-INSTANCE-VAR)))
    ((EVAL-PORT? NEW-VALUE)
     (CHANGE-BOX BOX (GET-PORT-TARGET NEW-VALUE)))
    ((EVAL-BOX? NEW-VALUE)
     (TELL BOX :SET-STATIC-VARIABLES-ALIST NIL)
     (TELL BOX :SET-CONTENTS-FROM-STREAM (MAKE-BOXER-STREAM NEW-VALUE) T T)
     (TELL BOX :EXIT-FROM-SPRITE-INSTANCE-VAR)
     (let ((ll (if (box? new-value)
               (tell new-value :eval-inside-yourself 'local-library)
               (get-evbox-local-library new-value))))
       (unless (null ll)
         (let ((new-ll (tell ll :copy)))
           (tell box :set-local-library new-ll)
           (tell new-ll :export-all-variables)
           (tell box :add-static-variable-pair *exporting-box-marker* new-ll)))))
    (T (FERROR "Don't know how to change ~A to be ~A" BOX NEW-VALUE))))


;; who cares where we put anything anymore
(defun get-evbox-local-library (evbox)
  (do* ((bindings
      (evbox-bindings evbox)
      (cdr bindings))
    (item (car bindings) (car bindings)))
       ((null bindings) nil)
    (when (and (eq (car item) *exporting-box-marker*)
           (ll-box? (cdr item)))
      (return (cdr item)))))

(DEFUN CHANGE-EVBOX (EVBOX NEW-VALUE)
  (COND ((OR (SYMBOLP NEW-VALUE) (NUMBERP NEW-VALUE))
     (SETF (EVBOX-ROWS EVBOX) `(,(MAKE-EVROW-FROM-ENTRY NEW-VALUE))))
    ((EVAL-PORT? NEW-VALUE)
     (CHANGE-EVBOX EVBOX (GET-PORT-TARGET NEW-VALUE)))
    ((EVAL-BOX? NEW-VALUE)
     (SETF (EVBOX-ROWS EVBOX) (GET-ROWS-FOR-SELECTOR NEW-VALUE))
     (let ((ll (get-evbox-local-library new-value)))
       (unless (null ll)
         (let ((new-ll (tell ll :copy)))
           (tell new-ll :export-all-variables)
           (add-static-variable-to-evbox evbox *exporting-box-marker* new-ll)))))
    (T (FERROR "Don't Know how to change ~A to be ~A" EVBOX NEW-VALUE))))

;; disptches on the type of BOX
(DEFUN CHANGE (BOX-OR-PORT NEW-VALUE)
  (LET ((BOX (BOX-OR-PORT-TARGET BOX-OR-PORT)))
    (COND ((EVBOX? BOX) (CHANGE-EVBOX BOX NEW-VALUE))
      ((BOX? BOX)   (CHANGE-BOX BOX NEW-VALUE))
      (T (FERROR "Don't know how to CHANGE ~A" BOX)))))

(DEFBOXER-FUNCTION CHANGE((PORT-TO BOX) NEW-VALUE)
  (CHANGE BOX NEW-VALUE)
  ':NOPRINT)

(DEFBOXER-FUNCTION CHANGE-ITEM ((NUMBERIZE N) BOX NEW-ITEM)
  (MULTIPLE-VALUE-BIND (ROW COL)
      (GET-ROW-AND-COL-NUMBER N BOX)
    (COND ((NULL ROW)
       (BOXER-ERROR "The Box ~A does not have an item ~D" BOX N))
      (T
       (CHANGE-ITEM-AT-ITEM-NO-IN-ROW-NO COL ROW (BOX-OR-PORT-TARGET BOX)
                         (GET-FIRST-ELEMENT NEW-ITEM) (EVAL-BOX? BOX))))))

(DEFBOXER-FUNCTION CHANGE-RC ((numberize ROW) (numberize COL) BOX NEW-ITEM)
  (CHANGE-ITEM-AT-ITEM-NO-IN-ROW-NO (1- COL) (1- ROW) (BOX-OR-PORT-TARGET BOX)
                    (GET-FIRST-ELEMENT NEW-ITEM) (EVAL-BOX? BOX)))

(DEFBOXER-FUNCTION CHANGE-ROW ((NUMBERIZE N) BOX NEW-ROW)
  (CHANGE-ROW-AT-ROW-NO (1- N) (BOX-OR-PORT-TARGET BOX)
            (GET-FIRST-ROW-FOR-SELECTOR NEW-ROW) (EVAL-BOX? BOX)))

(DEFBOXER-FUNCTION DELETE-ITEM ((NUMBERIZE N) BOX)
  (MULTIPLE-VALUE-BIND (ROW COL)
      (GET-ROW-AND-COL-NUMBER N BOX)
    (COND ((NULL ROW)
       (BOXER-ERROR "The Box ~A does not have an item ~D" BOX N))
      (T
       (DELETE-ITEM-AT-ITEM-NO-IN-ROW-NO COL ROW
                         (BOX-OR-PORT-TARGET BOX) (EVAL-BOX? BOX))))))

(DEFBOXER-FUNCTION DELETE-RC ((NUMBERIZE ROW) (NUMBERIZE COL) BOX)
  (DELETE-ITEM-AT-ITEM-NO-IN-ROW-NO (1- COL) (1- ROW)
                    (BOX-OR-PORT-TARGET BOX) (EVAL-BOX? BOX)))

(DEFBOXER-FUNCTION DELETE-ROW ((NUMBERIZE N) BOX)
  (DELETE-ROW-AT-ROW-NO (1- N) (BOX-OR-PORT-TARGET BOX) (EVAL-BOX? BOX)))

(DEFBOXER-FUNCTION INSERT-ITEM ((NUMBERIZE N) BOX NEW-ITEM)
  (MULTIPLE-VALUE-BIND (ROW COL)
      (GET-ROW-AND-COL-NUMBER N BOX)
    (COND ((AND (NULL ROW) (= N (1+ (GET-BOX-LENGTH-IN-ELEMENTS BOX))))
       (LET* ((LAST-ROW-NO (1- (GET-BOX-LENGTH-IN-ROWS BOX)))
          (LAST-COL-NO (LENGTH (GET-NTH-ROW LAST-ROW-NO BOX))))
         (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (1+ LAST-COL-NO) LAST-ROW-NO
                           (BOX-OR-PORT-TARGET BOX)
                           (GET-FIRST-ELEMENT NEW-ITEM)
                           (EVAL-BOX? BOX))))
      ((NULL ROW)
       (BOXER-ERROR "The Box ~A does not have an item ~D" BOX N))
      (T
       (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO COL ROW (BOX-OR-PORT-TARGET BOX)
                         (GET-FIRST-ELEMENT NEW-ITEM)
                         (EVAL-BOX? BOX))))))

(DEFBOXER-FUNCTION INSERT-RC ((NUMBERIZE ROW) (NUMBERIZE COL) BOX NEW-ITEM)
  (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (1- COL) (1- ROW) (BOX-OR-PORT-TARGET BOX)
                    (GET-FIRST-ELEMENT NEW-ITEM) (EVAL-BOX? BOX)))

(DEFBOXER-FUNCTION INSERT-ROW ((NUMBERIZE N) BOX NEW-ROW)
  (INSERT-ROW-AT-ROW-NO (1- N) (BOX-OR-PORT-TARGET BOX)
            (GET-FIRST-ROW-FOR-SELECTOR NEW-ROW) (EVAL-BOX? BOX)))

;;  Needs more robustness and arg checking
(DEFBOXER-FUNCTION INSERT-NAMED ((PORT-TO BOX) NAME)
  (INSERT-ITEM-AT-ITEM-NO-IN-ROW-NO (1+ (LENGTH (GET-NTH-ROW
                          (1- (GET-BOX-LENGTH-IN-ROWS BOX)) BOX)))
                    (1- (GET-BOX-LENGTH-IN-ROWS BOX))
                    (BOX-OR-PORT-TARGET BOX)
                    (MAKE-BOX '(()) ':DATA-BOX (GET-FIRST-ELEMENT NAME))
                    (EVAL-BOX? BOX)))



;;; Characters  Words

(DEFUN EXPLODE-ROW (ROW)
  (LOOP FOR ENTRY IN (MAPCAR #'ROW-ENTRY-ELEMENT ROW)
    APPENDING (IF (EVAL-BOX? ENTRY) (NCONS ENTRY)
              (MAPCAR #'(LAMBDA (X) (FORMAT NIL "~C" X))
                  (LISTARRAY (STRINGIFY ENTRY))))))


(defun implode-row (row)
  (let ((string (make-array 0 :type 'art-string)))
    (loop for entry in (mapcar #'row-entry-element row) do
      (setq string (string-append string
                  (if (box? entry) (send entry :text-string)
                      (stringify entry)))))
    (make-evrow-from-entry (intern string 'bu))))

(DEFBOXER-FUNCTION CHARACTERS (BOX)
  (LET ((ROWS (GET-BOX-ROWS BOX)))
    (MAKE-EVDATA ROWS (MAPCAR #'EXPLODE-ROW ROWS))))

(defboxer-function words (box)
  (let ((rows (get-box-rows box)))
    (make-evdata rows (mapcar #'implode-row rows))))

(defboxer-function substring ((port-to box) startnum endnum)
  (let* ((string-box (box-or-port-target box))
     (string (tell string-box :text-string)))
    (substring string startnum endnum)))

;;; Doit  Data

;;; TEXT takes either the name of a DOIT box or a DOIT box as input and returns
;;; a DATA box containing the text (i.e., the rows) of the specified DOIT box.
(DEFBOXER-FUNCTION TEXT ((DATAFY BOX-OR-NAME))
  (LET ((OBJECT (GET-FIRST-ELEMENT BOX-OR-NAME)))
    (IF (SYMBOLP OBJECT) (SETQ OBJECT (BOXER-SYMEVAL OBJECT)))
    (MAKE-EVDATA ROWS (MAPCAR #'MAKE-EVROW-FROM-ITEMS (GET-BOX-ROWS OBJECT T)))))