home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / boxer / boxer.lha / boxdef.lisp < prev    next >
Encoding:
Text File  |  1993-07-17  |  39.2 KB  |  1,235 lines
  1. ;; -*- Mode:LISP; Package:(BOXER GLOBAL 1000); Fonts:cptfont; Base:10. -*-
  2. ;;
  3. ;; Copyright 1982-1985 Massachusetts Institute of Technology
  4. ;;
  5. ;; Permission to use, copy, modify, distribute, and sell this software
  6. ;; and its documentation for any purpose is hereby granted without fee,
  7. ;; provided that the above copyright notice appear in all copies and that
  8. ;; both that copyright notice and this permission notice appear in
  9. ;; supporting documentation, and that the name of M.I.T. not be used in
  10. ;; advertising or publicity pertaining to distribution of the software
  11. ;; without specific, written prior permission.  M.I.T. makes no
  12. ;; representations about the suitability of this software for any
  13. ;; purpose.  It is provided "as is" without express or implied warranty.
  14. ;;
  15. ;;
  16. ;; This file is part of the BOXER system.
  17. ;;
  18. ;; Written by Gregor (GREGOR@MIT-AI) et al
  19. ;;
  20. ;; This file contains the defs for Boxer.
  21. ;;
  22.  
  23.  
  24.  
  25. ;;;; GRAY PATTERNS
  26.  
  27. ;; These are useful for drawing gray areas on the screen.
  28.  
  29. (DEFUN MAKE-PATTERN (LIST-OF-ROWS)
  30.    (LET ((ARRAY #-LMITI (MAKE-ARRAY `(32. ,(LENGTH LIST-OF-ROWS)) ':TYPE 'ART-1B)
  31.         #+LMITI (MAKE-PIXEL-ARRAY 32. (LENGTH LIST-OF-ROWS) ':TYPE 'ART-1B))
  32.      (CURRENT-ROW 0) (CURRENT-COLUMN 0))
  33.      (DOLIST (ROW LIST-OF-ROWS)
  34.        (DO () (NIL)
  35.      (DOLIST (ELEMENT ROW)
  36.        (IF (> CURRENT-COLUMN 31.) (RETURN NIL))
  37.        (ASET ELEMENT ARRAY #-LMITI CURRENT-COLUMN CURRENT-ROW #+LMITI CURRENT-COLUMN)
  38.        (SETQ CURRENT-COLUMN (1+ CURRENT-COLUMN)))
  39.      (IF (> CURRENT-COLUMN 31.) (RETURN NIL)))
  40.        (SETQ CURRENT-ROW (1+ CURRENT-ROW)
  41.          CURRENT-COLUMN 0))
  42.      ARRAY))
  43.  
  44. (DEFVAR *GRAY0* (MAKE-PATTERN
  45.           '((1 0 0 0 0 1 0 0 0 0)
  46.             (0 0 1 0 0 0 0 1 0 0)
  47.             (0 0 0 0 1 0 0 0 0 1)
  48.             (0 1 0 0 0 0 1 0 0 0)
  49.             (0 0 0 1 0 0 0 0 1 0))))
  50.  
  51. (DEFVAR *GRAY1* (MAKE-PATTERN
  52.           '((1 0 0 0 1 0 0 0)
  53.             (0 1 0 0 0 1 0 0)
  54.             (0 0 0 1 0 0 0 1)
  55.             (0 0 1 0 0 0 1 0))))
  56. (DEFVAR *GRAY2* (MAKE-PATTERN
  57.           '((1 0 0 0)
  58.             (0 0 1 0)
  59.             (0 1 0 0))))
  60. (DEFVAR *GRAY3* (MAKE-PATTERN
  61.           '((1 0 0 0 1 0 1 0)
  62.             (0 1 0 1 0 0 0 1)
  63.             (1 0 0 0 1 0 1 0)
  64.             (0 1 0 1 0 0 0 1))))
  65. (DEFVAR *GRAY4* (MAKE-PATTERN
  66.           '((1 0 1 0 1 0 1 0)
  67.             (0 1 0 0 0 1 0 0)
  68.             (1 0 1 0 1 0 1 0))))
  69. (DEFVAR *GRAY5* (MAKE-PATTERN
  70.           '((1 0 1 0 1 0 1 0)
  71.             (0 1 0 1 0 1 0 1)
  72.             (1 0 1 0 1 0 1 0)
  73.             (0 1 0 1 0 1 0 1))))
  74.  
  75.  
  76.  
  77. ;;; Random useful macros.
  78.  
  79. (DEFUN WARN-ABOUT-INTERNAL-FUNCTION (FN-NAME)
  80.   (COMPILER:WARN '(:BAD-STYLE) "~S is an internal function -- you may lose." FN-NAME))
  81.  
  82. (DEFMACRO BARF (CONDITION . ERROR-INIT-OPTIONS)
  83.   `(ERROR ,CONDITION . ,ERROR-INIT-OPTIONS))
  84.  
  85. (DEFMACRO NOT-NULL (X)
  86.   `(NOT (NULL ,X)))
  87.  
  88. (DEFMACRO ENSURE-LIST (ITEM . IGNORE)
  89.   `(IF (AND ,ITEM (NOT (LISTP ,ITEM))) (SETF ,ITEM (NCONS ,ITEM))))
  90.  
  91. (DEFMACRO LIST-OR-LISTIFY (ITEM)
  92.   `(IF (NOT (LISTP ,ITEM)) (NCONS ,ITEM) ,ITEM))
  93.  
  94. ;;; This is an abbreviation for SEND which also has the feature of quoting
  95. ;;; the second argument (or message) automatically.
  96. (DEFMACRO TELL (INSTANCE MESSAGE-NAME . ARGS)    
  97.   (ONCE-ONLY (INSTANCE)                ;<<<*** Get this not-null check
  98.     `(AND (NOT-NULL ,INSTANCE)            ;<<<*** out of here soon!!!!!!!
  99.       (SEND ,INSTANCE ',MESSAGE-NAME . ,ARGS))))
  100.  
  101. ;;; This version of tell checks to see if its first agument (the instance)
  102. ;;; is nil. If it is, it doesn't try to send the message, and just returns
  103. ;;; nil.
  104. (DEFMACRO TELL-CHECK-NIL (INSTANCE MESSAGE-NAME . ARGS)
  105.   (ONCE-ONLY (INSTANCE)
  106.     `(AND (NOT-NULL ,INSTANCE)
  107.       (SEND ,INSTANCE ',MESSAGE-NAME . ,ARGS))))
  108.  
  109. (DEFMACRO MAP-TELL (LIST-OF-INSTANCES MESSAGE-NAME . ARGS)
  110.   `(MAPCAR '(LAMBDA (INSTANCE) (SEND INSTANCE ',MESSAGE-NAME . ,ARGS)) ,LIST-OF-INSTANCES))
  111.  
  112.  
  113. ;;; These list hacking macros are so useful that I expect all MIT arpanet
  114. ;;; ports to be tied up for months while everybody copies them.
  115.  
  116. (DEFMACRO SPLICE-LIST-INTO-LIST (INTO-LIST LIST BEFORE-ITEM)
  117.   `(SETF ,INTO-LIST (SPLICE-LIST-INTO-LIST-1 ,INTO-LIST ,LIST ,BEFORE-ITEM)))
  118.  
  119. (DEFMACRO SPLICE-ITEM-INTO-LIST (INTO-LIST ITEM BEFORE-ITEM)
  120.   `(SETF ,INTO-LIST (SPLICE-LIST-INTO-LIST-1 ,INTO-LIST `(,,ITEM) ,BEFORE-ITEM)))
  121.  
  122. (DEFUN SPLICE-LIST-INTO-LIST-1 (INTO-LIST LIST BEFORE-ITEM)
  123.   (LET ((BEFORE-ITEM-POSITION (FIND-POSITION-IN-LIST BEFORE-ITEM INTO-LIST)))
  124.     (COND ((OR (NULL BEFORE-ITEM-POSITION)
  125.            (= BEFORE-ITEM-POSITION 0))
  126.        (NCONC LIST INTO-LIST)
  127.        LIST)
  128.       (T
  129.        (DO* ((TAIL INTO-LIST (CDR TAIL))
  130.          (NEXT-ITEM (CADR TAIL) (CADR TAIL)))
  131.         ((EQ NEXT-ITEM BEFORE-ITEM)
  132.          (NCONC LIST (CDR TAIL))
  133.          (RPLACD TAIL LIST)
  134.          INTO-LIST))))))
  135.  
  136. (DEFMACRO SPLICE-LIST-ONTO-LIST (ONTO-LIST LIST)
  137.   `(SETF ,ONTO-LIST (NCONC ,ONTO-LIST ,LIST)))
  138.  
  139. (DEFMACRO SPLICE-ITEM-ONTO-LIST (ONTO-LIST ITEM)
  140.   `(SPLICE-LIST-ONTO-LIST ,ONTO-LIST `(,,ITEM)))
  141.  
  142. ;(DEFMACRO SPLICE-LIST-OUT-OF-LIST (&YOW LOSING-BADLY)) ;doesn't make sense
  143.  
  144. (DEFMACRO SPLICE-ITEM-OUT-OF-LIST (OUT-OF-LIST ITEM)
  145.   `(SETF ,OUT-OF-LIST (DELETE ,ITEM ,OUT-OF-LIST)))
  146.  
  147. (DEFMACRO SPLICE-ITEM-AND-TAIL-OUT-OF-LIST (OUT-OF-LIST ITEM)
  148.   `(SETF ,OUT-OF-LIST (SPLICE-ITEM-AND-TAIL-OUT-OF-LIST-1 ,OUT-OF-LIST ,ITEM)))
  149.  
  150. (DEFUN SPLICE-ITEM-AND-TAIL-OUT-OF-LIST-1 (OUT-OF-LIST ITEM)
  151.   (LET ((ITEM-POSITION (FIND-POSITION-IN-LIST ITEM OUT-OF-LIST)))
  152.     (COND ((NULL ITEM-POSITION) OUT-OF-LIST)
  153.       ((= ITEM-POSITION 0) NIL)
  154.       (T (RPLACD (NTHCDR (- ITEM-POSITION 1) OUT-OF-LIST) NIL)
  155.          OUT-OF-LIST))))
  156.  
  157. (DEFMACRO SPLICE-BETWEEN-ITEMS-OUT-OF-LIST (LIST FROM-ITEM TO-ITEM)
  158.   `(DO ((FROM-ITEM-PREVIOUS-CONS NIL FROM-ITEM-PREVIOUS-CONS)
  159.     (TO-ITEM-PREVIOUS-CONS NIL TO-ITEM-PREVIOUS-CONS)
  160.     (SCAN ,LIST (CDR SCAN)))
  161.        ((OR (NULL SCAN) (NOT-NULL TO-ITEM-PREVIOUS-CONS))
  162.     (COND ((NULL FROM-ITEM-PREVIOUS-CONS)
  163.            (SETF ,LIST (CDR TO-ITEM-PREVIOUS-CONS)))
  164.           (T
  165.            (RPLACD FROM-ITEM-PREVIOUS-CONS (CDR TO-ITEM-PREVIOUS-CONS))))
  166.     (RPLACD TO-ITEM-PREVIOUS-CONS NIL))
  167.      (COND ((EQ (CADR SCAN) ,FROM-ITEM)
  168.         (SETQ FROM-ITEM-PREVIOUS-CONS SCAN))
  169.        ((EQ (CADR SCAN) ,TO-ITEM)
  170.         (SETQ TO-ITEM-PREVIOUS-CONS SCAN)))))
  171.  
  172.  
  173. ;;;new list splicing macros that use index numbers...
  174.  
  175. (DEFMACRO SPLICE-LIST-INTO-LIST-AT (INTO-LIST LIST POSITION)
  176.   `(COND ((= ,POSITION 0)
  177.       (SETF ,INTO-LIST (NCONC ,LIST ,INTO-LIST)))
  178.      (( ,POSITION (LENGTH ,INTO-LIST))
  179.       (SETF ,INTO-LIST (NCONC ,INTO-LIST ,LIST)))
  180.      (T (SETF ,INTO-LIST (NCONC (FIRSTN ,POSITION ,INTO-LIST)
  181.                     ,LIST
  182.                     (NTHCDR ,POSITION ,INTO-LIST))))))
  183.  
  184. (DEFMACRO SPLICE-ITEM-INTO-LIST-AT (INTO-LIST ITEM POSITION)
  185.   `(SPLICE-LIST-INTO-LIST-AT ,INTO-LIST `(,,ITEM) ,POSITION))
  186.  
  187. (DEFMACRO SPLICE-ITEM-OUT-OF-LIST-AT (LIST POSITION)
  188.   `(COND ((= ,POSITION 0)
  189.       (SETF ,LIST (CDR ,LIST)))
  190.      (( ,POSITION (LENGTH ,LIST))
  191.       (SETF ,LIST (BUTLAST ,LIST)))
  192.      (T (SETF ,LIST (NCONC (FIRSTN ,POSITION ,LIST)
  193.                    (NTHCDR (+ ,POSITION 1) ,LIST))))))
  194.  
  195. (DEFMACRO SPLICE-ITEM-AND-TAIL-OUT-OF-LIST-FROM (LIST POSITION)
  196.   `(COND (( ,POSITION (LENGTH ,LIST)))
  197.      (T (SETF ,LIST (FIRSTN ,POSITION ,LIST)))))
  198.  
  199. (DEFMACRO SPLICE-ITEMS-FROM-TO-OUT-OF-LIST (LIST START-POSITION STOP-POSITION)
  200.   `(COND ((> ,START-POSITION ,STOP-POSITION)
  201.       (FERROR "The Starting number: ~S is greater than the ending number ~S"
  202.           ,START-POSITION ,STOP-POSITION))
  203.      (( ,START-POSITION (LENGTH ,LIST)))
  204.      ((= ,START-POSITION ,STOP-POSITION)
  205.       (SPLICE-ITEM-OUT-OF-LIST-AT ,LIST ,START-POSITION))
  206.      (( ,STOP-POSITION (LENGTH ,LIST))
  207.       (SPLICE-ITEM-AND-TAIL-OUT-OF-LIST-FROM ,LIST ,START-POSITION))
  208.      (T (SETF ,LIST (NCONC (FIRSTN ,START-POSITION ,LIST)
  209.                    (NTHCDR ,STOP-POSITION ,LIST))))))
  210.  
  211. (DEFMACRO ITEMS-SPLICED-FROM-TO-FROM-LIST (LIST START-POSITION STOP-POSITION)
  212.   `(COND ((> ,START-POSITION ,STOP-POSITION)
  213.       (FERROR "The Starting number: ~S is greater than the ending number ~S"
  214.           ,START-POSITION ,STOP-POSITION))
  215.      (( ,START-POSITION (LENGTH ,LIST))
  216.       '())
  217.      ((= ,START-POSITION ,STOP-POSITION)
  218.       (LIST (NTH ,START-POSITION ,LIST)))
  219.      (( ,STOP-POSITION (LENGTH ,LIST))
  220.       (NTHCDR ,START-POSITION ,LIST))
  221.      (T (FIRSTN (- ,STOP-POSITION ,START-POSITION)
  222.             (NTHCDR ,START-POSITION ,LIST)))))
  223.  
  224.  
  225.  
  226. ;; COLLECT is straight from the book, and is documented there.
  227. (DEFVAR *COLLECT-VARIABLE*)
  228.  
  229. (DEFMACRO WITH-COLLECTION (&BODY BODY)
  230.   (LET ((VAR (GENSYM)))
  231.     `(LET ((,VAR NIL))
  232.        (COMPILER-LET ((*COLLECT-VARIABLE* ',VAR))
  233.              . ,BODY)
  234.        (NREVERSE ,VAR))))
  235.  
  236. (DEFMACRO COLLECT (THING)
  237.   `(PUSH ,THING ,*COLLECT-VARIABLE*))
  238.  
  239.  
  240. (DEFMACRO DOPLIST ((PLIST PROPERTY INDICATOR) &BODY BODY)
  241.   (LET ((PLIST-SYMBOL (GENSYM)))
  242.     `(DO ((,PLIST-SYMBOL ,PLIST (CDDR ,PLIST-SYMBOL))
  243.       (,PROPERTY) (,INDICATOR))
  244.      ((NULL ,PLIST-SYMBOL))
  245.        (SETQ ,PROPERTY  (CADR ,PLIST-SYMBOL)
  246.          ,INDICATOR (CAR ,PLIST-SYMBOL))
  247.        ,@BODY)))
  248.  
  249. ;; Working inside is neat, and is best documented by example:
  250. ;;
  251. ;;(DEFUN TEST-WORKING-INSIDE-LIST ()
  252. ;;  (LET ((TEST-LIST (LIST 1 2 3)))
  253. ;;    (FORMAT T "~%Before  -> ~s" TEST-LIST)
  254. ;;    (WORKING-INSIDE-LIST (A B C) TEST-LIST (SETQ A 4 B 5 C 6))
  255. ;;    (FORMAT T "~%After   -> ~s" TEST-LIST)))
  256. ;;
  257. ;;(TEST-WORKING-INSIDE-LIST)
  258. ;;Before -> (1 2 3)
  259. ;;After  -> (4 5 6)
  260.  
  261. (DEFMACRO WORKING-INSIDE (VARS LOCS &BODY BODY)
  262.   `(LOCAL-DECLARE ((SPECIAL . ,VARS))
  263.      ; Use progv because it returns multiple values.
  264.      (PROGV ',VARS NIL
  265.         (LOOP FOR VAR-LOC IN (MAPCAR #'VARIABLE-LOCATION ',VARS)
  266.           FOR VAL-LOC IN ,LOCS
  267.           DO
  268.            (%P-STORE-TAG-AND-POINTER VAR-LOC DTP-EXTERNAL-VALUE-CELL-POINTER VAL-LOC))
  269.         . ,BODY)))
  270.  
  271. (DEFMACRO WORKING-INSIDE-LIST (VARS LIST &BODY BODY)
  272.   `(WORKING-INSIDE ,VARS (LOCIFY-LIST ,LIST)
  273.      . ,BODY))
  274.  
  275. (DEFUN LOCIFY-LIST (LIST)
  276.   (LOOP FOR L ON LIST COLLECT (LOCF (CAR L))))
  277.  
  278. (DEFMACRO MAXIMIZE (VAR . VALS)
  279.   `(SETF ,VAR (MAX ,VAR . ,VALS)))
  280.  
  281. (DEFMACRO MINIMIZE (VAR . VALS)
  282.   `(SETF ,VAR (MIN ,VAR . ,VALS)))
  283.  
  284. (DEFMACRO WITH-SUMMATION (&BODY BODY)
  285.   (LET ((SUMMATION-VAR (GENSYM)))
  286.     `(LET ((,SUMMATION-VAR 0))
  287.        (COMPILER-LET ((SUMMATION-VAR ',SUMMATION-VAR))
  288.      (PROGN . ,BODY)
  289.      ,SUMMATION-VAR))))
  290.  
  291. (DEFMACRO SUM (X)
  292.   (LOCAL-DECLARE ((SPECIAL SUMMATION-VAR))
  293.     `(INCF ,SUMMATION-VAR ,X)))
  294.  
  295. ;; BETWEEN
  296. (DEFMACRO BETWEEN? (X A B)
  297.   `(OR (AND (> ,X ,A) (< ,X ,B))
  298.        (AND (< ,X ,A) (> ,X ,B))))
  299.  
  300. (DEFMACRO INCLUSIVE-BETWEEN? (X A B)
  301.   `(OR (AND ( ,X ,A) ( ,X ,B))
  302.        (AND ( ,X ,A) ( ,X ,B))))
  303.  
  304. (DEFMACRO DEFTYPE-CHECKING-MACROS (TYPE TYPE-STRING)
  305.   (LET ((PREDICATE-NAME (INTERN (FORMAT NIL "~S?" TYPE)))
  306.     (CHECK-ARG-NAME (INTERN (FORMAT NIL "CHECK-~S-ARG" TYPE))))
  307.     `(PROGN 'COMPILE
  308.        (DEFSUBST  ,PREDICATE-NAME (X) (TYPEP X ',TYPE))
  309.        (DEFMACRO  ,CHECK-ARG-NAME (X) `(CHECK-ARG ,X  ,',PREDICATE-NAME ,,TYPE-STRING)))))
  310.  
  311.  
  312.  
  313.  
  314. ;;;; Flavor hacking stuff.
  315.  
  316. (DEFMACRO DEFGET-METHOD ((FLAVOR-NAME METHOD-NAME) VAR-NAME)
  317.   `(DEFMETHOD (,FLAVOR-NAME ,METHOD-NAME) ()
  318.      ,VAR-NAME))
  319.  
  320. (DEFMACRO DEFSET-METHOD ((FLAVOR-NAME METHOD-NAME) VAR-NAME)
  321.   `(DEFMETHOD (,FLAVOR-NAME ,METHOD-NAME) (NEW-VALUE)
  322.      (SETQ ,VAR-NAME NEW-VALUE)))
  323.  
  324. (DEFMACRO DEFMETHOD-ALIAS ((FLAVOR ALIAS-METHOD) TO-METHOD)
  325.   (IF (LISTP TO-METHOD)
  326.       `(DEFF (:METHOD ,FLAVOR ,ALIAS-METHOD) #'(:METHOD . ,TO-METHOD))
  327.       `(DEFF (:METHOD ,FLAVOR ,ALIAS-METHOD) #'(:METHOD ,FLAVOR ,TO-METHOD))))
  328.  
  329. (DEFMACRO DEFMETHOD-FORWARD ((FLAVOR-NAME METHOD-NAME) FORM-TO-EVAL-AND-FORWARD-TO)
  330.   (ONCE-ONLY (FORM-TO-EVAL-AND-FORWARD-TO)
  331.     `(DEFMETHOD (,FLAVOR-NAME ,METHOD-NAME) (&REST ARGS)
  332.        (UNLESS (NULL ,FORM-TO-EVAL-AND-FORWARD-TO)
  333.      (LEXPR-SEND ,FORM-TO-EVAL-AND-FORWARD-TO ARGS)))))
  334.  
  335. (DEFMACRO DEFMETHODS (METHOD-SPECS ARGS . BODY)
  336.   (LET ((MAIN-METHOD-SPEC (CAR METHOD-SPECS))
  337.     (ALIAS-METHOD-SPECS (CDR METHOD-SPECS)))
  338.     `(PROGN 'COMPILE
  339.       (DEFMETHOD ,MAIN-METHOD-SPEC ,ARGS . ,BODY)
  340.       . ,(LOOP FOR ALIAS-METHOD-SPEC IN ALIAS-METHOD-SPECS
  341.            COLLECT `(DEFMETHOD-ALIAS ,ALIAS-METHOD-SPEC ,MAIN-METHOD-SPEC)))))
  342.  
  343. (DEFMACRO DEFGET-METHODS (((FLAVOR-NAME METHOD-NAME) . OTHER-METHOD-NAMES) VAR-NAME)
  344.   `(DEFMETHODS ((,FLAVOR-NAME ,METHOD-NAME)
  345.         . ,(LOOP FOR OTHER-METHOD-NAME IN OTHER-METHOD-NAMES
  346.              COLLECT `(,FLAVOR-NAME ,OTHER-METHOD-NAME))) ()
  347.      ,VAR-NAME))
  348.  
  349. (DEFMACRO DEFSET-METHODS (((FLAVOR-NAME METHOD-NAME) . OTHER-METHOD-NAMES) VAR-NAME)
  350.   `(DEFMETHODS ((,FLAVOR-NAME ,METHOD-NAME)
  351.         . ,(LOOP FOR OTHER-METHOD-NAME IN OTHER-METHOD-NAMES
  352.              COLLECT `(,FLAVOR-NAME ,OTHER-METHOD-NAME))) (NEW-VALUE)
  353.      (SETQ ,VAR-NAME NEW-VALUE)))
  354.  
  355.  
  356.  
  357. (defflavor FLAVOR-HACKING-MIXIN
  358.     ()
  359.     ()
  360.   (:DOCUMENTATION :MIXIN
  361.    "This mixin attempts to make up for the flavor system's total lossage in not
  362.     providing a way for instances to change their flavor.
  363.  
  364.     We provide a :SET-FLAVOR message which can be sent to an instance to get it
  365.     to change its flavor. If instances of the current and new flavors both have
  366.     the same shape (same instance variables in the same order) the old instance
  367.     is preserved (only its flavor is changed). If instances of the current and
  368.     new flavors do not have the same shape, then an instance the new flavor is
  369.     created, that instance is sent a :INIT-SELF-FROM-OLD-INSTANCE message, and
  370.     the old instance is structure-forwarded to the new instance. We also provide
  371.     a default version of :INIT-SELF-FROM-OLD-INSTANCE which just copies over all
  372.     the instance variables the two flavors have in common and does not touch the
  373.     rest. Many applications will want to define :AFTER daemons on this method.
  374.  
  375.     NOTE THAT BOTH THE NEW AND OLD FLAVORS NEED TO HAVE FLAVOR-HACKING-MIXIN MIXED IN."))
  376.  
  377. ;; make this use CHANGE-INSTANCE-FLAVOR
  378. (DEFMETHOD (FLAVOR-HACKING-MIXIN :SET-FLAVOR) (NEW-FLAVOR)
  379.   (SEND SELF ':SET-FLAVOR-DESCRIPTOR (GET NEW-FLAVOR 'SI:FLAVOR)))
  380.  
  381. (DEFMETHOD (FLAVOR-HACKING-MIXIN :SET-FLAVOR-DESCRIPTOR) (NEW-DESCRIPTOR)
  382.   (LET* ((CURRENT-DESCRIPTOR (%MAKE-POINTER #-3600 DTP-ARRAY-POINTER #+3600 SYS:DTP-ARRAY
  383.                         (%P-POINTER SELF)))
  384.      (CURRENT-INSTANCE-VARIABLES (SI:FLAVOR-ALL-INSTANCE-VARIABLES CURRENT-DESCRIPTOR))
  385.      (NEW-INSTANCE-VARIABLES (SI:FLAVOR-ALL-INSTANCE-VARIABLES NEW-DESCRIPTOR)))
  386.     (IF (EQUAL CURRENT-INSTANCE-VARIABLES NEW-INSTANCE-VARIABLES)
  387.     (%P-STORE-POINTER SELF NEW-DESCRIPTOR)
  388.     (LET ((NEW-INSTANCE (INSTANTIATE-FLAVOR (SI:FLAVOR-NAME NEW-DESCRIPTOR) ())))
  389.       (TELL NEW-INSTANCE :INIT-SELF-FROM-OLD-INSTANCE SELF)))))
  390.  
  391. (DEFMETHOD (FLAVOR-HACKING-MIXIN :INIT-SELF-FROM-OLD-INSTANCE) (OLD-INSTANCE)
  392.   (LET ((OLD-VARIABLES (SI:FLAVOR-ALL-INSTANCE-VARIABLES 
  393.              (%MAKE-POINTER #-3600 DTP-ARRAY-POINTER #+3600 SYS:DTP-ARRAY
  394.                     (%P-POINTER OLD-INSTANCE))))
  395.     (NEW-VARIABLES (SI:FLAVOR-ALL-INSTANCE-VARIABLES 
  396.              (%MAKE-POINTER #-3600 DTP-ARRAY-POINTER #+3600 SYS:DTP-ARRAY
  397.                     (%P-POINTER SELF)))))
  398.     (LOOP FOR VAR IN NEW-VARIABLES
  399.       WHEN (AND (MEMQ VAR OLD-VARIABLES)
  400.             #-LMITI(BOUNDP-IN-INSTANCE OLD-INSTANCE VAR) #+LMITI T)
  401.         DO (SET-IN-INSTANCE SELF VAR (SYMEVAL-IN-INSTANCE
  402.                        OLD-INSTANCE VAR))))
  403.   (STRUCTURE-FORWARD OLD-INSTANCE SELF))
  404.     
  405.  
  406.  
  407. (DEFFLAVOR PLIST-MIXIN
  408.     ((PLIST NIL))
  409.     ()
  410.   (:DOCUMENTATION :MIXIN
  411.    "This gives instances their very own plist. I thought there was a
  412.     system supplied mixin that did this, but I couldn't find it so I
  413.     figured I would just write my own."))
  414.  
  415. (DEFMETHOD (PLIST-MIXIN :PLIST) ()
  416.   (LOCF PLIST))
  417.  
  418. (DEFMETHOD (PLIST-MIXIN :GET) (INDICATOR)
  419.   (GET (LOCF PLIST) INDICATOR))
  420.  
  421. (DEFMETHOD (PLIST-MIXIN :GETL) (LIST-OF-INDICATORS)
  422.   (GETL (LOCF PLIST) LIST-OF-INDICATORS))
  423.  
  424. (DEFMETHOD (PLIST-MIXIN :PUTPROP) (X INDICATOR)
  425.   (PUTPROP (LOCF PLIST) X INDICATOR))
  426.  
  427. (DEFMETHOD (PLIST-MIXIN :REMPROP) (INDICATOR)
  428.   (REMPROP (LOCF PLIST) INDICATOR))
  429.  
  430.  
  431.  
  432. (DEFFLAVOR VIRTUAL-COPY-MIXIN
  433.     ((VC-ROWS NIL)                ;used by virtual copy
  434.      (INFERIOR-PORTS   NIL)
  435.      (INFERIOR-TARGETS NIL))
  436.     ()
  437.   (:DOCUMENTATION :MIXIN
  438.    "This has Slots That are used by the Virtual Copy Mechanism. "))
  439.  
  440. ;;; All of the methods are defined in the virtcopy file
  441.  
  442.  
  443.  
  444.  
  445. (DEFFLAVOR UNIQUE-NAME-MIXIN
  446.     ((UNIQUE-NAME NIL))
  447.     ()
  448.   (:INIT-KEYWORDS :UNIQUE-NAME)
  449.   (:DOCUMENTATION :MIXIN
  450.    "Giving a flavor this mixin will cause objects of that flavor to have
  451.     a unique-name. It will also use that unique-name scheme to only allow
  452.     one object with a certain unique-name to exist at a time. After the
  453.     object is made it it will set the value of its unique-name to itself,
  454.     and when the object is killed it will set the value of its unique-name
  455.     to nil."))
  456.  
  457. (DEFMETHOD (UNIQUE-NAME-MIXIN :BEFORE :INIT) (INIT-PLIST)
  458.   (LET ((INITIAL-UNIQUE-NAME (GET INIT-PLIST ':UNIQUE-NAME)))
  459.     (WHEN (NOT-NULL INITIAL-UNIQUE-NAME)
  460.       ;; If there is already a window with this unique-name, then
  461.       ;; it must be an earlier copy of us. Kill that window,
  462.       ;; and set our unique-name.
  463.       (AND (BOUNDP INITIAL-UNIQUE-NAME)
  464.        (NOT (NULL (EVAL INITIAL-UNIQUE-NAME)))
  465.        (SEND (EVAL INITIAL-UNIQUE-NAME) ':KILL))
  466.       (TELL SELF :SET-UNIQUE-NAME INITIAL-UNIQUE-NAME))))
  467.  
  468. (DEFMETHOD (UNIQUE-NAME-MIXIN :AFTER :KILL) (&REST IGNORE)
  469.   (AND (BOUNDP UNIQUE-NAME)
  470.        (EQ (EVAL UNIQUE-NAME) SELF)
  471.        (SET UNIQUE-NAME NIL)))
  472.  
  473. (DEFMETHOD (UNIQUE-NAME-MIXIN :UNIQUE-NAME) ()
  474.   UNIQUE-NAME)
  475.  
  476. (DEFMETHOD (UNIQUE-NAME-MIXIN :SET-UNIQUE-NAME) (NEW-UNIQUE-NAME)
  477.   ;; If we already have a unique-name, then make it not point
  478.   ;; to us anymore. Then make our new unique-name point to us,
  479.   ;; and remember that that its our unique-name.
  480.   (WHEN (NOT (NULL UNIQUE-NAME))
  481.     (SET UNIQUE-NAME NIL))
  482.   (SET NEW-UNIQUE-NAME SELF)
  483.   (SETQ UNIQUE-NAME NEW-UNIQUE-NAME))
  484.  
  485.  
  486.  
  487.  
  488. ;;;; Stuff that is particular to boxer.
  489.  
  490. ;;;; DEFVARS
  491.  
  492. (DEFVAR *BOXER-SYNCHRONOUS-INTERCEPTED-CHARACTERS*
  493.     (REM #'(LAMBDA (LIST ITEM) (MEMBER ITEM LIST))
  494.          '(#\BREAK #\ABORT)
  495.          TV:KBD-STANDARD-INTERCEPTED-CHARACTERS)
  496.   "These are the characters which Boxer would like the KBD code to
  497.    intercept and deal with synchronously.")
  498.  
  499. (DEFVAR *RETURNED-VALUES-NOT-TO-PRINT* '(:NOPRINT NOPRINT :? NIL)
  500.   "Items on this list will not be printed out if they are returned by
  501.    from a doit-key.")
  502.  
  503. (DEFVAR *INSIDE-LISP-BREAKPOINT-P* NIL)
  504.  
  505. (DEFVAR *POINT* NIL)
  506.  
  507. (DEFVAR *MARK* NIL)
  508.  
  509. (DEFVAR *POINT-BLINKER* NIL)
  510. (DEFVAR *CURSOR-BLINKER-WID* 3.)
  511. (DEFVAR *CURSOR-BLINKER-MIN-HEI* 12.)
  512.  
  513. (DEFVAR *MOUSE-BLINKER* NIL)
  514.  
  515. (DEFVAR *SPRITE-BLINKER* NIL)
  516.  
  517. (DEFVAR *MINIMUM-CURSOR-HEIGHT* 12.
  518.   "The minimum height to draw the cursor so that it doesn't dissapear.")
  519.  
  520. (DEFVAR *MINIMUM-BOX-WID* 25.
  521.   "The minimum width any box will be drawn on the screen.")
  522.  
  523. (DEFVAR *MINIMUM-BOX-HEI* 25.
  524.   "The minimum height any box will be drawn on the screen.")
  525.  
  526. (DEFVAR *MULTIPLICATION* 1)
  527.  
  528. (DEFVAR *KILL-RING* NIL)
  529.  
  530. (DEFVAR *COM-MAKE-PORT-CURRENT-PORT* NIL
  531.   "This variable is used to store newly created ports until they are inserted into the
  532.    World. ")
  533.  
  534. (DEFVAR *CURRENT-FONT-NO* 0
  535.   "The no of the font the user is currently using. This number is used to
  536.    to determine the font-no of newly created chas.")
  537.  
  538. (DEFVAR *BOLDFACE-FONT-NO* 2
  539.   "The font number of boldface characters.  This relies on the details of what the font
  540. map for the *BOXER-PANE* is.  ")
  541.  
  542. (DEFVAR *ITALICS-FONT-NO* 3
  543.   "The font number of italics characters.  This relies on the details of what the font
  544. map for the *BOXER-PANE* is.  ")
  545.  
  546. (DEFVAR *BOXER-READTABLE* (COPY-READTABLE SI:INITIAL-READTABLE))
  547.  
  548. (DEFVAR *INITIAL-BOX* NIL
  549.   "The initial box the editor starts with, this box cannot be deleted
  550.    killed etc.")
  551.  
  552. (DEFVAR *CURRENT-SCREEN-BOX* NIL
  553.   "The Lowest Level Screen Box Which Contains the *Point*")
  554.  
  555. (DEFVAR *MARKED-SCREEN-BOX* NIL
  556.   "The Lowest Level Scren Box Which Contains the *mark*")
  557.  
  558. (DEFVAR *BOXER-FUNCTIONS* NIL
  559.   "This variable contains a list of symbols for all the 
  560.    lisp functions imported to Boxer.")
  561.  
  562. ;;;Region Variables
  563.  
  564. (DEFVAR *CURRENT-EDITOR-REGION* NIL)
  565.  
  566. (DEFVAR *REGION-BEING-DEFINED* NIL
  567.   "Bound to a region which is in the process of being delineated.  NIL Otherwise.")
  568.  
  569. (DEFVAR *KILLED-REGION-BUFFER* NIL
  570.   "this should be integrated into the generic kill buffer eventually")
  571.  
  572. (DEFVAR *HIGHLIGHT-YANKED-REGION* NIL
  573.   "Controls whether freshly yanked back region should be highlighted. ")
  574.  
  575. (DEFVAR REGION-LIST NIL)
  576.  
  577. ;;;Box top variables...
  578.  
  579. (DEFVAR *FONT-NUMBER-FOR-NAMING* 2.
  580.   "The font number that specifies the font for names and variables. ")
  581.  
  582. ;;;variables that PORTS use...
  583.  
  584. (DEFVAR *PORT-HASH-TABLE* NIL            ;this is ONLY used by the old the file system
  585.   "This variable is a table consisting of boxes which are being
  586.    ported to and their TRUE-NAMES. FLUSH AS SOON AS THE FASDUMPER WORKS.")
  587.  
  588. ;;;these are used by the file system
  589.  
  590. (DEFVAR *BOX-STORAGE-ARRAY* NIL            ;this is ONLY used by the old file system
  591.   "This is used for intermediate storage of the box array
  592.    during fast-saves and fast-reads")
  593.  
  594. (DEFVAR *BOX-STORAGE-LIST* NIL            ;this is ONLY used by the old file system
  595.   "This is used for intermediate storage of the box array
  596.    during saves and reads")
  597.  
  598. (DEFVAR *FILE-PORT-HASH-TABLE* NIL        ;this is ONLY used by the old file system
  599.   "This variable is a table consisting of boxes which are being
  600.    ported to along with their TRUE-NAMES. This table is used only
  601.    by file streams. FLUSH AS SOON AS THE FASDUMPER WORKS. ")
  602.  
  603. (DEFVAR *RENAME-QUEUE* NIL            ;this is ONLY used by the old file system
  604.   "A list of boxes which have TRUE-NAME's which need to be changed
  605.    since other boxes may already have those names.")
  606.  
  607. (DEFVAR *FILE-PORT-QUEUE* NIL            ;this is ONLY used by the old file system
  608.   "A list of port boxes waiting for their ported to box to be built 
  609.    by the file system.")
  610.  
  611.  
  612. ;;;; Variables Having To Do With Redisplay.
  613.  
  614. (DEFVAR *REDISPLAYABLE-WINDOWS* NIL
  615.   "This is a list of all the windows which should be redisplayed when
  616.    REDISPLAY is called. Windows which have the redisplayable-window-mixin
  617.    take care of adding/removing themselves to/from this list automatically.")
  618.  
  619. (DEFVAR *REDISPLAY-WINDOW* NIL
  620.   "Inside of REDISPLAYING-WINDOW, this variable is bound to the window
  621.    being redisplayed.")
  622.  
  623. (DEFVAR *OUTERMOST-BOX* NIL
  624.   "Inside of REDISPLAYING-WINDOW, this variable is bound to the window
  625.    being redisplayed's outermost-box. This is the box which currently
  626.    fills that window.")
  627.  
  628. (DEFVAR *OUTERMOST-SCREEN-BOX* NIL
  629.   "Inside of REDISPLAYING-WINDOW, this variable is bound to the window
  630.    being redisplayed's outermost-screen-box. This is the screen box which
  631.    represents that window outermost-box.")
  632.  
  633. (DEFVAR *REDISPLAY-CLUES* NIL
  634.   "A list of redisplay-clues. This are hints left behind by the editor
  635.    to help the redisplay code figure out what is going on.")
  636.  
  637. (DEFVAR *COMPLETE-REDISPLAY-IN-PROGRESS?* NIL
  638.   "Binding this variable to T around a call to redisplay will 'force'
  639.    the redisplay. That is it will cause a complete redisplay of the
  640.    screen. FORCE-REDISPLAY-WINDOW uses this.")
  641.  
  642. (DEFVAR *SPACE-AROUND-OUTERMOST-SCREEN-BOX* 9.
  643.   "This is the number of pixels between the outside of the outermost screen
  644.    box and the inside of the window. This space exists to allow the user to
  645.    move the mouse out of the outermost box.")
  646.  
  647. (DEFVAR *TICK* 0
  648.   "This is the global variable used by the (TICK) function to generate
  649.    a continuously increasing series of integers. This is mostly used by
  650.    the redisplay code although it wouldn't mess things up if (TICK)
  651.    was called by other sections of code.")
  652.  
  653. (DEFVAR *BOX-ZOOM-WAITING-TIME* 1
  654.   "The amount of time spent waiting between the individual steps when zooming a box. ")
  655.  
  656. (DEFVAR *CONTROL-CHARACTER-DISPLAY-PREFIX* #/
  657.   "For display of control characters (all of them until we decide on different prefixes")
  658.  
  659. (DEFUN TICK ()
  660.   (SETQ *TICK* (+ *TICK* 1)))
  661.  
  662. (DEFVAR *OUTERMOST-SCREEN-BOX-STACK* NIL
  663.   "Keeps track of the previous outermost screen boxes so that they can be returned to. ")
  664.  
  665. ;;;editor variables...
  666.  
  667. (DEFVAR *COLUMN* 0
  668.   "the cha-no of the point for use with cntrl-p and cntrl-n")
  669.  
  670. (DEFVAR *WORD-DELIMITERS* '(#/< #/> #/  #/- #/, #/. #/' #/: #/ #/|))
  671.  
  672. (DEFVAR *FUNCTION-DELIMITERS* '(#/   #/, #/: #/ #/|))
  673.  
  674. (DEFVAR *KILL-BUFFER-ROW* NIL)
  675.  
  676. (DEFVAR *BOXER-VERSION-INFO* NIL
  677.   "This variable keeps track of what version of boxer is currently loaded
  678.    and being used.  Versions for general release are numbered while specific
  679.    development versions have associated names.")
  680.  
  681.  
  682. ;;;;windows that boxer uses, and other related things
  683.  
  684. (DEFVAR *BOXER-FRAME* NIL
  685.   "This frame contains *turtle-pane* *boxer-pane* etc.")
  686.  
  687. (DEFVAR *NAME-PANE* NIL)
  688.  
  689. (DEFVAR *BOXER-PANE* NIL
  690.   "The pane which contains the actual boxer screen editor.")
  691.  
  692. ;For the error handler to peek at until we get a real evaluator.
  693.  
  694. (DEFVAR *CURRENT-FUNCTION-BEING-FUNCALLED* "Toplevel")
  695.  
  696. (DEFVAR *BOXER-ERROR-HANDLER-P* T
  697.   "If the value of this variable is non-nil, errors inside of Boxer will
  698.    be passed to the regular LISPM error handler instead of the Boxer
  699.    error handler.")
  700.  
  701. ;;; STEPPING VARS
  702.  
  703. (defvar *step-flag* nil "Controls whether the (interim) stepper is in operation.")
  704.  
  705. (defvar *box-copy-for-stepping* nil "Should be an evaluator variable, when we have one.  A
  706. copy of the the currently-executing box, placed in the stepping window.  The :funcall method
  707. needs the actual box so it can flash lights inside it.")
  708.  
  709. ;;; graphics variables
  710.  
  711. (DEFVAR *DEFAULT-TURTLE-BOX-WID* 326
  712.   "The default width of any newly created turtle box. ")
  713.  
  714. (DEFVAR *DEFAULT-TURTLE-BOX-HEI* 217
  715.   "The default height of any newly created turtle box. ")
  716.  
  717. (DEFVAR *DEFAULT-GRAPHICS-BOX-WID* 326
  718.   "The default width of any newly created graphics box. ")
  719.  
  720. (DEFVAR *DEFAULT-GRAPHICS-BOX-HEI* 217
  721.   "The default height of any newly created graphics box. ")
  722.  
  723. ;;; Binding variables
  724.  
  725. (DEFVAR *EXPORTING-BOX-MARKER* ':EXPORT
  726.   "This is a marker used by the binding code to mark subboxes which want to export some or
  727. all of their bindings into the superior environment. ")
  728.  
  729. (DEFVAR *EXPORT-ALL-VARIABLES-MARKER* ':ALL
  730.   "The prescence of this marker in the EXPORTS slot of a box indicates that ALL of the box's
  731. bindings are to be exported to other boxes. ")
  732.  
  733.  
  734.  
  735. (DEFFLAVOR BOXER-FRAME
  736.     ()
  737.     (UNIQUE-NAME-MIXIN TV:BORDERED-CONSTRAINT-FRAME)
  738.   (:DEFAULT-INIT-PLIST
  739.    :UNIQUE-NAME '*BOXER-FRAME*))
  740.  
  741. (DEFFLAVOR NAME-PANE
  742.     ()
  743.     (UNIQUE-NAME-MIXIN
  744.      TV:PANE-MIXIN
  745.      TV:WINDOW)
  746.   (:DEFAULT-INIT-PLIST
  747.    :UNIQUE-NAME              '*NAME-PANE*
  748.    :SAVE-BITS                T
  749.    :DEEXPOSED-TYPEOUT-ACTION ':PERMIT
  750.    :LABEL                    NIL
  751.    :BLINKER-P                NIL
  752.    :FONT-MAP                 `(,FONTS:MEDFNB)))
  753.  
  754. (DEFFLAVOR BOXER-PANE
  755.     ()
  756.     (UNIQUE-NAME-MIXIN
  757.      REDISPLAYABLE-WINDOW-MIXIN
  758.      TV:PROCESS-MIXIN
  759.      TV:PANE-MIXIN
  760.  #+LMITI TV:ANY-TYI-MIXIN
  761.      TV:WINDOW)
  762.   (:DEFAULT-INIT-PLIST
  763.    :UNIQUE-NAME              '*BOXER-PANE*
  764.    :SAVE-BITS                T
  765.    :DEEXPOSED-TYPEOUT-ACTION ':PERMIT
  766.    :LABEL                    NIL
  767.    :BLINKER-P                NIL
  768.    :FONT-MAP                 `(,FONTS:MEDFNT ,FONTS:CPTFONT ,FONTS:MEDFNB)
  769.  
  770.    :ASYNCHRONOUS-CHARACTERS  ()))
  771.  
  772.  
  773. (DEFFLAVOR CURSOR-BLINKER
  774.     ()
  775.     (TV:RECTANGULAR-BLINKER)
  776.   (:DEFAULT-INIT-PLIST :VISIBILITY NIL
  777.                :FOLLOW-P T
  778.                :WIDTH *CURSOR-BLINKER-WID*
  779.                :HEIGHT *CURSOR-BLINKER-MIN-HEI*))
  780.  
  781. ;;; We need to use our own blinkers because the standard mouse blinkers in SYmbolics REL6 use 
  782. ;;; FAST-TRACKING-MIXIN which doesn't allow us to turn the mouse blinker off
  783.  
  784. (DEFFLAVOR BOXER-MOUSE-BLINKER
  785.     ()
  786.     (#+SYMBOLICS TV:MOUSE-BLINKER-MIXIN
  787.      #-SYMBOLICS TV:MOUSE-BLINKER-FAST-TRACKING-MIXIN
  788.      TV:CHARACTER-BLINKER)
  789.   (:DEFAULT-INIT-PLIST :VISIBILITY NIL
  790.                :font 'fonts:mouse
  791.                :char 6))
  792.  
  793. ;;; Sprite Blinker by Jeremy
  794. ;;; This blinker is the rectangle which is used to highlight sprites
  795. ;;; The slots remember which screen box and which turtle were highlighted.
  796.  
  797. (defflavor Sprite-blinker
  798.     ((selected-sprite nil)
  799.      (sprite-screen-box nil))
  800.     (tv:hollow-rectangular-blinker)
  801.   :settable-instance-variables
  802.   :gettable-instance-variables)
  803.   
  804.  
  805.  
  806.  
  807. ;;;;EDITOR OBJECT DEFINITIONS
  808.  
  809. ;;;cha is only available as a component of the box flavor
  810. ;;;normal chas are now fixnums store in the superior row's chas-array
  811.  
  812. (DEFFLAVOR CHA
  813.     ((SUPERIOR-ROW NIL)
  814.      (CHA-CODE #\SPACE)          ;if this is the symbol :BOX then the
  815.                       ;cha is actually a box, if this
  816.                       ;is not the symbol :BOX then it is the
  817.                       ;cha code of this cha
  818.      (FONT-NO *CURRENT-FONT-NO*))      ;this only makes sense if cha-code
  819.                       ;is actually a cha code
  820.     (ACTUAL-OBJ-MIXIN  PLIST-MIXIN)
  821.   (:INIT-KEYWORDS :SUPERIOR-ROW :CHA-CODE :FONT)
  822.   (:DEFAULT-INIT-PLIST :CHA-CODE #\SPACE)
  823.   (:DOCUMENTATION :MIXIN
  824.    "Chas are no longer meant to be instantiated.  The flavor exists only as a mixin to the
  825. Box flavor. "))
  826.  
  827. (DEFFLAVOR POP-UP-BOX-MIXIN
  828.     ()
  829.     ()
  830.   (:DOCUMENTATION :MIXIN
  831.    "Makes the box go away when it is exited.  Removal is executed by an :AFTER demon."))
  832.  
  833. (DEFSUBST CHA? (CHA) (FIXNUMP CHA))
  834.  
  835. (DEFVAR %%BOXER-CHA-CODE-FIELD #O0010)
  836.  
  837. (DEFVAR %%BOXER-FONT-NO-FIELD #O1404)
  838.  
  839. (DEFVAR %%BOXER-CHA-CTRL-FIELD #O1004)
  840.  
  841. (DEFVAR %%BOXER-CHA-CODE-AND-CTRL-FIELD #O0014)
  842.  
  843. (DEFVAR %%NUMBER-FIELD #O0004
  844.   "Byte specifier for getting the number out of a keycode for a number key (i.e. ctrl-2). ")
  845.  
  846. (DEFUN MAKE-CHA (CHA-CODE &OPTIONAL(FONT-NO *CURRENT-FONT-NO*))
  847.   (DPB FONT-NO %%BOXER-FONT-NO-FIELD CHA-CODE))
  848.  
  849. (DEFSUBST CHA-CODE-NO-CTRL (CHA)
  850.   (IF (CHA? CHA)
  851.       (LDB %%BOXER-CHA-CODE-FIELD CHA)
  852.       ':BOX))
  853.  
  854. (DEFSUBST FONT-NO (CHA)
  855.   (IF (CHA? CHA)
  856.       (LDB %%BOXER-FONT-NO-FIELD CHA)
  857.       NIL))
  858.  
  859. (DEFSUBST CTRL-CODE (CHA)
  860.   (IF (CHA? CHA)
  861.       (LDB %%BOXER-CHA-CTRL-FIELD CHA)
  862.       NIL))
  863.  
  864. (DEFSUBST CHA-CODE (CHA)
  865.   (IF (CHA? CHA)
  866.       (LDB %%BOXER-CHA-CODE-AND-CTRL-FIELD CHA)
  867.       NIL))
  868.  
  869. (DEFSUBST NUMBER-CODE (CHA)
  870.   (IF (CHA? CHA)
  871.       (LDB %%NUMBER-FIELD CHA)
  872.       NIL))
  873.  
  874. (DEFSUBST SET-FONT-NO (CHA FN)
  875.   (IF (CHA? CHA)
  876.       (DPB FN %%BOXER-FONT-NO-FIELD CHA)
  877.       CHA))
  878.  
  879. (DEFSUBST SET-CTRL-CODE (CHA CD)
  880.   (IF (CHA? CHA)
  881.       (DPB CD %%BOXER-CHA-CTRL-FIELD CHA)
  882.       CHA))
  883.  
  884. (DEFFLAVOR ROW
  885.     ((SUPERIOR-BOX NIL)
  886.      (PREVIOUS-ROW NIL)
  887.      (NEXT-ROW NIL)
  888.      (CHAS-ARRAY NIL)
  889.      ;(BOXES NIL)
  890.      (CACHED? NIL)
  891.      ;;flag indicating valid caching.  The old method of checking caused blank rows
  892.      ;;to call the READER 
  893.      (CACHED-CHAS NIL)
  894.      (CACHED-ITEMS NIL)
  895.      (CACHED-ENTRIES NIL)
  896.      (CACHED-ELEMENTS NIL))
  897.     (ACTUAL-OBJ-MIXIN   PLIST-MIXIN)
  898.   (:INIT-KEYWORDS :SUPERIOR-BOX :CHAS-ARRAY))
  899.  
  900. (DEFFLAVOR NAME-ROW
  901.     ((CACHED-NAME NIL))
  902.      ;used for environmental info--a symbol in the boxer users package
  903.     (ROW)
  904.   :INITABLE-INSTANCE-VARIABLES)
  905.  
  906. (DEFFLAVOR BOX
  907.     ((FIRST-INFERIOR-ROW NIL)
  908.      (CACHED-ROWS NIL)
  909.      (CACHED-CODE NIL)
  910.      (PORTS NIL)
  911.      (DISPLAY-STYLE-LIST (LIST ':NORMAL NIL NIL));A list beginning with :SHRUNK
  912.                         ;or                    :NORMAL
  913.      (NAME NIL)
  914.      (STATIC-VARIABLES-ALIST NIL)
  915.      (EXPORTS NIL)
  916.      (LOCAL-LIBRARY NIL)
  917.      (REGION NIL)
  918.      (SHRINK-PROOF? NIL)
  919.      (entry-trigger nil)
  920.      (exit-trigger nil)
  921.      (entry-trigger-flag 'disabled)
  922.      (exit-trigger-flag 'disabled))
  923.     (CHA ACTUAL-OBJ-MIXIN VIRTUAL-COPY-MIXIN PLIST-MIXIN FLAVOR-HACKING-MIXIN)
  924.   :INITABLE-INSTANCE-VARIABLES
  925.   (:INIT-KEYWORDS :SUPERIOR-ROW :TYPE :FIXED-WID :FIXED-HEI))
  926.  
  927. (DEFFLAVOR DOIT-BOX
  928.     ()
  929.     (BOX))
  930.  
  931. (DEFFLAVOR DATA-BOX
  932.     ()
  933.     (BOX))
  934.  
  935. (DEFFLAVOR LL-BOX
  936.     ()
  937.     (BOX POP-UP-BOX-MIXIN))
  938.  
  939. (DEFFLAVOR PORT-BOX
  940.     ()
  941.     (BOX))
  942.  
  943. ;;; Just add a slot for the turtle to a normal box
  944. (defflavor sprite-box 
  945.     ((associated-turtle nil))
  946.     (box)
  947.   :gettable-instance-variables
  948.   :initable-instance-variables
  949.   :init-keywords
  950.   :settable-instance-variables) 
  951.  
  952. ;;; I still think these two flavors should become one and only the type 
  953. ;;;of screen box should toggle.
  954. (DEFFLAVOR GRAPHICS-BOX
  955.     ((GRAPHICS-SHEET NIL))           ;a leaderless <art-1b> array (no color yet)
  956.     (BOX)
  957.   :INITABLE-INSTANCE-VARIABLES
  958.   (:INIT-KEYWORDS :SUPERIOR-ROW :PICTURE-WID :PICTURE-HEI)
  959.   (:DEFAULT-INIT-PLIST :PICTURE-WID 320 :PICTURE-HEI 200))
  960.  
  961. (defflavor graphics-data-box
  962.     ((graphics-sheet nil))
  963.     (BOX)
  964.   :initable-instance-variables
  965.   (:DEFAULT-INIT-PLIST :FIXED-WID 320 :FIXED-HEI 200))
  966.  
  967. (DEFFLAVOR INPUT-BOX
  968.     ()
  969.     (BOX POP-UP-BOX-MIXIN)
  970.   (:INIT-KEYWORDS :INPUT-TYPE))
  971.  
  972. (DEFFLAVOR EDITOR-REGION
  973.     ((START-BP NIL)
  974.      (STOP-BP NIL)
  975.      (ROWS NIL)
  976.      (BOX NIL)
  977.      (VISIBILITY NIL)
  978.      (BLINKER-LIST NIL))
  979.     ()
  980.   :INITABLE-INSTANCE-VARIABLES)
  981.  
  982. ;;; Modified by Jeremy to include Draw-mode which can be wrap, window, or fence
  983.  
  984. (DEFSTRUCT (GRAPHICS-SHEET (:TYPE :NAMED-ARRAY)
  985.                :CONC-NAME
  986.                (:CONSTRUCTOR %MAKE-GRAPHICS-SHEET
  987.                 (DRAW-WID DRAW-HEI BIT-ARRAY SUPERIOR-BOX))
  988.                (:CONSTRUCTOR MAKE-GRAPHICS-SHEET-FROM-FILE
  989.                 (DRAW-WID DRAW-HEI BIT-ARRAY draw-mode))
  990.                (:PRINT "#<GRAPHICS-SHEET W-~D. H-~D.>"
  991.                 (GRAPHICS-SHEET-DRAW-WID GRAPHICS-SHEET)
  992.                 (GRAPHICS-SHEET-DRAW-HEI GRAPHICS-SHEET)))
  993.   (DRAW-WID *DEFAULT-GRAPHICS-SHEET-WIDTH*)
  994.   (DRAW-HEI *DEFAULT-GRAPHICS-SHEET-HEIGHT*)
  995.   (SCREEN-OBJS NIL)
  996.   (BIT-ARRAY (TV:MAKE-SHEET-BIT-ARRAY *BOXER-PANE*
  997.                       *DEFAULT-GRAPHICS-SHEET-WIDTH*
  998.                       *DEFAULT-GRAPHICS-SHEET-HEIGHT*))
  999.   (OBJECT-LIST NIL)
  1000.   (SUPERIOR-BOX NIL)
  1001.   (draw-mode ':wrap)
  1002.   )
  1003.  
  1004. (DEFTYPE-CHECKING-MACROS ROW "a row object")
  1005. (DEFTYPE-CHECKING-MACROS NAME-ROW "A Row used to name boxes. ")
  1006. (DEFTYPE-CHECKING-MACROS BOX "a box object")
  1007. (DEFTYPE-CHECKING-MACROS DOIT-BOX "a Doit Box")
  1008. (DEFTYPE-CHECKING-MACROS DATA-BOX "a Data Box")
  1009. (DEFTYPE-CHECKING-MACROS LL-BOX "a local library")
  1010. (DEFTYPE-CHECKING-MACROS PORT-BOX "a Port Box")
  1011. (DEFTYPE-CHECKING-MACROS GRAPHICS-BOX "A Box used for Graphics")
  1012. (DEFTYPE-CHECKING-MACROS INPUT-BOX "a box used for input")
  1013. (DEFTYPE-CHECKING-MACROS EDITOR-REGION "A Boxer Editor Region")
  1014. (deftype-checking-macros Sprite-box "A sprite-box")
  1015. (deftype-checking-macros Graphics-data-box "A Graphics-data-box")
  1016. (DEFTYPE-CHECKING-MACROS GRAPHICS-SHEET "A Bit Array for Graphics Boxes")
  1017.  
  1018.  
  1019. ;;;BP's are pointers which are used to move within REAL(that is, ACTUAL) structure
  1020. ;;;Note that they have nothing to do with SCREEN structure...
  1021. ;;;The *point* is a BP as is the *mark*
  1022. ;;;however, operations which move the *point* and the *mark* also update the
  1023. ;;;global variable's  *current-screen-box* and *marked-screen-box*
  1024.  
  1025. (DEFSTRUCT (BP (:TYPE :NAMED-LIST)           ;Easier to Debug
  1026.            (:CONSTRUCTOR MAKE-BP (TYPE))
  1027.            (:CONSTRUCTOR MAKE-INITIALIZED-BP (TYPE ROW CHA-NO))
  1028.            (:CONC-NAME   %BP-)
  1029.            (:ALTERANT    %ALTER-BP))
  1030.   (ROW    NIL)
  1031.   (CHA-NO 0)
  1032.   (SCREEN-BOX NIL)
  1033.   (TYPE ':FIXED))
  1034.  
  1035. (DEFSUBST BP? (X)
  1036.   (AND (LISTP X) (EQ (CAR X) 'BP)))
  1037.  
  1038. (DEFMACRO CHECK-BP-ARG (X)
  1039.   `(CHECK-ARG ,X BP? "A Boxer Editor Buffer-Pointer (BP)."))
  1040.  
  1041. (DEFF BP-ROW        '%BP-ROW)
  1042. (DEFF BP-CHA-NO     '%BP-CHA-NO)
  1043. (DEFF BP-SCREEN-BOX  '%BP-SCREEN-BOX)
  1044. (DEFF BP-TYPE       '%BP-TYPE)
  1045.  
  1046.  
  1047. (DEFPROP BP-ROW        ((BP-ROW BP)        SET-BP-ROW BP SI:VAL)        SETF)
  1048. (DEFPROP BP-CHA-NO     ((BP-CHA-NO BP)     SET-BP-CHA-NO BP SI:VAL)     SETF)
  1049. (DEFPROP BP-SCREEN-BOX ((BP-SCREEN-BOX BP) SET-BP-SCREEN-BOX SI:VAL)    SETF)
  1050. (DEFPROP BP-TYPE       ((BP-TYPE BP)       SET-BP-TYPE BP SI:VAL)       SETF)
  1051.  
  1052. (DEFSUBST ROW-BPS (ROW) (TELL ROW :BPS))
  1053. #-LMITI
  1054. (DEFPROP ROW-BPS ((ROW-BPS ROW) TELL ROW :SET-BPS SI:VAL) SETF)
  1055. #+LMITI
  1056. (DEFSETF ROW-BPS (ROW) (NEW-BPS) `(TELL ,ROW :SET-BPS ,NEW-BPS))
  1057.  
  1058. (DEFMACRO MOVE-BP (BP FORM)
  1059.   `(MULTIPLE-VALUE-BIND (NEW-ROW NEW-CHA-NO NEW-SCREEN-BOX)
  1060.        ,FORM
  1061.      (MOVE-BP-1 ,BP NEW-ROW NEW-CHA-NO NEW-SCREEN-BOX)))
  1062.  
  1063. (DEFMACRO MOVE-POINT (FORM)
  1064.   `(MULTIPLE-VALUE-BIND (NEW-ROW NEW-CHA-NO NEW-SCREEN-BOX)
  1065.        ,FORM
  1066.      (MOVE-POINT-1 NEW-ROW NEW-CHA-NO NEW-SCREEN-BOX)))
  1067.  
  1068. (DEFUN BP-CHA (BP)
  1069.   (TELL (BP-ROW BP) :CHA-AT-CHA-NO (BP-CHA-NO BP)))
  1070.  
  1071.  
  1072.  
  1073. ;;;; FLAVORS HAVING TO DO WITH reDISPLAY.
  1074.  
  1075. (DEFFLAVOR REDISPLAYABLE-WINDOW-MIXIN
  1076.     ((OUTERMOST-SCREEN-BOX NIL))
  1077.     ()
  1078.   )
  1079.  
  1080. (DEFSUBST REDISPLAYABLE-WINDOW? (X)
  1081.   (TYPEP X 'REDISPLAYABLE-WINDOW-MIXIN))
  1082.  
  1083. (DEFFLAVOR ACTUAL-OBJ-MIXIN
  1084.     ((SCREEN-OBJS NIL)
  1085.      (TICK 1))
  1086.     ()
  1087.   (:ORDERED-INSTANCE-VARIABLES TICK)
  1088.   (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES TICK)
  1089.   (:DOCUMENTATION :MIXIN
  1090.    "Giving an flavor this mixin will allow the the redisplay code to be
  1091.     able to display and redisplay that object"))
  1092.  
  1093. (DEFTYPE-CHECKING-MACROS ACTUAL-OBJ "an obj with the Actual-Obj-Mixin")
  1094.  
  1095.  
  1096. (DEFFLAVOR SCREEN-OBJ
  1097.     ((ACTUAL-OBJ NIL)
  1098.      (X-OFFSET 0)
  1099.      (Y-OFFSET 0)
  1100.      (WID 0)
  1101.      (HEI 0)
  1102.      (X-GOT-CLIPPED? NIL)
  1103.      (Y-GOT-CLIPPED? NIL)
  1104.      (NEW-WID 0)
  1105.      (NEW-HEI 0)
  1106.      (NEW-X-GOT-CLIPPED? NIL)
  1107.      (NEW-Y-GOT-CLIPPED? NIL)
  1108.      (TICK -1)
  1109.      (NEEDS-REDISPLAY-PASS-2? NIL)
  1110.      (FORCE-REDISPLAY-INFS? NIL))
  1111.     ()
  1112.   :ORDERED-INSTANCE-VARIABLES
  1113.   :OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES
  1114.   :SETTABLE-INSTANCE-VARIABLES
  1115.   (:REQUIRED-METHODS :REDISPLAY-PASS-1
  1116.              :REDISPLAY-PASS-2))
  1117.  
  1118. (DEFTYPE-CHECKING-MACROS SCREEN-OBJ "an object of type Screen-Obj")
  1119.  
  1120. (DEFFLAVOR SUPERIOR-SCREEN-OBJ
  1121.     ()
  1122.     (SCREEN-OBJ))
  1123.  
  1124. (DEFTYPE-CHECKING-MACROS SUPERIOR-SCREEN-OBJ "an object of type Superior-Screen-Obj")
  1125.  
  1126. ;;;screen chas are now obselete.  They only exist as a mixin for the box flavor
  1127. (DEFFLAVOR SCREEN-CHA
  1128.     ((SCREEN-ROW NIL))
  1129.     (SCREEN-OBJ)
  1130.   :SETTABLE-INSTANCE-VARIABLES)
  1131.  
  1132. (DEFFLAVOR SCREEN-ROW
  1133.     ((SCREEN-BOX NIL)
  1134.      (SCREEN-CHAS NIL)
  1135.      (OUT-OF-SYNCH-MARK NIL))
  1136.     (SUPERIOR-SCREEN-OBJ)
  1137.   :SETTABLE-INSTANCE-VARIABLES)
  1138.  
  1139. (DEFTYPE-CHECKING-MACROS SCREEN-ROW "a Screen-Row")
  1140.  
  1141. (DEFFLAVOR SCREEN-BOX
  1142.     ((SCREEN-ROWS NIL)
  1143.      (SCROLL-TO-ACTUAL-ROW NIL)
  1144.      (INF-HOR-SHIFT 0.)
  1145.      (NAME NIL)
  1146.      (BOX-TYPE ':DOIT-BOX)
  1147.      (BPS NIL)
  1148.      (DISPLAY-STYLE-LIST (LIST NIL NIL NIL)) ;NIL means use the information
  1149.                          ;in the actual Box, Otherwise
  1150.                          ;this (like the actual Box) is
  1151.                          ;A list beginning with :SHRUNK
  1152.                          ;or                    :NORMAL
  1153.                          ;or                    :FIXED
  1154.      (SUPERIOR-SCREEN-BOX NIL))      ;this stores display info when the box
  1155.     (SCREEN-CHA SUPERIOR-SCREEN-OBJ FLAVOR-HACKING-MIXIN)  ;is made into an outermost box
  1156.   :SETTABLE-INSTANCE-VARIABLES)
  1157.  
  1158. (DEFTYPE-CHECKING-MACROS SCREEN-BOX "a Screen-Box")
  1159.  
  1160. (DEFUN CHECK-SCREEN-CHA-ARG (SCREEN-CHA)
  1161.   (OR (FIXNUMP SCREEN-CHA)
  1162.       (SCREEN-BOX? SCREEN-CHA)))
  1163.  
  1164. (DEFFLAVOR GRAPHICS-SCREEN-BOX
  1165.     ()
  1166.     (SCREEN-BOX)
  1167.   (:SETTABLE-INSTANCE-VARIABLES))
  1168.  
  1169. (DEFTYPE-CHECKING-MACROS GRAPHICS-SCREEN-BOX "A Screen Box used for Graphics")
  1170.  
  1171.  
  1172. (DEFFLAVOR REGION-ROW-BLINKER
  1173.     ((UID NIL))
  1174.     (TV:RECTANGULAR-BLINKER)
  1175.   (:OUTSIDE-ACCESSIBLE-INSTANCE-VARIABLES UID))
  1176.  
  1177. (DEFTYPE-CHECKING-MACROS REGION-ROW-BLINKER "A Boxer Editor Region Blinker")
  1178.  
  1179. ;;;just in case...
  1180.  
  1181. (COMPILER:MAKE-OBSOLETE DO-CHAS "Use (DO-ROW-CHAS (<var> <row>) <body>) instead.")
  1182. (COMPILER:MAKE-OBSOLETE DO-ROWS "Use (DO-BOX-ROWS (<var> <box>) <body>) instead.")
  1183. (COMPILER:MAKE-OBSOLETE DO-OBJS "Why were you using it anyways??")
  1184.  
  1185.  
  1186.  
  1187. ;;; Setting up the BOXER-USER package.
  1188.  
  1189. ;; Boxer stores global definitions in the value cell of the symbol used to name
  1190. ;; the primitive or variable.  In order to be sure that boxer-functions don't get randomly
  1191. ;; redefined, we need to be sure that those symbols can't get lambda-bound or
  1192. ;; have their values set by any code other than boxer-function code.  In order
  1193. ;; to do this, we set up a special package, the BOXER-USER package, in which we
  1194. ;; intern all the symbols we use to name boxer-functions.  In addition, this
  1195. ;; package is set up so that it shadows all symbols. This is done by setting
  1196. ;; the package's pkg-super-package to nil. Please take a moment to consider
  1197. ;; the effects of having a package's super package be nil... it means that it
  1198. ;; will intern all symbols locally, it means that none of the lispms functions
  1199. ;; or variables are available from that package, it means that if you should
  1200. ;; manage to bind the value of the variable package to that package you would
  1201. ;; be in a lot of trouble.  Since I don't expect you to believe this, or even
  1202. ;; take the time to think about it, I am going to intern the symbols PKG-GOTO,
  1203. ;; and PKG-USER-PACKAGE in the boxer-user package, this will allow people who
  1204. ;; manage to get stuck in the boxer-user package to unstick themselves without
  1205. ;; having to warm-boot (do a (PKG-GOTO PKG-USER-PACKAGE)).
  1206.  
  1207. #+MIT
  1208. (EVAL-WHEN (LOAD)
  1209.   (MAKE-PACKAGE "BOXER-USER"
  1210.         ':NICKNAMES '(BU BOXER-USERS PKG-BU-PACKAGE PKG-BOXER-USER-PACKAGE)
  1211.         ':SIZE 1000
  1212.         ':USE NIL)
  1213.   )
  1214.  
  1215. #-MIT
  1216. (EVAL-WHEN (LOAD)
  1217.   (DEFPACKAGE BOXER-USER
  1218.     (:NICKNAMES BU BOXER-USERS PKG-BU-PACKAGE PKG-BOXER-USER-PACKAGE)
  1219.     (:PREFIX-NAME BU)
  1220.     (:USE)
  1221.     (:IMPORT SI:PKG-GOTO)
  1222.     (:SIZE 1000)))
  1223.  
  1224. (EVAL-WHEN (LOAD)
  1225.   
  1226.   (DEFVAR PKG-BOXER-USER-PACKAGE (PKG-FIND-PACKAGE 'BOXER-USER))
  1227.   (DEFVAR PKG-BU-PACKAGE (PKG-FIND-PACKAGE 'BOXER-USER))
  1228.   (DEFUN INTERN-IN-BOXER-USER-PACKAGE (SYMBOL)
  1229.     (INTERN (STRING SYMBOL) 'BOXER-USER))
  1230.   (DEFUN INTERN-IN-BU-PACKAGE (SYMBOL)
  1231.     (INTERN (STRING SYMBOL) 'BU))
  1232.   
  1233.   )
  1234.  
  1235.