;;;-*-SYNTAX: ZETALISP; MODE: LISP; PACKAGE: (BOXER GLOBAL 1000); BASE: 10; FONTS: CPTFONT-*- ;; (C) Copyright 1982-1985 Massachusetts Institute of Technology ;; ;; Permission to use, copy, modify, distribute, and sell this software ;; and its documentation for any purpose is hereby granted without fee, ;; provided that the above copyright notice appear in all copies and that ;; both that copyright notice and this permission notice appear in ;; supporting documentation, and that the name of M.I.T. not be used in ;; advertising or publicity pertaining to distribution of the software ;; without specific, written prior permission. M.I.T. makes no ;; representations about the suitability of this software for any ;; purpose. It is provided "as is" without express or implied warranty. ;; (EVAL-WHEN (LOAD) (TV:ADD-SYSTEM-KEY #/B 'BOXER-FRAME "Boxer" '(PROGN (MAKE-BOXER) (START-BOXER))) (TV:ADD-TO-SYSTEM-MENU-PROGRAMS-COLUMN "Boxer" '(TV:SELECT-OR-CREATE-WINDOW-OF-FLAVOR 'BOXER-FRAME) "Boxer") ; This is really dangerous because the Y-OR-NO-P never happens. ; (TV:ADD-SYSTEM-KEY #/CONTROL-B 'BOXER-FRAME "Boxer" ; '(WHEN ; (Y-OR-N-P "Really blow away the old boxer, making a brand new one? ") ; (MAKE-BOXER)(START-BOXER))) ) ;;;;**************MAIN ENTRY POINTS TO BOXER SYSTEM************** (DEFMETHOD (BOXER-FRAME :BEFORE :INIT) (&REST IGNORE) (SETQ TV:PANES '((:NAME NAME-PANE) (:BOXER BOXER-PANE)) TV:CONSTRAINTS '((MAIN . ((:NAME :BOXER) ((:NAME 1 :LINES)) ((:BOXER :EVEN))))))) (DEFMETHOD (BOXER-FRAME :AFTER :INIT) (&REST IGNORE) ;; Leave pointers to the various global things. (SETQ *POINT-BLINKER* (TV:MAKE-BLINKER *BOXER-PANE* 'CURSOR-BLINKER :VISIBILITY ':BLINK) *MOUSE-BLINKER* (TV:MAKE-BLINKER *BOXER-PANE* 'BOXER-MOUSE-BLINKER) *SPRITE-BLINKER* (TV:MAKE-BLINKER *BOXER-PANE* 'SPRITE-BLINKER :VISIBILITY NIL)) ;; Do various other system initializations. (INSTANTIATE-FLAVOR 'DOIT-BOX '(#+MIT ()) ()) ;A bad but necessary hack for (INSTANTIATE-FLAVOR 'DATA-BOX '(#+MIT ()) ()) ;flavor-hacking mixin. (INSTANTIATE-FLAVOR 'LL-BOX '(#+MIT ()) ()) (INSTANTIATE-FLAVOR 'PORT-BOX '(#+MIT ()) ()) (INSTANTIATE-FLAVOR 'GRAPHICS-BOX '(#+MIT ()) ()) (INSTANTIATE-FLAVOR 'SPRITE-BOX '(#+MIT ()) ()) (INSTANTIATE-FLAVOR 'GRAPHICS-DATA-BOX '(#+MIT ()) ()) (INSTANTIATE-FLAVOR 'INPUT-BOX '(#+MIT ()) ()) (SETUP-REDISPLAY) (SETUP-EDITOR T) ;; We setup and start the boxer process from here because we ;; need to make sure that all the initializations are complete ;; before it gets a chance to run. (LET ((P (TELL *BOXER-PANE* :PROCESS))) (PROCESS-PRESET P #'BOXER-PROCESS-TOP-LEVEL-FN *BOXER-PANE*) (PROCESS-ENABLE P))) (DEFMETHOD (BOXER-PANE :BEFORE :INIT) (&REST IGNORE) (SETQ TV:PROCESS (MAKE-PROCESS "Boxer" ':REGULAR-PDL-SIZE 9000 ':SPECIAL-PDL-SIZE 6000))) (DEFMETHOD (BOXER-FRAME :NAME-FOR-SELECTION) () "Boxer") (DEFMETHOD (BOXER-PANE :SCREEN-ARRAY) () TV:SCREEN-ARRAY) ;;;; Interface Between the way the lispm deals with the mouse, and the ;;;; way Boxer wants to be able to deal with the mouse. (DEFVAR MOUSE-ENTERS-WINDOW-HANDLER 'FANCY-MOUSE-ENTERS-WINDOW-HANDLER) (DEFVAR MOUSE-CLICK-HANDLER 'DEFAULT-MOUSE-CLICK-HANDLER) (DEFVAR MOUSE-MOVES-HANDLER 'FANCY-MOUSE-MOVES-HANDLER) (DEFVAR MOUSE-BUTTONS-HANDLER 'FANCY-MOUSE-BUTTONS-HANDLER) (DEFVAR WHO-LINE-DOCUMENTATION-STRING NIL) ;(set up near the def's of bu:mouse-middle, etc.) (DEFUN SET-MOUSE-ENTERS-WINDOW-HANDLER (NEW-VALUE) (WITHOUT-INTERRUPTS (SETQ MOUSE-ENTERS-WINDOW-HANDLER NEW-VALUE) (SETQ TV:MOUSE-RECONSIDER T))) (DEFUN SET-MOUSE-MOVES-HANDLER (NEW-VALUE) (WITHOUT-INTERRUPTS (SETQ MOUSE-MOVES-HANDLER NEW-VALUE) (SETQ TV:MOUSE-RECONSIDER T))) (DEFUN SET-MOUSE-CLICK-HANDLER (NEW-VALUE) (SETQ MOUSE-CLICK-HANDLER NEW-VALUE)) (DEFUN SET-MOUSE-BUTTONS-HANDLER (NEW-VALUE) (SETQ MOUSE-BUTTONS-HANDLER NEW-VALUE)) (DEFMETHOD (BOXER-PANE :HANDLE-MOUSE) () (FUNCALL MOUSE-ENTERS-WINDOW-HANDLER SELF)) (DEFMETHOD (BOXER-PANE :MOUSE-MOVES) (X Y) (FUNCALL MOUSE-MOVES-HANDLER SELF X Y)) (DEFMETHOD (BOXER-PANE :MOUSE-BUTTONS) (BD X Y) (FUNCALL MOUSE-BUTTONS-HANDLER SELF BD X Y)) (DEFMETHOD (BOXER-PANE :MOUSE-CLICK) (BUTTONS X Y) (FUNCALL MOUSE-CLICK-HANDLER SELF BUTTONS X Y) T) ;;;;BUG-BOXER subsystem. ;; This doesn't belong anyplace else that I can think of either. (DEFFLAVOR BUG-BOXER-WINDOW () (TV:TEMPORARY-WINDOW-MIXIN TV:WINDOW) (:DEFAULT-INIT-PLIST :SAVE-BITS NIL :FONT-MAP `(,FONTS:MEDFNT))) (DEFRESOURCE BUG-BOXER-WINDOW () :CONSTRUCTOR (TV:MAKE-WINDOW 'BUG-BOXER-WINDOW) :MATCHER 'T :INITIAL-COPIES 1) (DEFMACRO WITH-BUG-BOXER-WINDOW-SELECTED (VAR &BODY BODY) `(USING-RESOURCE (,VAR BUG-BOXER-WINDOW) (LET ((OLD-SELECTED-WINDOW TV:SELECTED-WINDOW) (OVER-WINDOW (BUG-BOXER-GET-BUG-BOXER-WINDOW-OVER-WINDOW))) (UNWIND-PROTECT (PROGN (EXPOSE-WINDOW-OVER-WINDOW ,VAR OVER-WINDOW) (TELL ,VAR :SELECT) . ,BODY) (TELL ,VAR :KILL) (TELL OLD-SELECTED-WINDOW :SELECT))))) (DEFUN BUG-BOXER-GET-BUG-BOXER-WINDOW-OVER-WINDOW () ;; Oh well looks like we are going to have to cover ;; up the boxer-pane. *BOXER-PANE*) (DEFUN EXPOSE-WINDOW-OVER-WINDOW (EXPOSE-WINDOW OVER-WINDOW) (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM) (TELL OVER-WINDOW :INSIDE-EDGES) (TELL EXPOSE-WINDOW :SET-SUPERIOR OVER-WINDOW) (TELL EXPOSE-WINDOW :SET-EDGES LEFT TOP RIGHT BOTTOM) (TELL EXPOSE-WINDOW :EXPOSE))) (DEFUN BUG-BOXER () (WITH-BUG-BOXER-WINDOW-SELECTED BUG-WINDOW (BUG-BOXER-PRINT-INSTRUCTIONS BUG-WINDOW) (BUG-BOXER-SEND-MESSAGE (BUG-BOXER-GET-BUG-MESSAGE BUG-WINDOW) BUG-WINDOW))) (DEFUN BUG-BOXER-PRINT-INSTRUCTIONS (TERMINAL-IO) (SEND TERMINAL-IO ':CLEAR-WINDOW) (FORMAT T "~%Please try to explain as carefully as possible the problem which~ ~%you encountered.~ ~% When done, pressing the will send your bug message~ ~% or pressing the key will abort sending.~ ~%~ ~% Type Ctrl-L to clear the screen. ~%~ ")) (DEFUN BUG-BOXER-GET-BUG-MESSAGE (&OPTIONAL (TERMINAL-IO TERMINAL-IO)) ;; Try to help the poor user out by getting a fancy rubout handler. (COND ((AND (NULL RUBOUT-HANDLER) (SEND TERMINAL-IO ':OPERATION-HANDLED-P ':RUBOUT-HANDLER)) (SEND TERMINAL-IO ':RUBOUT-HANDLER '((:PASS-THROUGH #\END NIL)) #'BUG-BOXER-GET-BUG-MESSAGE TERMINAL-IO)) (T (DO ((MESSAGE (MAKE-ARRAY 100 ':TYPE 'ART-STRING ':LEADER-LIST '(0))) (CHAR (SEND TERMINAL-IO ':TYI) (SEND TERMINAL-IO ':TYI))) ((MEMQ CHAR '(#\END NIL)) MESSAGE) (ARRAY-PUSH-EXTEND MESSAGE CHAR))))) (DEFUN BUG-BOXER-SEND-MESSAGE (MESSAGE REPORT-STREAM) #+SYMBOLICS (LET ((ZWEI:*HOST-FOR-BUG-REPORTS* (si:parse-host "Dewey")) (ZWEI:*TYPEIN-WINDOW* REPORT-STREAM)) (MULTIPLE-VALUE-BIND (DESTINATION SYSTEM-DESCRIPTION) (ZWEI:PARSE-BUG-ARG 'BOXER) (SEND (MAKE-INSTANCE 'ZWEI:SEND-MESSAGE-STRING-DRAFT-MSG ':HEADERS `(:TO ,(ZWEI:PARSE-ADDRESSES DESTINATION) :SUBJECT "BOXER BUG") ':TEXT (STRING-APPEND SYSTEM-DESCRIPTION MESSAGE)) ':TRANSMIT))) #+MIT (ZWEI:BUG "Boxer" MESSAGE) T) (DEFUN MAIL-TEXT-STRING (RECIPIENT SUBJECT MESSAGE &OPTIONAL (REPORT-STREAM TERMINAL-IO)) (LET ((ZWEI:*TYPEIN-WINDOW* REPORT-STREAM)) (SEND (MAKE-INSTANCE 'ZWEI:SEND-MESSAGE-STRING-DRAFT-MSG ':HEADERS `(:TO ,(ZWEI:PARSE-ADDRESSES RECIPIENT) :SUBJECT ,SUBJECT) ':TEXT MESSAGE) ':TRANSMIT)))