home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / editor.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  48.5 KB  |  1,349 lines
  1. ;;; -*- Mode:lisp; Package:(BOXER GLOBAL 1000); Base:10.;Fonts:cptfont,cptfontb -*-
  2.  
  3. #||
  4.             Copyright 1985 Massachusetts Institute of Technology
  5.  
  6.  Permission to use, copy, modify, distribute, and sell this software
  7.  and its documentation for any purpose is hereby granted without fee,
  8.  provided that the above copyright notice appear in all copies and that
  9.  both that copyright notice and this permission notice appear in
  10.  supporting documentation, and that the name of M.I.T. not be used in
  11.  advertising or publicity pertaining to distribution of the software
  12.  without specific, written prior permission.  M.I.T. makes no
  13.  representations about the suitability of this software for any
  14.  purpose.  It is provided "as is" without express or implied warranty.
  15.  
  16.  
  17.                                           +-Data--+
  18.                  This file is part of the | BOXER | system
  19.                                           +-------+
  20.  
  21.  This file contains low-level code for the BOXER editor.
  22.  
  23. ||#
  24.  
  25. ;;;;INIT methods.
  26.  
  27. (DEFUN MAKE-UNINITIALIZED-ROW (&REST INIT-PLIST)
  28.   (INSTANTIATE-FLAVOR 'ROW (LOCF INIT-PLIST)  NIL))
  29.  
  30. (DEFUN MAKE-UNINITIALIZED-BOX (&REST INIT-PLIST)
  31.   (INSTANTIATE-FLAVOR 'BOX (LOCF INIT-PLIST) NIL))
  32.  
  33. (DEFUN MAKE-INITIALIZED-ROW (&REST INIT-PLIST)
  34.   (INSTANTIATE-FLAVOR 'ROW (LOCF INIT-PLIST)  T))
  35.  
  36. (DEFUN MAKE-INITIALIZED-BOX (&REST INIT-PLIST)
  37.   (INSTANTIATE-FLAVOR 'BOX (LOCF INIT-PLIST) T))
  38.  
  39. (DEFUN MAKE-INITIALIZED-GRAPHICS-BOX (&REST INIT-PLIST)
  40.   (INSTANTIATE-FLAVOR 'GRAPHICS-BOX (LOCF INIT-PLIST) T))
  41.  
  42. (DEFMETHOD (ROW :INIT) (INIT-PLIST)
  43.   (SETQ SUPERIOR-BOX       (GET INIT-PLIST ':SUPERIOR-BOX)
  44.     PREVIOUS-ROW       (GET INIT-PLIST ':PREVIOUS-ROW)
  45.     NEXT-ROW           (GET INIT-PLIST ':NEXT-ROW)
  46.     CHAS-ARRAY         (OR (GET INIT-PLIST ':CHAS-ARRAY)
  47.                    (MAKE-CHAS-ARRAY))
  48.     CACHED-ELEMENTS    NIL
  49.     CACHED-ENTRIES     NIL))
  50.  
  51. (DEFMETHOD (DOIT-BOX :BEFORE :INIT) (INIT-PLIST)
  52.   (UNLESS (GET INIT-PLIST ':TYPE)
  53.     (PUTPROP INIT-PLIST ':DOIT-BOX ':TYPE)))
  54.  
  55. (DEFMETHOD (DATA-BOX :BEFORE :INIT) (INIT-PLIST)
  56.   (UNLESS (GET INIT-PLIST ':TYPE)
  57.     (PUTPROP INIT-PLIST ':DATA-BOX ':TYPE)))
  58.  
  59. (DEFMETHOD (BOX :INIT) (INIT-PLIST)
  60.   (SETQ ;; These we inherit from chas.
  61.         SUPERIOR-ROW       (GET INIT-PLIST ':SUPERIOR-ROW)
  62.     CHA-CODE           ':BOX
  63.     FONT-NO            NIL
  64.     ;; These come from box proper.
  65.     LOCAL-LIBRARY      (GET INIT-PLIST ':LOCAL-LIBRARY)
  66.     FIRST-INFERIOR-ROW NIL
  67.     CACHED-ROWS        NIL
  68.     CACHED-CODE        NIL)
  69.   (WHEN (EQ 'BOX (TYPEP SELF))    ;is it a vanilla box ?, if so make it what it wants to be or 
  70.     (TELL SELF :SET-TYPE (OR (GET INIT-PLIST ':TYPE) ':DOIT-BOX))))    ;else a doit box
  71.  
  72. (DEFMETHOD (LL-BOX :INIT) (INIT-PLIST)
  73.   (SETQ ;; These we inherit from chas.
  74.     SUPERIOR-ROW       (GET INIT-PLIST ':SUPERIOR-ROW)
  75.     CHA-CODE           ':BOX
  76.     FONT-NO            NIL
  77.     ;; these we inherit from vanilla boxes
  78.     FIRST-INFERIOR-ROW NIL
  79.     CACHED-ROWS        NIL
  80.     CACHED-CODE        NIL
  81.     STATIC-VARIABLES-ALIST (GET INIT-PLIST ':STATIC-VARIABLES-ALIST)
  82.     EXPORTS  *EXPORT-ALL-VARIABLES-MARKER*))
  83.  
  84. (DEFMETHOD (GRAPHICS-BOX :INIT) (INIT-PLIST)
  85.   (SETQ ;; These we inherit from chas.
  86.     SUPERIOR-ROW       (GET INIT-PLIST ':SUPERIOR-ROW)
  87.     CHA-CODE           ':BOX
  88.     FONT-NO            NIL
  89.     ;; these we inherit from vanilla boxes
  90.     LOCAL-LIBRARY      (GET INIT-PLIST ':LOCAL-LIBRARY)
  91.     FIRST-INFERIOR-ROW NIL
  92.     CACHED-ROWS        NIL
  93.     CACHED-CODE        NIL
  94.     STATIC-VARIABLES-ALIST (GET INIT-PLIST ':STATIC-VARIABLES-ALIST)
  95.     DISPLAY-STYLE-LIST (OR (GET INIT-PLIST ':DISPLAY-STYLE-LIST)
  96.                `(:NORMAL
  97.                  ,(GET INIT-PLIST ':FIXED-WID)
  98.                  ,(GET INIT-PLIST ':FIXED-HEI)))
  99.     ;; and this is from the graphics box itself
  100.     GRAPHICS-SHEET     (OR (GET INIT-PLIST ':GRAPHICS-SHEET)
  101.                (MAKE-GRAPHICS-SHEET (GET INIT-PLIST ':FIXED-WID)
  102.                         (GET INIT-PLIST ':FIXED-HEI)
  103.                         SELF))))
  104.  
  105. (DEFMETHOD (GRAPHICS-DATA-BOX :INIT) (INIT-PLIST)
  106.   (SETQ ;; These we inherit from chas.
  107.         SUPERIOR-ROW       (GET INIT-PLIST ':SUPERIOR-ROW)
  108.     CHA-CODE           ':BOX
  109.     FONT-NO            NIL
  110.     ;; These come from box proper.
  111.     LOCAL-LIBRARY      (GET INIT-PLIST ':LOCAL-LIBRARY)
  112.     FIRST-INFERIOR-ROW NIL
  113.     CACHED-ROWS        NIL
  114.     CACHED-CODE        NIL
  115.     GRAPHICS-SHEET     (OR (GET INIT-PLIST ':GRAPHICS-SHEET)
  116.                (MAKE-GRAPHICS-SHEET (GET INIT-PLIST ':FIXED-WID)
  117.                         (GET INIT-PLIST ':FIXED-HEI)
  118.                         SELF))))
  119.  
  120. (DEFMETHOD (CHA :AFTER :INIT-SELF-FROM-OLD-INSTANCE) (OLD-INSTANCE)
  121.   (LET ((SUPERIOR-CHAS-ARRAY (TELL-CHECK-NIL SUPERIOR-ROW :CHAS-ARRAY))
  122.     (OLD-CHA-NO  (TELL-CHECK-NIL (TELL OLD-INSTANCE :SUPERIOR-ROW)
  123.                       :CHA-CHA-NO OLD-INSTANCE)))
  124.     (WHEN (AND (NOT-NULL OLD-CHA-NO) (NOT-NULL SUPERIOR-CHAS-ARRAY))
  125.       (SETF (AREF SUPERIOR-CHAS-ARRAY OLD-CHA-NO)
  126.         (FOLLOW-STRUCTURE-FORWARDING (AREF SUPERIOR-CHAS-ARRAY OLD-CHA-NO))))))
  127.  
  128. ;;; this should go into BIND sometime
  129.  
  130. (DEFUN BINDINGS-FOR-OBJECT (OBJECT BINDING-ALIST)
  131.   (SUBSET #'(LAMBDA (X) (EQ OBJECT (CDR X))) BINDING-ALIST))
  132.  
  133. (DEFMETHOD (BOX :AFTER :INIT-SELF-FROM-OLD-INSTANCE) (OLD-INSTANCE)
  134.   (DOLIST (ROW (TELL SELF :ROWS))
  135.     (TELL ROW :SET-SUPERIOR-BOX (FOLLOW-STRUCTURE-FORWARDING (TELL ROW :SUPERIOR-BOX))))
  136.   (DOLIST (BINDING (BINDINGS-FOR-OBJECT
  137.              OLD-INSTANCE
  138.              (TELL (TELL SELF :SUPERIOR-BOX) :GET-STATIC-VARIABLES-ALIST)))
  139.     (SETF (CDR BINDING) (FOLLOW-STRUCTURE-FORWARDING (CDR BINDING)))))
  140.  
  141. (defMETHOD (GRAPHICS-BOX :BEFORE :SET-FLAVOR) (new)
  142.    (tell self :erase-from-screen)
  143.    (when (eq new 'graphics-data-box)
  144.      (convert-screen-objs 'screen-box)
  145. ;     (dolist (screen-obj (get-all-screen-objs self))
  146. ;      (unless (eq (tell screen-obj :box-type) :port-box)
  147. ;      (tell screen-obj :set-box-type ':graphics-data-box)))
  148.      (tell self :modified)))
  149.  
  150. (DEFUN-METHOD CONVERT-SCREEN-OBJS BOX (NEW-FLAVOR)
  151.   (MAPCAR #'(LAMBDA (OBJ)(TELL OBJ :SET-FLAVOR NEW-FLAVOR)
  152.             (UNLESS (PORT-BOX? (TELL OBJ :ACTUAL-OBJ))
  153.               (TELL OBJ :SET-ACTUAL-OBJ SELF)))
  154.       (GET-ALL-SCREEN-OBJS SELF)))
  155.  
  156. (defun get-visible-screen-objs (graphics-box)
  157.   (cond ((null (tell graphics-box :ports)) (tell graphics-box :displayed-screen-objs))
  158.     (t (append (tell graphics-box :displayed-screen-objs)
  159.            (loop for port in (tell graphics-box :ports)
  160.              appending (tell port :displayed-screen-objs))))))
  161.  
  162. (DEFUN GET-ALL-SCREEN-OBJS (BOX)
  163.   (cond ((null (tell box :ports)) (tell box :screen-objs))
  164.     (t (append (tell box :screen-objs)
  165.            (loop for port in (tell box :ports)
  166.              appending (tell port :screen-objs))))))
  167.  
  168. (DEFMETHOD (GRAPHICS-BOX :AFTER :INIT-SELF-FROM-OLD-INSTANCE) (IGNORE)
  169.   ;; presumably all the instance variables common with ordinary boxes will have been
  170.   ;; already initialized by the primary method.  All we have to do is...
  171.   (CONVERT-SCREEN-OBJS 'GRAPHICS-SCREEN-BOX)
  172.   (SETQ GRAPHICS-SHEET (MAKE-GRAPHICS-SHEET (CADR DISPLAY-STYLE-LIST)
  173.                         (CADDR DISPLAY-STYLE-LIST)
  174.                         SELF))
  175.   (TELL SELF :MODIFIED))
  176.  
  177. (DEFMETHOD (DOIT-BOX :AFTER :INIT-SELF-FROM-OLD-INSTANCE) (IGNORE)
  178.   (CONVERT-SCREEN-OBJS 'SCREEN-BOX)
  179.   (DOLIST (ROW (TELL SELF :ROWS))
  180.     (TELL ROW :MODIFIED)))
  181.  
  182. (DEFMETHOD (DATA-BOX :AFTER :INIT-SELF-FROM-OLD-INSTANCE) (IGNORE)
  183.   (CONVERT-SCREEN-OBJS 'SCREEN-BOX)
  184.   (DOLIST (ROW (TELL SELF :ROWS))
  185.     (TELL ROW :MODIFIED)))
  186.  
  187. (DEFMETHOD (BOX :AFTER :INIT) (INIT-PLIST)
  188.   (TELL SELF :APPEND-ROW (OR (GET INIT-PLIST ':FIRST-INFERIOR-ROW)
  189.                  (MAKE-INITIALIZED-ROW))))
  190.  
  191. (DEFMETHOD (BOX :SEMI-INIT) (INIT-PLIST)
  192.   (SETQ ;;these come from box proper
  193.     FIRST-INFERIOR-ROW (GET INIT-PLIST ':SUPERIOR-ROW)
  194.     CACHED-ROWS        NIL
  195.     CACHED-CODE        NIL
  196.     NAME               (WHEN (GET INIT-PLIST :NAME)
  197.                  (MAKE-NAME-ROW `(,(GET INIT-PLIST :NAME))))
  198.     DISPLAY-STYLE-LIST (OR (GET INIT-PLIST ':DISPLAY-STYLE-LIST)
  199.                    DISPLAY-STYLE-LIST))
  200.   (WHEN (NAME-ROW? NAME) (TELL NAME :SET-SUPERIOR-BOX SELF))
  201.   (TELL SELF :SET-TYPE (OR (GET INIT-PLIST ':TYPE) ':DOIT-BOX)))
  202.  
  203. (DEFMETHOD (PORT-BOX :AFTER :SEMI-INIT) (INIT-PLIST)
  204.   ;; might as well look to see if it is there...
  205.   (SETQ PORTS (OR (GET INIT-PLIST :PORTS) PORTS)))
  206.  
  207. (DEFMETHOD (BOX :RETURN-INIT-PLIST-FOR-FILING) ()
  208.   `(:TYPE ,(TELL SELF :TYPE)
  209.     :DISPLAY-STYLE-LIST ,DISPLAY-STYLE-LIST))
  210.  
  211. (DEFMETHOD (GRAPHICS-BOX :RETURN-INIT-PLIST-FOR-FILING) ()
  212.   `(:TYPE ,(TELL SELF :TYPE)
  213.     :DISPLAY-STYLE-LIST ,DISPLAY-STYLE-LIST
  214.     :GRAPHICS-SHEET ,GRAPHICS-SHEET))
  215.  
  216. (DEFMETHOD (BOX :RETURN-INIT-PLIST-FOR-COPY) ()
  217.   (IF (NAME-ROW? NAME)
  218.       `(:TYPE ,(TELL SELF :TYPE)
  219.     :DISPLAY-STYLE-LIST ,DISPLAY-STYLE-LIST :NAME ,(TELL SELF :NAME))
  220.       `(:TYPE ,(TELL SELF :TYPE)
  221.     :DISPLAY-STYLE-LIST ,DISPLAY-STYLE-LIST)))
  222.  
  223.  
  224.  
  225. ;;;;PRINT-SELF methods.
  226.  
  227. (DEFMETHOD (ROW :SHOW-CHAS) ()
  228.   (FORMAT STANDARD-OUTPUT "~%")
  229.   (DOLIST (CHA (TELL SELF :CHAS))
  230.     (IF (CHA? CHA)
  231.     (FORMAT STANDARD-OUTPUT "~C" CHA)
  232.     (TELL CHA :PRINT-SELF STANDARD-OUTPUT))))
  233.  
  234. (DEFMETHOD (BOX :PRINT-SELF) (STREAM &REST IGNORE)
  235.   (FORMAT STREAM "#<~a " (TELL SELF :TYPE))
  236.   (BOX-PRINT-SELF-INTERNAL SELF STREAM)
  237.   (FORMAT STREAM " >"))
  238.  
  239. (DEFMETHOD (GRAPHICS-BOX :PRINT-SELF) (STREAM &REST IGNORE)
  240.   (FORMAT STREAM "#<~a ~a >" (TELL SELF :TYPE) (tell self :NAME)))
  241.  
  242. (DEFMETHOD (SCREEN-BOX :PRINT-SELF) (STREAM &REST IGNORE)
  243.   (FORMAT STREAM "#<SCREEN-BOX ")
  244.   (IF (GRAPHICS-BOX? ACTUAL-OBJ)
  245.       (FORMAT STREAM "~a " (TELL ACTUAL-OBJ :TYPE))
  246.       (BOX-PRINT-SELF-INTERNAL ACTUAL-OBJ STREAM))
  247.   (FORMAT STREAM " >"))
  248.  
  249. (DEFMETHOD (ROW :PRINT-SELF) (STREAM &REST IGNORE)
  250.   (FORMAT STREAM "#<ROW ")
  251.   (ROW-PRINT-SELF-INTERNAL SELF STREAM)
  252.   (FORMAT STREAM " >"))
  253.  
  254. (DEFMETHOD (NAME-ROW :PRINT-SELF) (STREAM &REST IGNORE)
  255.   (FORMAT STREAM "#<NAME-ROW ")
  256.   (ROW-PRINT-SELF-INTERNAL SELF STREAM)
  257.   (FORMAT STREAM " >"))
  258.  
  259. (DEFUN CHA-PRINT-SELF-INTERNAL (CHA STREAM)
  260.   (COND ((BOX? CHA)
  261.      (FORMAT STREAM "[]"))
  262.     (T
  263.      (FORMAT STREAM "~C" (CHA-CODE CHA)))))
  264.  
  265. (DEFUN ROW-PRINT-SELF-INTERNAL (ROW STREAM)
  266.   (PROG ()
  267.     (DO-ROW-CHAS ((CHA ROW)
  268.           (CHA-NO 0 (+ CHA-NO 1)))
  269.      (COND ((> CHA-NO 5)
  270.         (FORMAT STREAM "...")
  271.         (RETURN))
  272.        (T
  273.         (CHA-PRINT-SELF-INTERNAL CHA STREAM))))))
  274.  
  275. (DEFUN BOX-PRINT-SELF-INTERNAL (BOX STREAM)
  276.   (LET ((FIRST-ROW (TELL BOX :ROW-AT-ROW-NO 0)))
  277.     (COND ((NULL FIRST-ROW))
  278.       (T
  279.        (ROW-PRINT-SELF-INTERNAL FIRST-ROW STREAM)))))
  280.  
  281.     
  282.  
  283. ;;keep these around for boxes to use...
  284.  
  285. (DEFGET-METHODS ((CHA :SUPERIOR-ROW) :SUPERIOR-OBJ) SUPERIOR-ROW)
  286. (DEFSET-METHODS ((CHA :SET-SUPERIOR-ROW) :SET-SUPERIOR-OBJ) SUPERIOR-ROW)
  287.  
  288. (DEFMETHOD (CHA :SUPERIOR-BOX) ()
  289.   (TELL SUPERIOR-ROW :SUPERIOR-BOX))
  290.  
  291.  
  292.  
  293.  
  294.  
  295.  
  296.  
  297. ;;;;USEFUL-MAPPING-FUNCTIONS
  298.  
  299. (DEFUN MAP-OVER-ALL-INFERIOR-BOXES (SUPERIOR-BOX FUNCTION)
  300.   (DO ((ROW (TELL SUPERIOR-BOX :FIRST-INFERIOR-ROW) (TELL ROW :NEXT-ROW)))
  301.       ((NULL ROW))
  302.     (DO* ((CHA-NO 0 (+ CHA-NO 1))
  303.       (CHA (TELL ROW :CHA-AT-CHA-NO CHA-NO) (TELL ROW :CHA-AT-CHA-NO CHA-NO)))
  304.      ((NULL CHA))
  305.       (COND ((BOX? CHA)
  306.          (FUNCALL FUNCTION CHA)
  307.          (MAP-OVER-ALL-INFERIOR-BOXES CHA FUNCTION))))))
  308.  
  309. (DEFUN MAP-OVER-INFERIOR-BOXES (SUPERIOR-BOX FUNCTION)
  310.   (DOLIST (ROW (TELL SUPERIOR-BOX :ROWS))
  311.     (DOLIST (CHA (TELL ROW :CHAS))
  312.       (WHEN (BOX? CHA)
  313.         (FUNCALL FUNCTION CHA)))))
  314.  
  315.  
  316.  
  317. (DEFMETHOD (BOX :MODIFIED) (&OPTIONAL (DECACHE T))
  318.   (WHEN (NOT-NULL DECACHE)
  319.     (SETQ CACHED-ROWS NIL
  320.           CACHED-CODE NIL)
  321.     (TELL SELF :PUTPROP NIL 'CACHED-BUILD))
  322.   (TELL-CHECK-NIL (TELL SELF :SUPERIOR-ROW) :MODIFIED))
  323.  
  324. (DEFMETHOD (ROW :MODIFIED) (&OPTIONAL (DECACHE T))
  325.   (WHEN (NOT-NULL DECACHE)
  326.     (SETQ CACHED-CHAS     NIL
  327.           CACHED-ENTRIES  NIL
  328.           CACHED-ELEMENTS NIL
  329.           CACHED-ITEMS    NIL
  330.           CACHED?         NIL))
  331.   (TELL-CHECK-NIL (TELL SELF :SUPERIOR-BOX) :MODIFIED T))
  332.  
  333.  
  334.  
  335.  
  336. ;;;;INCREMENT and SET-TYPE
  337.  
  338. (DEFVAR *TOGGLING-BOX-TYPES* `(:DOIT-BOX :DATA-BOX)
  339.   "This is a circular list of the different possible types of boxes.
  340.    The list is circular to make it easy to define a next type for
  341.    each type, this is used by (:method box :increment-type).")
  342.  
  343. (DEFUN TOGGLING-BOX-TYPES-NEXT-BOX-TYPE (OLD-TYPE)
  344.   (LET ((POS (FIND-POSITION-IN-LIST OLD-TYPE *TOGGLING-BOX-TYPES*))
  345.     (LEN (LENGTH *TOGGLING-BOX-TYPES*)))
  346.     (COND ((NULL POS) (CAR *TOGGLING-BOX-TYPES*))
  347.       (T (NTH (REMAINDER (+ POS 1) LEN) *TOGGLING-BOX-TYPES*)))))
  348.  
  349. (DEFMETHOD (LL-BOX :TOGGLE-TYPE) ()
  350.   (BEEP))
  351.  
  352. (DEFMETHOD (DOIT-BOX :TYPE) ()
  353.   ':DOIT-BOX)
  354.  
  355. (DEFMETHOD (DATA-BOX :TYPE) ()
  356.   ':DATA-BOX)
  357.  
  358. (DEFMETHOD (LL-BOX :TYPE) ()
  359.   ':LL-BOX)
  360.  
  361. (DEFMETHOD (PORT-BOX :TYPE) ()
  362.   ':PORT-BOX)
  363.  
  364. (DEFMETHOD (GRAPHICS-BOX :TYPE) ()
  365.   ':GRAPHICS-BOX)
  366.  
  367. (DEFMETHOD (INPUT-BOX :TYPE) ()
  368.   ':INPUT-BOX)
  369.  
  370. (DEFMETHOD (BOX :SET-TYPE) (NEW-TYPE)
  371.   (SELECTQ NEW-TYPE
  372.     ((:DOIT-BOX DOIT-BOX)
  373.      (TELL SELF :SET-FLAVOR 'DOIT-BOX))
  374.     ((:DATA-BOX DATA-BOX)
  375.      (TELL SELF :SET-FLAVOR 'DATA-BOX))
  376.     ((:PORT-BOX PORT-BOX)
  377.      (TELL SELF :SET-FLAVOR 'PORT-BOX))
  378.     ((:LL-BOX LL-BOX)
  379.      (TELL SELF :SET-FLAVOR 'LL-BOX))
  380.     ((:GRAPHICS-BOX GRAPHICS-BOX)
  381.      (TELL SELF :SET-FLAVOR 'GRAPHICS-BOX))
  382.     ((:graphics-data-box graphics-data-box)
  383.      (tell self :set-flavor 'graphics-data-box))
  384.     ((:sprite-box sprite-box)
  385.      (tell self :set-flavor 'sprite-box))
  386.     ((:INPUT-BOX INPUT-BOX)
  387.      (TELL SELF :SET-FLAVOR 'INPUT-BOX))
  388.     (OTHERWISE (FERROR "can't set ~s to ~s"SELF NEW-TYPE)))
  389.   (TELL SELF :MODIFIED))
  390.     
  391. (DEFMETHOD (BOX :TOGGLE-TYPE) ()
  392.   (TELL SELF :SET-TYPE (TOGGLING-BOX-TYPES-NEXT-BOX-TYPE (TELL SELF :TYPE))))
  393.  
  394. (DEFMETHOD (GRAPHICS-BOX :TOGGLE-TYPE) ()
  395.   (TELL SELF :SET-TYPE 'GRAPHICS-DATA-BOX))
  396.  
  397. (DEFMETHOD (GRAPHICS-DATA-BOX :TOGGLE-TYPE) ()
  398.   (IF (EQ SELF (OUTERMOST-BOX)) (BEEP)
  399.       (TELL SELF :SET-TYPE 'GRAPHICS-BOX)))
  400.  
  401.  
  402.  
  403. ;;;; PORTS.
  404.  
  405. (DEFMETHOD (PORT-BOX :SET-PORT-TO-BOX) (NEW-VALUE)
  406.   (TELL NEW-VALUE :ADD-PORT SELF)
  407.   (SETQ PORTS NEW-VALUE))
  408.  
  409. (DEFMETHOD (BOX :ADD-PORT) (PORT-TO-ADD)
  410.   (UNLESS (MEMQ PORT-TO-ADD PORTS)
  411.       (PUSH PORT-TO-ADD PORTS)))
  412.  
  413. (DEFMETHOD (PORT-BOX :ADD-PORT) (PORT-TO-ADD)
  414.   (TELL PORTS :ADD-PORT PORT-TO-ADD))
  415.  
  416. (DEFMETHOD (BOX :REMOVE-PORT) (PORT-TO-DELETE)
  417.   (SETQ PORTS (DELQ PORT-TO-DELETE PORTS)))
  418.  
  419. ;; what happens when a port's target is removed from the hierarchy ?
  420. ;; This is just a stub until we decide what to do.  Old proposal to mark the port as "broken"
  421. ;; needs some redisplay hacking
  422. (DEFMETHOD (PORT-BOX :TARGET-HAS-BEEN-DELETED-HANDLER) ()
  423.   )
  424.  
  425. ;; Another stub
  426. (DEFMETHOD (PORT-BOX :TARGET-HAS-BEEN-INSERTED-HANDLER) (TARGET)
  427.   TARGET)
  428.  
  429. ;; Doesn't create the back pointer so that the port can eventually be GC'd
  430. ;; ports which use this should NEVER, NEVER, NEVER be inserted into the editor
  431. (DEFMETHOD (PORT-BOX :SET-PORT-TO-BOX-FOR-EVAL) (NEW-VALUE)
  432.   (SETQ PORTS NEW-VALUE))
  433.  
  434. (DEFMETHOD (PORT-BOX :FIRST-INFERIOR-ROW) ()
  435.   (TELL-CHECK-NIL PORTS :FIRST-INFERIOR-ROW))
  436.  
  437. (DEFMETHOD (PORT-BOX :FIRST-INFERIOR-OBJ) ()
  438.   (TELL-CHECK-NIL PORTS :FIRST-INFERIOR-OBJ))
  439.  
  440. (DEFMETHOD (PORT-BOX :ROW-AT-ROW-NO) (ROW-NO)
  441.   (TELL-CHECK-NIL PORTS :ROW-AT-ROW-NO ROW-NO))
  442.  
  443. (DEFMETHOD (PORT-BOX :TICK) ()
  444.   (MAX (TELL-CHECK-NIL PORTS :TICK) TICK))
  445.                         
  446. (DEFWHOPPER (BOX :MODIFIED) (&OPTIONAL (DECACHE T))
  447.   (CONTINUE-WHOPPER DECACHE)
  448.   (IF (LISTP PORTS)
  449.       (DOLIST (PORT PORTS)
  450.     (TELL PORT :MODIFIED DECACHE))))
  451.  
  452. ;;; These are needed to handle :MODIFIED for circular structures
  453. (DEFVAR *PORTS-ALREADY-MODIFIED* NIL)
  454.  
  455. (DEFWHOPPER (PORT-BOX :MODIFIED) (&OPTIONAL (DECACHE T))
  456.   (UNLESS (MEMQ SELF *PORTS-ALREADY-MODIFIED*)
  457.     (LET ((*PORTS-ALREADY-MODIFIED* (APPEND *PORTS-ALREADY-MODIFIED* (NCONS SELF))))
  458.       (CONTINUE-WHOPPER DECACHE))))
  459.  
  460. (DEFMETHOD (BOX :CLEAR-PORTS)()
  461.   ;; for debugging
  462.   (SETQ PORTS NIL))
  463.  
  464. (DEFMETHOD (BOX :PORTS) ()
  465.   PORTS)
  466.  
  467. (DEFMETHOD (PORT-BOX :GRAPHICS-SHEET) ()
  468.   (TELL-CHECK-NIL PORTS :GRAPHICS-SHEET))
  469.  
  470. (DEFMETHOD (PORT-BOX :BIT-ARRAY-WID) ()
  471.   (TELL-CHECK-NIL PORTS :BIT-ARRAY-WID))
  472.  
  473. (DEFMETHOD (PORT-BOX :BIT-ARRAY-HEI) ()
  474.   (TELL-CHECK-NIL PORTS :BIT-ARRAY-HEI))
  475.  
  476. (DEFMETHOD (PORT-BOX :GRAPHICS-SHEET-SIZE) ()
  477.   (TELL-CHECK-NIL PORTS :GRAPHICS-SHEET-SIZE))
  478.  
  479. (DEFMETHOD (PORT-BOX :TOGGLE-TYPE) ()
  480.   (TELL-CHECK-NIL PORTS :TOGGLE-TYPE))
  481.  
  482. (DEFMETHOD (PORT-BOX :SET-TYPE) (TYPE)
  483.   (TELL-CHECK-NIL PORTS :SET-TYPE TYPE))
  484.  
  485. (COMMENT                    ;flush as soon as fasdumper works
  486. ;;;true names are given to boxes which are being ported to and are only assigned
  487. ;;;when a box merits one {which is at port creation time}.  If the port is
  488. ;;;streamified, then the true name is stored in the port-stream and both the
  489. ;;;true name and the box it refers to are stored in a hash table, the...
  490. ;;;...*port-hash-table*
  491.  
  492. (DEFMETHOD (BOX :SET-TRUE-NAME) (NEW-NAME)
  493.   (WHEN (NULL TRUE-NAME)
  494.     (SETQ TRUE-NAME NEW-NAME)
  495.     (INTERN NEW-NAME 'BOXER)))
  496.  
  497. (DEFMETHOD (BOX :TRUE-NAME) ()
  498.   TRUE-NAME)
  499.  
  500. (DEFMETHOD (BOX :CHANGE-TRUE-NAME) ()
  501.   (LET ((NEW-TRUE-NAME (GENSYM)))
  502.     (INTERN NEW-TRUE-NAME 'BOXER)
  503.     (SETQ TRUE-NAME NEW-TRUE-NAME)))
  504.  
  505. )                        ;end of comment
  506.  
  507.  
  508.  
  509. ;;; Keeping track of Ports and their targets
  510.  
  511. (DEFMETHOD (BOX :APPEND-INFERIOR-PORTS) (NEW-PORTS)
  512.   (IF (LISTP NEW-PORTS) (SETQ INFERIOR-PORTS (CL:DELETE-DUPLICATES
  513.                            (APPEND INFERIOR-PORTS NEW-PORTS)))
  514.       (UNLESS (MEMQ NEW-PORTS INFERIOR-PORTS)
  515.     (SETQ INFERIOR-PORTS (APPEND INFERIOR-PORTS (NCONS NEW-PORTS)))))
  516.   (TELL-CHECK-NIL (TELL SELF :SUPERIOR-BOX) :APPEND-INFERIOR-PORTS NEW-PORTS))
  517.  
  518. (DEFMETHOD (BOX :REMOVE-INFERIOR-PORTS) (OLD-PORTS)
  519.   (IF (LISTP OLD-PORTS) (SETQ INFERIOR-PORTS (CL:SET-DIFFERENCE INFERIOR-PORTS OLD-PORTS))
  520.       (SETQ INFERIOR-PORTS (DELQ OLD-PORTS INFERIOR-PORTS)))
  521.   (TELL-CHECK-NIL (TELL SELF :SUPERIOR-BOX) :REMOVE-INFERIOR-PORTS OLD-PORTS))
  522.  
  523. (DEFMETHOD (BOX :APPEND-INFERIOR-TARGETS) (NEW-TARGETS)
  524.   (IF (LISTP NEW-TARGETS) (SETQ INFERIOR-TARGETS (CL:DELETE-DUPLICATES
  525.                            (APPEND INFERIOR-TARGETS NEW-TARGETS)))
  526.       (UNLESS (MEMQ NEW-TARGETS INFERIOR-TARGETS)
  527.     (SETQ INFERIOR-TARGETS (APPEND INFERIOR-TARGETS (NCONS NEW-TARGETS)))))
  528.   (TELL-CHECK-NIL (TELL SELF :SUPERIOR-BOX) :APPEND-INFERIOR-TARGETS NEW-TARGETS))
  529.  
  530. (DEFMETHOD (BOX :REMOVE-INFERIOR-TARGETS) (OLD-TARGETS)
  531.   (IF (LISTP OLD-TARGETS) (SETQ INFERIOR-TARGETS
  532.                 (CL:SET-DIFFERENCE INFERIOR-TARGETS OLD-TARGETS))
  533.       (SETQ INFERIOR-TARGETS (DELQ OLD-TARGETS INFERIOR-TARGETS)))
  534.   (TELL-CHECK-NIL (TELL SELF :SUPERIOR-BOX) :REMOVE-INFERIOR-TARGETS OLD-TARGETS))
  535.  
  536.  
  537. ;;; in/out of the editor hierarchy
  538.  
  539. ;;; Every Box needs to hack the namespace and the deallocation of screen objs
  540.  
  541. (DEFMETHOD (BOX :DELETE-SELF-ACTION) ()
  542.   (LET ((SUPERIOR-BOX (TELL SELF :SUPERIOR-BOX)))
  543.     (SETQ SCREEN-OBJS NIL)
  544.     ;; update inferior port information
  545.     (UNLESS (NULL INFERIOR-PORTS)
  546.       (DOLIST (INFERIOR-PORT INFERIOR-PORTS)
  547.     (TELL (TELL INFERIOR-PORT :PORTS) :REMOVE-PORT INFERIOR-PORT))
  548.       (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-INFERIOR-PORTS INFERIOR-PORTS))
  549.     ;; update inferior target information
  550.     (COND ((AND (NULL INFERIOR-TARGETS) (NULL PORTS)))
  551.       ((NULL PORTS)
  552.        (DOLIST (INFERIOR-TARGET INFERIOR-TARGETS)
  553.          (DOLIST (P (TELL INFERIOR-TARGET :PORTS))
  554.            (TELL P :TARGET-HAS-BEEN-DELETED-HANDLER)))
  555.        (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-INFERIOR-TARGETS INFERIOR-TARGETS))
  556.       ((NULL INFERIOR-TARGETS)
  557.        (DOLIST (P PORTS)
  558.          (TELL P :TARGET-HAS-BEEN-DELETED-HANDLER))
  559.        (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-INFERIOR-TARGETS SELF))
  560.       (T
  561.        (DOLIST (INFERIOR-TARGET INFERIOR-TARGETS)
  562.          (DOLIST (P (TELL INFERIOR-TARGET :PORTS))
  563.            (TELL P :TARGET-HAS-BEEN-DELETED-HANDLER)))
  564.        (DOLIST (P PORTS)
  565.          (TELL P :TARGET-HAS-BEEN-DELETED-HANDLER))
  566.        (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-INFERIOR-TARGETS
  567.                             (LIST* SELF INFERIOR-TARGETS))))
  568.     ;; update the namespace 
  569.     (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-ALL-STATIC-BINDINGS SELF)))
  570.  
  571. (DEFMETHOD (PORT-BOX :DELETE-SELF-ACTION) ()
  572.   (LET ((SUPERIOR-BOX (TELL SELF :SUPERIOR-BOX)))
  573.     (SETQ SCREEN-OBJS NIL)
  574.     (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-ALL-STATIC-BINDINGS SELF)
  575.     (TELL-CHECK-NIL SUPERIOR-BOX :REMOVE-INFERIOR-PORTS SELF)
  576.     (TELL PORTS :REMOVE-PORT SELF)
  577.     (WHEN (NULL (TELL PORTS :PORTS))
  578.       ;; if the target has run out of ports, then inform its superior
  579.       (TELL-CHECK-NIL (TELL PORTS :SUPERIOR-BOX) :REMOVE-INFERIOR-TARGETS PORTS))))
  580.  
  581. (DEFMETHOD (BOX :INSERT-SELF-ACTION) ()
  582.   (LET ((SUPERIOR-BOX (TELL SELF :SUPERIOR-BOX)))
  583.     (COND-EVERY ((NAME-ROW? NAME)
  584.          (TELL NAME :UPDATE-BINDINGS T))
  585.         ((NOT-NULL EXPORTS)
  586.          (TELL-CHECK-NIL SUPERIOR-BOX
  587.                  :ADD-STATIC-VARIABLE-PAIR *EXPORTING-BOX-MARKER* SELF)))
  588.     ;; update the inferior port information
  589.     (UNLESS (NULL INFERIOR-PORTS)
  590.       (DOLIST (INFERIOR-PORT INFERIOR-PORTS)
  591.     (TELL (TELL INFERIOR-PORT :PORTS) :ADD-PORT INFERIOR-PORT))
  592.       (TELL-CHECK-NIL SUPERIOR-BOX :APPEND-INFERIOR-PORTS INFERIOR-PORTS))
  593.     ;; update the inferior target information
  594.     (COND ((AND (NULL INFERIOR-TARGETS) (NULL PORTS)))
  595.       ((NULL PORTS)
  596.        (DOLIST (INFERIOR-TARGET INFERIOR-TARGETS)
  597.          (DOLIST (P (TELL INFERIOR-TARGET :PORTS))
  598.            (TELL P :TARGET-HAS-BEEN-INSERTED-HANDLER INFERIOR-TARGET)))
  599.        (TELL-CHECK-NIL SUPERIOR-BOX :APPEND-INFERIOR-TARGETS INFERIOR-TARGETS))
  600.       ((NULL INFERIOR-TARGETS)
  601.        (DOLIST (P PORTS)
  602.          (TELL P :TARGET-HAS-BEEN-INSERTED-HANDLER SELF))
  603.        (TELL-CHECK-NIL SUPERIOR-BOX :APPEND-INFERIOR-TARGETS SELF))
  604.       (T
  605.        (DOLIST (INFERIOR-TARGET INFERIOR-TARGETS)
  606.          (DOLIST (P (TELL INFERIOR-TARGET :PORTS))
  607.            (TELL P :TARGET-HAS-BEEN-INSERTED-HANDLER INFERIOR-TARGET)))
  608.        (DOLIST (P PORTS)
  609.          (TELL P :TARGET-HAS-BEEN-INSERTED-HANDLER SELF))
  610.        (TELL-CHECK-NIL SUPERIOR-BOX :APPEND-INFERIOR-TARGETS
  611.                             (LIST* SELF INFERIOR-TARGETS))))))
  612.  
  613. (DEFMETHOD (PORT-BOX :INSERT-SELF-ACTION) ()
  614.   (LET ((SUPERIOR-BOX (TELL SELF :SUPERIOR-BOX)))
  615.     (COND-EVERY ((NAME-ROW? NAME)
  616.          (TELL NAME :UPDATE-BINDINGS T))
  617.         ((NOT-NULL EXPORTS)
  618.          (TELL-CHECK-NIL SUPERIOR-BOX
  619.                  :ADD-STATIC-VARIABLE-PAIR *EXPORTING-BOX-MARKER* SELF)))
  620.     (TELL-CHECK-NIL SUPERIOR-BOX :APPEND-INFERIOR-PORTS SELF)
  621.     ;; The inferior target information is handled here because this is the point where we can
  622.     ;; be absolutely sure that the port has been inserted/deleted from the hierarchy.  
  623.     ;; Otherwise ABORT in the middle of port creation would result in a spurious target entry
  624.     (TELL-CHECK-NIL PORTS :ADD-PORT SELF)
  625.     (TELL-CHECK-NIL  (TELL-CHECK-NIL PORTS :SUPERIOR-BOX) :APPEND-INFERIOR-TARGETS PORTS)))
  626.  
  627. (DEFMETHOD (LL-BOX :DELETE-SELF-ACTION) ()
  628.   ;; we don't want to remove the local library from the environment structure
  629.   NIL)
  630.  
  631. (DEFMETHOD (LL-BOX :INSERT-SELF-ACTION) ()
  632.   NIL)
  633.  
  634. (DEFUN GET-BOX-NAME (NAME-ROW)
  635.   (IF (ROW? NAME-ROW)
  636.       (LET ((ROW-ENTRIES (TELL NAME-ROW :ENTRIES)))
  637.     (COND ((NULL ROW-ENTRIES) NIL)
  638.           (T (INTERN
  639.            (LOOP WITH NAME = ""
  640.              FOR ENTRY IN ROW-ENTRIES
  641.              IF (EQ ENTRY (CAR ROW-ENTRIES))
  642.                DO (SETQ NAME (STRING ENTRY))
  643.              ELSE
  644.                DO (SETQ NAME (STRING-APPEND NAME (FORMAT NIL "_~A" ENTRY)))
  645.              FINALLY        
  646.                (RETURN NAME))
  647.            PKG-BU-PACKAGE))))
  648.       NIL))
  649.  
  650. (DEFUN MAKE-NAME-ROW (STUFF &OPTIONAL (CACHED-NAME NIL))
  651.   (COND ((ROW? STUFF)
  652.      STUFF)
  653.     (T
  654.      (LET ((ROW-STREAM (MAKE-ROW-STREAM `(:ROW . ,STUFF)))
  655.            (NEW-ROW (MAKE-INSTANCE 'NAME-ROW ':CACHED-NAME CACHED-NAME)))
  656.        (TELL NEW-ROW :SET-CONTENTS-FROM-STREAM ROW-STREAM NIL)
  657.        NEW-ROW))))
  658.  
  659. (DEFMETHOD (NAME-ROW :AFTER :MODIFIED) (&REST IGNORE)
  660.   ;(TELL SELF :UPDATE-BINDINGS)
  661.   (DOLIST (ROW (TELL SUPERIOR-BOX :ROWS))
  662.     (TELL ROW :MODIFIED)))
  663.  
  664. (DEFMETHOD (BOX :NAME-ROW) ()
  665.   (WHEN (NAME-ROW? NAME)
  666.     NAME))
  667.  
  668. (DEFMETHOD (BOX :MAKE-NAME-ROW) ()
  669.   (LET ((NAME-ROW (MAKE-INSTANCE 'NAME-ROW)))
  670.     (SETQ NAME NAME-ROW)
  671.     (TELL NAME-ROW :SET-SUPERIOR-BOX SELF)))
  672.  
  673.  
  674.  
  675.  
  676. ;;;; BP's
  677.  
  678. (DEFUN SET-BP-ROW (BP NEW-ROW)
  679.   (CHECK-BP-ARG BP)
  680.   (CHECK-ROW-ARG NEW-ROW)
  681.   (LET ((OLD-ROW (BP-ROW BP)))
  682.     (UNLESS (EQ OLD-ROW NEW-ROW)
  683.       (SETF (%BP-ROW BP) NEW-ROW)
  684.       (SETF (ROW-BPS OLD-ROW) (DELQ BP (ROW-BPS OLD-ROW)))
  685.       (SETF (ROW-BPS NEW-ROW) (CONS BP (ROW-BPS NEW-ROW))))))
  686.  
  687. (DEFUN SET-BP-CHA-NO (BP NEW-CHA-NO)
  688.   (CHECK-ARG NEW-CHA-NO 'NUMBERP "A number")
  689.   (SETF (%BP-CHA-NO BP) NEW-CHA-NO))
  690.  
  691. (DEFUN SET-BP-SCREEN-BOX (BP NEW-SCREEN-BOX)
  692.   (CHECK-BP-ARG BP)
  693.   (OR (NULL NEW-SCREEN-BOX) (CHECK-SCREEN-BOX-ARG NEW-SCREEN-BOX))
  694.   (LET ((OLD-SCREEN-BOX (BP-SCREEN-BOX BP)))
  695.     (UNLESS (EQ OLD-SCREEN-BOX NEW-SCREEN-BOX)
  696.       (SETF (%BP-SCREEN-BOX BP) NEW-SCREEN-BOX)
  697.       (TELL OLD-SCREEN-BOX :DELETE-BP BP)
  698.       (TELL NEW-SCREEN-BOX :ADD-BP BP))))
  699.  
  700. (DEFUN SET-BP-FROM-BP (BP FROM-BP &OPTIONAL (SCREEN-BOX-TOO? T))
  701.   "Changes the first BP to point to the same place as the second BP without changing
  702. the type. "
  703.   (CHECK-BP-ARG BP)
  704.   (CHECK-BP-ARG FROM-BP)
  705.   (SET-BP-CHA-NO BP (BP-CHA-NO FROM-BP))
  706.   (SET-BP-ROW    BP (BP-ROW FROM-BP))
  707.   (WHEN SCREEN-BOX-TOO?
  708.     (SET-BP-SCREEN-BOX BP (BP-SCREEN-BOX FROM-BP))))
  709.  
  710. (DEFUN SET-BP-TYPE (BP NEW-TYPE)
  711.   (COND ((MEMQ NEW-TYPE '(:MOVING :FIXED))
  712.      (SETF (%BP-TYPE BP) NEW-TYPE))
  713.     (T
  714.      (FERROR "~S is an illegal type for a BP."))))
  715.  
  716. ;;; This is useful. Note that setting a BP's Box doesn't make any sense.
  717.  
  718. (DEFUN BP-BOX (BP)
  719.   (TELL (BP-ROW BP) :SUPERIOR-BOX))
  720.  
  721. ;;; Comparing BP's. BP-> returns T if <BP1> is farther along in the buffer than <BP2>.
  722. ;;; Note that farther along is defined in a top-to-bottom left-to-right sense and that depth
  723. ;;; is ignored since the function traverses upward into the lowest common superior box before 
  724. ;;; doing the compare
  725.  
  726. ;; Both rows are assumed to be in the same box.  
  727. (DEFUN ROW-> (ROW1 ROW2 &OPTIONAL (BOX (TELL ROW1 :SUPERIOR-BOX)))
  728.   (LOOP FOR ROW = (TELL BOX :FIRST-INFERIOR-ROW) THEN (TELL ROW :NEXT-ROW)
  729.     UNTIL (NULL ROW)
  730.     WHEN (EQ ROW ROW1)
  731.     RETURN NIL
  732.     WHEN (EQ ROW ROW2)
  733.     RETURN T))
  734.  
  735. (DEFUN ROW-< (ROW1 ROW2 &OPTIONAL (BOX (TELL ROW1 :SUPERIOR-BOX)))
  736.   (LOOP FOR ROW = (TELL BOX :FIRST-INFERIOR-ROW) THEN (TELL ROW :NEXT-ROW)
  737.     UNTIL (NULL ROW)
  738.     WHEN (EQ ROW ROW2)
  739.     RETURN NIL
  740.     WHEN (EQ ROW ROW1)
  741.     RETURN T))
  742.  
  743. ;; this assumes that the BP's are in the same box and have already been decoded
  744. ;; into ROWs and CHA-NOs and returns T if the BP represented by ROW1, CHA-NO1 come FIRST
  745. (DEFSUBST BP-COMPARE-INTERNAL-SIMPLE (ROW1 ROW2 CHA-NO1 CHA-NO2)
  746.   (COND ((AND (EQ ROW1 ROW2) (= CHA-NO1 CHA-NO2)) :EQUAL)
  747.     ((AND (EQ ROW1 ROW2) (< CHA-NO1 CHA-NO2)) T)
  748.     ((EQ ROW1 ROW2)                        NIL)
  749.     ((ROW-< ROW1 ROW2)                        T)
  750.     (T                                        NIL)))
  751.  
  752. ;; this gets used ONLY IF the BP's aren't in the same box
  753. ;; returns the BP which occurs FIRST
  754. ;; since we are doing all this marching up and down in box structure, we might as well also
  755. ;; throw back the top level box which is inferior to the lowest common superior for each BP
  756. ;; so that other functions won't have to do all this work
  757. ;; The order of the values reurned are 1) Leading BP. 2) Leading box. 3) Trailing Box
  758.  
  759. (DEFSUBST BP-COMPARE-INTERNAL-HAIRY (BP1 BP2 ROW1 ROW2 BOX1 BOX2)
  760.   (MULTIPLE-VALUE-BIND (TOP12 PATH12)
  761.       (FIND-PATH BOX1 BOX2)
  762.     (MULTIPLE-VALUE-BIND (TOP21 PATH21)
  763.     (FIND-PATH BOX2 BOX1)
  764.       (LET ((APPARENT-ROW1 (TELL-CHECK-NIL (CAR PATH21) :SUPERIOR-ROW))
  765.         (APPARENT-ROW2 (TELL-CHECK-NIL (CAR PATH12) :SUPERIOR-ROW)))
  766.     (COND ((AND (NULL TOP12)        ;BP2 is in some inferior of BOX1
  767.             (BP-COMPARE-INTERNAL-SIMPLE
  768.               ROW1            APPARENT-ROW2
  769.               (BP-CHA-NO BP1) (TELL APPARENT-ROW2 :CHA-CHA-NO (CAR PATH12))))
  770.            (VALUES BP1 (CAR PATH21) (CAR PATH12)))
  771.           ((NULL TOP12)
  772.            (VALUES BP2 (CAR PATH12) (CAR PATH21)))
  773.           ((AND (NULL TOP21)        ;BP1 is in some inferior of BOX2 and
  774.             (EQ :EQUAL            ;
  775.             (BP-COMPARE-INTERNAL-SIMPLE
  776.               APPARENT-ROW1 ROW2
  777.               (TELL APPARENT-ROW1 :CHA-CHA-NO (CAR PATH21)) (BP-CHA-NO BP2))))
  778.            (VALUES BP2 (CAR PATH12) (CAR PATH21)))
  779.           ((AND (NULL TOP21)        ;BP1 is in some inferior of BOX2
  780.             (BP-COMPARE-INTERNAL-SIMPLE
  781.               APPARENT-ROW1 ROW2
  782.               (TELL APPARENT-ROW1 :CHA-CHA-NO (CAR PATH21)) (BP-CHA-NO BP2)))
  783.            (VALUES BP1 (CAR PATH21) (CAR PATH12)))
  784.           ((NULL TOP21)
  785.            (VALUES BP2 (CAR PATH12) (CAR PATH21)))
  786.           ;; neither box is contained in the other
  787.           ((BP-COMPARE-INTERNAL-SIMPLE
  788.          APPARENT-ROW1 APPARENT-ROW2
  789.          (TELL APPARENT-ROW1 :CHA-CHA-NO (CAR PATH21))
  790.          (TELL APPARENT-ROW2 :CHA-CHA-NO (CAR PATH12)))
  791.            (VALUES BP1 (CAR PATH21) (CAR PATH12)))
  792.           (T (VALUES BP2 (CAR PATH12) (CAR PATH21))))))))
  793.  
  794. (DEFUN BP-COMPARE (BP1 BP2)
  795.   "returns the BP which occurs FIRST. If they are in the same place, the first one
  796. is returned.  If they are on different levels, and the superior BP points to the 
  797. Box which contains the lower BP, then the superior BP is returned. "
  798.   (LET ((ROW1 (BP-ROW BP1)) (BOX1 (BP-BOX BP1))
  799.     (ROW2 (BP-ROW BP2)) (BOX2 (BP-BOX BP2)))
  800.     (COND ((AND (EQ BOX1 BOX2)
  801.         (BP-COMPARE-INTERNAL-SIMPLE ROW1 ROW2 (BP-CHA-NO BP1) (BP-CHA-NO BP2)))
  802.        BP1)
  803.       ((EQ BOX1 BOX2) BP2)
  804.       ;; so much for the simple cases, it looks like we have to do some work
  805.       (T (BP-COMPARE-INTERNAL-HAIRY BP1 BP2 ROW1 ROW2 BOX1 BOX2)))))
  806.  
  807. (DEFUN BP-< (BP1 BP2)
  808.   (IF (EQ BP2 (BP-COMPARE BP1 BP2)) NIL T))
  809.  
  810. (DEFUN BP-> (BP1 BP2)
  811.   (IF (EQ BP1 (BP-COMPARE BP1 BP2)) NIL T))
  812.  
  813. (DEFUN BP-= (BP1 BP2)
  814.   (AND (EQ (BP-ROW BP1)    (BP-ROW BP2))
  815.        (=  (BP-CHA-NO BP1) (BP-CHA-NO BP2))))
  816.  
  817. ;;; These two functions take two BP's and return two BP's which are ordered according to 
  818. ;;; location in the BUFFER and are guaranteed to be at the same level i.e. corresponding
  819. ;;; to rows in the same BOX.  Note that when the second BP is in a subbox, the returned 
  820. ;;; second BP's CHA-NO will be one greater than the Box's own CHA-NO so that the Box itself
  821. ;;; will be included in the specified region.
  822. ;;; Note that ORDER-BPS creates new BP's to return so we don't have to worry about accidently
  823. ;;; mutating something like the *POINT*
  824.  
  825. (DEFUN ORDER-BPS (BP1 BP2)
  826.   (LET ((START-BP (MAKE-BP :FIXED))
  827.     (STOP-BP  (MAKE-BP :FIXED)))
  828.     (MULTIPLE-VALUE-BIND (FIRST-BP FIRST-BOX LAST-BOX)
  829.     (BP-COMPARE BP1 BP2)
  830.       (COND ((AND (NULL FIRST-BOX) (NULL LAST-BOX)    ;both BPs are at the same level
  831.           (EQ FIRST-BP BP1))        ;and are ordered correctly
  832.          (MOVE-BP START-BP (BP-VALUES BP1))    ;place the BP's to be returned in the
  833.          (MOVE-BP STOP-BP (BP-VALUES BP2))    ;right places
  834.          (VALUES START-BP STOP-BP))
  835.         ((AND (NULL FIRST-BOX) (NULL LAST-BOX))
  836.          (MOVE-BP START-BP (BP-VALUES BP2))
  837.          (MOVE-BP STOP-BP (BP-VALUES BP1))
  838.          (VALUES START-BP STOP-BP))
  839.         ;; looks like the BPs are in different boxes
  840.         ;; first we look for the case where on BP's box is inside the other one's
  841.         ((AND (NULL FIRST-BOX) (EQ FIRST-BP BP1))    ;the leading BP is at the right level
  842.          (MOVE-BP START-BP (BP-VALUES BP1))
  843.          (MOVE-BP STOP-BP (BOX-SELF-BP-VALUES LAST-BOX))    ;point to where the box is
  844.          (SET-BP-CHA-NO STOP-BP (1+ (BP-CHA-NO STOP-BP)))    ;include the box itself
  845.          (VALUES START-BP STOP-BP))
  846.         ((NULL FIRST-BOX)
  847.          (MOVE-BP START-BP (BP-VALUES BP2))
  848.          (MOVE-BP STOP-BP (BOX-SELF-BP-VALUES LAST-BOX))    ;point to where the box is
  849.          (SET-BP-CHA-NO STOP-BP (1+ (BP-CHA-NO STOP-BP)))    ;include the box itself
  850.          (VALUES START-BP STOP-BP))
  851.         ((AND (NULL LAST-BOX) (EQ FIRST-BP BP1))    ;the trailing BP is at the right level
  852.          (MOVE-BP START-BP (BOX-SELF-BP-VALUES FIRST-BOX))
  853.          (MOVE-BP STOP-BP (BP-VALUES BP2))
  854.          (VALUES START-BP STOP-BP))
  855.         ((NULL LAST-BOX)
  856.          (MOVE-BP START-BP (BOX-SELF-BP-VALUES FIRST-BOX))
  857.          (MOVE-BP STOP-BP (BP-VALUES BP1))
  858.          (VALUES START-BP STOP-BP))
  859.         ;; looks like neither BP was at the right level
  860.         (T
  861.          (MOVE-BP START-BP (BOX-SELF-BP-VALUES FIRST-BOX))
  862.          (MOVE-BP STOP-BP  (BOX-SELF-BP-VALUES LAST-BOX))
  863.          (SET-BP-CHA-NO STOP-BP (1+ (BP-CHA-NO STOP-BP)))
  864.          (VALUES START-BP STOP-BP))))))
  865.  
  866. ;;;move-point moves the *POINT* BP
  867.  
  868. (DEFUN MOVE-POINT-1 (NEW-ROW NEW-CHA-NO &OPTIONAL(NEW-SCREEN-BOX NIL))
  869.   (UNLESS (NULL NEW-SCREEN-BOX)
  870.     (SET-BP-SCREEN-BOX *POINT* NEW-SCREEN-BOX))
  871.   (SET-BP-ROW *POINT* NEW-ROW)
  872.   (SET-BP-CHA-NO *POINT* NEW-CHA-NO))
  873.  
  874. (DEFUN MOVE-BP-1 (BP NEW-ROW NEW-CHA-NO &OPTIONAL (NEW-SCREEN-BOX NIL))
  875.   (UNLESS (NULL NEW-SCREEN-BOX)
  876.     (SET-BP-SCREEN-BOX BP NEW-SCREEN-BOX))
  877.   (SET-BP-ROW BP NEW-ROW)
  878.   (SET-BP-CHA-NO BP NEW-CHA-NO))
  879.  
  880. (DEFUN POINT-SCREEN-BOX ()
  881.   (BP-SCREEN-BOX *POINT*))
  882.  
  883. (DEFF BP-COMPUTE-NEW-SCREEN-BOX 'IGNORE)
  884.  
  885. (DEFUN BP-COMPUTE-NEW-SCREEN-BOX-OUT (OLD-BOX NEW-BOX OLD-SCREEN-BOX)
  886.   (LET ((LEVEL (LEVEL-OF-SUPERIORITY NEW-BOX OLD-BOX))
  887.     (NEW-SCREEN-BOX OLD-SCREEN-BOX))
  888.     (DOTIMES (I LEVEL)
  889.       (SETQ NEW-SCREEN-BOX (TELL NEW-SCREEN-BOX :SCREEN-BOX)))
  890.     NEW-SCREEN-BOX))
  891.  
  892. (DEFUN BP-COMPUTE-NEW-SCREEN-BOX-IN (OLD-BOX NEW-BOX OLD-SCREEN-BOX)
  893.   (COND ((EQ NEW-BOX OLD-BOX) OLD-SCREEN-BOX)
  894.     (T
  895.      (TELL NEW-BOX
  896.            :ALLOCATE-SCREEN-OBJ-FOR-USE-IN
  897.            (BP-COMPUTE-NEW-SCREEN-BOX-IN
  898.          OLD-BOX (TELL NEW-BOX :SUPERIOR-BOX) OLD-SCREEN-BOX)))))
  899.        
  900. (DEFUN VISIBLE-SCREEN-OBJ-OF-INFERIOR-ACTUAL-OBJ (INFERIOR-ACTUAL-OBJ SUPERIOR-SCREEN-OBJ)
  901.   (CAR (MEM #'(LAMBDA (SB SR) (TELL SR :SUPERIOR? SB)) SUPERIOR-SCREEN-OBJ
  902.         (TELL INFERIOR-ACTUAL-OBJ :DISPLAYED-SCREEN-OBJS))))
  903.  
  904. (DEFUN LOWEST-VISIBLE-BOX (SUPERIOR-SCREEN-BOX BOXES)
  905.   (LOOP FOR N FROM 0 TO (1- (LENGTH BOXES))
  906.     FOR BOX = (NTH N BOXES)
  907.     FOR SCREEN-BOX = (VISIBLE-SCREEN-OBJ-OF-INFERIOR-ACTUAL-OBJ BOX SUPERIOR-SCREEN-BOX)
  908.     WHEN (NULL SCREEN-BOX)
  909.       RETURN (WHEN (> N 0) (NTH (1- N) BOXES))
  910.     FINALLY (RETURN (CAR (LAST BOXES)))))
  911.  
  912.  
  913.  
  914.  
  915. (DEFUN BP-FORWARD-CHA-VALUES (BP &OPTIONAL (TIMES 1) (NO-OF-TIMES-TO-COUNT-CRLF 1))
  916.   (CHECK-BP-ARG BP)
  917.   (BP-FORWARD-CHA-VALUES-1 (BP-ROW BP) (BP-CHA-NO BP) TIMES NO-OF-TIMES-TO-COUNT-CRLF))
  918.  
  919. (DEFUN BP-FORWARD-CHA-VALUES-1 (OLD-ROW OLD-CHA-NO TIMES NO-OF-TIMES-TO-COUNT-CRLF)
  920.   (LET ((OLD-ROW-LENGTH-IN-CHAS (TELL OLD-ROW :LENGTH-IN-CHAS)))
  921.     (COND ((<= (+ OLD-CHA-NO TIMES) OLD-ROW-LENGTH-IN-CHAS)
  922.        ;; The destination is is this row. Our job easy.
  923.        (VALUES OLD-ROW (+ OLD-CHA-NO TIMES)))
  924.       ((NULL (TELL OLD-ROW :NEXT-ROW))
  925.        ;; The destination isn't in this row, and there
  926.        ;; is no next row. Just go the the end of this
  927.        ;; row.
  928.        (VALUES OLD-ROW OLD-ROW-LENGTH-IN-CHAS))
  929.       (T
  930.        ;; The destination isn't in this row, and there
  931.        ;; is a next row to go to. Move the BP to the
  932.        ;; beginning of the next row and call ourselves
  933.        ;; recursively.
  934.        (BP-FORWARD-CHA-VALUES-1 (TELL OLD-ROW :NEXT-ROW)
  935.                     0
  936.                     (- TIMES
  937.                        (- OLD-ROW-LENGTH-IN-CHAS OLD-CHA-NO)
  938.                        NO-OF-TIMES-TO-COUNT-CRLF)
  939.                     NO-OF-TIMES-TO-COUNT-CRLF)))))
  940.  
  941. (DEFUN BP-BACKWARD-CHA-VALUES (BP &OPTIONAL (TIMES 1) (NO-OF-TIMES-TO-COUNT-CRLF 1))
  942.   (CHECK-BP-ARG BP)
  943.   (BP-BACKWARD-CHA-VALUES-1 (BP-ROW BP) (BP-CHA-NO BP) TIMES NO-OF-TIMES-TO-COUNT-CRLF))
  944.  
  945. (DEFUN BP-BACKWARD-CHA-VALUES-1 (OLD-ROW OLD-CHA-NO TIMES NO-OF-TIMES-TO-COUNT-CRLF)
  946.   (COND ((<= TIMES OLD-CHA-NO)
  947.      ;; The destination is in this row. Our job is easy.
  948.      (VALUES OLD-ROW (- OLD-CHA-NO TIMES)))
  949.     ((NULL (TELL OLD-ROW :PREVIOUS-ROW))
  950.      ;; The destination isn't in this row, and there
  951.      ;; is no previous row to go to. Just go to the
  952.      ;; beginning of this row.
  953.      (VALUES OLD-ROW 0))
  954.     (T
  955.      ;; The destination isn't in this row, and there
  956.      ;; is a previous row to go to. Go to the end of
  957.      ;; the previous row and call ourselves recursivley.
  958.      (LET ((OLD-PREVIOUS-ROW (TELL OLD-ROW :PREVIOUS-ROW)))
  959.        (BP-BACKWARD-CHA-VALUES-1 OLD-PREVIOUS-ROW
  960.                      (TELL OLD-PREVIOUS-ROW :LENGTH-IN-CHAS)
  961.                      (- TIMES
  962.                     OLD-CHA-NO
  963.                     NO-OF-TIMES-TO-COUNT-CRLF)
  964.                      NO-OF-TIMES-TO-COUNT-CRLF)))))
  965.  
  966.  
  967.  
  968. (DEFUN CHA-BP-VALUES (CHA)
  969.   (LET ((ROW (TELL CHA :SUPERIOR-ROW)))
  970.     (VALUES ROW (TELL ROW :CHA-CHA-NO CHA))))
  971.  
  972. (DEFUN CHA-NEXT-BP-VALUES (CHA)
  973.   (LET ((ROW (TELL CHA :SUPERIOR-ROW)))
  974.     (VALUES ROW (+ (TELL ROW :CHA-CHA-NO CHA) 1))))
  975.  
  976. (DEFUN ROW-FIRST-BP-VALUES (ROW)
  977.   (CHECK-ROW-ARG ROW)
  978.   (VALUES ROW 0))
  979.  
  980. (DEFUN ROW-LAST-BP-VALUES (ROW)
  981.   (CHECK-ROW-ARG ROW)
  982.   (VALUES ROW (TELL ROW :LENGTH-IN-CHAS)))
  983.  
  984. (DEFUN BOX-FIRST-BP-VALUES (BOX)
  985.   (CHECK-BOX-ARG BOX)
  986.   (VALUES (TELL BOX :ROW-AT-ROW-NO 0) 0))
  987.  
  988. ;; this handles boxes that may be partially scrolled
  989. (defun box-first-visible-bp-values (box
  990.                     &optional
  991.                     (screen-box (car (tell box :displayed-screen-objs))))
  992.   (check-box-arg box)
  993.   (values (or (and (screen-box? screen-box)
  994.            (tell screen-box :scroll-to-actual-row))
  995.           (tell box :row-at-row-no 0))
  996.       0))
  997.  
  998. (DEFUN BOX-LAST-BP-VALUES (BOX)
  999.   (CHECK-BOX-ARG BOX)
  1000.   (LET* ((BOX-LENGTH-IN-ROWS (TELL BOX :LENGTH-IN-ROWS))
  1001.      (LAST-ROW (TELL BOX :ROW-AT-ROW-NO (- BOX-LENGTH-IN-ROWS 1)))
  1002.      (LAST-ROW-LENGTH-IN-CHAS (TELL LAST-ROW :LENGTH-IN-CHAS)))
  1003.     (VALUES LAST-ROW LAST-ROW-LENGTH-IN-CHAS)))
  1004.  
  1005. (DEFUN BOX-SELF-BP-VALUES (BOX)
  1006.   (CHECK-BOX-ARG BOX)
  1007.   (LET ((SUPERIOR-ROW (TELL BOX :SUPERIOR-ROW)))
  1008.     (VALUES SUPERIOR-ROW (TELL SUPERIOR-ROW :CHA-CHA-NO BOX))))
  1009.  
  1010. (DEFUN BP-VALUES (BP)
  1011.   (CHECK-BP-ARG BP)
  1012.   (VALUES (BP-ROW BP) (BP-CHA-NO BP) (BP-SCREEN-BOX BP)))
  1013.  
  1014. (COMPILER:MAKE-OBSOLETE SET-BP-FROM-BP "Use BP-VALUES with MOVE-BP instead")
  1015.  
  1016.  
  1017.  
  1018. ;;; Interaction between the editor and the programming environment
  1019. ;;; Utilities for Prompting, Documentation, Help among other things
  1020.  
  1021. ;; start from *POINT* and move backwards until we get to a DOIT-BOX.  If we are looking at
  1022. ;; a symbol instead, then return a starting CHA-NO for the symbol in the row.
  1023. ;; if we run into something obviously NOT a function (like a DATA-BOX) then return NIL
  1024. (DEFUN FIND-BOX-OR-SYMBOL-START-NO (BP)
  1025.   (LET ((ROW (BP-ROW BP)))
  1026.     (IF (= 0 (BP-CHA-NO BP))            ;BP is at beginning of row
  1027.     (FIRST-CHA-FUNCTION-OR-START-NO ROW)
  1028.     (LOOP WITH INSIDE-SYMBOL-P = NIL     ;set this flag after any initial whitespace ends
  1029.           FOR CHA-NO = (1- (BP-CHA-NO BP)) THEN (1- CHA-NO)
  1030.           FOR CHA = (TELL ROW :CHA-AT-CHA-NO CHA-NO)
  1031.           UNTIL (AND INSIDE-SYMBOL-P
  1032.              (MEMQ (CHA-CODE CHA) *FUNCTION-DELIMITERS*))
  1033.           WHEN (NOT (MEMQ (CHA-CODE CHA) *FUNCTION-DELIMITERS*))
  1034.           DO (SETQ INSIDE-SYMBOL-P T)
  1035.           WHEN (DOIT-BOX? CHA)
  1036.           RETURN CHA
  1037.           WHEN (= CHA-NO 0)
  1038.           RETURN CHA-NO
  1039.           WHEN (DATA-BOX? CHA)
  1040.           RETURN NIL
  1041.           WHEN (PORT-BOX? CHA)
  1042.           RETURN (WHEN (DOIT-BOX? (TELL CHA :PORTS)) (TELL CHA :PORTS))
  1043.           FINALLY
  1044.           (RETURN CHA-NO)))))
  1045.  
  1046. (DEFUN FIRST-CHA-FUNCTION-OR-START-NO (ROW)
  1047.   (LET ((FIRST-CHA (TELL ROW :CHA-AT-CHA-NO 0)))
  1048.     (COND ((DOIT-BOX? FIRST-CHA) FIRST-CHA)
  1049.       ((DATA-BOX? FIRST-CHA) NIL)
  1050.       ((PORT-BOX? FIRST-CHA)
  1051.        (WHEN (DOIT-BOX? (TELL FIRST-CHA :PORTS)) (TELL FIRST-CHA :PORTS)))
  1052.       (T 0))))
  1053.  
  1054. (DEFUN FIND-SYMBOL-END-NO (BP)
  1055.   (LOOP WITH ROW = (BP-ROW BP)
  1056.     FOR CHA-NO = (IF (= 0 (BP-CHA-NO BP)) 0 (1- (BP-CHA-NO BP))) THEN (1+ CHA-NO)
  1057.     FOR CHA = (TELL ROW :CHA-AT-CHA-NO CHA-NO)
  1058.     UNTIL (OR (NULL CHA) (MEMQ (CHA-CODE CHA) *FUNCTION-DELIMITERS*))
  1059.     FINALLY
  1060.     (RETURN CHA-NO)))
  1061.  
  1062. ;; If it's not a BOX, then we have to do some work in finding the end point of the symbol
  1063. ;; remember, we already have the starting point from the function above
  1064. (DEFUN FIND-SYMBOL-FROM-START-NO (START-NO BP)
  1065.   (LET* ((END-NO (FIND-SYMBOL-END-NO BP))
  1066.      (ROW (BP-ROW BP))
  1067.      (START-BP (MAKE-INITIALIZED-BP :FIXED ROW START-NO))
  1068.      (END-BP   (MAKE-INITIALIZED-BP :FIXED ROW END-NO))
  1069.      (STREAM   (MAKE-BOXER-STREAM START-BP END-BP))
  1070.      ;;should instead, make editor streams handle :ENTRIES
  1071.      (STUFF    (PARSE-LIST-FOR-EVAL (BOXER-READ STREAM NIL))))
  1072.     (TELL ROW :DELETE-BP START-BP)        ;cleanup time
  1073.     (TELL ROW :DELETE-BP END-BP)
  1074.     (WHEN (SYMBOLP (CAR STUFF)) (CAR STUFF))))
  1075.  
  1076. (DEFUN FUNCTION-AT-BP (BP)
  1077.   (LET ((FUNCTION-OR-START-NO (FIND-BOX-OR-SYMBOL-START-NO BP)))
  1078.     (COND ((NULL FUNCTION-OR-START-NO) NIL)
  1079.       ((DOIT-BOX? FUNCTION-OR-START-NO) FUNCTION-OR-START-NO)
  1080.       ((NUMBERP FUNCTION-OR-START-NO)
  1081.        (FIND-SYMBOL-FROM-START-NO FUNCTION-OR-START-NO BP))
  1082.       (T (FERROR "Can't find anything around the BP ~A" BP)))))
  1083.  
  1084. (DEFUN FUNCTION-AT-POINT ()
  1085.   (FUNCTION-AT-BP *POINT*))
  1086.  
  1087.  
  1088.  
  1089. ;;;;CURSOR-TRACKER
  1090.  
  1091. ;;Given the fact that there is a variable *POINT* , we can define
  1092. ;;these simple functions.
  1093.  
  1094. (DEFUN POINT-BOX ()
  1095.   (BP-BOX *POINT*))
  1096.  
  1097. (DEFUN POINT-ROW ()
  1098.   (BP-ROW *POINT*))
  1099.  
  1100. (DEFUN POINT-CHA-NO ()
  1101.   (BP-CHA-NO *POINT*))
  1102.  
  1103. (DEFUN POINT-SCREEN-BOX ()
  1104.   (BP-SCREEN-BOX *POINT*))
  1105.  
  1106. (DEFUN SET-POINT-SCREEN-BOX (NEW-SCREEN-BOX)
  1107.   (SET-BP-SCREEN-BOX *POINT* NEW-SCREEN-BOX))
  1108.  
  1109. (DEFUN POINT-CHA-AFTER-POINT ()
  1110.   (TELL (POINT-ROW) :CHA-AT-CHA-NO (POINT-CHA-NO)))
  1111.  
  1112. (DEFF POINT-CHA 'POINT-CHA-AFTER-POINT)
  1113.  
  1114. (DEFUN SETUP-EDITOR (&OPTIONAL (LOAD-INIT-FILE-P NIL))
  1115.   (SETQ *INITIAL-BOX* (MAKE-INITIALIZED-BOX ':TYPE ':DATA-BOX))
  1116.   (TELL *INITIAL-BOX* :SET-NAME "WORLD")
  1117.   (SET-OUTERMOST-BOX *INITIAL-BOX*)      ;this calls redisplay !
  1118.   (TELL (CAR (TELL *INITIAL-BOX* :SCREEN-OBJS)) :SET-SCREEN-ROW *BOXER-PANE*)
  1119.   (TELL (CAR (TELL *INITIAL-BOX* :SCREEN-OBJS))
  1120.     :SET-SUPERIOR-SCREEN-BOX *BOXER-PANE*)
  1121. ;; no one seems to use this an it isn't robust enough yet anyway
  1122. ;  (WHEN LOAD-INIT-FILE-P
  1123. ;    (INITIALIZE-BOXER-WORLD))
  1124.   (SETQ *POINT*  (MAKE-BP ':MOVING))
  1125.   (MULTIPLE-VALUE-BIND (ROW CHA-NO)      
  1126.       (BOX-FIRST-BP-VALUES *INITIAL-BOX*)
  1127.     (MOVE-POINT-1 ROW CHA-NO (CAR (TELL *INITIAL-BOX* :SCREEN-OBJS)))))
  1128.  
  1129.  
  1130.  
  1131. ;;;; Support for scrolling (after a c-N from the bottom of a box for example)
  1132.  
  1133. ;; Estimate the size of a row from the actual structure
  1134. ;; we are assuming that boxes are ALWAYS bigger than chas
  1135. ;; this assumes that the font map is already bound
  1136. ;; it is used by ASSURE-HEAD-ROOM-IN-BOX which bind the font map
  1137. (DEFUN ESTIMATE-ROW-HEIGHT (ROW)
  1138.     (LET ((BOXES (TELL ROW :BOXES-IN-ROW)))
  1139.       (IF (NULL BOXES)
  1140.       (LOOP FOR FONT FROM 0 TO (1- (ARRAY-LENGTH %DRAWING-FONT-MAP))
  1141.         MAXIMIZE (FONT-CHAR-HEIGHT (AREF %DRAWING-FONT-MAP FONT)))
  1142.       (LOOP FOR BOX IN BOXES
  1143.         MAXIMIZE (ESTIMATE-BOX-HEIGHT BOX)))))
  1144.  
  1145. ;; this assumes that the font map is already bound
  1146. ;; it is used by ASSURE-HEAD-ROOM-IN-BOX which bind the font map
  1147. (DEFUN ESTIMATE-BOX-HEIGHT (BOX)
  1148.   (COND ((EQ (TELL BOX :DISPLAY-STYLE) ':SHRUNK)
  1149.      27.)
  1150.     ((NUMBERP (CADDR (TELL BOX :DISPLAY-STYLE-LIST)))
  1151.      (CADDR (TELL BOX :DISPLAY-STYLE-LIST)))
  1152.     (T
  1153.        (MULTIPLE-VALUE-BIND (IGNORE TOP IGNORE BOT)
  1154.            (BOX-BORDERS-FN ':BORDER-WIDS (TELL BOX :TYPE) NIL)
  1155.          (+ TOP BOT (LOOP FOR ROW IN (TELL BOX :ROWS)
  1156.                   SUMMING (ESTIMATE-ROW-HEIGHT ROW)))))))
  1157.  
  1158. (DEFUN ASSURE-HEAD-ROOM-IN-BOX (LAST-ROW SCREEN-BOX &OPTIONAL (WINDOW *BOXER-PANE*))
  1159.   "This starts at LAST-ROW and returns the highest up row that can be the 1st row and still
  1160. have LAST-ROW be displayed based on the current size of SCREEN-BOX. "
  1161.   (WITH-FONT-MAP-BOUND (WINDOW)
  1162.     (LET ((AVAILABLE-ROOM (MULTIPLE-VALUE-BIND (IGNORE TOP IGNORE BOT)
  1163.                   (BOX-BORDERS-FN ':BORDER-WIDS
  1164.                           (TELL (TELL SCREEN-BOX :ACTUAL-OBJ) :TYPE)
  1165.                           NIL)
  1166.                 (- (TELL SCREEN-BOX :HEI) TOP BOT))))
  1167.       (LOOP FOR ROW = LAST-ROW THEN (TELL ROW :PREVIOUS-ROW)
  1168.         FOR ROOM = (- AVAILABLE-ROOM (ESTIMATE-ROW-HEIGHT ROW))
  1169.              THEN (- ROOM (ESTIMATE-ROW-HEIGHT ROW))
  1170.         WHEN (NULL ROW)
  1171.           RETURN (TELL (TELL LAST-ROW :SUPERIOR-BOX) :FIRST-INFERIOR-ROW)
  1172.         UNTIL ( ROOM 0)
  1173.         FINALLY
  1174.           (RETURN ROW)))))
  1175.  
  1176. (DEFUN ASSURE-LEG-ROOM-IN-BOX (ROW SCREEN-BOX)
  1177.   SCREEN-BOX                    ;bound but never used...
  1178.   ROW)
  1179.  
  1180. ;; does the row have screen structure within the screen box
  1181. (DEFMETHOD (ROW :ROW-HAS-SCREEN-STRUCTURE?)(&OPTIONAL (CURRENT-SCREEN-BOX (POINT-SCREEN-BOX)))
  1182.   (CDR (ASSQ CURRENT-SCREEN-BOX SCREEN-OBJS)))
  1183.  
  1184. (DEFUN ENSURE-ROW-IS-DISPLAYED (ROW SCREEN-BOX &OPTIONAL (DIRECTION -1) SCROLL-ANYWAY)
  1185.   "Make sure that the screen box's scroll to actual row is such that ROW will be seen.
  1186. a DIRECTION of 1 specifies that we are moving downward, -1 upward. "
  1187.   (WHEN (OR SCROLL-ANYWAY
  1188.         (NULL (TELL ROW :ROW-HAS-SCREEN-STRUCTURE? SCREEN-BOX))
  1189.         (TELL (TELL ROW :ALLOCATE-SCREEN-OBJ-FOR-USE-IN SCREEN-BOX) :Y-GOT-CLIPPED?))
  1190.     (TELL SCREEN-BOX :SET-SCROLL-TO-ACTUAL-ROW (IF (MINUSP DIRECTION)
  1191.                            (ASSURE-HEAD-ROOM-IN-BOX ROW SCREEN-BOX)
  1192.                            ;; sounds like a box is a luxury car
  1193.                            (ASSURE-LEG-ROOM-IN-BOX  ROW SCREEN-BOX)))))
  1194.  
  1195.  
  1196.  
  1197. ;;;; Input Boxes
  1198. ;;; input boxes usurp the point and recursively call the boxer editing command loop
  1199. ;;; when the desired configuration of the input box is achieved, then the USER exits
  1200. ;;; the box at which point the recursive command loop is THROWN out of and the desired value
  1201. ;;; is CATCHed
  1202.  
  1203. ;;; this will have to be moved elsewhere.  Also, is there any situation in which we would need
  1204. ;;; a REAL box to be created....
  1205.  
  1206. (DEFUN PARSE-SELF-FOR-INPUT (BOX)
  1207.   "Make a Evdata Box from an input box without the prompt string. "
  1208.   (LOOP FOR ROW IN (GET-BOX-ROWS BOX)
  1209.     UNLESS (NULL ROW)
  1210.       COLLECT (MAKE-EVROW-FROM-ENTRIES ROW) INTO RETURN-ROWS
  1211.     FINALLY (RETURN (MAKE-EVDATA ROWS RETURN-ROWS))))
  1212.  
  1213. (DEFMETHOD (INPUT-BOX :AFTER :EXIT) (&REST IGNORE)
  1214.   ;; return out of the inferior command-loop
  1215.   (*THROW 'BOXER-IO (PARSE-SELF-FOR-INPUT SELF)))
  1216.  
  1217. (DEFUN MAKE-INPUT-BOX (PROMPT)
  1218.   (COND ((NULL PROMPT) (MAKE-BOX '(()) 'INPUT-BOX))
  1219.     ((EVAL-BOX? PROMPT)
  1220.      (LET ((BOX (MAKE-BOX (NCONS (LIST ";" PROMPT)) 'INPUT-BOX)))
  1221.        (TELL BOX :APPEND-ROW (MAKE-ROW '()))
  1222.        BOX))
  1223.     ((LISTP PROMPT)
  1224.      (LET ((BOX (MAKE-BOX (NCONS (APPEND '(";") PROMPT)) ':INPUT-BOX)))
  1225.        (TELL BOX :APPEND-ROW (MAKE-ROW '()))
  1226.        BOX))
  1227.     ((STRINGP PROMPT)
  1228.      (LET ((BOX (MAKE-BOX (NCONS (LIST ";" PROMPT)) ':INPUT-BOX)))
  1229.        (TELL BOX :APPEND-ROW (MAKE-ROW '()))
  1230.        BOX))
  1231.     (T (FERROR "Don't know how to make an input box from ~A" PROMPT))))
  1232.  
  1233. (DEFUN GET-BOXER-INPUT (PROMPT)
  1234.   (LET ((INPUT-BOX (MAKE-INPUT-BOX PROMPT)))
  1235.     (UNWIND-PROTECT
  1236.     (*CATCH 'BOXER-IO
  1237.       (INSERT-CHA *POINT* INPUT-BOX)
  1238.       (REDISPLAY)
  1239.       (MOVE-POINT (BOX-LAST-BP-VALUES INPUT-BOX))
  1240.       (SET-POINT-SCREEN-BOX (CAR (TELL INPUT-BOX :SCREEN-OBJS)))
  1241.       (MINI-BOXER-COMMAND-LOOP))
  1242.       (WHEN (TELL (POINT-BOX) :SUPERIOR? INPUT-BOX)
  1243.     ;; if we are inside the input box when an ABORT hits...
  1244.     ;; we'd better get rid of it
  1245.     (SET-POINT-SCREEN-BOX (BP-COMPUTE-NEW-SCREEN-BOX-OUT (POINT-BOX)
  1246.                                  (TELL INPUT-BOX :SUPERIOR-BOX)
  1247.                                  (POINT-SCREEN-BOX)))
  1248.     (MOVE-POINT (BOX-SELF-BP-VALUES INPUT-BOX))
  1249.     (TELL (TELL INPUT-BOX :SUPERIOR-ROW) :DELETE-CHA INPUT-BOX)))))
  1250.  
  1251.  
  1252.  
  1253. ;;;; The Boxer Status Line
  1254. ;;;  We are currently using ONE line of the *NAME-PANE*.  In the future, we might want to 
  1255. ;;;  expand this to several lines and make it like an EMACS typein window
  1256.  
  1257. (DEFUN GET-BOXER-VERSION-STRING ()
  1258.   "Special versions of BOXER are indicated by SETQing *BOXER-VERSION-INFO*
  1259. to a descriptive string.  Otherwise, the release status, major and minor version numbers
  1260. of the currently loaded system are used. "
  1261.   (MULTIPLE-VALUE-BIND (MAJOR MINOR STATUS)
  1262.       (SI:GET-SYSTEM-VERSION "Boxer")
  1263.     (IF (NULL *BOXER-VERSION-INFO*)
  1264.     (FORMAT NIL "~A BOXER ~D.~D" STATUS MAJOR MINOR)
  1265.     *BOXER-VERSION-INFO*)))
  1266.  
  1267. (DEFUN GET-BOXER-STATUS-STRING (&OPTIONAL (OUTERMOST-BOX-NAME (TELL (OUTERMOST-BOX) :NAME)))
  1268.   (IF (NULL *EDITOR-NUMERIC-ARGUMENT*)
  1269.       (FORMAT NIL "~A | Outermost Box: ~A" (GET-BOXER-VERSION-STRING) OUTERMOST-BOX-NAME)
  1270.       (FORMAT NIL "~A | Outermost Box: ~A | Arg: ~D" (GET-BOXER-VERSION-STRING)
  1271.                                                  OUTERMOST-BOX-NAME
  1272.                              *EDITOR-NUMERIC-ARGUMENT*)))
  1273.  
  1274. (DEFUN REQUIRED-STATUS-LINE-LENGTH (&OPTIONAL (OUTERMOST-BOX-NAME
  1275.                         (TELL (OUTERMOST-BOX) :NAME)))
  1276.   (TELL *NAME-PANE* :STRING-LENGTH (FORMAT NIL "~A | Outermost Box: ~A"
  1277.                            (GET-BOXER-VERSION-STRING)
  1278.                            OUTERMOST-BOX-NAME)))
  1279.  
  1280. (DEFUN REDRAW-STATUS-LINE (&OPTIONAL NEW-NAME)
  1281.   (COND ((NULL NEW-NAME)
  1282.      (TELL *NAME-PANE* :SET-CURSORPOS (REQUIRED-STATUS-LINE-LENGTH) 0)
  1283.      (TELL *NAME-PANE* #+SYMBOLICS :CLEAR-REST-OF-LINE #-SYMBOLICS :CLEAR-EOL)
  1284.      (UNLESS (NULL *EDITOR-NUMERIC-ARGUMENT*)
  1285.        (TELL *NAME-PANE* :STRING-OUT
  1286.                      (FORMAT NIL " | Arg: ~D" *EDITOR-NUMERIC-ARGUMENT*))))
  1287.     (T   (TELL *NAME-PANE* #+SYMBOLICS :CLEAR-WINDOW #-SYMBOLICS :CLEAR-SCREEN)
  1288.          (TELL *NAME-PANE* :STRING-OUT (GET-BOXER-STATUS-STRING NEW-NAME)))))
  1289.           
  1290.  
  1291.  
  1292. (COMMENT
  1293. (DEFVAR *HISTORY-LIST* NIL)
  1294.  
  1295. (DEFUN HISTORY-RECORD-USER-ENTERED-BOX (BOX)
  1296.   (HISTORY-LIST-ADD-BOX-TO-HISTORY BOX))
  1297.  
  1298. (DEFUN HISTORY-LIST-ADD-BOX-TO-HISTORY (BOX)
  1299.   (PUSH BOX *HISTORY-LIST*))
  1300.  
  1301.  
  1302. (DEFUN HISTORY-RECORD-USER-CHANGED-OUTERMOST-BOX (OLD-OUTERMOST-BOX)
  1303.   (HISTORY-PANE-ADD-BOX-TO-HISTORY OLD-OUTERMOST-BOX))
  1304.  
  1305. (DEFVAR *HISTORY-PANE-NO-OF-HISTORY-PORTS* 5.)
  1306.  
  1307. (DEFUN SETUP-HISTORY-PANE ()
  1308.   (LET* ((NEW-BOX (MAKE-INITIALIZED-BOX ':TYPE ':DATA-BOX))
  1309.      (NEW-SCREEN-BOX (TELL NEW-BOX :ALLOCATE-SCREEN-OBJ-FOR-USE-IN
  1310.                    *HISTORY-PANE*)))
  1311.     (SET-OUTERMOST-BOX NEW-BOX NEW-SCREEN-BOX *HISTORY-PANE*)))
  1312.  
  1313. (DEFUN HISTORY-PANE-SCREEN-BOX ()
  1314.   (TELL *HISTORY-PANE* :OUTERMOST-SCREEN-BOX))
  1315.  
  1316. (DEFUN HISTORY-PANE-SCREEN-ROW ()
  1317.   (TELL (HISTORY-PANE-SCREEN-BOX) :FIRST-SCREEN-ROW))
  1318.  
  1319. (DEFUN HISTORY-PANE-BOX ()
  1320.   (SCREEN-OBJ-ACTUAL-OBJ (HISTORY-PANE-SCREEN-BOX)))
  1321.  
  1322. (DEFUN HISTORY-PANE-ROW ()
  1323.   (SCREEN-OBJ-ACTUAL-OBJ (HISTORY-PANE-SCREEN-ROW)))
  1324.  
  1325. (DEFUN HISTORY-PANE-SCREEN-HISTORY-PORT-BOX-SIZE ()
  1326.   (REDISPLAYING-WINDOW (*HISTORY-PANE*)
  1327.     (MULTIPLE-VALUE-BIND (IL IT IR IB)
  1328.     (BOX-BORDERS-FN ':BORDER-WIDS ':PORT-BOX)
  1329.       (LET ((INSIDE-WID (- (SCREEN-OBJ-WID (HISTORY-PANE-SCREEN-BOX)) IL IR))
  1330.         (INSIDE-HEI (- (SCREEN-OBJ-HEI (HISTORY-PANE-SCREEN-BOX)) IT IB)))
  1331.     (VALUES (// INSIDE-WID (+ *HISTORY-PANE-NO-OF-HISTORY-PORTS* 1))
  1332.         INSIDE-HEI)))))
  1333.  
  1334. (DEFUN HISTORY-PANE-ADD-BOX-TO-HISTORY (BOX)
  1335.   (LET ((PORT-BOX (MAKE-INITIALIZED-BOX ':TYPE ':PORT-BOX)))
  1336.     (TELL PORT-BOX :SET-PORT-TO-BOX BOX)
  1337.     (IF (>= (TELL (HISTORY-PANE-ROW) :LENGTH-IN-CHAS)
  1338.         *HISTORY-PANE-NO-OF-HISTORY-PORTS*)
  1339.     (TELL (HISTORY-PANE-ROW) :DELETE-CHA-AT-CHA-NO 0))
  1340.     (TELL (HISTORY-PANE-ROW) :APPEND-CHA PORT-BOX)
  1341.     (MULTIPLE-VALUE-BIND (SCREEN-PORT-BOX-WID SCREEN-PORT-BOX-HEI)
  1342.     (HISTORY-PANE-SCREEN-HISTORY-PORT-BOX-SIZE)
  1343.       (LET ((SCREEN-PORT-BOX
  1344.           (TELL PORT-BOX :ALLOCATE-SCREEN-OBJ-FOR-USE-IN (HISTORY-PANE-SCREEN-BOX))))
  1345.     (TELL SCREEN-PORT-BOX :SET-DISPLAY-STYLE
  1346.                           (CONS SCREEN-PORT-BOX-WID SCREEN-PORT-BOX-HEI))))))
  1347.  
  1348. )
  1349.