;-*- Mode:LISP; Package:USER; Base:8 -*- (DECLARE (SPECIAL BRUSH PAINT PAINT-SCREEN PAINT-LIST ALTERNATE-PAINT PAINT-MENU SELECT-MENU AREA-MENU DRAW-MENU BRUSH-LOW-X BRUSH-LOW-Y BRUSH-HIGH-X BRUSH-HIGH-Y BRUSH-CURSOR BRUSH-CURSOR-ARRAY BRUSH-PHASE BRUSH-CURSOR-X BRUSH-CURSOR-Y PAINT-CLOCK PAINT-CLOCK-RATE PAINT-DEFAULT-CLOCK-RATE BLINK-CLOCK-RATE PAINT-AREA-Y PAINT-AREA-X PAINT-DISPATCH-ALWAYS MOUSE-TOP-SWITCH MOUSE-TOP-SWITCH-HOLD MOUSE-MID-SWITCH MOUSE-BOT-SWITCH MOUSE-MIDSW-HOLD ;IF T, WILL NOT DISPATCH TO COMMAND UNTIL MIDSW RELEASED MOUSE-BOTSW-HOLD ;SET TO NIL IF BOTSW SEEN OFF. MOUSE-X MOUSE-Y PAINT-MODE PAINT-BRUSH-INHIBIT-BLINK PAINT-CURRENT-MENU PAINT-SAVED-SCREEN PAINT-MODE-PC-PPR PAINT-MODE-STREAM PAINT-CONSOLE-IO-PC-PPR CONSOLE-IO-PC-PPR PAINT-LABELING-PC-PPR PAINT-LABELING-STREAM PAINT-DLC-STATE PAINT-DLC-MODE PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y PAINT-SUBC-PHASE PAINT-EXIT-FLAG PAINT-ARG-STRING PAINT-TEXT-HOLDING-STRING PAINT-TEXT-FONT PAINT-PICTURE-LIST )) (DECLARE (SPECIAL TV-ALU-AND)) (SETQ TV-ALU-AND 1_3) (DEFCLASS PAINT-AREA-CLASS OBJECT-CLASS ( PAINT-AREA-ARRAY PAINT-AREA-X ;LOW X COORD OF AREA WITHIN ARRAY PAINT-AREA-Y ;LOW Y COORD OF AREA WITHIN ARRAY PAINT-AREA-X-SIZE ;X-SIZE IN # BITS PAINT-AREA-Y-SIZE ;Y-SIZE IN # BITS PAINT-AREA-BUFFER-ARRAY ;NIL OR ANOTHER ARRAY TO BUFFER AREA ) ) (DEFMETHOD (PAINT-AREA-CLASS :INSIDE-P) (ARY X Y) (AND (EQ ARY PAINT-AREA-ARRAY) (NOT (< X PAINT-AREA-X)) (NOT (< Y PAINT-AREA-Y)) (< X (+ PAINT-AREA-X PAINT-AREA-X-SIZE)) (< Y (+ PAINT-AREA-Y PAINT-AREA-Y-SIZE)))) (DEFMETHOD (PAINT-AREA-CLASS :COPY-TO) (TO-ARY &OPTIONAL (TO-X 0) (TO-Y 0) (ALU-OP TV-ALU-SETA)) (BITBLT ALU-OP PAINT-AREA-X-SIZE PAINT-AREA-Y-SIZE PAINT-AREA-ARRAY PAINT-AREA-X PAINT-AREA-Y TO-ARY TO-X TO-Y)) (DEFMETHOD (PAINT-AREA-CLASS :COPY-TO-CENTERED) (TO-ARY C-X C-Y &OPTIONAL (ALU-OP TV-ALU-SETA)) (<- SELF ':COPY-TO TO-ARY (- C-X (// PAINT-AREA-X-SIZE 2)) (- C-Y (// PAINT-AREA-Y-SIZE 2)) ALU-OP)) (DEFMETHOD (PAINT-AREA-CLASS :COPY-TO-BUFFER) NIL ;DUPLICATE AREA IN BUFFER (PROG (BA-AT BITS-PE BA-D1-BITS PA-D1-BITS) (COND ((NULL PAINT-AREA-BUFFER-ARRAY) (SETQ BA-AT (ARRAY-TYPE PAINT-AREA-ARRAY)) (SETQ BITS-PE (CDR (ASSQ BA-AT ARRAY-BITS-PER-ELEMENT))) (SETQ PA-D1-BITS (* BITS-PE PAINT-AREA-X-SIZE)) (SETQ BA-D1-BITS (* (// (+ PA-D1-BITS 31.) 32.) 32.)) ;ASSURE MULT OF 32. SO ;BITBLT WINS. (SETQ PAINT-AREA-BUFFER-ARRAY (MAKE-ARRAY NIL (ARRAY-TYPE PAINT-AREA-ARRAY) (LIST (// BA-D1-BITS BITS-PE) PAINT-AREA-Y-SIZE))))) (<- SELF ':COPY-TO PAINT-AREA-BUFFER-ARRAY))) (DEFMETHOD (PAINT-AREA-CLASS :COPY-FROM-BUFFER-CENTERED) (TO-ARY C-X C-Y &OPTIONAL (ALU-OP TV-ALU-SETA)) (BITBLT ALU-OP PAINT-AREA-X-SIZE PAINT-AREA-Y-SIZE PAINT-AREA-BUFFER-ARRAY 0 0 TO-ARY (- C-X (// PAINT-AREA-X-SIZE 2)) (- C-Y (// PAINT-AREA-Y-SIZE 2)))) (DEFSTRUCT (PAINT-LINE-ITEM) ;ALSO USED FOR CIRCLES PAINT-LINE-HANDLER ;NAMED-STRUCTURE-HANDLER PAINT-LINE-TYPE ;LINE OR CIRCLE PAINT-LINE-STATUS ;IN OR OUT PAINT-LINE-MODE ;0S 1S OR XOR PAINT-LINE-X0 ;CENTER OF CIRCLE OR ENDPOINT OF LINE PAINT-LINE-Y0 PAINT-LINE-X1 ;RADIUS OF CIRCLE OR ENDPOINT OF LINE PAINT-LINE-Y1 ;UNUSED IF CIRCLE ) (DEFSTRUCT (PAINT-PATH) PAINT-PATH-HANDLER ;NAMED-STRUCTURE-HANDLER PAINT-PATH-STATUS PAINT-PATH-MODE PAINT-PATH-POINTS-ARRAY ) (DEFSTRUCT (PAINT-TEXT) PAINT-TEXT-NAME PAINT-TEXT-TEXT PAINT-TEXT-FONT PAINT-TEXT-XPOS PAINT-TEXT-YPOS ) (DEFUN PAINT-INIT NIL (MAKUNBOUND 'PAINT-LABELING-PC-PPR) (MAKUNBOUND 'PAINT-LABELING-STREAM) (MAKUNBOUND 'PAINT-MODE-PC-PPR) (MAKUNBOUND 'PAINT-MODE-STREAM) (MAKUNBOUND 'PAINT-CONSOLE-IO-PC-PPR) (MAKUNBOUND 'PAINT-MENU) (MAKUNBOUND 'SELECT-MENU) (MAKUNBOUND 'AREA-MENU) (MAKUNBOUND 'DRAW-MENU) ) (DEFUN PAINT (&OPTIONAL (INPUT-ROUTINE 'MOUSE) (INITP T)) (PROG (DX DY MOUSE-TOP-SWITCH MOUSE-TOP-SWITCH-HOLD MOUSE-MID-SWITCH MOUSE-MIDSW-HOLD MOUSE-BOT-SWITCH MOUSE-BOTSW-HOLD TEM (MOUSE-X 300) (MOUSE-Y 300) (PAINT-CLOCK 0) (BLINK-CLOCK 0) PAINT-MODE NEW-PAINT-MODE PAINT-BRUSH-INHIBIT-BLINK PAINT-CURRENT-MENU OLD-CONSOLE-IO-PC-PPR PAINT-DISPATCH-ALWAYS PAINT-EXIT-FLAG PAINT-ARG-STRING CH PAINT-TEXT-HOLDING-STRING PAINT-TEXT-FONT PAINT-PICTURE-LIST) (COND ((NOT (ZEROP (SCREEN-PLANE-MASK TV-DEFAULT-SCREEN))) (SETQ TV-DEFAULT-SCREEN SI:TV-CPT-SCREEN) ; (BREAK "TV-DEFAULT-SCREEN not 32 bit." T) )) (COND ((AND (BOUNDP 'PAINT-SCREEN) ;JUST TO UNWEDGE IF YOU LOSE (NOT (EQ TV-DEFAULT-SCREEN PAINT-SCREEN))) ;THIS VERSION ONLY WINS (PAINT-INIT))) ;FOR 32 BIT TV'S (SETQ BRUSH-PHASE NIL) (COND ((NULL (BOUNDP 'PAINT-DEFAULT-CLOCK-RATE)) (SETQ PAINT-DEFAULT-CLOCK-RATE 1))) (SETQ PAINT-CLOCK-RATE PAINT-DEFAULT-CLOCK-RATE) (COND ((NULL (BOUNDP 'BLINK-CLOCK-RATE)) (SETQ BLINK-CLOCK-RATE 200))) (COND ((NULL (BOUNDP 'PAINT-LABELING-PC-PPR)) (SETQ PAINT-LABELING-PC-PPR (TV-DEFINE-PC-PPR 'PAINT-LABELING-PC-PPR (LIST (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN)) 'BLINKER-P NIL 'MORE-P NIL)) (SETF (PC-PPR-CHAR-ALUF PAINT-LABELING-PC-PPR) TV-ALU-XOR) (SETF (PC-PPR-ERASE-ALUF PAINT-LABELING-PC-PPR) TV-ALU-NOOP))) (COND ((NULL (BOUNDP 'PAINT-LABELING-STREAM)) (SETQ PAINT-LABELING-STREAM (TV-MAKE-STREAM PAINT-LABELING-PC-PPR)))) (COND ((NULL (BOUNDP 'PAINT-MODE-PC-PPR)) (SETQ PAINT-MODE-PC-PPR (TV-DEFINE-PC-PPR 'PAINT-MODE-PC-PPR (LIST (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN)) 'TOP 0 ;THIS IS THE SMALL FROB IN THE UPPER RIGHT THAT 'BOTTOM 12. ;SHOWS THE CURRENT MODE 'RIGHT (SCREEN-X2 TV-DEFAULT-SCREEN) 'LEFT (- (SCREEN-X2 TV-DEFAULT-SCREEN) 120.) 'BLINKER-P NIL 'MORE-P NIL 'END-LINE-FCN 'TV-BACKSPACE 'END-SCREEN-FCN 'TV-HOME)))) (COND ((NULL (BOUNDP 'PAINT-MODE-STREAM)) (SETQ PAINT-MODE-STREAM (TV-MAKE-STREAM PAINT-MODE-PC-PPR)))) (COND ((NULL (BOUNDP 'PAINT-CONSOLE-IO-PC-PPR)) (SETQ PAINT-CONSOLE-IO-PC-PPR (TV-DEFINE-PC-PPR 'PAINT-CONSOLE-IO-PC-PPR (LIST (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN)) 'TOP (- (SCREEN-Y2 TV-DEFAULT-SCREEN) 100) 'RIGHT (// (SCREEN-X2 TV-DEFAULT-SCREEN) 2) 'MORE-P NIL)))) (SETQ OLD-CONSOLE-IO-PC-PPR CONSOLE-IO-PC-PPR) (COND ((NOT (EQ CONSOLE-IO-PC-PPR PAINT-CONSOLE-IO-PC-PPR)) (TV-DEACTIVATE-PC-PPR CONSOLE-IO-PC-PPR) (SETQ CONSOLE-IO-PC-PPR PAINT-CONSOLE-IO-PC-PPR) (TV-ACTIVATE-PC-PPR CONSOLE-IO-PC-PPR))) (COND (INITP (TV-CLEAR-SCREEN) (INIT-PAINTS))) (COND ((NULL (BOUNDP 'PAINT-MENU)) (SETQ PAINT-MENU (DEFINE-MENU 'PAINT-MENU '(SELECT-MENU DRAW-MENU AREA-MENU RESTORE-PALLET NORMAL-MODE XOR-MODE EXIT) 'OPTION 'ADVANCING)))) (COND ((NULL (BOUNDP 'SELECT-MENU)) (SETQ SELECT-MENU (DEFINE-MENU 'SELECT-MENU '(SELECT-BRUSH SELECT-PAINT SELECT-ALTERNATE-PAINT PAINT-MENU EXIT) 'OPTION 'ADVANCING)))) (COND ((NULL (BOUNDP 'AREA-MENU)) (SETQ AREA-MENU (DEFINE-MENU 'AREA-MENU '(SAVE-SCREEN RESTORE-SCREEN MOUSE-UPPER-LEFT MOUSE-LOWER-RIGHT DEFINE-AREA SHOW-AREA SELECT-MENU PAINT-MENU EXIT) 'OPTION 'ADVANCING)))) (COND ((NULL (BOUNDP 'DRAW-MENU)) (SETQ DRAW-MENU (DEFINE-MENU 'DRAW-MENU '(DRAW-DIRECT DRAW-LINES-AND-CIRCLES TEXT PAINT-MENU EXIT) 'OPTION 'ADVANCING)))) (SETQ PAINT-TEXT-FONT (SCREEN-DEFAULT-FONT TV-DEFAULT-SCREEN)) (SETQ PAINT-ARG-STRING (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 50 NIL '(0))) (PAINT-SELECT-MODE 'NORMAL-MODE) ;INITIALIZE PAINT-ARG-STRING BEFORE THIS (SETQ PAINT-CURRENT-MENU PAINT-MENU) (DISPLAY-MENU PAINT-CURRENT-MENU) (SETQ PAINT-SCREEN TV-DEFAULT-SCREEN) A (COND ((SETQ CH (KBD-TYI-NO-HANG)) (SETQ TEM (LOGAND CH 377)) ;FLUSH BUCKY BITS (COND ((= TEM 201) ;BREAK (SETQ PAINT-EXIT-FLAG T)) ((= TEM 204) ;ESCAPE (KBD-ESC)) ((= TEM 207) ;RUBOUT (COND ((NOT (ZEROP (ARRAY-ACTIVE-LENGTH PAINT-ARG-STRING))) (ARRAY-POP PAINT-ARG-STRING)))) ((< TEM 200) (ARRAY-PUSH PAINT-ARG-STRING TEM))))) ;STORE CHAR (COND (PAINT-EXIT-FLAG (TV-DEACTIVATE-PC-PPR CONSOLE-IO-PC-PPR) (SETQ CONSOLE-IO-PC-PPR OLD-CONSOLE-IO-PC-PPR) (TV-ACTIVATE-PC-PPR CONSOLE-IO-PC-PPR) (RETURN T))) (MULTIPLE-VALUE (DX DY MOUSE-TOP-SWITCH MOUSE-MID-SWITCH MOUSE-BOT-SWITCH) (FUNCALL INPUT-ROUTINE)) (SETQ MOUSE-X (+ MOUSE-X DX) MOUSE-Y (- MOUSE-Y DY)) ;upside-down coordinate system, use -dy (COND ((< MOUSE-X BRUSH-LOW-X) (SETQ MOUSE-X BRUSH-LOW-X)) ((> MOUSE-X BRUSH-HIGH-X) (SETQ MOUSE-X BRUSH-HIGH-X))) (COND ((< MOUSE-Y BRUSH-LOW-Y) (SETQ MOUSE-Y BRUSH-LOW-Y)) ((> MOUSE-Y BRUSH-HIGH-Y) (SETQ MOUSE-Y BRUSH-HIGH-Y))) A1 (COND (MOUSE-TOP-SWITCH (BRUSH-CLEAR) (COND ((< MOUSE-Y PAINT-AREA-Y) (COND ((< MOUSE-X PAINT-AREA-X) ;IN PAINT AREA, SELECT BRUSH (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y)) ;OR PAINT DIRECTLY (SETQ PAINT TEM) (<- PAINT ':COPY-TO-BUFFER))) ) (T (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y)) (SELECT-BRUSH TEM))))) ) (T (MULTIPLE-VALUE (NIL NEW-PAINT-MODE) ;IN MENU AREA, SELECT FROM MENU, ;OTHERWISE MAYBE COUNT MODE (SELECT-ITEM-FROM-MENU PAINT-CURRENT-MENU MOUSE-X MOUSE-Y (NULL MOUSE-TOP-SWITCH-HOLD))) ; (PAINT-SELECT-MODE NEW-PAINT-MODE) )) (SETQ MOUSE-TOP-SWITCH-HOLD T) (GO A))) (SETQ MOUSE-TOP-SWITCH-HOLD NIL) (COND ((NULL MOUSE-BOT-SWITCH) ;CLEAR THIS IF BOTSW SEEN OFF (SETQ MOUSE-BOTSW-HOLD NIL))) (COND (NEW-PAINT-MODE (COND (MOUSE-MID-SWITCH ;NEW MODE WAITING TO BE SELECTED, SELECT IT. (PAINT-SELECT-MODE NEW-PAINT-MODE) (SETQ NEW-PAINT-MODE NIL) (MENU-CLEAR-CURSOR PAINT-CURRENT-MENU))) (SETQ PAINT-CLOCK -1)) ;JUST BLINK, DONT PAINT (MOUSE-MIDSW-HOLD (COND (MOUSE-MID-SWITCH (SETQ PAINT-CLOCK -1)) ;THAT ONE WAS FOR MODE SELECTION (T (SETQ MOUSE-MIDSW-HOLD NIL))))) (COND ((AND MOUSE-MID-SWITCH PAINT-BRUSH-INHIBIT-BLINK)) ;IN THIS MODE, ;BLINKING CAUSES TOO MUCH LOSSAGE IF PAINTING ((> (SETQ BLINK-CLOCK (1+ BLINK-CLOCK)) (COND (MOUSE-MID-SWITCH (* BLINK-CLOCK-RATE 10.)) ;BLINK SLOWER IF PAINTING, (T BLINK-CLOCK-RATE))) ; BUT DO BLINK OCCAISIONALLY (BRUSH-BLINK MOUSE-X MOUSE-Y) (SETQ BLINK-CLOCK 0) (GO A))) (COND ((< (SETQ PAINT-CLOCK (1+ PAINT-CLOCK)) PAINT-CLOCK-RATE) (GO A))) (SETQ PAINT-CLOCK 0) (COND ((AND (SETQ TEM (GET PAINT-MODE 'PAINT-COMMAND)) (OR MOUSE-MID-SWITCH MOUSE-BOT-SWITCH PAINT-DISPATCH-ALWAYS)) (BRUSH-CLEAR) (FUNCALL TEM))) (GO A) )) (DEFUN PAINT-SELECT-MODE (NEW-MODE &AUX TEM) (PROG NIL (COND ((EQ NEW-MODE PAINT-MODE) ;REALLY SAME MODE. (RETURN NIL))) (COND ((SETQ TEM (GET PAINT-MODE 'PAINT-LEAVING-FCTN)) (FUNCALL TEM))) (COND ((NOT (ZEROP (SETQ TEM (ARRAY-ACTIVE-LENGTH PAINT-ARG-STRING)))) (ADJUST-ARRAY-SIZE PAINT-ARG-STRING TEM) (SETQ PAINT-ARG-STRING (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 50 NIL '(0))))) (SETQ PAINT-MODE NEW-MODE) (TV-CLEAR-PC-PPR PAINT-MODE-PC-PPR) (PRINC PAINT-MODE PAINT-MODE-STREAM) (SETQ PAINT-SUBC-PHASE NIL PAINT-SUBC-X NIL) (COND ((SETQ TEM (GET PAINT-MODE 'PAINT-ENTERING-FCTN)) (FUNCALL TEM))) (SETQ PAINT-BRUSH-INHIBIT-BLINK (GET PAINT-MODE 'PAINT-BRUSH-INHIBIT-BLINK)) (SETQ PAINT-DISPATCH-ALWAYS (GET PAINT-MODE 'PAINT-DISPATCH-ALWAYS)) (COND ((SETQ TEM (GET PAINT-MODE 'PAINT-CLOCK-RATE)) (SETQ PAINT-CLOCK-RATE TEM)) (T (SETQ PAINT-CLOCK-RATE PAINT-DEFAULT-CLOCK-RATE))) (SETQ MOUSE-MIDSW-HOLD T))) ;DONT DO ANYTHING UNTIL MIDSW RELEASED (DEFUN PAINT-SELECT-MENU (NEW-MENU) (MENU-CLEAR-CURSOR PAINT-CURRENT-MENU) (ERASE-MENU PAINT-CURRENT-MENU) (SETQ PAINT-CURRENT-MENU NEW-MENU) (DISPLAY-MENU PAINT-CURRENT-MENU) (PAINT-SELECT-MODE 'NORMAL-MODE)) (DEFPROP NORMAL-MODE PAINT-COM-NORMAL-MODE PAINT-COMMAND) (DEFUN PAINT-COM-NORMAL-MODE NIL (COND (MOUSE-MID-SWITCH (BRUSH-PAINT BRUSH PAINT MOUSE-X MOUSE-Y)) (MOUSE-BOT-SWITCH (BRUSH-PAINT BRUSH ALTERNATE-PAINT MOUSE-X MOUSE-Y)))) (DEFPROP XOR-MODE PAINT-COM-XOR-MODE PAINT-COMMAND) (DEFUN PAINT-COM-XOR-MODE NIL (COND (MOUSE-MID-SWITCH (BRUSH-PAINT BRUSH PAINT MOUSE-X MOUSE-Y 'T)) (MOUSE-BOT-SWITCH (BRUSH-PAINT BRUSH ALTERNATE-PAINT MOUSE-X MOUSE-Y)))) (DEFPROP RESTORE-PALLET PAINT-COM-RESTORE-PALLET PAINT-COMMAND) (DEFUN PAINT-COM-RESTORE-PALLET NIL (INIT-PAINTS) (PAINT-SELECT-MENU PAINT-MENU)) (DEFPROP SELECT-MENU PAINT-COM-SELECT-MENU PAINT-COMMAND) (DEFUN PAINT-COM-SELECT-MENU NIL (PAINT-SELECT-MENU SELECT-MENU)) (DEFPROP AREA-MENU PAINT-COM-AREA-MENU PAINT-COMMAND) (DEFUN PAINT-COM-AREA-MENU NIL (PAINT-SELECT-MENU AREA-MENU)) (DEFPROP PAINT-MENU PAINT-COM-PAINT-MENU PAINT-COMMAND) (DEFUN PAINT-COM-PAINT-MENU NIL (PAINT-SELECT-MENU PAINT-MENU)) (DEFPROP DRAW-MENU PAINT-COM-DRAW-MENU PAINT-COMMAND) (DEFUN PAINT-COM-DRAW-MENU NIL (PAINT-SELECT-MENU DRAW-MENU)) (DEFPROP DRAW-DIRECT PAINT-COM-DRAW-DIRECT PAINT-COMMAND) (DEFPROP DRAW-DIRECT T PAINT-BRUSH-INHIBIT-BLINK) (DEFPROP DRAW-DIRECT 1 PAINT-CLOCK-RATE) (DEFUN PAINT-COM-DRAW-DIRECT NIL (COND (MOUSE-MID-SWITCH (AS-2 1 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) MOUSE-X MOUSE-Y)) (MOUSE-BOT-SWITCH (AS-2 0 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) MOUSE-X MOUSE-Y)))) (DEFPROP SELECT-BRUSH PAINT-COM-SELECT-BRUSH PAINT-COMMAND) (DEFUN PAINT-COM-SELECT-BRUSH (&AUX TEM) (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y)) (SELECT-BRUSH TEM) (PAINT-SELECT-MODE 'NORMAL-MODE))) ) (DEFPROP SELECT-PAINT PAINT-COM-SELECT-PAINT PAINT-COMMAND) (DEFUN PAINT-COM-SELECT-PAINT (&AUX TEM) (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y)) (SETQ PAINT TEM) (<- PAINT ':COPY-TO-BUFFER) (PAINT-SELECT-MODE 'NORMAL-MODE))) ) (DEFPROP SELECT-ALTERNATE-PAINT PAINT-COM-SELECT-ALTERNATE-PAINT PAINT-COMMAND) (DEFUN PAINT-COM-SELECT-ALTERNATE-PAINT (&AUX TEM) (COND ((SETQ TEM (PAINT-SELECT-ARRAY MOUSE-X MOUSE-Y)) (SETQ ALTERNATE-PAINT TEM) (<- ALTERNATE-PAINT ':COPY-TO-BUFFER) (PAINT-SELECT-MODE 'NORMAL-MODE))) ) (DEFUN SELECT-BRUSH (ARG &AUX TEM) (SETQ BRUSH ARG) (SETQ BRUSH-LOW-X (SETQ TEM (// (<- BRUSH ':PAINT-AREA-X-SIZE) 2))) (SETQ BRUSH-HIGH-X (- (SCREEN-X2 TV-DEFAULT-SCREEN) TEM)) (SETQ BRUSH-LOW-Y (SETQ TEM (// (<- BRUSH ':PAINT-AREA-Y-SIZE) 2))) (SETQ BRUSH-HIGH-Y (- (SCREEN-Y2 TV-DEFAULT-SCREEN) TEM)) (COND ((NULL (BOUNDP 'BRUSH-CURSOR-ARRAY)) (SETQ BRUSH-CURSOR-ARRAY (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-1B '(40 40))) ;ART-1B ; (SETQ BRUSH-CURSOR-WD-ARRAY ; (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-16B '(100) BRUSH-CURSOR-ARRAY)) ;32. ROWS BY 32. BITS )) ; (DO Y 0 (1+ Y) (= Y 40) ; (DO X 0 (1+ X) (= X 40) ; (AS-2 (COND ((OR (NOT (< X (CADDR BRUSH))) ; (NOT (< Y (CADDDR BRUSH)))) ; 0) ; (T (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) ; (+ (CAR BRUSH) X) (+ (CADR BRUSH) Y)))) ; BRUSH-CURSOR-ARRAY ; X ; Y))) (<- BRUSH ':COPY-TO-BUFFER) ; (SETQ BRUSH-CURSOR (LIST 0 0 (COND ((< (CADDR BRUSH) 40) (CADDR BRUSH)) ; (T 40)) ; (COND ((< (CADDDR BRUSH) 40) (CADDDR BRUSH)) ; (T 40)))) (SETQ BRUSH-CURSOR (<- PAINT-AREA-CLASS ':NEW 'PAINT-AREA-ARRAY BRUSH-CURSOR-ARRAY 'PAINT-AREA-X 0 'PAINT-AREA-Y 0 'PAINT-AREA-X-SIZE (MIN 40 (<- BRUSH ':PAINT-AREA-X-SIZE)) 'PAINT-AREA-Y-SIZE (MIN 40 (<- BRUSH ':PAINT-AREA-Y-SIZE)))) ) (DEFUN BRUSH-CLEAR NIL (COND (BRUSH-PHASE (BRUSH-BLINK)))) (DEFUN BRUSH-BLINK (&OPTIONAL X Y) ;X AND Y BETTER BE GIVEN EXCEPT FROM BRUSH-CLEAR (COND (BRUSH-PHASE (SETQ BRUSH-PHASE NIL)) (T (SETQ BRUSH-CURSOR-X X BRUSH-CURSOR-Y Y BRUSH-PHASE T))) ; (BRUSH-XOR BRUSH-CURSOR BRUSH-CURSOR-ARRAY BRUSH-CURSOR-X BRUSH-CURSOR-Y) (<- BRUSH-CURSOR ':COPY-FROM-BUFFER-CENTERED (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) BRUSH-CURSOR-X BRUSH-CURSOR-Y TV-ALU-XOR)) ;(DEFUN BRUSH-XOR (BW BH BRUSH-ARRAY X0 Y0) ; (SETQ X0 (- X0 (// BW 2)) ; Y0 (- Y0 (// BH 2))) ; (BITBLT TV-ALU-XOR BW BH ; BRUSH-ARRAY 0 0 ; (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) X0 Y0)) ;(DEFUN BRUSH-XOR (BRUSH BRUSH-ARRAY X0 Y0) ; (PROG (B-IIDX B-IDX B-OVER B-IBC B-BC B-YC ;B-IOVER IS 0 ; PICT-IIDX PICT-IDX PICT-IOVER PICT-OVER PICT-TEM PICT-FIELD ; BITS BRUSH-WD PICT-WD BUFFER-WORDS SCREEN-LINE-LOCATIONS) ; (SETQ SCREEN-LINE-LOCATIONS (* 2 (SCREEN-LOCATIONS-PER-LINE TV-DEFAULT-SCREEN))) ; (SETQ BUFFER-WORDS (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN)) ; (SETQ B-IIDX 0) ; (SETQ B-IBC (CADDR BRUSH)) ; (SETQ B-YC (CADDDR BRUSH)) ; ; (SETQ X0 (- X0 (// B-IBC 2)) ; Y0 (- Y0 (// B-YC 2))) ; ; (SETQ PICT-IIDX (+ (LSH X0 -4) (* Y0 SCREEN-LINE-LOCATIONS))) ; (SETQ PICT-IOVER (LOGAND X0 17)) ; ; XL (SETQ B-IDX B-IIDX PICT-IDX PICT-IIDX B-OVER 0 ; PICT-OVER PICT-IOVER B-BC B-IBC) ; L (SETQ BITS (MIN (- 20 (MAX B-OVER PICT-OVER)) B-BC)) ; (SETQ BRUSH-WD (LDB (+ (LSH B-OVER 6) ; BITS) ; (AR-1 BRUSH-ARRAY B-IDX))) ; (SETQ PICT-WD (LDB (SETQ PICT-FIELD ; (+ (LSH PICT-OVER 6) ; BITS)) ; (SETQ PICT-TEM (AR-1 BUFFER-WORDS PICT-IDX)))) ; (SETQ PICT-WD (LOGXOR PICT-WD BRUSH-WD)) ; (AS-1 (DPB PICT-WD PICT-FIELD PICT-TEM) BUFFER-WORDS PICT-IDX) ; (COND ((ZEROP (SETQ B-BC (- B-BC BITS))) ; (COND ((ZEROP (SETQ B-YC (1- B-YC))) ; (RETURN T)) ; (T (SETQ B-IIDX (+ B-IIDX 2) ; PICT-IIDX (+ PICT-IIDX SCREEN-LINE-LOCATIONS)) ; (GO XL))))) ; (COND ((>= (SETQ B-OVER (+ B-OVER BITS)) 20) ; (SETQ B-OVER 0 B-IDX (1+ B-IDX)))) ; (COND ((>= (SETQ PICT-OVER (+ PICT-OVER BITS)) 20) ; (SETQ PICT-OVER 0 PICT-IDX (1+ PICT-IDX)))) ; (GO L) ;)) ;(DEFUN BRUSH-XOR (BRUSH BRUSH-ARRAY X0 Y0) ; (PROG (PX PY BX BY BXL BYL) ; (SETQ PY (- Y0 (// (CADDDR BRUSH) 2)) ; BY (CADR BRUSH) ; BYL (+ BY (CADDDR BRUSH))) ; L (COND ((NOT (< BY BYL)) ; (RETURN T))) ; (SETQ PX (- X0 (// (CADDR BRUSH) 2)) ; BX (CAR BRUSH) ; BXL (+ BX (CADDR BRUSH))) ; L1 (COND ((NOT (< BX BXL)) ; (SETQ BY (1+ BY)) ; (SETQ PY (1+ PY)) ; (GO L))) ; (COND ((NOT (= 0 (AR-2 BRUSH-ARRAY BX BY))) ; (AS-2 (LOGXOR (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) PX PY) 1) ; (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) ; PX ; PY))) ; (SETQ PX (1+ PX) ; BX (1+ BX)) ; (GO L1))) ;(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE ; &AUX BUFFER-PIXELS) ; (SETQ BUFFER-PIXELS (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)) ;;COPY BRUSH TO BRUSH-BUFFER-ARRAY ; (<- BRUSH ':COPY-TO-BUFFER) ;;CLEAR OUT BRUSH REGION IN PICTURE ; (<- BRUSH ':COPY-FROM-BUFFER-CENTERED BUFFER-PIXELS X0 Y0 TV-ALU-ANDCA) ;;COMBINE PAINT WITH BRUSH-BUFFER ;) (DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE &AUX BW BH BBA BUFFER-PIXELS ZX ZY ZXW ZYW ZXD ZYD PBA PAINT-X PAINT-Y) (SETQ BBA (<- BRUSH ':PAINT-AREA-BUFFER-ARRAY)) (SETQ BW (<- BRUSH ':PAINT-AREA-X-SIZE)) (SETQ BH (<- BRUSH ':PAINT-AREA-Y-SIZE)) (SETQ BUFFER-PIXELS (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN)) (SETQ X0 (- X0 (// BW 2)) Y0 (- Y0 (// BH 2))) ;COPY BRUSH TO BRUSH-BUFFER-ARRAY (<- BRUSH ':COPY-TO-BUFFER) ;CLEAR BRUSH REGION IN PICTURE (COND ((NULL XOR-MODE) (BITBLT TV-ALU-ANDCA BW BH BBA 0 0 BUFFER-PIXELS X0 Y0) ;COMBINE PAINT WITH BRUSH-BUFFER, RESULT TO BRUSH-BUFFER (SETQ ZX (<- PAINT ':PAINT-AREA-X) ;FIGURE OUT PAINT PHASE, ETC. ZY (<- PAINT ':PAINT-AREA-Y) ZXW (<- PAINT ':PAINT-AREA-X-SIZE) ZYW (<- PAINT ':PAINT-AREA-Y-SIZE) ZXD (- ZXW (\ ZX ZXW)) ;PHASE OF PAINT ORIGIN ZYD (- ZYW (\ ZY ZYW)) PBA (<- PAINT ':PAINT-AREA-BUFFER-ARRAY)) (SETQ PAINT-X (\ (+ X0 ZXD) ZXW)) ;COMPUTE PAINT RELATIVE X-COORD OF FIRST BIT (SETQ PAINT-Y (\ (+ Y0 ZYD) ZYW)) ;LIKEWISE Y (BITBLT TV-ALU-AND BW BH PBA PAINT-X PAINT-Y BBA 0 0) ;IOR BRUSH-BUFFER TO PICTURE (BITBLT TV-ALU-IOR BW BH BBA 0 0 BUFFER-PIXELS X0 Y0)) (T (BITBLT TV-ALU-XOR BW BH BBA 0 0 BUFFER-PIXELS X0 Y0))) ) ;(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE) ; (PROG (B-IIDX B-IDX B-IOVER B-OVER B-IBC B-BC B-YC ; PAINT-IIDX PAINT-IDX PAINT-IOVER PAINT-OVER PAINT-IXBC PAINT-XBC PAINT-YBC ; PAINT-X PAINT-Y ; ZX ZY ZXW ZYW ZXD ZYD ; PICT-IIDX PICT-IDX PICT-IOVER PICT-OVER PICT-TEM PICT-FIELD ; BITS BRUSH-WD PAINT-WD PICT-WD BUFFER-WORDS SCREEN-LINE-LOCATIONS) ; (SETQ BUFFER-WORDS (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN)) ; (SETQ SCREEN-LINE-LOCATIONS (* 2 (SCREEN-LOCATIONS-PER-LINE TV-DEFAULT-SCREEN))) ; ;XXX-IDX IS A WORD INDEX INTO THE TV-BUFFER FOR XXX. ; ;XXX-IIDX IS THE VALUE OF XXX-IDX AT START OF CURRENT X-LINE. INCREMENT BY ; ;(* 2 (SCREEN-LOCATIONS-PER-LINE TV-DEFAULT-SCREEN)) TIMES TWO BECAUSE TWO ARRAY ENTRIES ; ; PER MEMORY WORD. ; ; (# VIDEO BUFFER WDS IN X LINE) WHEN STARTING NEW X-LINE. ; ;XXX-OVER IS HOW MANY BITS OVER WITHIN THAT WORD XXX IS. THUS XXX-OVER CAN VARY FROM ; ; 0 IF ALL 16. BITS ARE ACTIVE TO 17 IF ONLY ONE BIT IS. NOTE THIS ACTUALLY POINTS ; ; "AT" OF THE ACTIVE BIT, READY TO GOBBLE IT ON DIRECTLY ; ; (UNLIKE SIMILAR TO PDP-10 ILDB INSTRUCTION). ; ;XXX-IOVER IS VALUE OF XXX-OVER AT START OF X-LINE. ; ;XXX-BC IS BIT COUNT OF BITS REMAINING IN XXX IN CURRENT X-LINE. ;; BITS IS SET TO THE MINIMUM OF ;; 1- NUMBER OF BRUSH BITS REMAINING IN CURRENT X-LINE. ;; 2- NUMBER OF BRUSH BITS IN CURRENT BRUSH WD. ;; 3- NUMBER OF PAINT BITS REMAINING ALTOGETHER (BEFORE X WRAP REQD). ;; 4- NUMBER OF PAINT BITS IN CURRENT PAINT WD. ;; 5- NUMBER OF PICTURE BITS IN CURRENT PICTURE WD. ;; THEN THIS NUMBER OF BITS ARE PROCESSED. (NOTE THAT NO WORD BOUNDARIES CAN BE ;; CROSSED IN ANY OF THE BRUSH, PAINT OR PICTURE). ;; THEN ALL THE POINTERS ARE INCREMENTED BY BITS, AND ANOTHER LOOP MADE, IF NECC, ETC. ; ; (SETQ B-IIDX (+ (LSH (CAR BRUSH) -4) (* (CADR BRUSH) SCREEN-LINE-LOCATIONS))) ; (SETQ B-IOVER (LOGAND (CAR BRUSH) 17)) ; (SETQ B-IBC (CADDR BRUSH)) ; (SETQ B-YC (CADDDR BRUSH)) ;COUNT OF Y-LINES ; ; (SETQ X0 (- X0 (// B-IBC 2)) ;MOVE FROM CENTER OF BRUSH TO UPPER LEFT ; Y0 (- Y0 (// B-YC 2))) ; ; (SETQ ZX (CAR PAINT) ;FIGURE OUT PAINT PHASE, ETC. ; ZY (CADR PAINT) ; ZXW (CADDR PAINT) ; ZYW (CADDDR PAINT) ; ZXD (- ZXW (\ ZX ZXW)) ;PHASE OF PAINT ORIGIN ; ZYD (- ZYW (\ ZY ZYW))) ; ; (SETQ PAINT-X (\ (+ X0 ZXD) ZXW)) ;COMPUTE PAINT RELATIVE X-COORD OF FIRST BIT ; (SETQ PAINT-IXBC (- ZXW PAINT-X)) ;THIS MANY BITS AVAIL BEFORE MUST WRAP ; (SETQ PAINT-Y (\ (+ Y0 ZYD) ZYW)) ;LIKEWISE Y ; (SETQ PAINT-YBC (- ZYW PAINT-Y)) ; ; (SETQ PAINT-IIDX (+ (LSH (+ PAINT-X ZX) -4) (* (+ PAINT-Y ZY) ; SCREEN-LINE-LOCATIONS))) ; (SETQ PAINT-IOVER (LOGAND (+ PAINT-X ZX) 17)) ; ; (SETQ PICT-IIDX (+ (LSH X0 -4) (* Y0 SCREEN-LINE-LOCATIONS))) ; (SETQ PICT-IOVER (LOGAND X0 17)) ; ; XL (SETQ B-IDX B-IIDX PAINT-IDX PAINT-IIDX PICT-IDX PICT-IIDX ;START NEW X-LINE ; B-OVER B-IOVER PAINT-OVER PAINT-IOVER PICT-OVER PICT-IOVER ; PAINT-XBC PAINT-IXBC B-BC B-IBC) ; L (SETQ BITS (MIN (- 20 (MAX B-OVER PAINT-OVER PICT-OVER)) PAINT-XBC B-BC)) ; (SETQ BRUSH-WD (LDB (+ (LSH B-OVER 6) ; BITS) ; (AR-1 BUFFER-WORDS B-IDX))) ; (SETQ PAINT-WD (LDB (+ (LSH PAINT-OVER 6) ; BITS) ; (AR-1 BUFFER-WORDS PAINT-IDX))) ; (SETQ PICT-WD (LDB (SETQ PICT-FIELD ; (+ (LSH PICT-OVER 6) ; BITS)) ; (SETQ PICT-TEM (AR-1 BUFFER-WORDS PICT-IDX)))) ; (SETQ PAINT-WD (LOGAND PAINT-WD BRUSH-WD)) ; (SETQ PICT-WD (COND (XOR-MODE (LOGXOR PICT-WD BRUSH-WD)) ; (T (LOGIOR (LOGAND PICT-WD (LOGXOR -1 BRUSH-WD)) ; PAINT-WD)))) ; (AS-1 (DPB PICT-WD PICT-FIELD PICT-TEM) BUFFER-WORDS PICT-IDX) ; (COND ((ZEROP (SETQ B-BC (- B-BC BITS))) ;THRU WITH BRUSH IN X DIRECTION ; (COND ((ZEROP (SETQ B-YC (1- B-YC))) ; (RETURN T)) ;THRU IN Y, TOO. ; (T (SETQ PAINT-IIDX (+ PAINT-IIDX SCREEN-LINE-LOCATIONS) ; B-IIDX (+ B-IIDX SCREEN-LINE-LOCATIONS) ; PICT-IIDX (+ PICT-IIDX SCREEN-LINE-LOCATIONS) ) ; (COND ((ZEROP (SETQ PAINT-YBC (1- PAINT-YBC))) ;WRAP PAINT IN Y ; (SETQ PAINT-YBC ZYW) ; DIRECTION ; (SETQ PAINT-IIDX (- PAINT-IIDX ; (* SCREEN-LINE-LOCATIONS ZYW))))) ; (GO XL))) )) ; (COND ((ZEROP (SETQ PAINT-XBC (- PAINT-XBC BITS))) ; (SETQ PAINT-XBC ZXW) ; (SETQ PAINT-OVER (LOGAND ZX 17)) ; (SETQ PAINT-IDX (+ (LSH ZX -4) ; (* SCREEN-LINE-LOCATIONS ; (// PAINT-IDX SCREEN-LINE-LOCATIONS))))) ;SAME Y LINE AS BEFORE ; ((>= (SETQ PAINT-OVER (+ PAINT-OVER BITS)) 20) ; (SETQ PAINT-OVER 0 PAINT-IDX (1+ PAINT-IDX)))) ; (COND ((>= (SETQ B-OVER (+ B-OVER BITS)) 20) ; (SETQ B-OVER 0 B-IDX (1+ B-IDX)))) ; (COND ((>= (SETQ PICT-OVER (+ PICT-OVER BITS)) 20) ; (SETQ PICT-OVER 0 PICT-IDX (1+ PICT-IDX)))) ; (GO L) )) ;(DEFUN BRUSH-PAINT (BRUSH PAINT X0 Y0 &OPTIONAL XOR-MODE) ; (PROG (PX PY BX BY BXL BYL ZX ZY ZXW ZYW ZXD ZYD PB) ; (SETQ ZX (CAR PAINT) ; ZY (CADR PAINT) ; ZXW (CADDR PAINT) ; ZYW (CADDDR PAINT) ; ZXD (- ZXW (\ ZX ZXW)) ;THESE VARIABLES ARE SO THAT IF THE PAINT ITSELF ; ZYD (- ZYW (\ ZY ZYW))) ; IS PAINTED OVER, EACH BIT IS EXACTLY PAINTED ; ;OVER WITH ITSELF. THIS ASSURES THE PAINT IS UNCHANGED AND ALSO ; ;THAT WALL-PAPER PATTERNS "LINE UP" ; (SETQ PY (- Y0 (// (CADDDR BRUSH) 2)) ; BY (CADR BRUSH) ; BYL (+ BY (CADDDR BRUSH))) ; L (COND ((NOT (< BY BYL)) ; (RETURN T))) ; (SETQ PX (- X0 (// (CADDR BRUSH) 2)) ; BX (CAR BRUSH) ; BXL (+ BX (CADDR BRUSH))) ; L1 (COND ((NOT (< BX BXL)) ; (SETQ BY (1+ BY)) ; (SETQ PY (1+ PY)) ; (GO L))) ; (SETQ PB (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) ; (+ ZX (\ (+ PX ZXD) ZXW)) ; (+ ZY (\ (+ PY ZYD) ZYW)))) ; (COND ((NOT (= 0 (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) BX BY))) ; (AS-2 (COND (XOR-MODE (LOGXOR 1 (AR-2 (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) PX PY))) ; (T PB)) ; (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) PX PY))) ; (SETQ PX (1+ PX) ; BX (1+ BX)) ; (GO L1))) (DEFUN INIT-PAINT (X0 Y0 PATTERN-LIST &OPTIONAL (ARY (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN))) (PROG (X Y XL YL PAT COUNT) (SETQ Y Y0 XL (+ X0 40) YL (+ Y0 40) PAT PATTERN-LIST) L (COND ((NOT (< Y YL)) ; (RETURN (LIST X0 Y0 40 40)) (RETURN (<- PAINT-AREA-CLASS ':NEW 'PAINT-AREA-ARRAY ARY 'PAINT-AREA-X X0 'PAINT-AREA-Y Y0 'PAINT-AREA-X-SIZE 40 'PAINT-AREA-Y-SIZE 40)))) (SETQ X X0 COUNT -3) XL (AS-2 (LSH (CAR PAT) COUNT) ARY X Y) (COND ((NOT (< X XL)) (SETQ Y (1+ Y)) (COND ((NULL (SETQ PAT (CDR PAT))) (SETQ PAT PATTERN-LIST))) (GO L))) (SETQ X (1+ X)) (COND ((> (SETQ COUNT (1+ COUNT)) 0) (SETQ COUNT -3))) (GO XL))) (DEFUN INIT-PAINTS NIL (PROG ((X 0) (Y 10) (PL '((0 0 0 0) (1 0 0 4) (2 10 2 10) (1 12 2 14) (5 12 5 12) (16 5 15 3) (15 7 15 7) (16 17 17 13) (17 17 17 17))) (BL '((600 600 600 600 600 600 600 600 600 600 600 600 600 600 600 600) (0 0 0 0 0 0 0 177777 177777 0 0 0 0 0 0 0) (177777 177777 177777 177777 177777 177777 177777 177777 177777 177777 177777 177777 177777 177777 177777 177777) (0 0 0 0 7760 7760 7760 7760 7760 7760 7760 7760 0 0 0 0) (600 3740 17770 37774 37774 77776 77776 177777 177777 77776 77776 37774 37774 17770 3740 600) (0 0 0 0 1700 3740 7760 7760 7760 7760 3740 1700 0 0 0 0) (0 0 0 0 0 0 200 200 200 200 0 0 0 0 0 0) (0 0 0 0 0 0 0 1700 0 0 0 0 0 0 0 0))) (COUNT 0)) (TV-SELECT-SCREEN TV-DEFAULT-SCREEN) (TV-ERASE (SCREEN-WIDTH TV-DEFAULT-SCREEN) 50 0 0 TV-ALU-ANDCA) (SETQ PAINT-AREA-Y 50) ;MAX Y OF MAIN PAINT AREA (SETQ PAINT-LIST NIL) L (COND ((NULL PL) (SETQ PAINT-AREA-X X) ;MAX X OF MAIN PAINT AREA (SETQ X (+ X 40)) (SETQ COUNT 0) (GO L1))) (SETQ PAINT-LIST (CONS (INIT-PAINT X Y (CAR PL)) PAINT-LIST)) (COND ((= COUNT 0) ;ERASING PAINT (SETQ ALTERNATE-PAINT (CAR PAINT-LIST)) (<- ALTERNATE-PAINT ':COPY-TO-BUFFER)) ((= COUNT 4) ;INITIAL PAINT (SETQ PAINT (CAR PAINT-LIST)) (<- PAINT ':COPY-TO-BUFFER))) (SETQ X (+ X 42) PL (CDR PL)) (SETQ COUNT (1+ COUNT)) (GO L) L1 (COND ((NULL BL) (RETURN T))) (SETQ PAINT-LIST (CONS (INIT-BRUSH X (+ Y 10) (CAR BL)) PAINT-LIST)) (COND ((= COUNT 3) (SELECT-BRUSH (CAR PAINT-LIST)))) (SETQ X (+ X 24) BL (CDR BL)) (SETQ COUNT (1+ COUNT)) (GO L1))) ;(DEFUN PAINT-SELECT-ARRAY (X Y) ; (PROG (TEM) ; (SETQ TEM PAINT-LIST) ; L (COND ((NULL TEM) (RETURN NIL)) ; ((AND (< (CAAR TEM) X) ; (< (CADAR TEM) Y) ; (< X (+ (CAAR TEM) (CADDAR TEM))) ; (< Y (+ (CADAR TEM) (CAR (CDDDAR TEM))))) ; (RETURN (CAR TEM)))) ; (SETQ TEM (CDR TEM)) ; (GO L))) (DEFUN PAINT-SELECT-ARRAY (X Y &OPTIONAL (ARY (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN))) (DO ((P PAINT-LIST (CDR P))) ((NULL P)) (COND ((<- (CAR P) ':INSIDE-P ARY X Y) (RETURN (CAR P)))))) (DEFUN INIT-BRUSH (X0 Y0 PATTERN-LIST &OPTIONAL (ARY (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN))) (PROG (X Y XL YL PAT COUNT) (SETQ Y Y0 XL (+ X0 20) YL (+ Y0 20) PAT PATTERN-LIST) L (COND ((NOT (< Y YL)) ; (RETURN (LIST X0 Y0 20 20)) (RETURN (<- PAINT-AREA-CLASS ':NEW 'PAINT-AREA-ARRAY ARY 'PAINT-AREA-X X0 'PAINT-AREA-Y Y0 'PAINT-AREA-X-SIZE 20 'PAINT-AREA-Y-SIZE 20)))) (SETQ X X0 COUNT -17) XL (AS-2 (LSH (CAR PAT) COUNT) (SCREEN-BUFFER-PIXEL-ARRAY TV-DEFAULT-SCREEN) X Y) (COND ((NOT (< X XL)) (SETQ Y (1+ Y)) (SETQ PAT (CDR PAT)) (GO L))) (SETQ X (1+ X)) (SETQ COUNT (1+ COUNT)) (GO XL))) (DEFPROP SAVE-SCREEN PAINT-COM-SAVE-SCREEN PAINT-COMMAND) (DEFUN PAINT-COM-SAVE-SCREEN NIL (SAVE-SCREEN)) (DEFUN SAVE-SCREEN NIL (COND ((NULL (BOUNDP 'PAINT-SAVED-SCREEN)) (SETQ PAINT-SAVED-SCREEN (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-16B (ARRAY-DIMENSION-N 1 (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN)))))) (COPY-ARRAY-1 (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN) PAINT-SAVED-SCREEN)) (DEFPROP RESTORE-SCREEN PAINT-COM-RESTORE-SCREEN PAINT-COMMAND) (DEFUN PAINT-COM-RESTORE-SCREEN NIL (RESTORE-SCREEN)) (DEFUN RESTORE-SCREEN NIL (COND ((NULL (BOUNDP 'PAINT-SAVED-SCREEN)) NIL) (T (COPY-ARRAY-1 PAINT-SAVED-SCREEN (SCREEN-BUFFER-HALFWORD-ARRAY TV-DEFAULT-SCREEN))))) (DEFPROP DRAW-LINES-AND-CIRCLES PAINT-COM-DRAW-LINES-AND-CIRCLES PAINT-COMMAND) (DEFPROP DRAW-LINES-AND-CIRCLES PAINT-COM-DLC-ENTER PAINT-ENTERING-FCTN) (DEFPROP DRAW-LINES-AND-CIRCLES PAINT-COM-DLC-LEAVE PAINT-LEAVING-FCTN) (DEFPROP DRAW-LINES-AND-CIRCLES T PAINT-DISPATCH-ALWAYS) (DEFPROP DRAW-LINES-AND-CIRCLES 300 PAINT-CLOCK-RATE) (DEFUN PAINT-COM-DLC-ENTER NIL (SETQ PAINT-DLC-STATE 'SET-BASEPOINT) (SETQ PAINT-DLC-MODE 'LINE)) (DEFUN PAINT-COM-DRAW-LINES-AND-CIRCLES NIL (COND (MOUSE-MID-SWITCH (PAINT-DLC-ADVANCE) (SETQ MOUSE-MIDSW-HOLD T)) (T (PAINT-DLC-BLINK))) (COND ((AND MOUSE-BOT-SWITCH (NULL MOUSE-BOTSW-HOLD)) (PAINT-DLC-ALTER) (SETQ MOUSE-BOTSW-HOLD T)))) (DEFUN PAINT-DLC-ADVANCE NIL (COND ((EQ PAINT-DLC-STATE 'SET-BASEPOINT) (SETQ PAINT-DLC-BASE-X MOUSE-X) (SETQ PAINT-DLC-BASE-Y MOUSE-Y) (SETQ PAINT-SUBC-PHASE NIL) (SETQ PAINT-DLC-STATE (COND ((EQ PAINT-DLC-MODE 'LINE) 'RUBBER-BAND) ((EQ PAINT-DLC-MODE 'CIRCLE) 'RUBBER-CIRCLE)))) ((MEMQ PAINT-DLC-STATE '(RUBBER-BAND RUBBER-CIRCLE)) (COND (PAINT-SUBC-X (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND) (DRAW-ABSOLUTE-VECTOR-RASTER-COORDS PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y 'IOR)) ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE) (DRAW-ABSOLUTE-CIRCLE-RASTER-COORDS PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y 'IOR))) (SETQ PAINT-SUBC-X NIL))) (SETQ PAINT-SUBC-PHASE NIL) (SETQ PAINT-DLC-STATE 'SET-BASEPOINT)))) (DEFUN PAINT-DLC-BLINK NIL (COND ((NULL PAINT-SUBC-PHASE) (PAINT-DLC-SET)) (T (PAINT-DLC-CLEAR)))) (DEFUN PAINT-DLC-SET NIL (COND ((NULL PAINT-SUBC-PHASE) (SETQ PAINT-SUBC-X MOUSE-X PAINT-SUBC-Y MOUSE-Y) (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND) (DRAW-ABSOLUTE-VECTOR-RASTER-COORDS PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y 'XOR)) ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE) (DRAW-ABSOLUTE-CIRCLE-RASTER-COORDS PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y 'XOR))) (SETQ PAINT-SUBC-PHASE T)))) (DEFUN PAINT-DLC-CLEAR NIL (COND (PAINT-SUBC-PHASE (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND) (DRAW-ABSOLUTE-VECTOR-RASTER-COORDS PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y 'XOR)) ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE) (DRAW-ABSOLUTE-CIRCLE-RASTER-COORDS PAINT-DLC-BASE-X PAINT-DLC-BASE-Y PAINT-SUBC-X PAINT-SUBC-Y 'XOR))) (SETQ PAINT-SUBC-PHASE NIL)))) (DEFUN PAINT-DLC-ALTER NIL (PAINT-DLC-CLEAR) (SETQ PAINT-DLC-MODE (COND ((EQ PAINT-DLC-MODE 'LINE) 'CIRCLE) (T 'LINE))) (COND ((EQ PAINT-DLC-STATE 'RUBBER-BAND) (SETQ PAINT-DLC-STATE 'RUBBER-CIRCLE)) ((EQ PAINT-DLC-STATE 'RUBBER-CIRCLE) (SETQ PAINT-DLC-STATE 'RUBBER-BAND)))) (DEFUN PAINT-COM-DLC-LEAVE NIL NIL) (DEFUN COPY-ARRAY-1 (FROM TO) (PROG (LIM LIM2) (COND ((< (SETQ LIM2 (ARRAY-LENGTH FROM)) (SETQ LIM (ARRAY-LENGTH TO))) (SETQ LIM LIM2))) (DO I (1- LIM) (1- I) (= I 0) (AS-1 (AR-1 FROM I) TO I)))) (DEFPROP EXIT PAINT-COM-EXIT PAINT-COMMAND) (DEFPROP EXIT PAINT-COM-EXIT PAINT-ENTERING-FCTN) ;REALLY TRY TO GET THERE (DEFPROP EXIT T PAINT-DISPATCH-ALWAYS) (DEFPROP EXIT 1 PAINT-CLOCK-RATE) (DEFUN PAINT-COM-EXIT NIL (SETQ PAINT-EXIT-FLAG T)) (DEFPROP TEXT PAINT-COM-TEXT-ENTER PAINT-ENTERING-FCTN) (DEFPROP TEXT PAINT-COM-TEXT PAINT-COMMAND) (DEFPROP TEXT PAINT-COM-TEXT-LEAVE PAINT-LEAVING-FCTN) (DEFPROP TEXT T PAINT-DISPATCH-ALWAYS) (DEFPROP TEXT 300 PAINT-CLOCK-RATE) (DEFUN PAINT-COM-TEXT-ENTER NIL (SETQ PAINT-TEXT-HOLDING-STRING (MAKE-ARRAY DEFAULT-ARRAY-AREA 'ART-STRING 50 NIL '(0)))) (DEFUN PAINT-COM-TEXT (&AUX TEM) (COND (MOUSE-MID-SWITCH (PAINT-TEXT-ADVANCE) (SETQ MOUSE-MIDSW-HOLD T)) (T (PAINT-TEXT-BLINK))) (COND ((AND MOUSE-BOT-SWITCH (NULL MOUSE-BOTSW-HOLD) PAINT-SUBC-X (NOT (ZEROP (ARRAY-ACTIVE-LENGTH PAINT-ARG-STRING))) (BOUNDP (SETQ TEM (INTERN PAINT-ARG-STRING))) (ARRAYP (SYMEVAL TEM))) (SETQ PAINT-TEXT-FONT (SYMEVAL TEM)) (PAINT-TEXT-CLEAR) (SETQ PAINT-SUBC-X NIL) (STORE-ARRAY-LEADER 0 PAINT-ARG-STRING 0) ))) (DEFUN PAINT-TEXT-ADVANCE NIL (COND (PAINT-SUBC-X (PAINT-TEXT-SET) (STORE-ARRAY-LEADER 0 PAINT-ARG-STRING 0) ;RESET STRING ARG (SETQ PAINT-SUBC-X NIL) (SETQ PAINT-SUBC-PHASE NIL)))) (DEFUN PAINT-COM-TEXT-LEAVE NIL (RETURN-ARRAY PAINT-TEXT-HOLDING-STRING)) (DEFUN PAINT-TEXT-BLINK NIL (COND ((NULL PAINT-SUBC-PHASE) (PAINT-TEXT-SET)) (T (PAINT-TEXT-CLEAR)))) (DEFUN PAINT-TEXT-SET NIL (COND ((NULL PAINT-SUBC-PHASE) (SETQ PAINT-SUBC-X MOUSE-X PAINT-SUBC-Y MOUSE-Y) (COPY-ARRAY-CONTENTS-AND-LEADER PAINT-ARG-STRING PAINT-TEXT-HOLDING-STRING) (PAINT-TEXT-DRAW) (SETQ PAINT-SUBC-PHASE T)))) (DEFUN PAINT-TEXT-CLEAR NIL (COND (PAINT-SUBC-PHASE (PAINT-TEXT-DRAW) (SETQ PAINT-SUBC-PHASE NIL)))) (DEFUN PAINT-TEXT-DRAW NIL (TV-SET-CURSORPOS PAINT-LABELING-PC-PPR PAINT-SUBC-X PAINT-SUBC-Y) (TV-SET-FONT PAINT-LABELING-PC-PPR PAINT-TEXT-FONT) (TV-STRING-OUT PAINT-LABELING-PC-PPR PAINT-TEXT-HOLDING-STRING) )