;;; -*- Mode: Lisp; Package: Puser; Base: 10. ; -*-
;;; (c) 1980 Henry Lieberman, Massachusetts Institute of Technology


;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;           		Lisp Logo TV Turtle				      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;  -- for the Lisp Machine.
;; by HENRY.

;; Documentation: See AI Memo 307 on Lisp Logo, 
;; AI:LLOGO;LMTDOC for Lisp Machine version.

;; The only incompatible difference between this version and the MacLisp version, is that
;; the colon preceding global variables has been replaced by a star since 
;; the Lisp machine uses colon for packages.

;; Still to be implemented:
;; Brushes
;; Hard copy

;; (Color windows do not attempt to restore the palette, as they do in MacLisp.)

#-Symbolics ;;bug in System 93.
(cond ((eq 'eh-arg #'arg) (undefun 'arg)))

(DEFSYSTEM TVRTLE
	   (:NAME "Tvrtle")
	   (:PATHNAME-DEFAULT "LMP:LISP-LIBRARY;")
           (:MODULE SOURCE "LMT")
	   (:COMPILE-LOAD SOURCE)
	   )

(SSTATUS FEATURE TVRTLE) 

(DEFVAR NO-VALUE '?)


(DECLARE (SPECIAL *CLIP *DRAWSTATE *ERASERNUMBER *ERASERSTATE *HEADING
		  *PENCOLOR *ERASERNUMBER *PENSTATE *POLYGON *SEETURTLE *TURTLE *TURTLES
		  *WRAP *XCOR *XORSTATE *YCOR)
	 (SPECIAL SINE-HEADING COSINE-HEADING))

(EVAL-WHEN (EVAL COMPILE)
  (LOAD "LMP: LISP-LIBRARY; DEFINE")
  (defconst color (color:color-exists-p))
  (defconst bw (not color))
  (defconst s3600 (status feature 3600))
  (defconst debug-shade nil))

[COLOR (DEFUN NOT-IMPLEMENTED-IN-COLOR (LOSING-FORM)
              (PRINC '/;)
              (AND LOSING-FORM (PRINC LOSING-FORM))
              (PRINC '" NOT IMPLEMENTED IN COLOR TURTLE")
              (TERPRI)
              NO-VALUE)]

[BW (DEFUN NOT-IMPLEMENTED-IN-BW (LOSING-FORM)
           (PRINC '/;)
           (AND LOSING-FORM (PRINC LOSING-FORM))
           (PRINC '" IMPLEMENTED IN COLOR TURTLE ONLY")
           (TERPRI)
           NO-VALUE)]

(DEFMACRO TRANSFER-PIXELS ARGS `(SEND TVRTLE-WINDOW ':BITBLT . ,ARGS))


(DEFUN FUNCTION-PROP (F) (FBOUNDP F))
(DEFUN TYPE ARGS (DO ((I 1. (1+ I))) ((> I ARGS) (ARG (1- I))) (PRINC (ARG I))))
;;TYPE USED BY MARK, HOMCHECK, OBTERN OUTPUT BY DEFINE.
(DEFUN ERRBREAK ARGS
       (CERROR T NIL ':TVRTLE-ERROR
	       "Error in Tvrtle function ~S: ~A" (ARG 1.) (ARG 2.)))

(DEFINE DRAWMODE (MODE) (PROG1 *DRAWMODE (SETQ *DRAWMODE MODE)))

(let ((si:*all-free-interpreter-variable-references-special* T))
  (SETQ ANDC TV:ALU-ANDCA
	   ANDCA ANDC
	   XOR TV:ALU-XOR
	   IOR TV:ALU-IOR
	   SET TV:ALU-SETA
	   *DRAWMODE [BW IOR] [COLOR SET]))

(DEFUN TEMPORARY-PEN NIL
       [COLOR (SELECT-COLOR *PENNUMBER)]
       [BW (SETQ OLD-DRAWMODE *DRAWMODE) (DRAWMODE IOR)])

(DEFUN TEMPORARY-ERASER NIL
       [COLOR (SELECT-COLOR *ERASERNUMBER)]
       [BW (SETQ OLD-DRAWMODE *DRAWMODE) (DRAWMODE ANDC)])

(DEFUN TEMPORARY-XOR NIL
       [COLOR (SELECT-COLOR *PENNUMBER)]
       ;;Xor not implemented in color; assume pen instead.
       [BW (SETQ OLD-DRAWMODE *DRAWMODE) (DRAWMODE XOR)])

(DEFUN RESTORE-MODE NIL
       [COLOR (RESELECT-COLOR)]
       [BW (DRAWMODE OLD-DRAWMODE)])

[COLOR
 (DEFUN RESELECT-COLOR NIL 
	(SELECT-COLOR (COND (*ERASERSTATE *ERASERNUMBER) (*PENNUMBER))))
 (DEFUN SELECT-COLOR (COLOR-NUMBER) (SETQ *SELECTED-COLOR COLOR-NUMBER) T)]

(DEFUN INITIALIZE-PALETTE NIL 
       (SETQ COLOR-BITS [S3600 8.] [(NOT S3600) 4.] 
	     ;;Number of bits of color per point available.
	     COLOR-MAX (LSH 1. COLOR-BITS) 
	     ;;Number of distinct colors available.
	     INTENSITY-MAX [S3600 1023.0] [(NOT S3600) 255.0]
	     ;;Red, green, blue colors described on a scale to this number.
	     *COLORS NIL 
	     ;;Global list of colors.
             *NCOLORS 0.
             ;;Number of colors.
	     *PENCOLOR 'WHITE
	     ;;Current color.
	     *PENNUMBER 1.
	     ;;Current color for eraser, clearscreen.
	     *ERASERCOLOR 'BLACK 
	     *ERASERNUMBER 0.
             *COLORTICK 20.)
       (ARRAY PALETTE T COLOR-MAX)
       ;;Create the palette, set up initial pen and eraser colors.
       (PUTPROP NIL 0 'RED)
       (PUTPROP NIL 0 'BLUE)
       (PUTPROP NIL 0 'GREEN)
       (ERASERCOLOR (MAKECOLOR 'BLACK 0.0 0.0 0.0))
       (MAKEPALETTE *PENNUMBER (MAKECOLOR 'WHITE 1.0 1.0 1.0))
       ;;System supplied colors available.
       (MAKECOLOR 'LIGHTGRAY .75 .75 .75)
       (MAKECOLOR 'GOLD  1.0 .75 0.0)
       (MAKECOLOR 'BROWN 0.4 0.3 0.0)
       (MAKECOLOR 'PINK 1.0 0.5 0.5)
       (MAKECOLOR 'DARKGRAY .4 .4 .4)
       (MAKECOLOR 'GRAY .5 .5 .5)
       (MAKECOLOR 'ORANGE 1.0 0.5 0.0)
       (MAKECOLOR 'PURPLE 0.5 0.0 1.0)
       (MAKECOLOR 'CYAN 0.0 1.0 1.0)
       (MAKECOLOR 'MAGENTA 1.0 0.0 1.0)
       (MAKECOLOR 'YELLOW 1.0 1.0 0.0)
       (MAKECOLOR 'BLUE 0.0 0.0 1.0)
       (MAKECOLOR 'GREEN 0.0 1.0 0.0)
       (MAKECOLOR 'RED 1.0 0.0 0.0))
 

(DEFUN MAKECOLOR (COLOR-NAME RED GREEN BLUE) 
       ;;Arguments are atom naming the color, and red, green, and blue intensities,
       ;;as fractions between 0.0 and 1.0.
       (COND ((OR (< (SETQ RED (FLOAT RED)) 0.0) (> RED 1.0))
	      (SETQ RED (ERRBREAK 'MAKECOLOR (LIST RED '"SHOULD BE BETWEEN 0.0 AND 1.0")))))
       (COND ((OR (< (SETQ GREEN (FLOAT GREEN)) 0.0) (> GREEN 1.0))
	      (SETQ GREEN
		    (ERRBREAK 'MAKECOLOR (LIST GREEN '"SHOULD BE BETWEEN 0.0 AND 1.0")))))
       (COND ((OR (< (SETQ BLUE (FLOAT BLUE)) 0.0) (> BLUE 1.0))
	      (SETQ BLUE (ERRBREAK 'MAKECOLOR (LIST BLUE '"SHOULD BE BETWEEN 0.0 AND 1.0")))))
       (PUTPROP COLOR-NAME (ROUND (*$ RED INTENSITY-MAX)) 'RED)
       (PUTPROP COLOR-NAME (ROUND (*$ GREEN INTENSITY-MAX)) 'GREEN)
       (PUTPROP COLOR-NAME (ROUND (*$ BLUE INTENSITY-MAX)) 'BLUE)
       (COND ((MEMQ COLOR-NAME *COLORS))
	     (T (PUSH COLOR-NAME *COLORS) (INCREMENT *NCOLORS)))
       COLOR-NAME) 

(DEFUN ERASECOLOR (COLOR-NAME)
       (OR (GET COLOR-NAME 'RED) (ERRBREAK 'ERASECOLOR (LIST COLOR-NAME '"IS NOT A COLOR")))
       (DO I 0 (1+ I) (= I COLOR-MAX) 
	   (AND (EQ (AREF #'PALETTE I) COLOR-NAME)
		(ERRBREAK 'ERASECOLOR '"DON'T ERASE A COLOR ON THE PALETTE")))
       (MAPC '(LAMBDA (PROPERTY) (REMPROP COLOR-NAME PROPERTY)) '(RED BLUE GREEN))
       (DECREMENT *NCOLORS)
       (SETQ *COLORS (DELQ COLOR-NAME *COLORS))
       (LIST '/; COLOR-NAME '" ERASED"))
(FSET 'ERC 'ERASECOLOR)



(DEFINE REDPART (COLOR) 
	(LET ((RED-PROP (GET COLOR 'RED)))
	     (COND (RED-PROP (//$ (FLOAT RED-PROP) INTENSITY-MAX))
		   ((ERRBREAK 'REDPART (LIST COLOR '"IS NOT A COLOR")))))) 

(DEFINE GREENPART (COLOR) 
	(LET ((GREEN-PROP (GET COLOR 'GREEN)))
	     (COND (GREEN-PROP (//$ (FLOAT GREEN-PROP) INTENSITY-MAX))
		   ((ERRBREAK 'GREENPART (LIST COLOR '"IS NOT A COLOR")))))) 

(DEFINE BLUEPART (COLOR) 
	(LET ((BLUE-PROP (GET COLOR 'BLUE)))
	     (COND (BLUE-PROP (//$ (FLOAT BLUE-PROP) INTENSITY-MAX))
		   ((ERRBREAK 'BLUEPART (LIST COLOR '"IS NOT A COLOR")))))) 

 

(DEFUN PENCOLOR (COLOR-NAME) 
       ;;Selects a default color for the turtle to write in, etc.
       [COLOR (ERASE-TURTLE)]
       (COND ((FIXP COLOR-NAME)
	      ;;Selected by color map number.
	      (LET ((PALETTE-NAME (AREF #'PALETTE COLOR-NAME)))
		   (COND ((NULL PALETTE-NAME)
			  (ERRBREAK 'PENCOLOR (LIST COLOR-NAME '"IS NOT A COLOR NUMBER")))
			 ((SETQ *PENNUMBER COLOR-NAME *PENCOLOR PALETTE-NAME)))))
	     ((GET COLOR-NAME 'RED)
	      (LET ((COLOR-INDEX (INTERN-COLOR COLOR-NAME)))
		   ;;INTERN-COLOR returns index into color map, placing it there if not
		   ;;present.
		   (COND ((MINUSP COLOR-INDEX)
			  ;;Color not present in color map, and more places to put it.
			  (ERRBREAK 'PENCOLOR '"TOO MANY COLORS"))
			 ((SETQ *PENCOLOR COLOR-NAME *PENNUMBER COLOR-INDEX)))))
	     ((NULL *PENCOLOR) (PENCOLOR *ERASERNUMBER))
	     ((ERRBREAK 'PENCOLOR (LIST COLOR-NAME '"IS NOT A COLOR"))))
       [COLOR (RESELECT-COLOR)]
       [COLOR (DRAW-TURTLE)]
       COLOR-NAME)
(FSET 'PC 'PENCOLOR) 


(DEFINE MAKEPALETTE (COLOR-INDEX COLOR-NAME) 
        (COND ((= COLOR-INDEX *PENNUMBER) (SETQ *PENCOLOR COLOR-NAME))
              ;;If the color to be changed is that of the pen or eraser,
              ;;update the global variables appropriately.
              ((= COLOR-INDEX *ERASERNUMBER) (SETQ *ERASERCOLOR COLOR-NAME)))
	[COLOR (WRITE-COLOR-MAP COLOR-INDEX
    			        (GET COLOR-NAME 'RED)
			        (GET COLOR-NAME 'GREEN)
			        (GET COLOR-NAME 'BLUE))]
	(ASET COLOR-NAME #'PALETTE COLOR-INDEX))
(FSET 'MP 'MAKEPALETTE)

[COLOR (DEFUN WRITE-COLOR-MAP (SLOT RED GREEN BLUE)
	      (COLOR:WRITE-COLOR-MAP SLOT RED GREEN BLUE))]

 

(DEFUN INTERN-COLOR (COLOR-NAME) 
       ;;Finds first position in palette with specified color. If not in the color
       ;;map, it is inserted, and the index returned. Returns -1 if color map is
       ;;full.
       (COND ((EQ COLOR-NAME *ERASERCOLOR)
	      (MAKEPALETTE *ERASERNUMBER *ERASERCOLOR)
	      *ERASERNUMBER)
	     ;;ERASERCOLOR is always the last color.
             ((EQ COLOR-NAME *PENCOLOR) (MAKEPALETTE *PENNUMBER *PENCOLOR) *PENNUMBER)
	     ((DO ((COLOR-INDEX 0. (1+ COLOR-INDEX)))
		  ;;Already checked eraser color, stop at last pen color.
		  ((= COLOR-INDEX COLOR-MAX) -1.)
		  (COND ((EQ (AREF #'PALETTE COLOR-INDEX) COLOR-NAME) 
			 ;;Exhausted palette, couldn't insert it.
			 (MAKEPALETTE COLOR-INDEX COLOR-NAME)
			 (RETURN COLOR-INDEX))
			;;It was already there, return index.
			((NULL (AREF #'PALETTE COLOR-INDEX))
			 ;;Found a free place.
			 (MAKEPALETTE COLOR-INDEX COLOR-NAME)
			 (RETURN COLOR-INDEX))))))) 

;;There are two global default colors which the system keeps track of.  One is the
;;default color for drawing with the turtle, kept as the value of *PENCOLOR. The
;;other is a "background" color, *ERASERCOLOR.  CLEARSCREEN results in filling the
;;screen in the current background color.  The TV system also fills edges of the
;;picture with the background color.  It may also be used for eraser mode, drawing
;;in the same color as the background being supposed to erase whatever it writes
;;over.

(DEFINE ERASERCOLOR (ABB ERC ERASECOLOR) (COLOR-NAME) 
	;;Sets the background color, for CLEARSCREEN, eraser mode to the designated
	;;color.  It replaces the current background color.
	(MAKEPALETTE *ERASERNUMBER COLOR-NAME)
	COLOR-NAME) 

(DEFINE DELETECOLOR (ABB DC) (COLOR-NAME) 
 (LET
  ((COLOR-INDEX (INTERN-COLOR COLOR-NAME)))
  (COND ((EQ COLOR-NAME *PENCOLOR)
	 (ERRBREAK 'DELETECOLOR '"CAN'T ERASE CURRENT PEN COLOR"))
	((EQ COLOR-NAME *ERASERCOLOR)
	 (ERRBREAK 'DELETECOLOR '"CAN'T ERASE CURRENT ERASER COLOR"))
	((MINUSP COLOR-INDEX)
	 (ERRBREAK 'ERASECOLOR (LIST COLOR-NAME '"IS NOT A COLOR ON THE PALETTE")))
	;;Remove color, and mark place in palette as empty.
	(T (ASET NIL #'PALETTE COLOR-INDEX)
	   ;;Store background color into color map, thereby [probably] causing stuff
	   ;;on screen in deleted color to disappear.
	   [COLOR (WRITE-COLOR-MAP *ERASERNUMBER
				   (GET *ERASERCOLOR 'RED)
				   (GET *ERASERCOLOR 'GREEN)
				   (GET *ERASERCOLOR 'BLUE))])))) 

(DEFINE REPLACECOLOR (ABB RC) (OLD-COLOR NEW-COLOR) 
        ;;Changes the color map, replacing old color with new color.
        (DO ((COLOR-INDEX 0. (1+ COLOR-INDEX)))
            ((= COLOR-INDEX COLOR-MAX))
            (COND ((EQ (AREF #'PALETTE COLOR-INDEX) OLD-COLOR)
                   (MAKEPALETTE COLOR-INDEX NEW-COLOR))))
        NEW-COLOR)


;;*PAGE



(DEFINE TWIDDLECOLOR (ABB COLORTWIDDLE) NIL 
	;;Changes colors randomly in the color map every *COLORTICK seconds by
	;;replacing a random slot with a color chosen randomly from *COLORS.
	(TWIDDLEINIT)
	(DO NIL ((KBD-TYI-NO-HANG)) (TWIDDLEONCE) (PROCESS-SLEEP *COLORTICK))) 

;;RJL suggests this generate colors with random intensities as well.

(DEFINE RANDOMCOLOR NIL (NTH (RANDOM *NCOLORS) *COLORS))

(DEFUN TWIDDLEINIT NIL 
       (SETQ *NSLOTS (- (LENGTH (DELQ NIL (LISTARRAY 'PALETTE))) 1.))) 


(DEFUN TWIDDLEONCE NIL (MAKEPALETTE (1+ (RANDOM *NSLOTS)) (RANDOMCOLOR))) 

;;;
;;;(DEFUN TWIDDLEONCE NIL
;;;       (LET ((RANDOM-RED (RANDOM-BETWEEN 0. 511.))
;;;             (RANDOM-GREEN (RANDOM-BETWEEN 0. 511.))
;;;             (RANDOM-BLUE (RANDOM-BETWEEN 0. 511.))
;;;             (RANDOM-SLOT (RANDOM-BETWEEN 0 *NSLOTS)))
;;;            ;;THIS MESSES UP COLOR MAP, BUT....
;;;            (WRITE-COLOR-MAP RANDOM-SLOT RANDOM-RED RANDOM-GREEN RANDOM-BLUE)))
;;;

(DEFINE TWIDDLEREPEAT (TIMES) 
	(TWIDDLEINIT)
	(DO USELESS 0. (1+ USELESS) (= USELESS TIMES) (TWIDDLEONCE)))

(DEFINE FILLPALETTE NIL
        (DO ((COLORS *COLORS (CDR COLORS))
             (COLOR-INDEX 1. (1+ COLOR-INDEX))
             (COLOR))
            ((= COLOR-INDEX COLOR-MAX) (PENCOLOR 1.))
            (COND ((EQ (SETQ COLOR (CAR COLORS)) *ERASERCOLOR)
                   (POP COLORS)
                   (SETQ COLOR (CAR COLORS))))
            (MAKEPALETTE COLOR-INDEX COLOR)))


(let ((si:*all-free-interpreter-variable-references-special* T))
  (SETQ FLOATING-POINT-TOLERANCE 1.0E-3 
      TWICE-FLOATING-POINT-TOLERANCE (*$ 2.0 FLOATING-POINT-TOLERANCE) 
      *PI 3.1415926 
      PI-OVER-180 (//$ *PI 180.0) 
      *POLYGON 30.0 
      *ECHOLINES NIL 
      SINE-120 (SIN (*$ 120.0 PI-OVER-180)) 
      COSINE-120 (COS (*$ 120.0 PI-OVER-180)) 
      SINE-240 (SIN (*$ 240.0 PI-OVER-180)) 
      COSINE-240 (COS (*$ 240.0 PI-OVER-180)) 
      TV-PEN-RADIUS 3
      TV-TURTLE-FRONT-RADIUS 15.0 
      TV-TURTLE-SIDE-RADIUS 10.0 
      LESS-SUBR (FSYMEVAL '<)
      GREATER-SUBR (FSYMEVAL '>) 
      WINDOWFRAME-BOUNDS NIL 
      TURTLE-PROPERTIES 24.
      ;;Changing TURTLE-PROPERTIES also requires changing declarations
      ;;for HATCH-PROPERTY, TURTLE-PROPERTY below. 
      TURTLE-HOME-INDEX-X 0.
      ;;Indices of turtle's home in the turtle array.
      TURTLE-HOME-INDEX-Y 1.
      *SEETURTLE-INDEX 13.
      *WINDOWS NIL
      FIX-BITS 5.
      ;;Number of bits in fractional part.
      MINUS-FIX-BITS (- FIX-BITS)
      ;;Shift count for converting to ordinary integer.
      ;;One in fixed & float, mask for fractional part.
      UNIT-BIT (LSH 1. FIX-BITS)
      HALF-UNIT (LSH UNIT-BIT -1.)
      FLOAT-UNIT (FLOAT UNIT-BIT)
      UNIT-MASK (1- UNIT-BIT)
      *PENNUMBER 1.
      *ERASERNUMBER 0.
      INITIAL-TURTLE-PROPERTIES '(TV-PICTURE-CENTER-X TV-PICTURE-CENTER-Y
                                  *XCOR *YCOR *HEADING 
                                  SINE-HEADING COSINE-HEADING *PENSTATE *ERASERSTATE 
                                  *XORSTATE *DRAWSTATE *WRAP *CLIP *SEETURTLE *DRAWTURTLE
                                  *ERASETURTLE *PENCOLOR *PENNUMBER
                                  *BRUSH BRUSH-INFO BRUSH-PICTURE HORIZONTAL VERTICAL 
                                  *OFFSCREEN)
      HORIZONTAL-LINE-INDEX 21.
      VERTICAL-LINE-INDEX 22.))

(DEFUN INITIALIZE-TVRTLE-VARIABLES NIL
       (SETQ TVRTLE-SCREEN
	     [COLOR COLOR:COLOR-SCREEN]
	     [BW TV:DEFAULT-SCREEN]
	     TVRTLE-SCREEN-ARRAY
	     (SEND [BW (tv:sheet-get-screen tvrtle-window)]
		   [COLOR TVRTLE-SCREEN]
		   ':SCREEN-ARRAY)
	     ;; Used by MAKEWINDOW for BITBLT.
	     SCREEN-ARRAY-TYPE (ARRAY-TYPE TVRTLE-SCREEN-ARRAY)
	     SCREEN-ARRAY-DIMENSION-MULTIPLE
	     [BW 32.]
	     [COLOR (// 32.
                        ;; How do you ask this on a 3600?
                        [(NOT S3600) 4.]
                        [S3600 8.])])
       (LET ((EDGES (MULTIPLE-VALUE-LIST (SEND TVRTLE-SCREEN ':EDGES))))
	    (SETQ TV-SCREEN-LEFT (FIRST EDGES)
		  TV-SCREEN-TOP (SECOND EDGES)
		  TV-SCREEN-RIGHT (THIRD EDGES)
		  TV-SCREEN-BOTTOM (FOURTH EDGES)
		  TV-SCREEN-CENTER-X (// (+ TV-SCREEN-LEFT TV-SCREEN-RIGHT) 2.)
		  TV-SCREEN-CENTER-Y (// (+ TV-SCREEN-TOP TV-SCREEN-BOTTOM) 2.)))
       (SETQ TV-SIZE-X-MAX (- TV-SCREEN-RIGHT 2.)
	     TV-SIZE-Y-MAX (- TV-SCREEN-BOTTOM 2.))
       (SETQ TV-PICTURE-TOP
	     [COLOR 2.]
	     [BW 0.]
	     TV-PICTURE-BOTTOM
	     (MULTIPLE-VALUE-BIND (WIDTH HEIGHT)
                                  (SEND TVRTLE-WINDOW ':INSIDE-SIZE)
                                  HEIGHT)
             TV-PICTURE-BOTTOM-FIX (LSH TV-PICTURE-BOTTOM FIX-BITS)
             FLOAT-TV-PICTURE-BOTTOM (FLOAT TV-PICTURE-BOTTOM)
	     ;; Off by one because windows, screens give boundary, we want
	     ;; last included point.
	     TV-PICTURE-LEFT
	     [COLOR 2.]
	     [BW 0.]
             TV-PICTURE-LEFT-FIX (LSH TV-PICTURE-LEFT FIX-BITS)
             FLOAT-TV-PICTURE-LEFT (FLOAT TV-PICTURE-LEFT)
	     TV-PICTURE-RIGHT
	     (MULTIPLE-VALUE-BIND (WIDTH HEIGHT)
                                  (SEND TVRTLE-WINDOW ':INSIDE-SIZE)
                                  WIDTH)
	     TV-PICTURE-CENTER-X (// (+ TV-PICTURE-RIGHT TV-PICTURE-LEFT) 2.)
	     TV-PICTURE-CENTER-Y (// (+ TV-PICTURE-BOTTOM TV-PICTURE-TOP) 2.)
	     TV-SHIFT-X (- TV-PICTURE-CENTER-X TV-PICTURE-LEFT) 
             FLOAT-TV-SHIFT-X (+$ (FLOAT TV-SHIFT-X) 0.5)
	     TV-SHIFT-Y (- TV-PICTURE-BOTTOM TV-PICTURE-CENTER-Y) 
             FLOAT-TV-SHIFT-Y (+$ (FLOAT TV-SHIFT-Y) 0.5)
	     TV-PICTURE-HALF-X (// (- TV-PICTURE-RIGHT TV-PICTURE-LEFT) 2.)
	     TV-PICTURE-HALF-Y (// (- TV-PICTURE-BOTTOM TV-PICTURE-TOP) 2.)
	     TV-PICTURE-SIZE-X (1+ (- TV-PICTURE-RIGHT TV-PICTURE-LEFT))
             FLOAT-TV-PICTURE-SIZE-X (FLOAT (- TV-PICTURE-RIGHT TV-PICTURE-LEFT))
	     TV-PICTURE-SIZE-Y (1+ (- TV-PICTURE-BOTTOM TV-PICTURE-TOP))
             FLOAT-TV-PICTURE-SIZE-Y (FLOAT (- TV-PICTURE-BOTTOM TV-PICTURE-TOP))
	     TV-PICTURE-MIN (MIN TV-PICTURE-SIZE-X TV-PICTURE-SIZE-Y)
	     TV-FACTOR-X (QUOTIENT (FLOAT TV-PICTURE-SIZE-X) TV-PICTURE-MIN)
	     TV-FACTOR-Y (QUOTIENT (FLOAT TV-PICTURE-SIZE-Y) TV-PICTURE-MIN) 
	     TURTLE-PICTURE-MIN 1000.0 
	     *TVSTEP (//$ TURTLE-PICTURE-MIN
			  (-$ (FLOAT TV-PICTURE-MIN)
			      TWICE-FLOATING-POINT-TOLERANCE))
             TWICE-TVSTEP (*$ 2.0 *TVSTEP) 
	     TURTLE-FRONT-RADIUS (*$ TV-TURTLE-FRONT-RADIUS *TVSTEP) 
	     TURTLE-SIDE-RADIUS (*$ TV-TURTLE-SIDE-RADIUS *TVSTEP) 
	     TURTLE-PICTURE-SIZE-X (TIMES TV-FACTOR-X 1000.0) 
	     TURTLE-PICTURE-SIZE-Y (TIMES TV-FACTOR-Y 1000.0)  
	     TURTLE-PICTURE-TOP (* 500.0 TV-FACTOR-Y) 
	     TURTLE-PICTURE-BOTTOM (* -500.0 TV-FACTOR-Y) 
	     TURTLE-PICTURE-LEFT (* -500.0 TV-FACTOR-X) 
	     TURTLE-PICTURE-RIGHT (* 500.0 TV-FACTOR-X) 
	     *XCOR 0.0 
	     *YCOR 0.0 
	     *HEADING 0.0 
	     SINE-HEADING 0.0 
	     COSINE-HEADING 1.0 
	     *PENSTATE T 
	     *ERASERSTATE NIL 
	     *XORSTATE NIL 
             *DRAWSTATE 'PEN
	     *WRAP NIL 
             *CLIP NIL
             *OFFSCREEN NIL
	     *SEETURTLE NIL 
	     *DRAWTURTLE NIL 
	     *ERASETURTLE NIL 
	     *TURTLES '(LOGOTURTLE)
	     *TURTLE 'LOGOTURTLE 
	     *TVECHOLINES 10.
             *BRUSH NIL
             BRUSH-INFO NIL
             BRUSH-PICTURE NIL 
             *PATTERNS '(SOLID GRID CHECKER HORIZLINES VERTLINES DARKTEXTURE
			       LIGHTTEXTURE TEXTURE)
             HORIZONTAL #'HORIZONTAL-LINE
             VERTICAL #'VERTICAL-LINE
             *WINDOWOUTLINE [COLOR NIL] [BW T]
             *OUTLINE NIL
             *CAREFULTURTLE [BW NIL] [COLOR T] 
	     INITIAL-HATCH-PROPERTIES `(,TV-PICTURE-CENTER-X ,TV-PICTURE-CENTER-Y
					0.0 0.0 0.0 0.0 1.0 T NIL NIL PEN NIL NIL NIL
					NIL NIL WHITE 1. NIL NIL NIL HORIZONTAL-LINE 
					VERTICAL-LINE NIL)
             TURTLE-WINDOW-SIZE 50.0)
       (FILLARRAY (ARRAY TURTLE-PROPERTY T TURTLE-PROPERTIES) INITIAL-TURTLE-PROPERTIES)
       ;;TURTLE-PROPERTY are names of variables local to each turtle, HATCH-PROPERTY
       ;;contains the initial value for each of them.
       (FILLARRAY (ARRAY HATCH-PROPERTY T TURTLE-PROPERTIES) INITIAL-HATCH-PROPERTIES)
       (ASET #'HORIZONTAL-LINE #'HATCH-PROPERTY HORIZONTAL-LINE-INDEX)
       ;;Store the SUBR pointers for drawing horizontal and vertical lines.
       (ASET #'VERTICAL-LINE #'HATCH-PROPERTY VERTICAL-LINE-INDEX)
       (PUTPROP 'LOGOTURTLE (*ARRAY NIL T TURTLE-PROPERTIES) 'TURTLE)
       ;; Initialize shading pattern arrays.
       (PATTERN-INIT)) 

;;*PAGE

;;;

(COMMENT SCALING FUNCTIONS) 

;;;

(DEFUN TURTLE-SIZE-X (NEW-TURTLE-SIZE-X) 
       (LET ((CONVERSION-FACTOR (//$ NEW-TURTLE-SIZE-X TURTLE-PICTURE-SIZE-X)))
	    (SETQ TURTLE-PICTURE-SIZE-X NEW-TURTLE-SIZE-X 
                  TURTLE-WINDOW-SIZE (*$ TURTLE-WINDOW-SIZE CONVERSION-FACTOR)
		  TURTLE-PICTURE-LEFT (*$ TURTLE-PICTURE-LEFT CONVERSION-FACTOR) 
		  TURTLE-PICTURE-RIGHT (*$ TURTLE-PICTURE-RIGHT CONVERSION-FACTOR)))) 

(DEFUN TURTLE-SIZE-Y (NEW-TURTLE-SIZE-Y) 
       (LET ((CONVERSION-FACTOR (//$ NEW-TURTLE-SIZE-Y TURTLE-PICTURE-SIZE-Y)))
	    (SETQ TURTLE-PICTURE-SIZE-Y NEW-TURTLE-SIZE-Y 
		  TURTLE-PICTURE-TOP (*$ TURTLE-PICTURE-TOP CONVERSION-FACTOR) 
		  TURTLE-PICTURE-BOTTOM (*$ TURTLE-PICTURE-BOTTOM
					    CONVERSION-FACTOR)))) 

(DEFINE TURTLESIZE ARGS 
	(COND ((ZEROP ARGS))
	      ((= ARGS 1.)
               (ERASE-TURTLE)
	       (SETQ TURTLE-PICTURE-MIN (FLOAT (ARG 1.)) 
		     *TVSTEP (//$ TURTLE-PICTURE-MIN
					(-$ (FLOAT TV-PICTURE-MIN)
					    TWICE-FLOATING-POINT-TOLERANCE)) 
                     TWICE-TVSTEP (*$ 2.0 *TVSTEP)
		     TURTLE-FRONT-RADIUS (*$ TV-TURTLE-FRONT-RADIUS *TVSTEP) 
		     TURTLE-SIDE-RADIUS (*$ TV-TURTLE-SIDE-RADIUS *TVSTEP))
	       (TURTLE-SIZE-X (*$ TURTLE-PICTURE-MIN TV-FACTOR-X))
	       (TURTLE-SIZE-Y (*$ TURTLE-PICTURE-MIN TV-FACTOR-Y))
               (DRAW-TURTLE)))
	(LIST TURTLE-PICTURE-SIZE-X TURTLE-PICTURE-SIZE-Y))


(DEFUN TV-SETHOME (NEW-HOME-X NEW-HOME-Y) 
       (LET ((TURTLE-SHIFT-X (*$ (FLOAT (- NEW-HOME-X TV-PICTURE-CENTER-X))
				 *TVSTEP))
	     (TURTLE-SHIFT-Y (*$ (FLOAT (- TV-PICTURE-CENTER-Y NEW-HOME-Y))
				 *TVSTEP)))
	    (SETQ TV-PICTURE-CENTER-X NEW-HOME-X 
		  TV-PICTURE-CENTER-Y NEW-HOME-Y 
		  TV-SHIFT-X (- TV-PICTURE-CENTER-X TV-PICTURE-LEFT) 
                  FLOAT-TV-SHIFT-X (+$ (FLOAT TV-SHIFT-X) 0.5)
		  TV-SHIFT-Y (- TV-PICTURE-BOTTOM TV-PICTURE-CENTER-Y) 
                  FLOAT-TV-SHIFT-Y  (+$ (FLOAT TV-SHIFT-Y) 0.5)
		  TURTLE-PICTURE-RIGHT (-$ TURTLE-PICTURE-RIGHT TURTLE-SHIFT-X) 
		  TURTLE-PICTURE-LEFT (-$ TURTLE-PICTURE-LEFT TURTLE-SHIFT-X) 
		  TURTLE-PICTURE-TOP (-$ TURTLE-PICTURE-TOP TURTLE-SHIFT-Y) 
		  TURTLE-PICTURE-BOTTOM (-$ TURTLE-PICTURE-BOTTOM TURTLE-SHIFT-Y)))) 

(DEFINE SETHOME (ABB TURTLEHOME TH) ARGS 
	(ERASE-TURTLE)
	(LET ((TURTLE-HOME-X (COND ((ZEROP ARGS) *XCOR)
    				((= ARGS 1.) (FLOAT (CAR (ARG 1.))))
				((FLOAT (ARG 1.)))))
	      (TURTLE-HOME-Y (COND ((ZEROP ARGS) *YCOR)
				((= ARGS 1.) (FLOAT (CAR (ARG 1.))))
				((FLOAT (ARG 2.)))))
	      (*SEETURTLE NIL) 
              (*TURTLES NIL)
              (*DRAWSTATE NIL))
             (COND ((OR *OFFSCREEN 
                        (NOT (OUT-OF-BOUNDS-CHECK TURTLE-HOME-X TURTLE-HOME-Y)))
                    (TV-SETHOME (TV-X TURTLE-HOME-X) (TV-Y TURTLE-HOME-Y))
                    (SETXY$ 0.0 0.0))))
	(DRAW-TURTLE)
	NO-VALUE) 

;;*PAGE


(DEFUN INTERNAL-TV-SIZE (NEW-TV-SIZE-X NEW-TV-SIZE-Y) 
       (COND ((> NEW-TV-SIZE-X NEW-TV-SIZE-Y)
	      (SETQ TV-PICTURE-MIN (1+ NEW-TV-SIZE-Y) 
		    TV-FACTOR-Y 1.0 
		    TV-FACTOR-X (//$ (FLOAT NEW-TV-SIZE-X) (FLOAT NEW-TV-SIZE-Y))))
	     ((SETQ TV-PICTURE-MIN (1+ NEW-TV-SIZE-X) 
		    TV-FACTOR-X 1.0 
		    TV-FACTOR-Y (//$ (FLOAT NEW-TV-SIZE-Y) (FLOAT NEW-TV-SIZE-X)))))
      (LET ((TV-CONVERSION-X (//$ (FLOAT NEW-TV-SIZE-X) FLOAT-TV-PICTURE-SIZE-X))
            (TV-CONVERSION-Y (//$ (FLOAT NEW-TV-SIZE-Y) FLOAT-TV-PICTURE-SIZE-Y)))
           ;;Conversion factors between old & new TV sizes for X and Y.
       (SETQ TV-PICTURE-HALF-X (LSH NEW-TV-SIZE-X -1.) 
	     TV-SHIFT-X (ROUND (*$ (FLOAT TV-SHIFT-X) TV-CONVERSION-X)) 
             FLOAT-TV-SHIFT-X (+$ (FLOAT TV-SHIFT-X) 0.5)
	     TV-PICTURE-SIZE-X (1+ NEW-TV-SIZE-X) 
             FLOAT-TV-PICTURE-SIZE-X (FLOAT NEW-TV-SIZE-X)
	     TV-PICTURE-LEFT (- TV-SCREEN-CENTER-X TV-PICTURE-HALF-X) 
             FLOAT-TV-PICTURE-LEFT (FLOAT TV-PICTURE-LEFT)
             TV-PICTURE-LEFT-FIX (LSH TV-PICTURE-LEFT FIX-BITS)
	     TV-PICTURE-RIGHT (+ TV-SCREEN-CENTER-X TV-PICTURE-HALF-X) 
	     TV-PICTURE-CENTER-X (+ TV-PICTURE-LEFT TV-SHIFT-X) 
	     TV-PICTURE-HALF-Y (LSH NEW-TV-SIZE-Y -1.) 
	     TV-SHIFT-Y (ROUND (*$ (FLOAT TV-SHIFT-Y) TV-CONVERSION-Y)) 
             FLOAT-TV-SHIFT-Y (+$ (FLOAT TV-SHIFT-Y) 0.5)
	     TV-PICTURE-SIZE-Y (1+ NEW-TV-SIZE-Y) 
             FLOAT-TV-PICTURE-SIZE-Y (FLOAT NEW-TV-SIZE-Y)
	     TV-PICTURE-TOP (- TV-SCREEN-CENTER-Y TV-PICTURE-HALF-Y)
	     FLOAT-TV-PICTURE-TOP (FLOAT TV-PICTURE-TOP)
	     TV-PICTURE-TOP-FIX (LSH TV-PICTURE-TOP FIX-BITS)
	     TV-PICTURE-BOTTOM (+ TV-SCREEN-CENTER-Y TV-PICTURE-HALF-Y) 
             TV-PICTURE-BOTTOM-FIX (LSH TV-PICTURE-BOTTOM FIX-BITS)
             FLOAT-TV-PICTURE-BOTTOM (FLOAT TV-PICTURE-BOTTOM)
	     *TVECHOLINES (// (- TV-SCREEN-BOTTOM TV-PICTURE-BOTTOM 24.) 12.))
       ;;Update the homes of the turtles.
       (MAPC '(LAMBDA (TURTLE)
                      (COND ((EQ TURTLE *TURTLE))
                            ;;*TURTLE'S homes are spread in variables which
                            ;;have already been updated.
                            ((SETQ TURTLE (GET TURTLE 'TURTLE))
                             (ASET (+ TV-SCREEN-CENTER-X
				      (ROUND (*$ TV-CONVERSION-X 
						 (FLOAT (- (ARRAYCALL T TURTLE 0.)
							   TV-SCREEN-CENTER-X)))))
				   TURTLE 0.)
                             (ASET (+ TV-PICTURE-TOP 
				      (ROUND (*$ TV-CONVERSION-Y
						 (FLOAT (- (ARRAYCALL T TURTLE 1.)
							   TV-PICTURE-TOP)))))
				   TURTLE 1.))))
             *TURTLES))
       (ASET  (+ TV-PICTURE-TOP TV-PICTURE-HALF-Y) #'HATCH-PROPERTY 1.))

 



(DEFINE TVSIZE ARGS 
 (COND
  ((ZEROP ARGS))
  ((LET
    ((TV-SIZE-X (OR (ARG 1.) (1- TV-PICTURE-SIZE-X)))
     (TV-SIZE-Y (COND ((= ARGS 2.) (OR (ARG 2.) (1- TV-PICTURE-SIZE-Y)))
		      ((ARG 1.)))))
    (COND
     ((NOT (FIXP TV-SIZE-X))
      (SETQ TV-SIZE-X
	    (ERRBREAK 'TVSIZE
		      '"WRONG TYPE INPUT FOR X SIZE")))
     ((< TV-SIZE-X 30.)
      (SETQ TV-SIZE-X
	    (ERRBREAK 'TVSIZE
		      '"HORIZONTAL SIZE TOO SMALL")))
     ((> TV-SIZE-X TV-SIZE-X-MAX)
      (SETQ TV-SIZE-X
	    (ERRBREAK 'TVSIZE
		      '"HORIZONTAL SIZE TOO BIG")))
     ((ODDP TV-SIZE-X) (DECREMENT TV-SIZE-X)))
    (COND ((NOT (FIXP TV-SIZE-Y))
	   (SETQ TV-SIZE-Y
		 (ERRBREAK 'TVSIZE
			   '"WRONG TYPE INPUT FOR Y SIZE")))
	  ((< TV-SIZE-Y 30.)
	   (SETQ TV-SIZE-Y
		 (ERRBREAK 'TVSIZE
			   '"VERTICAL SIZE TOO SMALL")))
	  ((> TV-SIZE-Y TV-SIZE-Y-MAX)
	   (SETQ TV-SIZE-Y
		 (ERRBREAK 'TVSIZE
			   '"VERTICAL SIZE TOO BIG")))
          ((ODDP TV-SIZE-Y) (DECREMENT TV-SIZE-Y)))
    (INTERNAL-TV-SIZE TV-SIZE-X TV-SIZE-Y))
   (LET ((*SEETURTLE NIL)) (TURTLESIZE TURTLE-PICTURE-MIN))
   (CLEARSCREEN)))
 (LIST (1- TV-PICTURE-SIZE-X) (1- TV-PICTURE-SIZE-Y))) 

(DEFINE SCALE (SCALE-FACTOR)
        ;;Changes the turtlesize without moving the turtle's place on
        ;;the screen. SCALE 2 doubles the size of subsequent drawings, etc.
        (LET ((*DRAWSTATE NIL) 
              ;;Don't draw turtle or lines during TURTLESIZE, SETXY operations.
              (*SEETURTLE NIL) 
              (*TURTLES NIL)
              (FLOAT-SCALE-FACTOR (FLOAT SCALE-FACTOR)))
             (TURTLESIZE (//$ TURTLE-PICTURE-MIN FLOAT-SCALE-FACTOR))
             ;;Change the turtlesize appropriately and move the turtle so its
             ;;place on the visual screen doesn't change.
             (SETXY$ (//$ *XCOR FLOAT-SCALE-FACTOR)
                     (//$ *YCOR FLOAT-SCALE-FACTOR)))) 

;;*PAGE

;;ARITHMETIC.

(DEFUN \$ (MODULAND MODULUS) 
       (LET ((FIX-QUOTIENT (IFIX (//$ MODULAND MODULUS)))) 
            (-$ MODULAND (*$ MODULUS (FLOAT FIX-QUOTIENT)))))

(DEFINE SINE (DEGREES) (SIN (*$ (FLOAT DEGREES) PI-OVER-180))) 

(DEFINE COSINE (DEGREES) (COS (*$ (FLOAT DEGREES) PI-OVER-180))) 

(DEFINE ARCTAN (OPPOSITE ADJACENT) 
	(//$ (ATAN (FLOAT OPPOSITE) (FLOAT ADJACENT)) PI-OVER-180)) 

;;FUNCTIONS FOR CONVERTING BACK AND FORTH FROM TURTLE COORDINATES TO ABSOLUTE TV
;;COORDINATES.

(DEFUN TURTLE-X (TV-XCOR) (*$ (FLOAT (- TV-XCOR TV-PICTURE-CENTER-X)) *TVSTEP)) 

(DEFUN TURTLE-Y (TV-YCOR) (*$ *TVSTEP (FLOAT (- TV-PICTURE-CENTER-Y TV-YCOR)))) 

(DEFUN TV-X (TURTLE-X) 
       (LET ((RAW-X (+ (ROUND (//$ TURTLE-X *TVSTEP)) TV-SHIFT-X)))
	    ;;SCALE TO TV SIZED STEPS.
            (COND (*WRAP (COND ((MINUSP (SETQ RAW-X (\ RAW-X TV-PICTURE-SIZE-X)))
				(INCREMENT RAW-X TV-PICTURE-SIZE-X)))))
	    ;;MOVE ZERO TO LEFT EDGE AND WRAP.
	    (+ RAW-X TV-PICTURE-LEFT))) 

(DEFUN TV-Y (TURTLE-Y) 
       (LET ((RAW-Y (+ (ROUND (//$ TURTLE-Y *TVSTEP)) TV-SHIFT-Y)))
	    ;;SCALE TO TV SIZED STEPS.
            (COND (*WRAP (COND ((MINUSP (SETQ RAW-Y (\ RAW-Y TV-PICTURE-SIZE-Y)))
				(INCREMENT RAW-Y TV-PICTURE-SIZE-Y)))))
	    ;;MOVE ZERO TO BOTTOM. Y COORDINATES GO IN OTHER DIRECTION.
	    (- TV-PICTURE-BOTTOM RAW-Y))) 

;;*PAGE

;;;

[BW (DEFUN TV-CLEARSCREEN NIL (SEND TVRTLE-WINDOW ':CLEAR-SCREEN))]

[COLOR (DEFUN TV-CLEARSCREEN NIL (SEND COLOR:COLOR-SCREEN ':CLEAR-SCREEN))]

(DEFUN CLEAR-PALETTE NIL
       ;;Now we know that nothing is on the screen in any color
       ;;except the background, so we can mark all the slots in
       ;;the palette as empty.
       (MAKEPALETTE (SETQ *PENNUMBER 1.) *PENCOLOR)
       (DO ((PALETTE-INDEX 0. (1+ PALETTE-INDEX))) 
           ((= PALETTE-INDEX COLOR-MAX))
           (OR (= PALETTE-INDEX *PENNUMBER)
	       (= PALETTE-INDEX *ERASERNUMBER)
	       (ASET NIL #'PALETTE PALETTE-INDEX)))
       [COLOR (SELECT-COLOR 1.)]
       (ERASERCOLOR *ERASERCOLOR))

(DEFINE WIPECLEAN NIL
        (COND [BW ((NULL *ECHOLINES))]
              ;;Check for NODISPLAY mode.
              (T (TV-CLEARSCREEN) 
                 (OUTLINE) 
                 (CLEAR-PALETTE) 
                 (DRAW-TURTLES)))
        NO-VALUE)

(DEFINE CLEARSCREEN (ABB CS) NIL 
	(COND (*ECHOLINES (LET ((*DRAWSTATE NIL) (*SEETURTLE NIL) (*TURTLES NIL)) (HOME))
			  [COLOR (RESELECT-COLOR)]
                          (WIPECLEAN)
			  NO-VALUE)
	      ;;FOLLOWING FOR LOSER WHO FORGOT STARTDISPLAY.
	      ((STARTDISPLAY))))

;;STARTDISPLAY IS A LEXPR FOR COMPATIBILITY WITH 340/GT40 TURTLE.

(DEFINE STARTDISPLAY (ABB SD) ARGS
	(INITIALIZE-WINDOW)
	(INITIALIZE-TVRTLE-VARIABLES)
	(INITIALIZE-PALETTE)
	[COLOR (INTERNAL-TV-SIZE (1- TV-SIZE-X-MAX) (1- TV-SIZE-Y-MAX))
	       ;;Default TVSIZE for color takes up whole 
	       ;;screen.
	       (TURTLESIZE TURTLE-PICTURE-MIN)]
	(SETQ *ECHOLINES 0.)
	;;Set *ECHOLINES flag, checked by CLEARSCREEN
	;;to see if STARTDISPLAY's been done.
	(TV-CLEARSCREEN)
	(OUTLINE)
	(HATCH 'LOGOTURTLE)
	NO-VALUE) 

(DEFINE STARTDISPLAY-WITH (WINDOW)
	(SETQ TVRTLE-WINDOW WINDOW)
	(STARTDISPLAY))


[BW

(DEFUN INITIALIZE-WINDOW ()
       (COND ((NOT (BOUNDP 'TVRTLE-WINDOW))
	      (FORMAT T "
Use the mouse to create a window for pictures.
")
	      (LET ((NEW-WINDOW
		     ;; Create a new window with mouse (initially de-exposed.)
		     (tv:make-window			;was TV:WINDOW-CREATE
		      'TV:WINDOW ':EDGES-FROM ':MOUSE ':NAME "Tvrtle"))
		    (OLD-SELECTED TV:SELECTED-WINDOW))
		   (SETQ BEFORE-TVRTLE-WINDOW
			 ;; The "old window" is the "top level one you were typing at".
			 ;; For ZTOP, this means the ZMACS frame (which is SUPERIOR of the
			 ;; TV:SELECTED-WINDOW). For others such as Lisp Listener, take the
			 ;; SELECTED.
			 (COND ((AND (STATUS FEATURE ZTOP)
				     ;; If we're in ZTOP...
				     (BOUNDP 'ZWEI:*WINDOW*))
				(SEND TV:SELECTED-WINDOW ':EVAL-INSIDE-YOURSELF 'TV:SUPERIOR))
			       (TV:SELECTED-WINDOW)))
		   ;; Expose it so you can see what you're doing.
		   (SEND NEW-WINDOW ':EXPOSE)
		   (SETQ BEFORE-TVRTLE-EDGES
			 (MULTIPLE-VALUE-LIST (SEND BEFORE-TVRTLE-WINDOW ':EDGES)))
		   ;; Reshape the old window if necessary.
		   (COND ((WINDOW-OVERLAPS? NEW-WINDOW BEFORE-TVRTLE-WINDOW)
			  (SEND OLD-SELECTED ':SELECT)
			  (LET ((RESHAPE? (Y-OR-N-P "
Excuse me, but the window you just created overlaps the window for typing.
Would you like to redefine the window for typing? ")))
			       ;; Push old window out of the way of the new window.
			       (COND (RESHAPE? (SEND NEW-WINDOW ':EXPOSE)
					       (TV:MOUSE-SET-WINDOW-SIZE BEFORE-TVRTLE-WINDOW))))))
		   ;; Re-select the old window.
		   (SEND OLD-SELECTED ':SELECT)
		   (SETQ TVRTLE-WINDOW NEW-WINDOW)))))

(DEFUN WINDOW-OVERLAPS? (ONE-WINDOW OTHER-WINDOW)
       (MULTIPLE-VALUE-BIND (HIS-LEFT HIS-TOP HIS-RIGHT HIS-BOTTOM)
			    (SEND OTHER-WINDOW ':EDGES)
			    (MULTIPLE-VALUE-BIND (MY-LEFT MY-TOP MY-RIGHT MY-BOTTOM)
						 (SEND ONE-WINDOW ':EDGES)
						 (NOT (OR (< MY-RIGHT HIS-LEFT)
							  (< MY-BOTTOM HIS-TOP)
							  (> MY-TOP HIS-BOTTOM)
							  (> MY-LEFT HIS-RIGHT))))))]

[COLOR
(DEFUN INITIALIZE-WINDOW ()
       ;; Color to start WINDOW=SCREEN. Change it.
       (SETQ TVRTLE-WINDOW
             (TV:MAKE-WINDOW 'TV:WINDOW
                             ':BLINKER-P NIL
                             ':LABEL NIL
                             ':BORDERS NIL
                             ':SUPERIOR COLOR:COLOR-SCREEN
                             ':EXPOSE-P T)))
] 


(DEFINE NODISPLAY (ABB ND) NIL
	[BW (SEND TVRTLE-WINDOW ':BURY)
	    (LEXPR-SEND BEFORE-TVRTLE-WINDOW ':SET-EDGES BEFORE-TVRTLE-EDGES)]
	NO-VALUE)

(DEFINE WIPE ARGS 
	(COND ((ZEROP ARGS) (WIPECLEAN))
	      ;;NO ARGS, CLEARS SCREEN, BUT DOESN'T MOVE TURTLE, [AS LLOGO 340 WIPE,
	      ;;11LOGO'S WIPECLEAN].  ONE ARG A WINDOW, HIDES IT AT CURRENT LOCATION
	      ;;[AS 11LOGO'S WIPE].
	      ((HIDEWINDOW (ARG 1.) *XCOR *YCOR)))
	NO-VALUE)

(DEFINE SAVEDISPLAY (ABB SVD) NIL 
 ;;SINCE EXITING LISP AND GOING TO DDT RUINS THE SCREEN, THIS EXITS GRACEFULLY, SAVING
 ;;AND RESTORING PICTURE.
 (MAKEWINDOW 'WHOLESCREEN)
 NO-VALUE)

(DEFUN HORIZONTAL-LINE (FROM-X FROM-Y TO-X)
       [BW (SEND TVRTLE-WINDOW ':DRAW-LINE FROM-X FROM-Y TO-X FROM-Y *DRAWMODE)]
       [(AND COLOR (NOT S3600))
        ;; I think there's a fencepost- doesn't include end pt
        (COLOR:COLOR-DRAW-LINE FROM-X FROM-Y (1+ TO-X) FROM-Y *SELECTED-COLOR *DRAWMODE)]
       [(AND COLOR S3600)
        (SEND TVRTLE-WINDOW ':DRAW-LINE FROM-X FROM-Y TO-X FROM-Y (- *SELECTED-COLOR))])

(DEFUN VERTICAL-LINE (FROM-X FROM-Y TO-Y)
       [BW (SEND TVRTLE-WINDOW ':DRAW-LINE FROM-X FROM-Y FROM-X TO-Y *DRAWMODE)]
       ;; I think there's a fencepost- doesn't include end pt
       [(AND COLOR (NOT S3600))
        (COLOR:COLOR-DRAW-LINE FROM-X FROM-Y FROM-X (1+ TO-Y) *SELECTED-COLOR *DRAWMODE)]
       [(AND COLOR S3600)
        (SEND TVRTLE-WINDOW ':DRAW-LINE FROM-X FROM-Y FROM-X TO-Y (- *SELECTED-COLOR))])


(DEFINE OUTLINE NIL
        (AND *OUTLINE
	     [BW (LET ((OLD-DRAWMODE (DRAWMODE IOR)))
		      (TV-BOX TV-PICTURE-LEFT
			      TV-PICTURE-RIGHT
			      TV-PICTURE-BOTTOM
			      TV-PICTURE-TOP)
		      (DRAWMODE OLD-DRAWMODE))]
	     [COLOR (TV-BOX TV-PICTURE-LEFT
			    TV-PICTURE-RIGHT
			    TV-PICTURE-BOTTOM
			    TV-PICTURE-TOP)])
        NO-VALUE)

(DEFUN TV-BOX (LEFT RIGHT BOTTOM TOP) 
       (SETQ LEFT (1- LEFT) RIGHT (1+ RIGHT))
       (HORIZONTAL-LINE LEFT (1- TOP) RIGHT)
       (HORIZONTAL-LINE LEFT (1+ BOTTOM) RIGHT)
       (VERTICAL-LINE LEFT TOP BOTTOM)
       (VERTICAL-LINE RIGHT TOP BOTTOM))



;;Converts from float to fixed.

(DEFUN FIXIFY (FLONUM) (ROUND (*$ FLONUM FLOAT-UNIT)))

(DEFUN TV-FIX-X (TURTLE-X)
       ;;Turtle coordiates in fixed point. See code for TV-X, TV-Y.
       (FIXIFY (MAX TV-PICTURE-LEFT
		    (MIN TV-PICTURE-RIGHT
			 (+$ (+$ (//$ TURTLE-X *TVSTEP)
				 FLOAT-TV-SHIFT-X)
			     FLOAT-TV-PICTURE-LEFT)))))

(DEFUN TV-FIX-Y (TURTLE-Y)
       (FIXIFY (MAX TV-PICTURE-TOP
		    (MIN TV-PICTURE-BOTTOM
			 (-$ FLOAT-TV-PICTURE-BOTTOM 
			     (+$ (//$ TURTLE-Y *TVSTEP) FLOAT-TV-SHIFT-Y))))))

(DEFUN ROUNDIFY (SHIFTED-FIX)
       ;; Rounds a shifted fixnum. 
       (LSH (+ HALF-UNIT SHIFTED-FIX) MINUS-FIX-BITS))

(DEFUN TRUNCATE-FIX (FIX) (LSH FIX MINUS-FIX-BITS))

(DEFUN BOUNDED-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Floating point coordinates, i.e. turtle coordinates.
       (BOUNDED-VECTOR-FIX (TV-FIX-X FROM-X)
			   (TV-FIX-Y FROM-Y)
			   (TV-FIX-X TO-X)
			   (TV-FIX-Y TO-Y)))

						
(DEFUN BOUNDED-VECTOR-FIX (FROM-X FROM-Y TO-X TO-Y)
       [BW (SEND TVRTLE-WINDOW
		 ':DRAW-LINE
		 (ROUNDIFY FROM-X)
		 (ROUNDIFY FROM-Y)
		 (ROUNDIFY TO-X)
		 (ROUNDIFY TO-Y)
		 *DRAWMODE)]
       [(AND COLOR (NOT S3600))
        (COLOR:COLOR-DRAW-LINE (ROUNDIFY FROM-X)
                               (ROUNDIFY FROM-Y)
                               (ROUNDIFY TO-X)
                               (ROUNDIFY TO-Y)
                               *SELECTED-COLOR
                               *DRAWMODE)]
       [(AND COLOR S3600)
        (SEND TVRTLE-WINDOW
              ':DRAW-LINE
              (ROUNDIFY FROM-X)
              (ROUNDIFY FROM-Y)
              (ROUNDIFY TO-X)
              (ROUNDIFY TO-Y)
              (- *SELECTED-COLOR))])

(DEFUN TVECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Arguments in fixed point TV coordinates instead.
       [BW (SEND TVRTLE-WINDOW ':DRAW-LINE FROM-X FROM-Y TO-X TO-Y *DRAWMODE)]
       [(AND COLOR (NOT S3600))
        (COLOR:COLOR-DRAW-LINE FROM-X FROM-Y TO-X TO-Y *SELECTED-COLOR *DRAWMODE)]
       [(AND COLOR S3600)
        (SEND TVRTLE-WINDOW ':DRAW-LINE FROM-X FROM-Y TO-X TO-Y (- *SELECTED-COLOR))])



(DEFUN OUT-OF-BOUNDS-CHECK (NEW-X$ NEW-Y$)
	 (COND
	  ((> (-$ NEW-X$ TURTLE-PICTURE-RIGHT) FLOATING-POINT-TOLERANCE)
	   (ERRBREAK
             'SETXY$
             '"TURTLE MOVED OFF THE RIGHT SIDE OF THE SCREEN")
           T)
	  ((> (-$ TURTLE-PICTURE-LEFT NEW-X$) FLOATING-POINT-TOLERANCE)
	    (ERRBREAK
	     'SETXY$
	     '"TURTLE MOVED OFF THE LEFT SIDE OF THE SCREEN")
            T)
	  ((> (-$ NEW-Y$ TURTLE-PICTURE-TOP) FLOATING-POINT-TOLERANCE)
	    (ERRBREAK
	     'SETXY$
	     '"TURTLE MOVED OFF THE TOP OF THE SCREEN")
            T)
	  ((> (-$ TURTLE-PICTURE-BOTTOM NEW-Y$) FLOATING-POINT-TOLERANCE)
	    (ERRBREAK
	     'SETXY$
	     '"TURTLE MOVED OFF THE BOTTOM OF THE SCREEN")
            T)))
;;*PAGE

(COMMENT Wrap mode)
;;Following functions divide a floating point coordinate position into a
;;"screen" [integer multiple of screen size] and fraction of screen from the left
;;or bottom edge.

(DEFUN SCREEN-X (WRAP-X)
       ;;Translate to left edge, divide by picture area size in turtle coordinates.
       (IFIX (//$ (-$ WRAP-X TURTLE-PICTURE-LEFT) TURTLE-PICTURE-SIZE-X)))

(DEFUN SCREEN-Y (WRAP-Y)
       (IFIX (//$ (-$ WRAP-Y TURTLE-PICTURE-BOTTOM) TURTLE-PICTURE-SIZE-Y)))

(DEFUN SCREEN-FRACTION-X (SCREEN-X WRAP-X)
       ;;Arguments are screen, produced by SCREEN-X, and full wrap coordinate.
       (//$ (-$ (-$ WRAP-X TURTLE-PICTURE-LEFT) 
                (*$ (FLOAT SCREEN-X) TURTLE-PICTURE-SIZE-X))
            TURTLE-PICTURE-SIZE-X))

(DEFUN SCREEN-FRACTION-Y (SCREEN-Y WRAP-Y)
       (//$ (-$ (-$ WRAP-Y TURTLE-PICTURE-BOTTOM) 
                (*$ (FLOAT SCREEN-Y) TURTLE-PICTURE-SIZE-Y))
            TURTLE-PICTURE-SIZE-Y))

;;These take screen fraction, and convert into shifted fixnum TV coordinate suitable
;;for use by BOUNDED-VECTOR-FIX.

(DEFUN FIXIFY-SCREEN-FRACTION-X (SCREEN-FRACTION-X)
       (+ TV-PICTURE-LEFT-FIX (FIXIFY (*$ SCREEN-FRACTION-X FLOAT-TV-PICTURE-SIZE-X))))

(DEFUN FIXIFY-SCREEN-FRACTION-Y (SCREEN-FRACTION-Y)
       (- TV-PICTURE-BOTTOM-FIX (FIXIFY (*$ SCREEN-FRACTION-Y FLOAT-TV-PICTURE-SIZE-Y))))
;;*PAGE


(DEFUN WRAP-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       ;;Draws vector allowing wraparound. Argument in turtle coordnates.
       (LET ((FROM-SCREEN-X (SCREEN-X FROM-X))
	     (FROM-SCREEN-Y (SCREEN-Y FROM-Y))
	     (TO-SCREEN-X (SCREEN-X TO-X))
	     (TO-SCREEN-Y (SCREEN-Y TO-Y)))
	    (LET ((FROM-FRACTION-X (SCREEN-FRACTION-X FROM-SCREEN-X FROM-X))
		  (FROM-FRACTION-Y (SCREEN-FRACTION-Y FROM-SCREEN-Y FROM-Y))
		  (TO-FRACTION-X (SCREEN-FRACTION-X TO-SCREEN-X TO-X))
		  (TO-FRACTION-Y (SCREEN-FRACTION-Y TO-SCREEN-Y TO-Y)))
                 ;;Split up into screens and fractions of screens, then hand off
                 ;;to WRAP-SCREEN-VECTOR.
		 (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X
				     FROM-SCREEN-Y FROM-FRACTION-Y
				     TO-SCREEN-X TO-FRACTION-X
				     TO-SCREEN-Y TO-FRACTION-Y))))

(DEFUN WRAP-SCREEN-VECTOR
       (FROM-SCREEN-X FROM-FRACTION-X FROM-SCREEN-Y FROM-FRACTION-Y
        TO-SCREEN-X TO-FRACTION-X TO-SCREEN-Y TO-FRACTION-Y)
       (COND ((NOT (= FROM-SCREEN-X TO-SCREEN-X))
              ;;Vector crosses an X screen edge.
              (LET ((CHANGE-X (+$ (FLOAT (- TO-SCREEN-X FROM-SCREEN-X)) 
                                  (-$ TO-FRACTION-X FROM-FRACTION-X)))
                    (CHANGE-Y (+$ (FLOAT (- TO-SCREEN-Y FROM-SCREEN-Y))
                                  (-$ TO-FRACTION-Y FROM-FRACTION-Y))))
                   ;;[This can be done more efficiently.]
                   (LET ((TO-EDGE-X (-$ FROM-FRACTION-X))
                         (FROM-EDGE-FRACTION 0.0)
                         (TO-EDGE-FRACTION 1.0)
                         (SIGN-X -1.))
                        (AND (PLUSP CHANGE-X)
                             (SETQ SIGN-X 1.
                                   TO-EDGE-X (-$ 1.0 FROM-FRACTION-X)
                                   FROM-EDGE-FRACTION 1.0
                                   TO-EDGE-FRACTION 0.0))
                        ;;Compute X and Y coordinates to split the vector
                        ;;at the X edge.
                        (LET ((EDGE-FRACTION-Y 
                               (+$ FROM-FRACTION-Y 
                                   (*$ TO-EDGE-X (//$ CHANGE-Y CHANGE-X))))
                              (EDGE-SCREEN-Y FROM-SCREEN-Y))
                             (LET ((FIX-EDGE-FRACTION (IFIX EDGE-FRACTION-Y)))
                                  (INCREMENT EDGE-SCREEN-Y FIX-EDGE-FRACTION)
                                  (SETQ EDGE-FRACTION-Y 
                                        (-$ EDGE-FRACTION-Y (FLOAT FIX-EDGE-FRACTION)))
                                  (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X 
                                                      FROM-SCREEN-Y FROM-FRACTION-Y
                                                      FROM-SCREEN-X FROM-EDGE-FRACTION
                                                      EDGE-SCREEN-Y EDGE-FRACTION-Y)
                                  ;;Draw a vector on this screen from FROM point to the 
                                  ;;edge, then continue from the edge to TO point.
                                  (WRAP-SCREEN-VECTOR (+ FROM-SCREEN-X SIGN-X) 
                                                      TO-EDGE-FRACTION 
                                                      EDGE-SCREEN-Y EDGE-FRACTION-Y 
                                                      TO-SCREEN-X TO-FRACTION-X 
                                                      TO-SCREEN-Y TO-FRACTION-Y))))))
             ((NOT (= FROM-SCREEN-Y TO-SCREEN-Y))
              (LET ((CHANGE-X (+$ (FLOAT (- TO-SCREEN-X FROM-SCREEN-X)) 
                                  (-$ TO-FRACTION-X FROM-FRACTION-X)))
                    (CHANGE-Y (+$ (FLOAT (- TO-SCREEN-Y FROM-SCREEN-Y))
                                  (-$ TO-FRACTION-Y FROM-FRACTION-Y))))
                   (LET ((TO-EDGE-Y (-$ FROM-FRACTION-Y))
                         (FROM-EDGE-FRACTION 0.0)
                         (TO-EDGE-FRACTION 1.0)
                         (SIGN-Y -1.))
                        (AND (PLUSP CHANGE-Y)
                             (SETQ SIGN-Y 1.
                                   TO-EDGE-Y (-$ 1.0 FROM-FRACTION-Y)
                                   FROM-EDGE-FRACTION 1.0
                                   TO-EDGE-FRACTION 0.0))
                        (LET ((EDGE-FRACTION-X
                               (+$ FROM-FRACTION-X
                                   (*$ TO-EDGE-Y (//$ CHANGE-X CHANGE-Y))))
                              (EDGE-SCREEN-X FROM-SCREEN-X))
                             (LET ((FIX-EDGE-FRACTION (IFIX EDGE-FRACTION-X)))
                                  (INCREMENT EDGE-SCREEN-X FIX-EDGE-FRACTION)
                                  (SETQ EDGE-FRACTION-X 
                                        (-$ EDGE-FRACTION-X (FLOAT FIX-EDGE-FRACTION)))
                                  (WRAP-SCREEN-VECTOR FROM-SCREEN-X FROM-FRACTION-X 
                                                      FROM-SCREEN-Y FROM-FRACTION-Y
                                                      EDGE-SCREEN-X EDGE-FRACTION-X
                                                      FROM-SCREEN-Y FROM-EDGE-FRACTION)
                                  (WRAP-SCREEN-VECTOR EDGE-SCREEN-X EDGE-FRACTION-X
                                                      (+ FROM-SCREEN-Y SIGN-Y) 
                                                      TO-EDGE-FRACTION
                                                      TO-SCREEN-X TO-FRACTION-X 
                                                      TO-SCREEN-Y TO-FRACTION-Y))))))
             ((BOUNDED-VECTOR-FIX-ROUND (FIXIFY-SCREEN-FRACTION-X FROM-FRACTION-X)
                                        (FIXIFY-SCREEN-FRACTION-Y FROM-FRACTION-Y)
                                        (FIXIFY-SCREEN-FRACTION-X TO-FRACTION-X)
                                        (FIXIFY-SCREEN-FRACTION-Y TO-FRACTION-Y)))))

(DEFUN BOUNDED-VECTOR-FIX-ROUND (FROM-X-FIX FROM-Y-FIX TO-X-FIX TO-Y-FIX)
       ;;Increment coordinates by 1/2 so that truncation will round.
       (BOUNDED-VECTOR-FIX (+ FROM-X-FIX HALF-UNIT)
                           (+ FROM-Y-FIX HALF-UNIT)
                           (+ TO-X-FIX HALF-UNIT)
                           (+ TO-Y-FIX HALF-UNIT)))

(DEFUN BOUND-XCOR (BIG-XCOR)
       ;;Guarantees XCOR within screen boundaries.
       (+$ (\$ (-$ BIG-XCOR TURTLE-PICTURE-LEFT) TURTLE-PICTURE-SIZE-X) 
           TURTLE-PICTURE-LEFT))

(DEFUN BOUND-YCOR (BIG-YCOR)
       ;;Guarantees YCOR within screen boundaries.
       (+$ (\$ (-$ BIG-YCOR TURTLE-PICTURE-BOTTOM) TURTLE-PICTURE-SIZE-Y) 
           TURTLE-PICTURE-BOTTOM))

(DEFUN BOUND-HERE NIL
       ;;Smashes down turtle location to fit within the boundaries of the
       ;;display area. Used in leaving WRAP and CLIP modes where HERE may
       ;;exceed legal screen boundaries.
       (ERASE-TURTLE)
       ;;Changing turtle coordinates may result in slightly moving the turtle.
       (SETQ *XCOR (BOUND-XCOR *XCOR) *YCOR (BOUND-YCOR *YCOR))
       (DRAW-TURTLE))

(DEFINE WRAP NIL 
        (ERASE-TURTLE)
        (SETQ *WRAP T *CLIP NIL *OFFSCREEN 'WRAP) 
        (DRAW-TURTLE)
        NO-VALUE)

(DEFINE NOWRAP NIL 
        (BOUND-HERE) 
        (SETQ *WRAP NIL *CLIP NIL *OFFSCREEN NIL) 
        NO-VALUE)

(DEFUN IFIX (X) (FIX X))
;; Missing from LM, in MacLisp.



(DEFUN CLIP-VISIBILITY (POINT-X POINT-Y)
       (LET ((VISIBILITY 0.))
            (COND ((< POINT-X TURTLE-PICTURE-LEFT) (INCREMENT VISIBILITY 1.))
                  ((> POINT-X TURTLE-PICTURE-RIGHT) (INCREMENT VISIBILITY 2.)))
            (COND ((< POINT-Y TURTLE-PICTURE-BOTTOM) (+ VISIBILITY 4.))
                  ((> POINT-Y TURTLE-PICTURE-TOP) (+ VISIBILITY 8.))
                  (VISIBILITY))))

(DEFUN CLIP-VECTOR (FROM-X FROM-Y TO-X TO-Y)
       (CLIP-VECTOR-VISIBILITY FROM-X FROM-Y TO-X TO-Y 
                               (CLIP-VISIBILITY FROM-X FROM-Y)
                               (CLIP-VISIBILITY TO-X TO-Y)))

(DEFUN CLIP-VECTOR-VISIBILITY (FROM-X FROM-Y TO-X TO-Y FROM-VISIBILITY TO-VISIBILITY)
       (DO NIL
           ((AND (ZEROP FROM-VISIBILITY) (ZEROP TO-VISIBILITY))
            ;;Both points visible, draw line.
            (BOUNDED-VECTOR FROM-X FROM-Y TO-X TO-Y))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY TO-VISIBILITY)))
                 ;;Both points beyond visible bounds, reject entire line.
                 ((RETURN T)))
           (COND ((ZEROP FROM-VISIBILITY)
                  ;;Exchange points so that TO point is visible.
                  (SETQ FROM-X (PROG1 TO-X (SETQ TO-X FROM-X))
                        FROM-Y (PROG1 TO-Y (SETQ TO-Y FROM-Y))
                        FROM-VISIBILITY (PROG1 TO-VISIBILITY 
                                               (SETQ TO-VISIBILITY FROM-VISIBILITY)))))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 1.)))
                 ;;Push toward left edge.
                 ((SETQ FROM-Y (+$ FROM-Y
                                   (*$ (//$ (-$ TO-Y FROM-Y) (-$ TO-X FROM-X))
                                       (-$ TURTLE-PICTURE-LEFT FROM-X)))
                        FROM-X TURTLE-PICTURE-LEFT)))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 2.)))
                 ;;Push toward right edge.
                 ((SETQ FROM-Y (+$ FROM-Y
                                   (*$ (//$ (-$ TO-Y FROM-Y) (-$ TO-X FROM-X))
                                       (-$ TURTLE-PICTURE-RIGHT FROM-X)))
                        FROM-X TURTLE-PICTURE-RIGHT)))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 4.)))
                 ;;Push toward top.
                 ((SETQ FROM-X (+$ FROM-X
                                   (*$ (//$ (-$ TO-X FROM-X) (-$ TO-Y FROM-Y))
                                       (-$ TURTLE-PICTURE-BOTTOM FROM-Y)))
                        FROM-Y TURTLE-PICTURE-BOTTOM)))
           (COND ((ZEROP (BITWISE-AND FROM-VISIBILITY 8.)))
                 ;;Push toward bottom.
                 ((SETQ FROM-X (+$ FROM-X
                                   (*$ (//$ (-$ TO-X FROM-X) (-$ TO-Y FROM-Y))
                                       (-$ TURTLE-PICTURE-TOP FROM-Y)))
                        FROM-Y TURTLE-PICTURE-TOP)))
           (SETQ FROM-VISIBILITY (CLIP-VISIBILITY FROM-X FROM-Y))))

(DEFINE CLIP NIL 
        (ERASE-TURTLE)
        (SETQ *CLIP T *WRAP NIL *OFFSCREEN 'CLIP) 
        (DRAW-TURTLE)
        NO-VALUE)

(FSET 'NOCLIP 'NOWRAP)

(DEFINE OFFSCREEN (NEW-OFFSCREEN)
        (COND ((NULL NEW-OFFSCREEN) 
               (BOUND-HERE)
               (SETQ *OFFSCREEN NIL *WRAP NIL *CLIP NIL))
              ((EQ NEW-OFFSCREEN 'WRAP) (WRAP))
              ((EQ NEW-OFFSCREEN 'CLIP) (CLIP))
              ((ERRBREAK 'OFFSCREEN '"WRONG TYPE INPUT TO OFFSCREEN")))
        NO-VALUE)



;;THESE VARIABLES ALLOW USER TO SUBSTITUTE PROCEDURES FOR DRAWING AND ERASING THE
;;TURTLE MARKER.  NIL MEANS USE STANDARD SYSTEM ONES.

(DEFINE TRIANGLETURTLE NIL
        (LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
             (STANDARD-TRIANGLE)
             (STANDARD-PEN)
             [BW (DRAWMODE OLD-DRAWMODE)]))

(DEFUN DRAW-PEN NIL 
       (COND ((NOT *SEETURTLE))
             ((AND *CLIP (PLUSP (CLIP-VISIBILITY *XCOR *YCOR))))
             (*DRAWTURTLE (INVOKE-USER-DRAW-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR *PENNUMBER)]
		   (STANDARD-PEN)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)]))))


(DEFUN ERASE-PEN NIL 
       (COND ((NOT *SEETURTLE))
             ((AND *CLIP (PLUSP (CLIP-VISIBILITY *XCOR *YCOR))))
             (*ERASETURTLE (INVOKE-USER-ERASE-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR *ERASERNUMBER)]
		   (STANDARD-PEN)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)]))))

(DEFUN STANDARD-PEN NIL 
       (COND (*PENSTATE (DRAW-PEN-APPEARANCE))
	     (*ERASERSTATE (DRAW-ERASER-APPEARANCE))
	     (*XORSTATE (DRAW-XOR-APPEARANCE))))

(DEFUN DRAW-PEN-APPEARANCE ()
       ;; Draws a filled-in box INK-BLOCK-SIZE radius around START.
       (LET ((TV-XCOR (TV-X *XCOR))
	     (TV-YCOR (TV-Y *YCOR)))
	    (LET ((TOP (MAX (- TV-YCOR TV-PEN-RADIUS) TV-PICTURE-TOP))
		  (BOTTOM (MIN (+ TV-YCOR TV-PEN-RADIUS) TV-PICTURE-BOTTOM))
		  (LEFT (MAX (- TV-XCOR TV-PEN-RADIUS) TV-PICTURE-LEFT))
		  (RIGHT (MIN (+ TV-XCOR TV-PEN-RADIUS) TV-PICTURE-RIGHT)))
		 (LET ((INK-BLOCK-SIZE (1+ (MIN (- RIGHT LEFT) (- BOTTOM TOP)))))
		      [BW (SEND TVRTLE-WINDOW ':DRAW-RECTANGLE INK-BLOCK-SIZE INK-BLOCK-SIZE
				LEFT TOP XOR)]
		      [COLOR (DO ((Y TOP (1+ Y)))
				 ((> Y BOTTOM))
				 (DO ((X LEFT (1+ X)))
				     ((> X RIGHT))
				     (as-2-reverse *SELECTED-COLOR
						   TVRTLE-SCREEN-ARRAY
						   X
						   Y)))]))))

(DEFUN DRAW-ERASER-APPEARANCE ()
       (LET ((TV-XCOR (TV-X *XCOR))
	     (TV-YCOR (TV-Y *YCOR)))
	    (LET ((TOP (MAX (- TV-YCOR TV-PEN-RADIUS) TV-PICTURE-TOP))
		  (BOTTOM (MIN (+ TV-YCOR TV-PEN-RADIUS) TV-PICTURE-BOTTOM))
		  (LEFT (MAX (- TV-XCOR TV-PEN-RADIUS) TV-PICTURE-LEFT))
		  (RIGHT (MIN (+ TV-XCOR TV-PEN-RADIUS) TV-PICTURE-RIGHT)))
		 (TVECTOR LEFT TOP LEFT BOTTOM)
		 (TVECTOR LEFT TOP RIGHT TOP)
		 (TVECTOR RIGHT TOP RIGHT BOTTOM)
		 (TVECTOR LEFT BOTTOM (1+ RIGHT) BOTTOM))))

(DEFUN DRAW-XOR-APPEARANCE ()
       (LET ((TV-XCOR (TV-X *XCOR))
	     (TV-YCOR (TV-Y *YCOR)))
	    (LET ((TOP (MAX (- TV-YCOR TV-PEN-RADIUS) TV-PICTURE-TOP))
		  (BOTTOM (MIN (+ TV-YCOR TV-PEN-RADIUS) TV-PICTURE-BOTTOM))
		  (LEFT (MAX (- TV-XCOR TV-PEN-RADIUS) TV-PICTURE-LEFT))
		  (RIGHT (MIN (+ TV-XCOR TV-PEN-RADIUS) TV-PICTURE-RIGHT)))
		 (TVECTOR LEFT TOP RIGHT BOTTOM)
		 (TVECTOR RIGHT TOP LEFT BOTTOM))))

(DEFUN INVOKE-USER-DRAW-TURTLE NIL 
       (LET ((*XCOR *XCOR)
	     (*YCOR *YCOR)
	     (*HEADING *HEADING)
	     (SINE-HEADING SINE-HEADING)
	     (COSINE-HEADING COSINE-HEADING)
	     (*SEETURTLE NIL) 
             (*TURTLES NIL)
	     (*PENSTATE *PENSTATE)
	     (*ERASERSTATE *ERASERSTATE)
	     (*XORSTATE *XORSTATE)
             (*DRAWSTATE *DRAWSTATE))
	    (EVAL *DRAWTURTLE))
       ;;User function may screw up drawmode, color.
       [COLOR (RESELECT-COLOR)]
       [BW (DRAWMODE (COND (*ERASERSTATE ANDC) (*XORSTATE XOR) (IOR)))])

(DEFUN INVOKE-USER-ERASE-TURTLE NIL 
       (LET ((*XCOR *XCOR)
	     (*YCOR *YCOR)
	     (*HEADING *HEADING)
	     (SINE-HEADING SINE-HEADING)
	     (COSINE-HEADING COSINE-HEADING)
	     (*SEETURTLE NIL) 
             (*TURTLES NIL)
	     (*PENSTATE *PENSTATE)
	     (*ERASERSTATE *ERASERSTATE)
	     (*XORSTATE *XORSTATE)
             (*DRAWSTATE *DRAWSTATE))
	    (EVAL *ERASETURTLE))
       [COLOR (RESELECT-COLOR)]
       [BW (DRAWMODE (COND (*ERASERSTATE ANDC) (*XORSTATE XOR) (IOR)))])

(DEFUN DRAW-TRIANGLE NIL 
       (COND ((NOT *SEETURTLE))
             ((AND *CLIP (PLUSP (CLIP-VISIBILITY *XCOR *YCOR))))
             (*DRAWTURTLE (INVOKE-USER-DRAW-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR *PENNUMBER)]
		   (STANDARD-TRIANGLE)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)]))))

(DEFUN ERASE-TRIANGLE NIL 
       (COND ((NOT *SEETURTLE))
             ((AND *CLIP (PLUSP (CLIP-VISIBILITY *XCOR *YCOR))))
             (*ERASETURTLE (INVOKE-USER-ERASE-TURTLE))
	     ((LET ([BW (OLD-DRAWMODE (DRAWMODE XOR))])
                   [COLOR (SELECT-COLOR *ERASERNUMBER)]
		   (STANDARD-TRIANGLE)
                   [COLOR (RESELECT-COLOR)]
		   [BW (DRAWMODE OLD-DRAWMODE)]))))


(DEFUN STANDARD-TRIANGLE NIL 
       (LET ((TURTLE-FRONT-RADIUS-X (*$ TURTLE-FRONT-RADIUS SINE-HEADING))
	     (TURTLE-FRONT-RADIUS-Y (*$ TURTLE-FRONT-RADIUS COSINE-HEADING))
	     (TURTLE-RIGHT-RADIUS-X (*$ TURTLE-SIDE-RADIUS
					(+$ (*$ SINE-HEADING COSINE-120)
					    (*$ SINE-120 COSINE-HEADING))))
	     (TURTLE-RIGHT-RADIUS-Y (*$ TURTLE-SIDE-RADIUS
					(-$ (*$ COSINE-HEADING COSINE-120)
					    (*$ SINE-HEADING SINE-120))))
	     (TURTLE-LEFT-RADIUS-X (*$ TURTLE-SIDE-RADIUS
				       (+$ (*$ SINE-HEADING COSINE-240)
					   (*$ SINE-240 COSINE-HEADING))))
	     (TURTLE-LEFT-RADIUS-Y (*$ TURTLE-SIDE-RADIUS
				       (-$ (*$ COSINE-HEADING COSINE-240)
					   (*$ SINE-HEADING SINE-240)))))
	    (LET ((TURTLE-FRONT-X (+$ *XCOR TURTLE-FRONT-RADIUS-X))
		  (TURTLE-FRONT-Y (+$ *YCOR TURTLE-FRONT-RADIUS-Y))
		  (TURTLE-LEFT-X (+$ *XCOR TURTLE-LEFT-RADIUS-X))
		  (TURTLE-LEFT-Y (+$ *YCOR TURTLE-LEFT-RADIUS-Y))
		  (TURTLE-RIGHT-X (+$ *XCOR TURTLE-RIGHT-RADIUS-X))
		  (TURTLE-RIGHT-Y (+$ *YCOR TURTLE-RIGHT-RADIUS-Y))
                  (*WRAP T))
		 (WRAP-VECTOR *XCOR *YCOR TURTLE-FRONT-X TURTLE-FRONT-Y)
		 (WRAP-VECTOR TURTLE-FRONT-X
			      TURTLE-FRONT-Y
			      TURTLE-LEFT-X
			      TURTLE-LEFT-Y)
		 (WRAP-VECTOR TURTLE-LEFT-X
			      TURTLE-LEFT-Y
			      TURTLE-RIGHT-X
			      TURTLE-RIGHT-Y)
		 (WRAP-VECTOR TURTLE-RIGHT-X
			      TURTLE-RIGHT-Y
			      TURTLE-FRONT-X
			      TURTLE-FRONT-Y))))

(DEFUN DRAW-TURTLE NIL
       (COND ((NOT *SEETURTLE))
             ;;Turtle not visible, or clipped out of boundary, return.
             ((AND *CLIP (PLUSP (CLIP-VISIBILITY *XCOR *YCOR))))
             ;;If user set up a turtle display form, use it, else default.
             (*DRAWTURTLE (INVOKE-USER-DRAW-TURTLE))
             [BW ((TRIANGLETURTLE))]
             [COLOR (T (COND (*CAREFULTURTLE (MAKEWINDOW *TURTLE TURTLE-WINDOW-SIZE)))
                       (SELECT-COLOR *PENNUMBER)
                       (TRIANGLETURTLE)
                       (RESELECT-COLOR))]))

(DEFUN ERASE-TURTLE NIL
       (COND ((NOT *SEETURTLE))
             ;;Turtle not visible, or clipped out of boundary, return.
             ((AND *CLIP (PLUSP (CLIP-VISIBILITY *XCOR *YCOR))))
             ;;If user set up a turtle display form, use it, else default.
             (*ERASETURTLE (INVOKE-USER-ERASE-TURTLE))
             [BW ((TRIANGLETURTLE))]
             [COLOR (T (SELECT-COLOR *ERASERNUMBER)
                       (COND (*CAREFULTURTLE 
                              (LET ((*SEETURTLE NIL) (*TURTLES NIL))
                                   (FILLWINDOW TURTLE-WINDOW-SIZE)
                                   (SHOWWINDOW *TURTLE *XCOR *YCOR)))
                             ((TRIANGLETURTLE)))
                       (RESELECT-COLOR))]))

(DEFINE SHOWTURTLE (ABB ST) NIL 
	(COND (*SEETURTLE) ((SETQ *SEETURTLE T) (DRAW-TURTLE)))
	NO-VALUE)

(DEFINE HIDETURTLE (ABB HT) NIL (COND (*SEETURTLE (ERASE-TURTLE)))
				(SETQ *SEETURTLE NIL)
				NO-VALUE)

(DEFUN DRAW-TURTLES NIL 
       (DRAW-TURTLE)
       (LET ((OLD-TURTLE *TURTLE))
            (MAPC '(LAMBDA (OTHER-TURTLE)
                           (COND ((EQ OTHER-TURTLE OLD-TURTLE))
                                 ((ARRAYCALL NIL 
                                             (GET OTHER-TURTLE 'TURTLE) 
                                             *SEETURTLE-INDEX)
                                  (USETURTLE OTHER-TURTLE)
                                  (DRAW-TURTLE))))
                  *TURTLES)
            (COND ((EQ *TURTLE OLD-TURTLE))
                  ((USETURTLE OLD-TURTLE)))))

(DEFUN ERASE-TURTLES NIL 
       (ERASE-TURTLE)
       (LET ((OLD-TURTLE *TURTLE))
            (MAPC '(LAMBDA (OTHER-TURTLE)
                           (COND ((EQ OTHER-TURTLE OLD-TURTLE))
                                 ((ARRAYCALL NIL 
                                             (GET OTHER-TURTLE 'TURTLE) 
                                             *SEETURTLE-INDEX)
                                  (USETURTLE OTHER-TURTLE)
                                  (ERASE-TURTLE))))
                  *TURTLES)
            (COND ((EQ *TURTLE OLD-TURTLE))
                  ((USETURTLE OLD-TURTLE)))))

(DEFINE MAKETURTLE (&QUOTE &REST MAKETURTLE-ARGS)
	(LET ((DRAW-FORM (CAR MAKETURTLE-ARGS)) (ERASE-FORM (CADR MAKETURTLE-ARGS)))
	     (ERASE-TURTLE)
	     (SETQ *DRAWTURTLE DRAW-FORM *ERASETURTLE ERASE-FORM)
	     (DRAW-TURTLE))
	NO-VALUE)


(DEFINE USETURTLE (ABB UT) (TURTLE-NAME)
	(COND ((EQ TURTLE-NAME *TURTLE))
	      ((NULL (GET TURTLE-NAME 'TURTLE))
	       (ERRBREAK 'USETURTLE (LIST TURTLE-NAME '"IS NOT A TURTLE")))
	      ((LET ((NEW-TURTLE (GET TURTLE-NAME 'TURTLE))
		     (OLD-TURTLE (GET *TURTLE 'TURTLE))
		     (OLD-TURTLE-HOME-X TV-PICTURE-CENTER-X)
		     (OLD-TURTLE-HOME-Y TV-PICTURE-CENTER-Y))
		    (DO ((PROPERTY-INDEX 0. (1+ PROPERTY-INDEX))
			 (OLD-TURTLE-PROPERTY))
			((= PROPERTY-INDEX TURTLE-PROPERTIES)
			 [BW (DRAWMODE (COND (*ERASERSTATE ANDC) (*XORSTATE XOR) (IOR)))]
			 [COLOR (RESELECT-COLOR)]
			 (SETQ TV-PICTURE-CENTER-X OLD-TURTLE-HOME-X
			       TV-PICTURE-CENTER-Y OLD-TURTLE-HOME-Y)
			 ;;Set the new turtle's home to be the saved home in the
			 ;;new turtle. Crockishly must reset temporarily the turtle's
			 ;;home to its old value since SETHOME computes the differences
			 ;;between the old and new homes to effect the change.
			 (TV-SETHOME (ARRAYCALL NIL NEW-TURTLE TURTLE-HOME-INDEX-X)
				     (ARRAYCALL NIL NEW-TURTLE TURTLE-HOME-INDEX-Y)))
			(SETQ OLD-TURTLE-PROPERTY
			      (SYMEVAL (AREF #'TURTLE-PROPERTY PROPERTY-INDEX)))
			;;The old turtle property is saved in the turtle array, the new one
			;;is made current in the global variable. The old value is saved 
			;;across setting the new one in case of the current turtle.
			(SET (AREF #'TURTLE-PROPERTY PROPERTY-INDEX)
			     (ARRAYCALL T NEW-TURTLE PROPERTY-INDEX))
			(ASET OLD-TURTLE-PROPERTY OLD-TURTLE PROPERTY-INDEX))
		    (SETQ *TURTLE TURTLE-NAME)))))

;;HATCH CREATES A NEW TURTLE WITH THE SPECIFIED NAME.  ALL PROPERTIES OF THAT
;;PARTICULAR TURTLE ARE AS INITIALLY WHEN A STARTDISPLAY IS DONE.

(DEFINE HATCH (TURTLE-NAME) 
        (AND (EQ TURTLE-NAME *TURTLE) (ERASE-TURTLE))
	(PUTPROP TURTLE-NAME
                 (FILLARRAY (*ARRAY NIL T TURTLE-PROPERTIES) #'HATCH-PROPERTY)
                 'TURTLE)
	(OR (MEMQ TURTLE-NAME *TURTLES) (PUSH TURTLE-NAME *TURTLES))
	(USETURTLE TURTLE-NAME)
	(SHOWTURTLE)
	TURTLE-NAME)

(DEFINE ERASETURTLE (TURTLE-NAME)
       (OR (GET TURTLE-NAME 'TURTLE)
           (ERRBREAK 'ERASETURTLE (LIST TURTLE-NAME '"IS NOT A TURTLE")))
       (AND (EQ *TURTLE TURTLE-NAME)
            (ERRBREAK 'ERASETURTLE '"DON'T ERASE THE CURRENT TURTLE!"))
       (SETQ *TURTLES (DELQ TURTLE-NAME *TURTLES))
       (LET ((OLD-TURTLE *TURTLE)) 
            (USETURTLE TURTLE-NAME) 
            (ERASE-TURTLE) 
            (USETURTLE OLD-TURTLE))
       ;; Not in Lispm ... (*REARRAY (GET TURTLE-NAME 'TURTLE))
       (REMPROP TURTLE-NAME 'TURTLE)
       TURTLE-NAME)

(DEFINE ADDTURTLE (VARIABLE-NAME HATCH-VALUE)
        ;;Adds a new property to be switched when you switch turtles.
        ;;Give it the variable name and the initial value to be set upon HATCH.
        (INCREMENT TURTLE-PROPERTIES)
        (ARRAY 'TURTLE-PROPERTY T TURTLE-PROPERTIES)
        (ARRAY 'HATCH-PROPERTY T TURTLE-PROPERTIES)
        ;;Adjust the number of turtle properties, arrays with names & values of turtle props.
        (ASET VARIABLE-NAME #'TURTLE-PROPERTY (1- TURTLE-PROPERTIES))
        ;;Install the new properties.
        (ASET HATCH-VALUE #'HATCH-PROPERTY (1- TURTLE-PROPERTIES))
        (MAPC '(LAMBDA (TURTLE)
                       ;;Change all the current turtles to reflect the change. They
                       ;;assume the HATCH value for the property.
                       (ARRAY (GET TURTLE 'TURTLE) T TURTLE-PROPERTIES)
                       (ASET HATCH-VALUE (GET TURTLE 'TURTLE) (1- TURTLE-PROPERTIES)))
              *TURTLES)
        (SET VARIABLE-NAME HATCH-VALUE))



(COMMENT BASIC TURTLE COMMANDS)
;;;
;;;
;;THE BASIC TURTLE COMMANDS.  MANY COMMANDS WILL COME IN TWO FLAVORS.  FOR THE USER,
;;A KIND WHICH WILL ACCEPT FIXNUMS OR FLONUMS, PROVIDE ARGUMENT TYPE CHECKING, ETC.,
;;AND A SECOND INTERNAL VERSION EXPECTING FLONUMS ONLY OPTIMIZED FOR NCOMPL'ED
;;EFFICIENCY.  SUCH FLONUM-ONLY FUNCTIONS WILL HAVE THEIR NAMES SUFFIXED BY "$"	,
;;FOLLOWING THE LISP CONVENTION.

(DEFUN SETXY$ (NEW-X$ NEW-Y$) 
       (COND ((AND (NOT *OFFSCREEN) (OUT-OF-BOUNDS-CHECK NEW-X$ NEW-Y$)))
             ;;Check if coordinates off screen.
             (*DRAWSTATE (ERASE-TURTLES)
                         ;;If the turtle is supposed to draw when moved,
                         ;;draw the appropriate kind of line, hiding turtle
                         ;;cursor across the operation.
                         (COND (*WRAP (WRAP-VECTOR *XCOR *YCOR NEW-X$ NEW-Y$))
                               (*CLIP (CLIP-VECTOR *XCOR *YCOR NEW-X$ NEW-Y$))
                               ((BOUNDED-VECTOR *XCOR *YCOR NEW-X$ NEW-Y$)))
                         (SETQ *XCOR NEW-X$ *YCOR NEW-Y$)
                         (DRAW-TURTLES))
             (T (ERASE-TURTLE)
                ;;Otherwise, just set the coordinates and redisplay
                ;;the current turtle in the new position if necessary.
                (SETQ *XCOR NEW-X$ *YCOR NEW-Y$)
                (DRAW-TURTLE))))

(DEFINE SETXY (NEW-X NEW-Y) (SETXY$ (FLOAT NEW-X) (FLOAT NEW-Y)) NO-VALUE)

(DEFUN FORWARD$ (STEPS$) 
       (SETXY$ (+$ *XCOR (*$ STEPS$ SINE-HEADING))
	       (+$ *YCOR (*$ STEPS$ COSINE-HEADING))))

(DEFINE FORWARD (ABB FD) (STEPS) (FORWARD$ (FLOAT STEPS)) NO-VALUE)

(DEFINE BACK (ABB BK) (STEPS) (FORWARD$ (-$ (FLOAT STEPS))) NO-VALUE)

(DEFUN SETHEAD$ (NEW-HEADING$) 
       (ERASE-TRIANGLE)
       (LET ((NEW-HEADING-RADIANS (*$ NEW-HEADING$ PI-OVER-180)))
	    (SETQ *HEADING NEW-HEADING$ 
		  SINE-HEADING (SIN NEW-HEADING-RADIANS) 
		  COSINE-HEADING (COS NEW-HEADING-RADIANS))
	    (DRAW-TRIANGLE)))

(DEFINE SETHEAD (ABB SH SETHEADING) (NEW-HEADING) (SETHEAD$ (FLOAT NEW-HEADING))
						  NO-VALUE)

(DEFUN RIGHT$ (TURNS$) (SETHEAD$ (+$ *HEADING TURNS$)))

(DEFINE RIGHT (ABB RT) (TURNS) (RIGHT$ (FLOAT TURNS)) NO-VALUE)

(DEFINE LEFT (ABB LT) (TURNS) (RIGHT$ (-$ (FLOAT TURNS))) NO-VALUE)

(DEFINE PENUP (ABB PU) NIL (AND *PENSTATE (ERASE-PEN))
			   (SETQ *PENSTATE NIL *DRAWSTATE NIL)
			   (AND *DRAWTURTLE (DRAW-TURTLE))
			   NO-VALUE)

(DEFINE PENDOWN (ABB PD) NIL (ERASE-PEN)
			     [BW (DRAWMODE IOR)]
                             [COLOR (SELECT-COLOR *PENNUMBER)]
			     (SETQ *PENSTATE T 
                                   *ERASERSTATE NIL 
                                   *XORSTATE NIL 
                                   *DRAWSTATE 'PEN)
			     (DRAW-PEN)
			     NO-VALUE)

;;PENP FOR COMPATIBLILITY WITH 340/GT40 TURTLE.

(DEFINE PENP NIL *PENSTATE)

(DEFINE ERASERUP (ABB ERU) NIL (AND *ERASERSTATE (ERASE-PEN))
			       (SETQ *ERASERSTATE NIL *DRAWSTATE NIL)
                               (AND *DRAWTURTLE (DRAW-TURTLE))
                               [BW (DRAWMODE IOR)]
			       NO-VALUE)

(DEFINE ERASERDOWN (ABB ERD) NIL (ERASE-PEN)
				 [BW (DRAWMODE ANDC)]
                                 [COLOR (SELECT-COLOR *ERASERNUMBER)]
				 (SETQ *ERASERSTATE T 
                                       *PENSTATE NIL 
                                       *XORSTATE NIL
                                       *DRAWSTATE 'ERASER)
				 (DRAW-PEN)
				 NO-VALUE)

;;THE USER HAS THE OPTION OF USING XOR MODE IN A MANNER SIMILAR TO THE "PEN" AND THE
;;"ERASER".


[BW
(DEFINE XORDOWN (ABB XD) NIL (ERASE-PEN)
			     (DRAWMODE XOR)
			     (SETQ *XORSTATE T 
                                   *PENSTATE NIL 
                                   *ERASERSTATE NIL 
                                   *DRAWSTATE 'XOR)
			     (DRAW-PEN)
			     NO-VALUE) 

(DEFINE XORUP (ABB XU) NIL (AND *XORSTATE (ERASE-PEN))
			   (SETQ *XORSTATE NIL *DRAWSTATE NIL)
			   (AND *DRAWTURTLE (DRAW-TURTLE))
                           (DRAWMODE IOR)
			   NO-VALUE)
]

[COLOR (DEFINE XORUP NIL (NOT-IMPLEMENTED-IN-COLOR '(XORUP)))
       (DEFINE XORDOWN NIL (NOT-IMPLEMENTED-IN-COLOR '(XORDOWN)))]

(DEFINE DRAWSTATE (NEW-STATE)
        (COND ((NULL NEW-STATE)
               (ERASE-PEN)
               (SETQ *DRAWSTATE NIL *PENSTATE NIL *ERASERSTATE NIL *XORSTATE NIL)
               [BW (DRAWMODE IOR)]
               (AND *DRAWTURTLE (DRAW-TURTLE))
               (DRAW-PEN))
              ((EQ NEW-STATE 'PEN) (PENDOWN))
              ((EQ NEW-STATE 'ERASER) (ERASERDOWN))
              ((EQ NEW-STATE 'XOR) (XORDOWN))
              ((ERRBREAK 'DRAWSTATE '"WRONG TYPE INPUT TO DRAWSTATE")))
        NO-VALUE)

(DEFINE HOME (ABB H) NIL (COND (*DRAWSTATE (ERASE-TURTLES)) ((ERASE-TURTLE)))
			 ;;SEETURTLE HACKING HANDLED EXPLICITY SO THAT TURTLE
			 ;;APPEARANCE AND DISAPPEARANCE DOES NOT OCCUR TWICE, ONCE
			 ;;WITH SETXY, ONCE WITH SETHEAD.
			 (LET ((*SEETURTLE NIL) (*TURTLES NIL)) 
                              (SETXY$ 0.0 0.0) 
                              (SETHEAD$ 0.0))
                         ;;If *DRAWSTATE is on, requires display of all turtles,
                         ;;else only the current turtle need to be redisplayed.
                         (COND (*DRAWSTATE (DRAW-TURTLES)) ((DRAW-TURTLE)))
			 NO-VALUE)

(DEFINE SETTURTLE (ABB SETT) (P) 
        (COND (*DRAWSTATE (ERASE-TURTLES)) ((ERASE-TURTLE)))
        ;;(SETTURTLE '(100 100 90)) SETS THE STATE OF THE
        ;;TURTLE TO THE POSITION '(100 100) AND HEADING 90. 
        ;;THE HEADING IS OPTIONAL.  (SETTURTLE (HERE)) IS A NO-OP.
        (LET ((*SEETURTLE NIL) (*TURTLES NIL))
             (SETXY$ (FLOAT (CAR P)) (FLOAT (CADR P)))
             (AND (CDDR P) (SETHEAD$ (FLOAT (CADDR P)))))
        (COND (*DRAWSTATE (DRAW-TURTLES)) ((DRAW-TURTLE)))
        NO-VALUE)

(DEFINE SETX (X) (SETXY$ (FLOAT X) *YCOR) NO-VALUE)
(DEFINE SETY (Y) (SETXY$ *XCOR (FLOAT Y)) NO-VALUE)

(DEFINE XCOR NIL (ROUND (BOUND-XCOR *XCOR)))
(DEFINE YCOR NIL (ROUND (BOUND-YCOR *YCOR)))

(DEFINE HEADING NIL 
	(LET ((SMASHED-HEADING (\ (ROUND *HEADING) 360.))) 
             (OR (AND (MINUSP SMASHED-HEADING) (+ 360. SMASHED-HEADING)) 
                 SMASHED-HEADING)))

(DEFINE HERE NIL (LIST (XCOR) (YCOR) (HEADING)))

(DEFINE DELX (X) (SETXY$ (+$ (FLOAT X) *XCOR) *YCOR) NO-VALUE)
(DEFINE DELY (Y) (SETXY$ *XCOR (+$ *YCOR (FLOAT Y))) NO-VALUE)
(DEFINE DELXY (X Y) (SETXY$ (+$ *XCOR (FLOAT X)) (+$ *YCOR (FLOAT Y))) NO-VALUE)

(DEFINE MOVETO (X Y) 
	(LET ((OSTATE *DRAWSTATE))
	     (PENUP) 
	     (SETXY X Y) 
	     (PENDOWN)
	     (DRAWSTATE OSTATE)))

;;MARK NEEDS A CONVENIENT WAY TO ERASE TEXT FROM SCREEN.  PRINTING OF TEXT DOESN'T
;;SEEM TO BE AFFECTED BY DRAWMODE.

[BW (DEFINE MARK (TEXT)
	    (SEND TVRTLE-WINDOW ':SET-CURSORPOS (TV-X *XCOR) (TV-Y *YCOR))
	    (SEND TVRTLE-WINDOW ':STRING-OUT TEXT))]
[BW
;;;
;;SET OR READ ANY POINT IN TV BUFFER.

(DEFUN WRITE-TV-POINT (POINT-X POINT-Y)
       (SEND TVRTLE-WINDOW ':DRAW-POINT POINT-X POINT-Y *DRAWMODE) 
       T) 

(DEFUN READ-TV-POINT (POINT-X POINT-Y)
       (NOT (ZEROP (SEND TVRTLE-WINDOW ':POINT POINT-X POINT-Y))))

;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
]

[COLOR
 (DEFUN WRITE-TV-POINT (POINT-X POINT-Y)
	(as-2-reverse *SELECTED-COLOR TVRTLE-SCREEN-ARRAY POINT-X POINT-Y))
 
 (DEFUN READ-TV-POINT (POINT-X POINT-Y)
	(NOT (ZEROP (READ-TV-POINT-NUMBER POINT-X POINT-Y))))
 
 (DEFUN READ-TV-POINT-NUMBER (POINT-X POINT-Y)
	(ar-2-reverse TVRTLE-SCREEN-ARRAY POINT-X POINT-Y))]

[BW

(DEFINE POINT ARGS 
	(LET ((X-COR *XCOR) (Y-COR *YCOR) (DARK-OR-LIGHT *DRAWMODE))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.) (SETQ DARK-OR-LIGHT (COND ((ARG 1.) IOR) (ANDC))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.))))
		   ((= ARGS 3.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  DARK-OR-LIGHT (COND ((ARG 3.) IOR) (ANDC)))))
             (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK X-COR Y-COR)))
                    (ERASE-TURTLES)
                    (LET ((OLD-DRAWMODE (DRAWMODE DARK-OR-LIGHT)))
			 (SEND TVRTLE-WINDOW ':DRAW-POINT (TV-X X-COR) (TV-Y Y-COR) *DRAWMODE)
                         (DRAWMODE OLD-DRAWMODE)
                         (DRAW-TURTLES)))))
	NO-VALUE) 

(DEFINE POINTSTATE (ABB PS)  ARGS 
	(LET ((X-COR *XCOR) (Y-COR *YCOR))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.)))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))))
             (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK X-COR Y-COR)))
                    (ERASE-TURTLES)
                    (PROG1 (READ-TV-POINT (TV-X X-COR) (TV-Y Y-COR))
                           (DRAW-TURTLES))))))

(DEFINE POINTCOLOR ARGS 
	(LET ((X-COR *XCOR) (Y-COR *YCOR))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.)))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))))
             (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK X-COR Y-COR)))
                    (ERASE-TURTLES)
                    (PROG1 (COND ((READ-TV-POINT (TV-X X-COR) (TV-Y Y-COR)) *PENCOLOR)
                                 (*ERASERCOLOR))
                           (DRAW-TURTLES))))))

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
]

[COLOR 

(DEFINE POINT ARGS 
	(LET ((X-COR *XCOR) (Y-COR *YCOR) (POINT-COLOR *PENNUMBER))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.) (COND ((ARG 1.)) ((SETQ POINT-COLOR *ERASERNUMBER))))
		   ((= ARGS 2.) (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.))))
		   ((= ARGS 3.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))
                    (COND ((ARG 3.)) ((SETQ POINT-COLOR *ERASERNUMBER)))))
             (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK X-COR Y-COR)))
                    (ERASE-TURTLES)
                    (SELECT-COLOR POINT-COLOR)
                    (WRITE-TV-POINT (TV-X X-COR) (TV-Y Y-COR))
                    (RESELECT-COLOR)
                    (DRAW-TURTLES))))
	NO-VALUE) 

(DEFINE POINTSTATE (ABB PS) ARGS 
	(LET ((X-COR *XCOR) (Y-COR *YCOR))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.)))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))))
             (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK X-COR Y-COR)))
                    (ERASE-TURTLES)
                    (LET ((POINTSTATE (READ-TV-POINT-NUMBER (TV-X X-COR) (TV-Y Y-COR))))
                         (DRAW-TURTLES)
                         (NOT (= POINTSTATE *ERASERNUMBER)))))))

(DEFINE POINTCOLOR ARGS 
	(LET ((X-COR *XCOR) (Y-COR *YCOR))
	     (COND ((ZEROP ARGS))
		   ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.)))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) Y-COR (FLOAT (ARG 2.)))))
             (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK X-COR Y-COR)))
                    (ERASE-TURTLES)
                    (LET ((POINTSTATE (READ-TV-POINT-NUMBER (TV-X X-COR) (TV-Y Y-COR))))
                         (DRAW-TURTLES)
                         (AREF #'PALETTE POINTSTATE))))))

;;;END OF COLOR CONDITIONAL SECTION.
]



(DEFUN ARC$ (RADIUS$ DEGREES$) 
       ;;ONE OF THESE DAYS, INCLUDE A MORE EFFICIENT ARC DRAWING PROCEDURE.
       (ERASE-TURTLES)
       ;;Turtle hidden during execution of ARC.
       
       (LET ((UNIT-CIRCLE-SIDE (*$ 2.0 (SIN (//$ *PI *POLYGON))))
	     (HALF-TURN (//$ 360.0 *POLYGON 2.0)))
	    (LET ((SIDE (*$ RADIUS$ UNIT-CIRCLE-SIDE))
		  (OLD-XCOR *XCOR)
		  (OLD-YCOR *YCOR)
		  (OLD-HEADING *HEADING)
		  (SINE-HEADING SINE-HEADING)
		  (COSINE-HEADING COSINE-HEADING)
		  (*DRAWSTATE NIL)
		  (*SEETURTLE NIL) 
                  (*TURTLES NIL))
		 (FORWARD$ RADIUS$)
		 (RIGHT$ 90.0)
		 (DO ((SIDES (//$ DEGREES$ HALF-TURN 2.0) (1-$ SIDES)) 
                      (*DRAWSTATE 'PEN))
		     ((< SIDES 1.0) (RIGHT$ HALF-TURN) (FORWARD$ (*$ SIDES SIDE)))
		     (RIGHT$ HALF-TURN)
		     (FORWARD$ SIDE)
		     (RIGHT$ HALF-TURN))
		 (SETXY$ OLD-XCOR OLD-YCOR)
		 (SETHEAD$ OLD-HEADING)))
       (DRAW-TURTLES))

(DEFINE ARC (RADIUS DEGREES) (ARC$ (FLOAT RADIUS) (FLOAT DEGREES)) NO-VALUE)

(DEFINE CIRCLE (RADIUS)
	[BW (SEND TVRTLE-WINDOW
		  ':DRAW-CIRCLE
		  (TV-X *XCOR)
		  (TV-Y *YCOR)
		  (ROUND (// RADIUS *TVSTEP))
		  *DRAWMODE)]
	[COLOR (ARC RADIUS 360.0)]
	NO-VALUE)
;;*PAGE

;;;

(COMMENT GLOBAL NAVIGATION)
;;;

(DEFINE BEARING ARGS 
	(LET ((X-COR 0.0)
	      (Y-COR 0.0)
	      (DELTA-X 0.0)
	      (DELTA-Y 0.0)
	      (ALLEGED-BEARING 0.0)
	      (RETURN-FIXNUM))
	     (COND ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.))) 
			  RETURN-FIXNUM (AND (FIXP (CAR (ARG 1.)))
					     (FIXP (CADR (ARG 1.))))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  RETURN-FIXNUM (AND (FIXP (ARG 1.)) (FIXP (ARG 2.)))))
		   ((ERRBREAK 'BEARING
			      '"WRONG NUMBER OF INPUTS")))
	     (SETQ DELTA-X (-$ X-COR *XCOR) DELTA-Y (-$ Y-COR *YCOR))
	     (COND ((AND (< (ABS DELTA-X) FLOATING-POINT-TOLERANCE)
			 (< (ABS DELTA-Y) FLOATING-POINT-TOLERANCE)))
		   ((MINUSP (SETQ ALLEGED-BEARING
				  (QUOTIENT (ATAN DELTA-X DELTA-Y) PI-OVER-180)))
		    (SETQ ALLEGED-BEARING (-$ 360.0 ALLEGED-BEARING))))
	     (COND (RETURN-FIXNUM (\ (ROUND ALLEGED-BEARING) 360.))
		   ((\$ ALLEGED-BEARING 360.0)))))

(DEFINE TOWARDS ARGS 
	;;DIRECTION OF A POINT RELATIVE TO TURTLE HEADING.  +0-360 DEGREES.  POINT =
	;;(X Y).
	(LET ((X-COR 0.0) (Y-COR 0.0) (RETURN-FIXNUM))
	     (COND ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.))) 
			  RETURN-FIXNUM (AND (FIXP (CAR (ARG 1.)))
					     (FIXP (CADR (ARG 1.))))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  RETURN-FIXNUM (AND (FIXP (ARG 1.)) (FIXP (ARG 2.)))))
		   ((ERRBREAK 'TOWARDS
			      '"WRONG NUMBER OF INPUTS")))
	     (LET ((ALLEGED-TOWARDS (-$ (BEARING X-COR Y-COR) *HEADING)))
		  (COND ((MINUSP ALLEGED-TOWARDS)
			 (SETQ ALLEGED-TOWARDS (+$ 360.0 ALLEGED-TOWARDS))))
		  (COND (RETURN-FIXNUM (\ (ROUND ALLEGED-TOWARDS) 360.))
			((\$ ALLEGED-TOWARDS 360.0))))))
(DEFINE RANGE ARGS 
	(LET ((X-COR 0.0)
	      (Y-COR 0.0)
	      (ALLEGED-RANGE 0.0)
	      (DELTA-X 0.0)
	      (DELTA-Y 0.0)
	      (RETURN-FIXNUM))
	     (COND ((= ARGS 1.)
		    (SETQ X-COR (FLOAT (CAR (ARG 1.))) 
			  Y-COR (FLOAT (CADR (ARG 1.))) 
			  RETURN-FIXNUM (AND (FIXP (CAR (ARG 1.)))
					     (FIXP (CADR (ARG 1.))))))
		   ((= ARGS 2.)
		    (SETQ X-COR (FLOAT (ARG 1.)) 
			  Y-COR (FLOAT (ARG 2.)) 
			  RETURN-FIXNUM (AND (FIXP (ARG 1.)) (FIXP (ARG 2.)))))
		   ((ERRBREAK 'RANGE
			      '"WRONG NUMBER OF INPUTS")))
	     (SETQ DELTA-X (-$ X-COR *XCOR) 
		   DELTA-Y (-$ Y-COR *YCOR) 
		   ALLEGED-RANGE (SQRT (+$ (*$ DELTA-X DELTA-X)
					   (*$ DELTA-Y DELTA-Y))))
	     (COND (RETURN-FIXNUM (ROUND ALLEGED-RANGE)) (ALLEGED-RANGE))))

;; Returns the position of the mouse in turtle coordinates.

(DEFINE MOUSE-HERE (ABB MH) ()
	(LIST (TURTLE-X (- TV:MOUSE-X (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
							   (SEND TVRTLE-WINDOW ':EDGES)
							   LEFT)))
	      (TURTLE-Y (- TV:MOUSE-Y (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
							   (SEND TVRTLE-WINDOW ':EDGES)
							   TOP)))))

(DEFINE MOUSE-SETXY (X Y)
	(TV:MOUSE-WARP (+ (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
					       (SEND TVRTLE-WINDOW ':EDGES)
					       LEFT)
			  (TV-X X))
		       (+ (MULTIPLE-VALUE-BIND (LEFT TOP RIGHT BOTTOM)
					       (SEND TVRTLE-WINDOW ':EDGES)
					       TOP)
			  (TV-Y Y))))


(COMMENT RUN-LENGTH ENCODING)

(DEFUN RUNAWAY-FORWARD (START-X START-Y RUN-TYPE)
       ;; Counts run length of pixels with value RUN-TYPE
       ;; from starting point forward on a line.
       (RUN-LENGTH START-X START-Y RUN-TYPE 1. TV-PICTURE-RIGHT))

(DEFUN RUNAWAY-BACKWARD (START-X START-Y RUN-TYPE)
       (RUN-LENGTH START-X START-Y RUN-TYPE -1. TV-PICTURE-LEFT))

[BW 

(DEFUN RUN-LENGTH (START-X START-Y RUN-TYPE DIRECTION LIMIT)
       (DO ((TRAVEL-X START-X (+ TRAVEL-X DIRECTION))
	    (RUN-COUNTER 0. (1+ RUN-COUNTER)))
	   ((OR (NOT (= (SEND TVRTLE-WINDOW ':POINT TRAVEL-X START-Y) RUN-TYPE))
		(AND (= TRAVEL-X LIMIT) (INCREMENT RUN-COUNTER)))
	    RUN-COUNTER)))

(DEFUN FIND-RIGHT-BOUNDARY (START-X START-Y AREA-COLOR) 
       ;;AREA-COLOR is 0 for region off, 1 for region on.
       (SETQ START-X (+ START-X (RUNAWAY-FORWARD START-X START-Y AREA-COLOR)))
       ;;RIGHTWARDS RUN UNTIL BOUNDARY REACHED, THEN BACK OFF.
       (COND ((> START-X TV-PICTURE-RIGHT) TV-PICTURE-RIGHT)
             ;;IF PAST THE RIGHT EDGE OF TV SCREEN.
             ((- START-X (RUNAWAY-BACKWARD START-X START-Y (- 1. AREA-COLOR))))))

(DEFUN FIND-LEFT-BOUNDARY (START-X START-Y AREA-COLOR) 
       (SETQ START-X (- START-X (RUNAWAY-BACKWARD START-X START-Y AREA-COLOR)))
       ;;LEFTWARDS RUN UNTIL BOUNDARY, BACK OFF TO INTERIOR POINT.
       (COND ((< START-X TV-PICTURE-LEFT) TV-PICTURE-LEFT)
             ((+ START-X (RUNAWAY-FORWARD START-X START-Y (- 1. AREA-COLOR))))))

;; End of BW conditional...
]

[COLOR

(DEFUN RUN-LENGTH (START-X START-Y RUN-TYPE DIRECTION LIMIT)
       (DO ((TRAVEL-X START-X (+ TRAVEL-X DIRECTION))
	    (RUN-COUNTER 0. (1+ RUN-COUNTER)))
	   ((OR (NOT (= (READ-TV-POINT-NUMBER TRAVEL-X START-Y) RUN-TYPE))
		(AND (= TRAVEL-X LIMIT) (INCREMENT RUN-COUNTER)))
	    RUN-COUNTER)))

(DEFUN FIND-RIGHT-BOUNDARY (START-X START-Y RUN-COLOR) 
       (SETQ START-X (+ START-X (RUNAWAY-FORWARD START-X START-Y RUN-COLOR)))
       ;;RIGHTWARDS RUN UNTIL BOUNDARY REACHED, THEN BACK OFF.
       (COND ((> START-X TV-PICTURE-RIGHT) TV-PICTURE-RIGHT)
             ((- START-X (RUNAWAY-BACKWARD-BOUNDARY START-X START-Y)))))

(DEFUN FIND-LEFT-BOUNDARY (START-X START-Y RUN-COLOR) 
       (SETQ START-X (- START-X (RUNAWAY-BACKWARD START-X START-Y RUN-COLOR)))
       ;;LEFTWARDS RUN UNTIL BOUNDARY, BACK OFF TO INTERIOR POINT.
       (COND ((< START-X TV-PICTURE-LEFT) TV-PICTURE-LEFT)
             ((+ START-X (RUNAWAY-FORWARD-BOUNDARY START-X START-Y)))))

(DEFUN RUNAWAY-FORWARD-BOUNDARY (START-X START-Y) 
       (RUNAWAY-FORWARD START-X START-Y (READ-TV-POINT-NUMBER START-X START-Y))) 

(DEFUN RUNAWAY-BACKWARD-BOUNDARY (START-X START-Y) 
       (RUNAWAY-BACKWARD START-X START-Y (READ-TV-POINT-NUMBER START-X START-Y)))

;; End of COLOR conditional..
]


;;;


(COMMENT WINDOW COMMANDS)
;;;
;;;
;;THE FOLLOWING FUNCTIONS ALLOW THE USER TO SAVE RECTANGULAR AREAS OF THE SCREEN IN
;;BIT-IMAGE ARRAYS, AND REDISPLAY SUCH ARRAYS ANYWHERE ON THE SCREEN.  ALTHOUGH
;;SOMEWHAT SPACE CONSUMING, IT ALLOWS SUPERQUICK REDISPLAY, MINIMIZING RECOMPUTATION
;;OF POINTS.  THIS MAKES IT IDEAL FOR PROGRAMS WHICH WANT TO MAKE ONLY LOCAL CHANGES
;;TO A PICTURE, BUT NEED SPEED FOR DYNAMIC UPDATING.  EXAMPLES: SHIPS IN SPACE WAR,
;;BOUNCING BALL TYPE PROGRAMS, CELLS IN LIFE GAME. 
;;;
;;NOTE THAT THESE "WINDOW"S ARE DIFFERENT FROM LLOGO'S SNAPS: WHAT YOU SEE IS
;;EXACTLY WHAT YOU GET!


(DEFUN RECTANGLE-SPEC (CHECKER SPEC-LIST &OPTIONAL OUT-OF-BOUNDS-ERROR?) 
       ;;HANDLES DEFAULTS FOR SPECIFYING A RECTANGULAR AREA OF THE SCREEN FOR USE
       ;;WITH THE WINDOW AND XGP COMMANDS.
       (LET ((LEFT-X TV-PICTURE-LEFT)
	     (RIGHT-X TV-PICTURE-RIGHT)
	     (TOP-Y TV-PICTURE-TOP)
	     (BOTTOM-Y TV-PICTURE-BOTTOM)
	     (CENTER-X (TV-X *XCOR))
	     (CENTER-Y (TV-Y *YCOR))
	     (RADIUS-X TV-PICTURE-HALF-X)
	     (RADIUS-Y TV-PICTURE-HALF-Y))
	    (COND ((NULL SPEC-LIST)
		   (SETQ CENTER-X (+ TV-PICTURE-LEFT TV-PICTURE-HALF-X) 
			 CENTER-Y (+ TV-PICTURE-TOP TV-PICTURE-HALF-Y)))
		  (T (COND ((CDDR SPEC-LIST)
			    (SETQ CENTER-X (TV-X (FLOAT (CAR SPEC-LIST))) 
				  CENTER-Y (TV-Y (FLOAT (CADR SPEC-LIST))) 
				  SPEC-LIST (CDDR SPEC-LIST))))
		     (SETQ RADIUS-X (ROUND (//$ (FLOAT (CAR SPEC-LIST)) *TVSTEP)) 
			   RADIUS-Y (COND ((CDR SPEC-LIST)
					   (ROUND (//$ (FLOAT (CADR SPEC-LIST)) *TVSTEP)))
					  (RADIUS-X)) 
			   LEFT-X (- CENTER-X RADIUS-X) 
			   RIGHT-X (+ CENTER-X RADIUS-X) 
			   TOP-Y (- CENTER-Y RADIUS-Y) 
			   BOTTOM-Y (+ CENTER-Y RADIUS-Y))
		     (AND (OR (> RADIUS-X TV-PICTURE-HALF-X) (> RADIUS-Y TV-PICTURE-HALF-Y))
			  (ERRBREAK CHECKER '"AREA TOO LARGE"))))
	    ;;THE RECTANGULAR AREA SPECIFIED BY THE NUMBERS BELOW INCLUDES THE TOP,
	    ;;BOTTOM, LEFT & RIGHT MOST POINTS.
	    (APPEND (RECTANGLE-WITHIN-BOUNDS CHECKER OUT-OF-BOUNDS-ERROR?
					     TOP-Y BOTTOM-Y LEFT-X RIGHT-X)
		    (LIST CENTER-X CENTER-Y))))

(DEFUN RECTANGLE-WITHIN-BOUNDS (CHECKER OUT-OF-BOUNDS-ERROR? TOP-Y BOTTOM-Y LEFT-X RIGHT-X)
       (COND ((< LEFT-X TV-PICTURE-LEFT)
	      (SETQ LEFT-X (COND (OUT-OF-BOUNDS-ERROR?
				  (ERRBREAK CHECKER "Area off the Left side of the screen"))
				 (TV-PICTURE-LEFT)))))
       (COND ((> RIGHT-X TV-PICTURE-RIGHT)
	      (SETQ RIGHT-X (COND (OUT-OF-BOUNDS-ERROR?
				   (ERRBREAK CHECKER "Area off the Right side of the screen"))
				  (TV-PICTURE-RIGHT)))))
       (COND ((< TOP-Y TV-PICTURE-TOP)
	      (SETQ TOP-Y (COND (OUT-OF-BOUNDS-ERROR?
				 (ERRBREAK CHECKER "Area off the Top of the screen"))
				(TV-PICTURE-TOP)))))
       (COND ((> BOTTOM-Y TV-PICTURE-BOTTOM)
	      (SETQ BOTTOM-Y (COND (OUT-OF-BOUNDS-ERROR?
				    (ERRBREAK CHECKER "Area off the Bottom of the screen"))
				   (TV-PICTURE-BOTTOM)))))
       	    (LIST TOP-Y BOTTOM-Y LEFT-X RIGHT-X))

;;THE DIMENSIONS ARE STORED IN THE ARRAY SO THAT GETWINDOWS CAN RECREATE A
;;TWO-DIMESIONAL ARRAY FROM THE ONE DIMENSIONAL ARRAY RETURNED BY LOADARRAYS.


(let ((si:*all-free-interpreter-variable-references-special* T))
  (SETQ WINDOW-INFO-TAIL '(- W I N D O W - I N F O) 
      WINDOW-PICTURE-TAIL '(- W I N D O W - P I C T U R E) 
      [COLOR WINDOW-PALETTE-TAIL '(- W I N D O W - P A L E T T E)
	     WINDOW-SILHOUETTE-TAIL '(- W I N D O W - S I L H O U E T T E)
             RUN-COUNTER-SHIFT 4.
             MINUS-RUN-COUNTER-SHIFT (- RUN-COUNTER-SHIFT)
             RUN-COLOR-MASK (1- (LSH 1. RUN-COUNTER-SHIFT))
             RUN-MAX (LSH 1. 14.)
             RUN-ESTIMATE 10.
             WINDOW-BLOAT 100.]
      WINDOW-INFO-DIMENSION 8.))

(DEFUN MAKEWINDOW-STORE (TOP BOTTOM LEFT RIGHT)
       (LET ((HEIGHT (1+ (- BOTTOM TOP)))
	     (WIDTH (1+ (- RIGHT LEFT))))
	    (LET ((WINDOW-ARRAY (MAKEWINDOW-CREATE-ARRAY WIDTH HEIGHT)))
		  [(OR BW (AND COLOR S3600))
                   (SEND TVRTLE-WINDOW ':BITBLT-FROM-SHEET IOR WIDTH HEIGHT
                         LEFT TOP WINDOW-ARRAY 0. 0.)]
		  [(AND COLOR (NOT S3600))
                   (BITBLT IOR WIDTH HEIGHT
                           TVRTLE-SCREEN-ARRAY LEFT TOP
                           WINDOW-ARRAY 0. 0.)]
		 WINDOW-ARRAY)))

(DEFUN MAKEWINDOW-CREATE-ARRAY (WIDTH HEIGHT)
       ;; Pixel arrays for BITBLT have this funny restriction that the rows be word aligned.
       ;; The first dimension must be a multiple of (// 32. BITS-PER-ARRAY-ELEMENT).
         (make-pixel-array (next-highest-multiple screen-array-dimension-multiple width)
			   height
			   ':type screen-array-type))

(DEFUN NEXT-HIGHEST-MULTIPLE (MULTIPLE DESTINATION)
       ;; The next highest number equal or above DESTINATION which is a multiple of MULTIPLE.
       (* MULTIPLE (// (1- (+ DESTINATION MULTIPLE)) MULTIPLE)))


(DEFUN MAKEWINDOW-ARRAY (WINDOW-NAME HOME-X HOME-Y TOP-Y BOTTOM-Y LEFT-X RIGHT-X) 
       (LET ((WINDOW-INFO (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-INFO-TAIL)))
	     (WINDOW-PICTURE (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-PICTURE-TAIL)))
             [COLOR 
              (WINDOW-PALETTE (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-PALETTE-TAIL)))
	      (WINDOW-SILHOUETTE
	       (MAKNAM (NCONC (EXPLODEC WINDOW-NAME) WINDOW-SILHOUETTE-TAIL)))])
	    (COND ((MINUSP TOP-Y)
		   ;;EMPTY WINDOWS ARE MARKED BY HAVING THE FIRST WORD OF INFO ARRAY
		   ;;0.
		   (*ARRAY WINDOW-INFO 'FIXNUM 1.)
		   (*ARRAY WINDOW-PICTURE T 1. 1.)
                   [COLOR (*ARRAY WINDOW-PALETTE 'FIXNUM 1.)
			  (*ARRAY WINDOW-SILHOUETTE T 1. 1.)])
		  (T (*ARRAY WINDOW-INFO 'FIXNUM WINDOW-INFO-DIMENSION)
		     ;;LEFT, RIGHT, TOP AND BOTTOM RELATIVE TO HOME, SO THAT EASY
		     ;;TO COMPUTE NEW ONES WHEN MOVED TO NEW HOME.
		     [COLOR (FILLARRAY (*ARRAY WINDOW-PALETTE T 16.) #'PALETTE)]
		     (LET ((WINDOW-PICTURE-ARRAY
			    (MAKEWINDOW-STORE TOP-Y BOTTOM-Y LEFT-X RIGHT-X)))
			  (FSET WINDOW-PICTURE WINDOW-PICTURE-ARRAY)
			  [COLOR
			   (MAKEWINDOW-SILHOUETTE
			    WINDOW-SILHOUETTE
			    WINDOW-PICTURE-ARRAY
			    (pixel-array-width WINDOW-PICTURE-ARRAY)
			    (pixel-array-height WINDOW-PICTURE-ARRAY))]
			  (FILLARRAY WINDOW-INFO
				     (LIST (pixel-array-width WINDOW-PICTURE-ARRAY)
					   (pixel-array-height WINDOW-PICTURE-ARRAY)
					   HOME-X
					   HOME-Y
					   (- TOP-Y HOME-Y)
					   (- BOTTOM-Y HOME-Y)
					   (- LEFT-X HOME-X)
					   (- RIGHT-X HOME-X))))))
	    ;;THE WINDOW PROPERTY OF ATOM IS LIST OF THE TWO ARRAYS.
	    (PUTPROP WINDOW-NAME
		     (LIST WINDOW-INFO
			   WINDOW-PICTURE
			   [COLOR WINDOW-PALETTE WINDOW-SILHOUETTE])
		     'WINDOW)))

(DEFUN MAKEWINDOW-VISIBLE (WINDOW-NAME TV-TOP TV-BOTTOM TV-LEFT TV-RIGHT
			   TV-CENTER-X TV-CENTER-Y) 
       ;;TAKING THE HOME AND BOUNDARIES IN TV COORDINATES, THIS COMPUTES THE EXTREMES OF
       ;;THE AREA IN WHICH CRUD IS ACTUALLY VISIBLE ON THE SCREEN, AND SAVES THE
       ;;STUFF IN THAT AREA.
       (DO ((TRAVEL-Y TV-TOP (1+ TRAVEL-Y))
	    ;;"VISIBLE" VARIABLES MARK EXTREMES OF VISIBLE AREA.  TOP, BOTTOM
	    ;;INITIALIZED TO IMPOSSIBLE VALUE, LEFT & RIGHT INITIALIZED TO EACH
	    ;;OTHER.
	    (VISIBLE-TOP -1.)
	    (VISIBLE-BOTTOM -1.)
	    (VISIBLE-RIGHT TV-LEFT)
	    (VISIBLE-LEFT TV-RIGHT)
	    (FIRST-VISIBLE)
	    ;;FIRST AND LAST VISIBLE POINTS IN A GIVEN LINE.
	    (LAST-VISIBLE))
	   ((> TRAVEL-Y TV-BOTTOM)
	    (MAKEWINDOW-ARRAY WINDOW-NAME
			      TV-CENTER-X
			      TV-CENTER-Y
			      VISIBLE-TOP
			      VISIBLE-BOTTOM
			      VISIBLE-LEFT
			      VISIBLE-RIGHT))
	   (COND ((> (SETQ FIRST-VISIBLE (+ TV-LEFT (RUNAWAY-FORWARD TV-LEFT 
								     TRAVEL-Y 
								     [BW 0.] 
								     [COLOR *ERASERNUMBER])))
		     ;;IS WHOLE LINE CLEAR IN AREA WITHIN WINDOW BOUNDS?
		     TV-RIGHT))
		 ((SETQ VISIBLE-BOTTOM TRAVEL-Y)
		  ;;IF NOT, THIS IS THE LOWEST LINE SO FAR WITH ANYTHING ON IT.
		  (COND ((MINUSP VISIBLE-TOP)
			 ;;IF WE HAVEN'T HIT ANYTHING SO FAR IN DOWNWARD SCAN.
			 (SETQ VISIBLE-TOP TRAVEL-Y)))
		  (COND ((< FIRST-VISIBLE VISIBLE-LEFT)
			 ;;IF TO LEFT OF LEFTMOST POINT SO FAR. 
			 (SETQ VISIBLE-LEFT FIRST-VISIBLE)))
		  (COND ((> (SETQ LAST-VISIBLE (- TV-RIGHT
						  (RUNAWAY-BACKWARD TV-RIGHT 
								    TRAVEL-Y 
								    [BW 0.]
								    [COLOR *ERASERNUMBER])))
			    VISIBLE-RIGHT)
			 (SETQ VISIBLE-RIGHT LAST-VISIBLE)))))))

[COLOR 
(DEFUN MAKEWINDOW-SILHOUETTE (WINDOW-SILHOUETTE PICTURE-ARRAY PICTURE-X-DIM PICTURE-Y-DIM)
       ;; An array just like the picture array except that wherever the
       ;; picture has a color different than the erasercolor, we put all ones.
       ;; This is used to mask out a region for the picture.
       (FSET WINDOW-SILHOUETTE
	     (make-pixel-array picture-x-dim picture-y-dim
			       ':type (ARRAY-TYPE TVRTLE-SCREEN-ARRAY)))
       (LET ((SILHOUETTE-ARRAY (FSYMEVAL WINDOW-SILHOUETTE))
	     (ALL-ONES-PIXEL (1- COLOR-MAX)))
	    (DO ((X-INDEX 0. (1+ X-INDEX)))
		((= X-INDEX PICTURE-X-DIM))
		(DO ((Y-INDEX 0. (1+ Y-INDEX)))
		    ((= Y-INDEX PICTURE-Y-DIM))
		    (COND ((NOT (= (ar-2-reverse PICTURE-ARRAY X-INDEX Y-INDEX) *ERASERNUMBER))
			   (as-2-reverse ALL-ONES-PIXEL SILHOUETTE-ARRAY X-INDEX Y-INDEX)))))))]
;;*PAGE


(DEFINE MAKEWINDOW (ABB MW) ARGS 
	(OR (SYMBOLP (ARG 1.))
	    (SETARG 1. (ERRBREAK 'MAKEWINDOW (LIST (ARG 1.) '"IS NOT A VALID NAME"))))
	(INTERNAL-WINDOW (ARG 1.) (RECTANGLE-SPEC 'MAKEWINDOW (LISTIFY (- 1. ARGS)))))

(DEFUN INTERNAL-WINDOW (WINDOW-NAME RECTANGLE) 
       (COND (*WINDOWOUTLINE 
              [COLOR (SELECT-COLOR *PENNUMBER)]
              (INTERNAL-WINDOWFRAME RECTANGLE)
              [COLOR (RESELECT-COLOR)]))
       (APPLY 'MAKEWINDOW-VISIBLE (CONS WINDOW-NAME RECTANGLE))
       ;;ADD TO LIST OF USER NAMED WINDOWS.
       (OR (MEMQ WINDOW-NAME *WINDOWS) (PUSH WINDOW-NAME *WINDOWS))
       (COND (*WINDOWOUTLINE 
              [COLOR (SELECT-COLOR *ERASERNUMBER)] 
              (INTERNAL-WINDOWFRAME RECTANGLE)
              [COLOR (RESELECT-COLOR)]))
       WINDOW-NAME)

(DEFINE WINDOWHOME (ABB WH) ARGS 
 ;;CHANGES THE CENTER LOCATION ASSOCIATED WITH A WINDOW.
 (LET
  ((WINDOW-ARRAY
    (COND ((MEMQ (ARG 1.) *WINDOWS) (FSYMEVAL (CAR (GET (ARG 1.) 'WINDOW))))
	  ((ERRBREAK 'WINDOWHOME (LIST (ARG 1.) '"IS NOT A WINDOW")))))
   (NEW-WINDOW-HOME-X *XCOR)
   (NEW-WINDOW-HOME-Y *YCOR))
  (COND ((= ARGS 1.))
	((= ARGS 2.) (SETQ NEW-WINDOW-HOME-X (FLOAT (CAR (ARG 2.))) 
			   NEW-WINDOW-HOME-Y (FLOAT (CADR (ARG 2.)))))
	((= ARGS 3.) (SETQ NEW-WINDOW-HOME-X (FLOAT (ARG 2.)) 
			   NEW-WINDOW-HOME-Y (FLOAT (ARG 3.)))))
  (COND ((OR *OFFSCREEN (NOT (OUT-OF-BOUNDS-CHECK NEW-WINDOW-HOME-X NEW-WINDOW-HOME-Y)))
         (ASET (TV-X NEW-WINDOW-HOME-X) WINDOW-ARRAY 2.)
         (ASET (TV-Y NEW-WINDOW-HOME-Y) WINDOW-ARRAY 3.))))
 NO-VALUE)

[BW (DEFUN DISPLAYWINDOW-STORE (INFO-ARRAY PICTURE-ARRAY TOP BOTTOM LEFT RIGHT)
       (LET ((HEIGHT (1+ (- BOTTOM TOP)))
	     (WIDTH (1+ (- RIGHT LEFT))))
	    ;; BITBLT operation does clipping...
	    (SEND TVRTLE-WINDOW ':BITBLT *DRAWMODE WIDTH HEIGHT
		  PICTURE-ARRAY 0. 0. LEFT TOP)))]

[COLOR 

;; CLIP feature of windows...

(DEFUN DISPLAYWINDOW-STORE (INFO-ARRAY PICTURE-ARRAY TOP BOTTOM LEFT RIGHT) 
       (LET ((PICTURE-START-X 0.)
	     (PICTURE-START-Y 0.))
	    (COND ((< BOTTOM TV-PICTURE-TOP))
		  ((> TOP TV-PICTURE-BOTTOM))
		  ((< RIGHT TV-PICTURE-LEFT))
		  ((> LEFT TV-PICTURE-RIGHT))
		   ;;These four conditions above indicate the entire picture is 
		   ;;out of the area, don't bother displaying it.
		   ;;If beyond bounds of display area, cut off at boundary.
		  (T (AND (> BOTTOM TV-PICTURE-BOTTOM) (SETQ BOTTOM TV-PICTURE-BOTTOM))
		     (AND (> RIGHT TV-PICTURE-RIGHT) (SETQ RIGHT TV-PICTURE-RIGHT))
		     ;;IF GREATER THAN MAX TV COORDINATE, JUST STOP WHEN YOU GET TO EDGE.
		     (AND (< TOP TV-PICTURE-TOP)
			  (INCREMENT PICTURE-START-Y (- TV-PICTURE-TOP TOP))
			  (SETQ TOP TV-PICTURE-TOP))
		     ;;IF LESS THAN MIN, YOU'VE GOT TO START IN THE MIDDLE
		     ;;OF THE WINDOW ARRAY.
		     (AND (< LEFT TV-PICTURE-LEFT)
			  (SETQ PICTURE-START-X (- TV-PICTURE-LEFT LEFT) 
				LEFT TV-PICTURE-LEFT))))
	    (DISPLAYWINDOW-STORE-PICTURE PICTURE-ARRAY PICTURE-START-X PICTURE-START-Y
					 TOP BOTTOM LEFT RIGHT)))
(DEFUN DISPLAYWINDOW-STORE-PICTURE
       (PICTURE-ARRAY PICTURE-START-X PICTURE-START-Y TOP BOTTOM LEFT RIGHT)
       (LET ((HEIGHT (1+ (- BOTTOM TOP)))
	     (WIDTH (1+ (- RIGHT LEFT))))
	    [(OR BW (AND COLOR S3600))
             (SEND TVRTLE-WINDOW ':BITBLT *DRAWMODE
                   WIDTH HEIGHT PICTURE-ARRAY PICTURE-START-X PICTURE-START-Y LEFT TOP)]
	    [(AND COLOR (NOT S3600))
             (BITBLT *DRAWMODE WIDTH HEIGHT
                     PICTURE-ARRAY PICTURE-START-X PICTURE-START-Y
                     TVRTLE-SCREEN-ARRAY LEFT TOP)]))]


[BW 

(DEFINE DISPLAYWINDOW (ABB DW) (&REST ARGS) (APPLY 'DISPLAYWINDOW-ARGS ARGS))

(DEFUN DISPLAYWINDOW-ARGS (&REST ARGS)
       (LET ((WINDOW-PROP (GET (CAR ARGS) 'WINDOW))
	     (NUMBER-OF-ARGS (LENGTH ARGS)))
	    (COND ((NULL WINDOW-PROP)
		   (SETQ WINDOW-PROP
			 (ERRBREAK 'DISPLAYWINDOW (LIST (CAR ARGS) '"IS NOT A WINDOW")))))
	    (LET ((WINDOW-INFO (FSYMEVAL (CAR WINDOW-PROP)))
		  (WINDOW-PICTURE (FSYMEVAL (CADR WINDOW-PROP)))
		  (HOME-X 0.)
		  (HOME-Y 0.))
		 (COND ((ZEROP (ARRAYCALL FIXNUM WINDOW-INFO 0.)))
		       ;;IS WINDOW EMPTY?
		       (T (COND ((= NUMBER-OF-ARGS 1.)
				 (SETQ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 2.)
				       HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 3.)))
				((= NUMBER-OF-ARGS 3.)
				 (SETQ HOME-X (TV-X (FLOAT (CADR ARGS)))
				       HOME-Y (TV-Y (FLOAT (CADDR ARGS)))))
				((ERRBREAK 'DISPLAYWINDOW
					   '"WRONG NUMBER OF ARGS TO WINDOW FUNCTION")))
			  (ERASE-TURTLES)
			  ;;Turtle hidden during execution of window commands.
			  (DISPLAYWINDOW-TV WINDOW-INFO WINDOW-PICTURE HOME-X HOME-Y)
			  (DRAW-TURTLES)))))) 

;;END OF BLACK AND WHITE CONDITIONAL SECTION.
]

(DEFUN DISPLAYWINDOW-TV (WINDOW-INFO WINDOW-PICTURE HOME-X HOME-Y) 
       (DISPLAYWINDOW-STORE WINDOW-INFO 
                            WINDOW-PICTURE
			    (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 4.))
			    (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 5.))
			    (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 6.))
			    (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 7.))))
;;*PAGE



[COLOR

(DEFUN DISPLAYWINDOW-COLOR (SHOW? &REST ARGS)
       (LET ((WINDOW-PROP (GET (CAR ARGS) 'WINDOW))
	     (NUMBER-OF-ARGS (LENGTH ARGS)))
	    (COND ((NULL WINDOW-PROP)
		   (SETQ WINDOW-PROP (ERRBREAK 'DISPLAYWINDOW-COLOR
					       (LIST (CAR ARGS) '"IS NOT A WINDOW")))))
	    (LET ((WINDOW-INFO (FSYMEVAL (CAR WINDOW-PROP)))
		  (WINDOW-PICTURE (FSYMEVAL (CADR WINDOW-PROP)))
		  (WINDOW-PALETTE (AND (CDDR WINDOW-PROP) (FSYMEVAL (CADDR WINDOW-PROP))))
		  (WINDOW-SILHOUETTE (AND (CDDR WINDOW-PROP) (FSYMEVAL (CADDDR WINDOW-PROP))))
		  (HOME-X 0.)
		  (HOME-Y 0.))
		 (COND ((ZEROP (ARRAYCALL FIXNUM WINDOW-INFO 0.)))
		       ;;IS WINDOW EMPTY?
		       (T (COND ((= NUMBER-OF-ARGS 1.)
				 (SETQ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 2.)
				       HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 3.)))
				((= NUMBER-OF-ARGS 3.)
				 (SETQ HOME-X (TV-X (FLOAT (CADR ARGS)))
				       HOME-Y (TV-Y (FLOAT (CADDR ARGS)))))
				((ERRBREAK 'DISPLAYWINDOW-COLOR
					   '"WRONG NUMBER OF ARGS TO WINDOW FUNCTION")))
			  (ERASE-TURTLES)
			  ;;Hide the turtle during execution of window display command.
			  (COND (WINDOW-PALETTE
				 (DISPLAYWINDOW-TV-COLOR SHOW?
							 WINDOW-INFO
							 WINDOW-PICTURE
							 WINDOW-PALETTE
							 WINDOW-SILHOUETTE
							 HOME-X
							 HOME-Y))
				;;If there is a palette, its a color window,
				;;else a black and white window.
				((DISPLAYWINDOW-TV WINDOW-INFO WINDOW-PICTURE HOME-X HOME-Y)))
			  (DRAW-TURTLES)))))) 

(DEFUN DISPLAYWINDOW-TV-COLOR 
       (SHOW? WINDOW-INFO WINDOW-PICTURE WINDOW-PALETTE WINDOW-SILHOUETTE HOME-X HOME-Y)
       (DISPLAYWINDOW-STORE-COLOR SHOW?  
                                  WINDOW-PICTURE
                                  WINDOW-PALETTE
				  WINDOW-SILHOUETTE
    			          (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 4.))
			          (+ HOME-Y (ARRAYCALL FIXNUM WINDOW-INFO 5.))
			          (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 6.))
			          (+ HOME-X (ARRAYCALL FIXNUM WINDOW-INFO 7.))))

(DEFUN DISPLAYWINDOW-STORE-COLOR
       (SHOW? PICTURE-ARRAY PALETTE-ARRAY SILHOUETTE-ARRAY TOP BOTTOM LEFT RIGHT) 
       (LET ((PICTURE-START-X 0.)
	     (PICTURE-START-Y 0.))
	    (COND ((< BOTTOM TV-PICTURE-TOP))
		  ((> TOP TV-PICTURE-BOTTOM))
		  ((< RIGHT TV-PICTURE-LEFT))
		  ((> LEFT TV-PICTURE-RIGHT))
		   ;;These four conditions above indicate the entire picture is 
		   ;;out of the area, don't bother displaying it.
		   ;;If beyond bounds of display area, cut off at boundary.
		  (T (AND (> BOTTOM TV-PICTURE-BOTTOM) (SETQ BOTTOM TV-PICTURE-BOTTOM))
		     (AND (> RIGHT TV-PICTURE-RIGHT) (SETQ RIGHT TV-PICTURE-RIGHT))
		     ;;IF GREATER THAN MAX TV COORDINATE, JUST STOP WHEN YOU GET TO EDGE.
		     (AND (< TOP TV-PICTURE-TOP)
			  (INCREMENT PICTURE-START-Y (- TV-PICTURE-TOP TOP))
			  (SETQ TOP TV-PICTURE-TOP))
		     ;;IF LESS THAN MIN, YOU'VE GOT TO START IN THE MIDDLE
		     ;;OF THE WINDOW ARRAY.
		     (AND (< LEFT TV-PICTURE-LEFT)
			  (SETQ PICTURE-START-X (- TV-PICTURE-LEFT LEFT) 
				LEFT TV-PICTURE-LEFT))))
	    (DISPLAYWINDOW-STORE-PICTURE-COLOR SHOW? 
					       PICTURE-ARRAY SILHOUETTE-ARRAY PALETTE-ARRAY
					       PICTURE-START-X PICTURE-START-Y
					       TOP BOTTOM LEFT RIGHT)))

(DEFUN DISPLAYWINDOW-STORE-PICTURE-COLOR
       (SHOW? PICTURE-ARRAY SILHOUETTE-ARRAY PALETTE-ARRAY PICTURE-START-X 
	PICTURE-START-Y TOP BOTTOM LEFT RIGHT)
       (LET ((HEIGHT (1+ (- BOTTOM TOP)))
	     (WIDTH (1+ (- RIGHT LEFT))))
	    [S3600 (SEND TVRTLE-WINDOW ':BITBLT ANDCA WIDTH HEIGHT
                         SILHOUETTE-ARRAY PICTURE-START-X PICTURE-START-Y
                         LEFT TOP)
                   (COND (SHOW? (SEND TVRTLE-WINDOW ':BITBLT IOR WIDTH HEIGHT
                                      PICTURE-ARRAY PICTURE-START-X PICTURE-START-Y
                                      LEFT TOP)))]
            [(NOT S3600)
             (BITBLT ANDCA WIDTH HEIGHT
                     SILHOUETTE-ARRAY PICTURE-START-X PICTURE-START-Y
                     TVRTLE-SCREEN-ARRAY LEFT TOP)
             (COND (SHOW? (BITBLT IOR WIDTH HEIGHT
                                  PICTURE-ARRAY PICTURE-START-X PICTURE-START-Y
                                  TVRTLE-SCREEN-ARRAY LEFT TOP)))]))

;;;END OF COLOR CONDITIONAL SECTION.
]

;;*PAGE


;;Should points in the current *ERASERCOLOR be saved in windows and restored
;;when redisplayed? For consistency with operation of the black and 
;;white system, and with treatment of eraser color as background, currently will
;;not redisplay points in eraser color.
;;Should HIDEWINDOW be treated as displaying all points not in the eraser color in 
;;the window in the current eraser color?
 
(DECLARE (SPECIAL WINDOWFRAME-BOUNDS))
(DEFINE WINDOWFRAME (ABB WF BOX) ARGS 
	;;DRAWS A BOX TO SHOW EXTENT OF RECTANGULAR AREA FOR WINDOW, XGP COMMANDS.
	(OR (AND (ZEROP ARGS) WINDOWFRAME-BOUNDS)
	    (SETQ WINDOWFRAME-BOUNDS (RECTANGLE-SPEC 'WINDOWFRAME (LISTIFY ARGS))))
	(INTERNAL-WINDOWFRAME WINDOWFRAME-BOUNDS))

(DEFUN INTERNAL-WINDOWFRAME (RECTANGLE-SPEC) 
       (LET ((TOP-Y (CAR RECTANGLE-SPEC))
	     (BOTTOM-Y (CADR RECTANGLE-SPEC))
	     (LEFT-X (CADDR RECTANGLE-SPEC))
	     (RIGHT-X (CADDDR RECTANGLE-SPEC))
             [BW (OLD-DRAWMODE (DRAWMODE XOR))])
	    (AND (OR (< LEFT-X TV-PICTURE-LEFT)
		     (> RIGHT-X TV-PICTURE-RIGHT)
		     (< TOP-Y TV-PICTURE-TOP)
		     (> BOTTOM-Y TV-PICTURE-BOTTOM))
		 (ERRBREAK 'WINDOWFRAME '"WINDOW FRAME OUT OF BOUNDS"))
	    (OR (= TOP-Y TV-PICTURE-TOP)
		(HORIZONTAL-LINE (1- LEFT-X) (1- TOP-Y) (1+ RIGHT-X)))
	    (OR (= BOTTOM-Y TV-PICTURE-BOTTOM)
		(HORIZONTAL-LINE (1- LEFT-X) (1+ BOTTOM-Y) (1+ RIGHT-X)))
	    (OR (= LEFT-X TV-PICTURE-LEFT)
		(VERTICAL-LINE (1- LEFT-X) TOP-Y BOTTOM-Y))
	    (OR (= RIGHT-X TV-PICTURE-RIGHT)
		(VERTICAL-LINE (1+ RIGHT-X) TOP-Y BOTTOM-Y))
	    [BW (DRAWMODE OLD-DRAWMODE)])
       NO-VALUE)
;;WINDOWS CAN BE SHOWN IN VARIOUS MODES.

[BW
 
 (DEFINE SHOWWINDOW (ABB SW) (&REST ARGS)
	 (LET ((OLD-DRAWMODE (DRAWMODE IOR)))
	      (APPLY 'DISPLAYWINDOW-ARGS ARGS)
	      (DRAWMODE OLD-DRAWMODE))
	 NO-VALUE) 
 
 (DEFINE HIDEWINDOW (ABB HW) (&REST ARGS)
	 (LET ((OLD-DRAWMODE (DRAWMODE ANDC)))
	      (APPLY 'DISPLAYWINDOW-ARGS ARGS)
	      (DRAWMODE OLD-DRAWMODE))
	 NO-VALUE) 
 
 (DEFINE XORWINDOW (ABB XW) (&REST ARGS)
	 (LET ((OLD-DRAWMODE (DRAWMODE XOR)))
	      (APPLY 'DISPLAYWINDOW-ARGS ARGS)
	      (DRAWMODE OLD-DRAWMODE))
	 NO-VALUE)
 
 ;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
 ]
[COLOR

(DEFINE SHOWWINDOW (ABB SW) (&REST ARGS) (LEXPR-FUNCALL 'DISPLAYWINDOW-COLOR T ARGS) NO-VALUE)

(DEFINE HIDEWINDOW (ABB HW) (&REST ARGS)
	(LEXPR-FUNCALL 'DISPLAYWINDOW-COLOR NIL ARGS)
	NO-VALUE)

(DEFINE XORWINDOW (ABB XW) (&REST ARGS) 
        (NOT-IMPLEMENTED-IN-COLOR (CONS 'XORWINDOW (LISTIFY ARGS))))

(DEFINE DISPLAYWINDOW (ABB DW) (&REST ARGS)
	(LEXPR-FUNCALL 'DISPLAYWINDOW-COLOR (NOT *ERASERSTATE) ARGS)
	NO-VALUE)

;;;END OF COLOR CONDITIONAL SECTION.
]

(DEFINE ERASEWINDOW (ABB EW) (WINDOW-NAME) 
	(OR (MEMQ WINDOW-NAME *WINDOWS)
	    (ERRBREAK 'ERASEWINDOW (LIST WINDOW-NAME '"IS NOT A WINDOW")))
	(REMPROP WINDOW-NAME 'WINDOW)
	(SETQ *WINDOWS (DELQ WINDOW-NAME *WINDOWS))
	(LIST '/; WINDOW-NAME 'ERASED))

(DEFINE FILLWINDOW (ABB FW) ARGS
        (ERASE-TURTLES)
        (LET ((RECTANGLE-SPEC (RECTANGLE-SPEC 'FILLWINDOW (LISTIFY ARGS))))
             (LET ((TOP-Y (CAR RECTANGLE-SPEC))
                   (BOTTOM-Y (CADR RECTANGLE-SPEC))
                   (LEFT-X (CADDR RECTANGLE-SPEC))
                   (RIGHT-X (CADDDR RECTANGLE-SPEC)))
		  [BW (SEND TVRTLE-WINDOW ':DRAW-RECTANGLE
			    (1+ (- RIGHT-X LEFT-X))
			    (1+ (- BOTTOM-Y TOP-Y))
			    LEFT-X
			    TOP-Y
			    *DRAWMODE)]
		  [COLOR (SEND TVRTLE-WINDOW ':DRAW-RECTANGLE
                               (1+ (- RIGHT-X LEFT-X))
                               (1+ (- BOTTOM-Y TOP-Y))
                               LEFT-X
                               TOP-Y
                               (- *SELECTED-COLOR))]))
        (DRAW-TURTLES)
        NO-VALUE)

(DEFINE ERASEWINDOWS (ABB EWS) NIL 
	(MAPC '(LAMBDA (WINDOW) (REMPROP WINDOW 'WINDOW)) *WINDOWS)
	(SETQ *WINDOWS NIL)
	'";ALL WINDOWS ERASED")

;;PUTS THE WINDOW AT THE CURRENT TURTLE LOCATION.

(DEFINE DISPLAY (WINDOW) (SHOWWINDOW WINDOW *XCOR *YCOR))

(DEFINE SNAP NIL (MAKEWINDOW (GENSYM)))



;;;		SAVING WINDOWS ON DISK FILES
;;;

(DEFINE SAVEWINDOWS (ABB SWS) (&REST &QUOTE FILENAME)
	(SETQ *SAVEWINDOWS
	      (MAPCAR '(LAMBDA (WINDOW)
			       (LIST WINDOW
				     (GET WINDOW 'WINDOW)
				     (MAPCAR 'FSYMEVAL (GET WINDOW 'WINDOW))))
		      *WINDOWS))
	(LET ((FILENAME (FILESPEC FILENAME "WINDOW")))
	     (SYS:DUMP-FORMS-TO-FILE FILENAME `((SETQ *SAVEWINDOWS ',*SAVEWINDOWS)))
	     FILENAME))




(DEFUN FILESPEC (FILENAME &OPTIONAL (DEFAULT-FN-2 '>))
       (COND ((CDR FILENAME) (FILESPEC-NAMELIST FILENAME DEFAULT-FN-2))
	     ((STRINGP (CAR FILENAME))
	      (FILESPEC-NAMESTRING (CAR FILENAME) DEFAULT-FN-2))
	     ((AND (LISTP (CAR FILENAME)) (EQ (CAAR FILENAME) 'QUOTE))
	      (FILESPEC-NAMELIST (CADAR FILENAME) DEFAULT-FN-2))
	     ((FILESPEC-NAMELIST (CAR FILENAME) DEFAULT-FN-2))))

(DEFUN FILESPEC-NAMESTRING (NAMESTRING DEFAULT-FN-2)
       (LET ((FILE (FS:PARSE-PATHNAME NAMESTRING)))
	    (COND ((OR (AND (SEND FILE ':TYPE) (NOT (EQ (SEND FILE ':TYPE) ':UNSPECIFIC)))
		       (SEND FILE ':VERSION))
		   FILE)
		  ((NUMBERP DEFAULT-FN-2)
		   (SEND FILE ':NEW-VERSION DEFAULT-FN-2))
		  ((SEND FILE ':NEW-TYPE DEFAULT-FN-2)))))

(DEFUN FILESPEC-NAMELIST (NAMELIST DEFAULT-FN-2)
       (COND ((SYMBOLP NAMELIST) (FILESPEC-NAMESTRING (GET-PNAME NAMELIST) DEFAULT-FN-2))
	     ((FILESPEC-NAMESTRING
	       (STRING-APPEND
		(GET-PNAME (CAR NAMELIST))
		(COND ((CDR NAMELIST)
		       (STRING-APPEND
			" "
			(GET-PNAME (CADR NAMELIST))
			(COND ((CDDR NAMELIST)
			       (STRING-APPEND
				" "
				(GET-PNAME (CADDR NAMELIST))
				(COND ((CDDDR NAMELIST)
				       (STRING-APPEND ":"
						      (GET-PNAME (CADDDR NAMELIST))
						      ";"))
				      (""))))
			      (""))))
		      ("")))
	       DEFAULT-FN-2))))

;;SAVEWINDOWS AND GETWINDOWS ALLOW WINDOWS TO BE SAVED ON THE DSK IN BINARY FORMAT,
;;RELOADED. 

(DEFINE GETWINDOWS (ABB GW GWS) (&REST &QUOTE FILENAME) 
	(LET ((FILENAME (FILESPEC FILENAME "WINDOW")))
	     (LOAD FILENAME)
	     (MAPC '(LAMBDA (WINDOW-LIST)
			    (LET ((WINDOW-NAME (CAR WINDOW-LIST))
				  (WINDOW-SYMBOLS (CADR WINDOW-LIST))
				  (WINDOW-VALUES (CADDR WINDOW-LIST)))
				 (PUTPROP WINDOW-NAME WINDOW-SYMBOLS 'WINDOW)
				 (MAPC 'FSET WINDOW-SYMBOLS WINDOW-VALUES)
				 (COND ((NOT (MEMQ WINDOW-NAME *WINDOWS))
					(PUSH WINDOW-NAME *WINDOWS)))))
		   *SAVEWINDOWS)
	     FILENAME))


(COMMENT SHADING)
;;;
;;THE SHADE PRIMITIVE SHADES IN AN AREA ENCLOSING THE TURTLE'S CURRENT LOCATION,
;;SPEICFYING A PATTERN AND OPTIONALY BOUNDARIES.  THE AREA IS BOUNDED BY PRESUMABLY
;;A CLOSED CURVE DRAWN BY THE TURTLE IN PENDOWN MODE.  A PATTERN IS SPECIFIED BY A
;;FUNCTION, WHICH GIVEN THE LOCATION TO BE SHADED, TELLS HOW TO SHADE THAT LOCATION. 
;;THE FUNCTION SHOULD ACCEPT TWO INTEGER ARGUMENTS, X [WORD] AND Y [BIT] SPECIFYING
;;A WORD IN THE TV MEMORY, AND RETURN A FIXNUM INDICATING THE STATE OF THE 32 BITS,
;;LEFT JUSTIFIED.
;;;
;;STARTING AT THE TURTLE'S LOCATION, SUCCESSIVE HORIZONTAL LINES ARE SHADED, UPWARDS
;;AND DOWNWARD, UNTIL THE ENTIRE FIGURE IS SHADED.  SINCE 32 BITS CAN BE SET AT ONCE
;;BY A SINGLE MEMORY WRITE, A HORIZONTAL SCANNING PROCESS RESULTS IN THE FASTEST
;;POSSIBLE SHADING.  SHADE-VERTICALLY INITIATES THE VERTICAL SCAN.  FOR EACH
;;HORIZONTAL LINE, STARTING AT A POINT KNOWN TO BE IN THE INTERIOR OF THE FIGURE, WE
;;SEARCH LEFT AND RIGHT UNTIL WE HIT THE BOUNDARY OF THE FIGURE.  LEFT-X AND RIGHT-X
;;ARE LAST INTERIOR POINTS BEFORE LEFT AND RIGHT BOUNDARY, RESPECTIVELY.  THE
;;PREVIOUS VALUES OF LEFT-X AND RIGHT-X FOR THE IMMEDIATELY LAST LINE SHADED ARE
;;ALWAYS KEPT AS SHADED-LEFT-X AND SHADED-RIGHT-X.  WHEN LEFT-X EXCEEDS THE LAST
;;VALUE OF SHADED-RIGHT-X, WE'VE HIT THE TOP OR BOTTOM BOUNDARY OF THE FIGURE, AND
;;VERTICAL SHADING IS TERMINATED.  THE NEXT HORIZONTAL LINE IS SHADED STARTING FROM
;;THE POINT IN THE COLUMN OF PREVIOUS LEFT-X.
;;;
;;THE SUBTLETLY IN THE PROGRAM CONSISTS OF TWO REFINEMENTS TO THE ABOVE NAIVE
;;PROCEDURE.  FIRST, WE HAVE TO BE ABLE TO SHADE "AROUND CORNERS".  THERE ARE 3
;;TYPES OF CORNERS THAT CAN OCCUR* [ASSUME SHADING IS PROCEDING UPWARD, POINTS ON
;;MARKED WITH "|".]
;;;
;;;         ||LEFT-X                RIGHT-X|||| NEW SCAN [UP]   ||
;;;         ||							||
;;;         ||SHADED-LEFT-X   ..INTERIOR...       SHADED-RIGHT-X||
;;;
;;;--------------------------------------------------------------------------------
;;ABOVE IS "S-TURN" -- NEW SCAN PROCEEDS IN SAME DIRECTION AS OLD.  BELOW ARE
;;"U-TURNS" SHADING PROCEEDS IN OPPOSITE DIRECTION.
;;;
;;;         ||LEFT-X                                         RIGHT-X||
;;;	    ||							    ||
;;;         ||SHADED-LEFT-X    SHADED-RIGHT-X||||| NEW SCAN [DOWN]  ||
;;;
;;;--------------------------------------------------------------------------------
;;;
;;;         ||LEFT-X  ..INTERIOR...                              RIGHT-X||
;;;	    ||                                                          ||
;;;         ||    NEW SCAN [DOWN]   ||||||SHADED-LEFT-X   SHADED-RIGHT-X||
;;;
;;;--------------------------------------------------------------------------------
;;;
;;EACH NEW SCAN CAUSED BY TURNING A CORNER CAUSES A RECURSIVE CALL TO
;;SHADE-VERTICALLY.  IT IS NOT NECESSARY TO DETECT THE FOURTH CASE, WHERE LEFT-X
;;INCREASES, SINCE THE SCAN IN THE NEXT LINE IS STARTED FROM LEFT-X. 
;;;
;;THE SHADING PROCESS MUST ALSO KEEP SOME INFORMATION ABOUT WHERE IT HAS BEEN.  IT
;;MUST KEEP TRACK OF WHAT AREAS HAVE ALREADY BEEN SHADED, SO THAT THE PROCESS CAN BE
;;TERMINATED WHEN SHADING AN AREA WITH HOLES, PREVENTING THE SCAN FROM CIRCLING THE
;;HOLE FOREVER.  SINCE AN ARBITRARY SHADING PATTERN MAY BE USED, NO INFORMATION ON
;;THE SCREEN CAN BE USED TO DETECT WHEN SCAN REACHES A PREVIOUSLY SHADED REGION. 
;;THE PROGRAM KEEPS TWO LISTS OF "OPEN" EDGES, WHICH MIGHT BE REACHED BY A VERTICAL
;;SCAN.  INITIALLY, AND WHEN A RECURSIVE CALL TO SHADE-VERTICALLY IS MADE, THE LAST
;;SHADED EDGE IS PUT ON THE LIST OF OPEN EDGES IN THE DIRECTION OF VERTICAL SHADING. 
;;EDGES ARE REMOVED WHEN SAFE, I.E.  WHEN THE CALL RETURNS.  THE LISTS ARE ORDERED
;;VERTICALLY, AND THE CLOSEST EDGE IS COMPUTED INITIALLY, TO SAVE SEARCHING THE
;;LIST.  AS THE VERTICAL SHADING PROCEEDS, IT IS CHECKED AGAINST THE OPPOSITE
;;DIRECTION OPEN EDGE, AND SHADING STOPS IF IT HITS. 
;;;

(DEFUN TV-OFF-SCREEN? (TV-X TV-Y)
       (OR (< TV-X TV-PICTURE-LEFT)
           (> TV-X TV-PICTURE-RIGHT)
           (< TV-Y TV-PICTURE-TOP)
           (> TV-Y TV-PICTURE-BOTTOM)))
(DECLARE (SPECIAL FUNCTION-PATTERN SHADING-PATTERN))
(DEFINE SHADE ARGS 
	(LET ([BW (OLD-DRAWMODE *DRAWMODE)]
	      (TV-XCOR (TV-X *XCOR))
	      (TV-YCOR (TV-Y *YCOR))
              (PATTERN))
             (COND ((TV-OFF-SCREEN? TV-XCOR TV-YCOR))
                   ;; Don't shade if the point is off screen.
                    ;;TURTLE HIDDEN DURING SHADING SO AS NOT TO MESS UP SEARCH FOR
                    ;;BOUNDARIES.  WILL REAPPEAR AFTER SHADING.
                   (T (ERASE-TURTLES)
		      ;;DEFAULT SHADING PATTERN IS SOLID.
		      (COND ((ZEROP ARGS)
			     (INTERNAL-SHADE #'SOLID TV-XCOR TV-YCOR))
			    ((SETQ PATTERN (GET (ARG 1.) 'WINDOW))
			     (SHADE-WINDOW-PATTERN PATTERN TV-XCOR TV-YCOR))
			    ((SETQ PATTERN (FSYMEVAL (ARG 1.)))
			     (COND ((SUBRP PATTERN)
				    (INTERNAL-SHADE PATTERN TV-XCOR TV-YCOR))
				   ((SHADE-FUNCTION-PATTERN (ARG 1.) TV-XCOR TV-YCOR))))
			    ((ERRBREAK 'SHADE (LIST (ARG 1.) '"IS NOT A SHADING PATTERN"))))
		      (DRAW-TURTLES)
		      [BW (DRAWMODE OLD-DRAWMODE)]))
	     NO-VALUE))
(DECLARE (SPECIAL PATTERN-INFO PATTERN-PICTURE PATTERN-PALETTE PATTERN-SILHOUETTE
		  PATTERN-PICTURE-SIZE-X PATTERN-PICTURE-SIZE-Y PATTERN-HOME-X
		  PATTERN-HOME-Y))
(DEFUN SHADE-WINDOW-PATTERN (WINDOW-PROP TV-XCOR TV-YCOR) 
       (LET ((PATTERN-INFO (FSYMEVAL (CAR WINDOW-PROP)))
	     (PATTERN-PICTURE (FSYMEVAL (CADR WINDOW-PROP)))
	     [COLOR (PATTERN-PALETTE (FSYMEVAL (CADDR WINDOW-PROP)))
		    (PATTERN-SILHOUETTE (FSYMEVAL (CADDDR WINDOW-PROP)))])
	    (LET ((PATTERN-PICTURE-SIZE-X (pixel-array-width PATTERN-PICTURE)
		   ;; (1+ (- (ARRAYCALL FIXNUM PATTERN-INFO 7.)
		   ;;   (ARRAYCALL FIXNUM PATTERN-INFO 6.)))
		   )
		  (PATTERN-PICTURE-SIZE-Y
		   (1+ (- (ARRAYCALL FIXNUM PATTERN-INFO 5.)
			  (ARRAYCALL FIXNUM PATTERN-INFO 4.))))
		  (PATTERN-HOME-X (ARRAYCALL FIXNUM PATTERN-INFO 2.))
		  (PATTERN-HOME-Y (ARRAYCALL FIXNUM PATTERN-INFO 3.)))
		 (INTERNAL-SHADE #'INVOKE-WINDOW-PATTERN TV-XCOR TV-YCOR))))
(DEFUN SHADE-FUNCTION-PATTERN (FUNCTION-PATTERN TV-XCOR TV-YCOR)
       (INTERNAL-SHADE (FUNCTION INVOKE-FUNCTION-PATTERN) TV-XCOR TV-YCOR))
(DEFUN INVOKE-FUNCTION-PATTERN (FROM-X FROM-Y TO-X)
       (FUNCALL FUNCTION-PATTERN FROM-X FROM-Y TO-X))
(DEFUN SHADE-HORIZONTAL-LINE (FROM-X FROM-Y TO-X)
       (FUNCALL SHADING-PATTERN FROM-X FROM-Y TO-X))
[BW  

(DEFUN RUNAWAY-FORWARD-BOUNDARY (START-X START-Y) (RUNAWAY-FORWARD START-X START-Y 1.))

(DEFUN RUNAWAY-BACKWARD-BOUNDARY (START-X START-Y) (RUNAWAY-BACKWARD START-X START-Y 1.))

;;;END OF BLACK-AND-WHITE CONDITIONAL SECTION.
] 

(DEFUN INTERNAL-SHADE (SHADING-PATTERN START-X START-Y) 
      (LET ((AREA-COLOR [COLOR (READ-TV-POINT-NUMBER START-X START-Y)]
                        [BW (COND ((READ-TV-POINT START-X START-Y)
                                   ;;Initial point on, shade in ERASER mode.
                                   (DRAWMODE ANDC)
                                   1.)
                                  ;;Off, draw shading in IOR mode. AREA-COLOR zero.
                                  (T (DRAWMODE IOR) 0.))]))
         [COLOR (COND ((= AREA-COLOR *PENNUMBER) (SELECT-COLOR *ERASERNUMBER)))]
         ;;If area is PENCOLOR, shade instead in ERASER mode.
       (LET ((INITIAL-LEFT (FIND-LEFT-BOUNDARY START-X START-Y AREA-COLOR))
             ;;Boundaries from starting point.
	     (INITIAL-RIGHT (FIND-RIGHT-BOUNDARY START-X START-Y AREA-COLOR)))
            ;;Shade the first line found.
            (SHADE-HORIZONTAL-LINE INITIAL-LEFT START-Y INITIAL-RIGHT)
            (LET ((INITIAL-EDGE (LIST START-Y INITIAL-LEFT INITIAL-RIGHT)))
                 (DO ((OPEN-SAME (LIST 'OPEN-POSITIVE INITIAL-EDGE))
                      ;;Lists of vertical scans yet to be performed, one
                      ;;of scans in the same direction as VERTICAL-DIRECTION,
                      ;;one opposite. The upward scans are ordered from top to
                      ;;bottom, the downward scans bottom to top.
                      (OPEN-OPPOSITE (LIST 'OPEN-NEGATIVE INITIAL-EDGE))
                      ;;Initial scan is in downward direction.
                      (VERTICAL-DIRECTION 1.)
                      (COMPARE-Y GREATER-SUBR)
                      (SCAN-EDGE))
                     ((COND ((NULL (CDR OPEN-SAME))
                             ;;No more scans to be done in this direction. If none
                             ;;in the other direction as well, stop. Else reverse
                             ;;directions.
                             (COND ((NULL (CDR OPEN-OPPOSITE)))
                                   (T (SETQ OPEN-OPPOSITE 
                                            (PROG1 OPEN-SAME 
                                                   (SETQ OPEN-SAME OPEN-OPPOSITE))
                                            VERTICAL-DIRECTION (- VERTICAL-DIRECTION)
                                            COMPARE-Y (COND ((EQ COMPARE-Y GREATER-SUBR)
                                                             LESS-SUBR)
                                                            (GREATER-SUBR)))
                                      NIL)))))
                     ;;Remove the edge to be scanned from the OPEN-SAME list,
                     ;;and send it off to start a vertical shading scan.
                     (SHADE-VERTICALLY (CADR (SETQ SCAN-EDGE (CADR OPEN-SAME))) 
                                       (CAR SCAN-EDGE) 
                                       (CADDR SCAN-EDGE)
                                       VERTICAL-DIRECTION  
                                       (RPLACD OPEN-SAME (CDDR OPEN-SAME))
                                       ;;Only pass along the part of the list
                                       ;;which will be past the start of the scan.
                                       (DO ((REST-OPEN OPEN-OPPOSITE (CDR REST-OPEN)))
                                           ((OR (NULL (CDR REST-OPEN))
                                                (FUNCALL COMPARE-Y
							 (CAADR REST-OPEN)
							 (CAR SCAN-EDGE)))
                                            REST-OPEN))
                                       AREA-COLOR))))))


;;*PAGE


(DEFUN OPEN-INCLUDE (OPEN-EDGE OPEN-LIST)
       [DEBUG-SHADE 
        (HORIZONTAL-LINE (CADR OPEN-EDGE) (CAR OPEN-EDGE) (CADDR OPEN-EDGE))]
       (RPLACD OPEN-LIST (CONS OPEN-EDGE (CDR OPEN-LIST))))

[DEBUG-SHADE (DEFUN SHADE-OPEN (LEFT Y RIGHT)
                    (DRAWMODE ANDC)
                    (HORIZONTAL-LINE LEFT Y RIGHT)
                    (DRAWMODE IOR)
                    (SHADE-HORIZONTAL-LINE LEFT Y RIGHT))]

;;These two functions start on a point assumed to be neighboring the border, 
;;return the next point in that direction which could be in the interior of a region.

[BW
    (DEFUN FIND-INTERIOR-FORWARD (INTERIOR-X INTERIOR-Y AREA-COLOR)
           ;;Increment the point to get onto the border, compute run from there.
           (+ (INCREMENT INTERIOR-X)
	      (RUNAWAY-FORWARD INTERIOR-X INTERIOR-Y (- 1. AREA-COLOR))))

    (DEFUN FIND-INTERIOR-BACKWARD (INTERIOR-X INTERIOR-Y AREA-COLOR)
           (- (DECREMENT INTERIOR-X) 
              (RUNAWAY-BACKWARD INTERIOR-X INTERIOR-Y (- 1. AREA-COLOR))))]

[COLOR
       (DEFUN FIND-INTERIOR-FORWARD (INTERIOR-X INTERIOR-Y INTERIOR-COLOR)
              (DO ((BORDER-COLOR 
                    (READ-TV-POINT-NUMBER (INCREMENT INTERIOR-X) INTERIOR-Y)
                    ;;The color of the next border region.
                    (READ-TV-POINT-NUMBER INTERIOR-X INTERIOR-Y)))
                  ((= BORDER-COLOR INTERIOR-COLOR) INTERIOR-X)
                  ;;Stop when the color is the same as the interior.
                  (SETQ INTERIOR-X 
                        (+ INTERIOR-X (RUNAWAY-FORWARD INTERIOR-X 
                                                       INTERIOR-Y 
                                                       BORDER-COLOR)))
                  (AND (> INTERIOR-X TV-PICTURE-RIGHT) (RETURN INTERIOR-X))))

       (DEFUN FIND-INTERIOR-BACKWARD (INTERIOR-X INTERIOR-Y INTERIOR-COLOR)
              (DO ((BORDER-COLOR 
                    (READ-TV-POINT-NUMBER (DECREMENT INTERIOR-X) INTERIOR-Y)
                    (READ-TV-POINT-NUMBER INTERIOR-X INTERIOR-Y)))
                  ((= BORDER-COLOR INTERIOR-COLOR) INTERIOR-X)
                  (SETQ INTERIOR-X 
                        (- INTERIOR-X (RUNAWAY-BACKWARD INTERIOR-X 
                                                        INTERIOR-Y 
                                                        BORDER-COLOR)))
                  (AND (< INTERIOR-X TV-PICTURE-LEFT) (RETURN INTERIOR-X))))]




;;*PAGE


(DEFUN SHADE-VERTICALLY (SHADED-LEFT SHADED-Y SHADED-RIGHT VERTICAL-DIRECTION
                         OPEN-SAME OPEN-OPPOSITE AREA-COLOR)
       ;;This function performs the vertical shading scan. The first 3 args
       ;;are a previously shaded edge from which to start. VERTICAL-DIRECTION is +1 
       ;;or -1. The OPEN variables are lists of pending vertical scans.
       [DEBUG-SHADE (SHADE-OPEN SHADED-LEFT SHADED-Y SHADED-RIGHT)]
       (DO ((TRAVEL-Y (+ SHADED-Y VERTICAL-DIRECTION))
            (STOP-Y (COND ((MINUSP VERTICAL-DIRECTION) (1- TV-PICTURE-TOP))
                          ((1+ TV-PICTURE-BOTTOM))))
            (LEFT-X) 
            (RIGHT-X) 
            (NONE-OPEN (NULL (CDR OPEN-OPPOSITE)))
            (OPEN-Y (AND (CDR OPEN-OPPOSITE) (CAADR OPEN-OPPOSITE)))
            (OPEN-LEFT (AND (CDR OPEN-OPPOSITE) (CADADR OPEN-OPPOSITE)))
            (OPEN-RIGHT (AND (CDR OPEN-OPPOSITE) (CADDR (CADR OPEN-OPPOSITE))))
            (MEET-OPEN NIL)
            (INTERIOR-X))
           ;;End the scan after meeting an open edge.
           (MEET-OPEN)
           (AND (= TRAVEL-Y STOP-Y) (RETURN T))
           ;;Stop if past legal display area.
           (DO NIL
               ;;This loop checks to see if scan meets the closest open edge.
               ((COND (NONE-OPEN)
                      ;;If none exist, or haven't yet reached closest Y value, 
                      ;;answer is NO.
                      ((NULL OPEN-Y) NIL)
                      ((NOT (= TRAVEL-Y OPEN-Y)))
                      ((AND (NOT (< SHADED-LEFT OPEN-LEFT))
                            (NOT (> SHADED-LEFT OPEN-RIGHT)))
                       ;;If within X values for open edge, answer is YES.
                       (SETQ MEET-OPEN T))))
               ;;Otherwise, we met an edge to the left or right of current scan
               ;;starting point. Pop it off and run the next one around the loop.
	       (POP OPEN-OPPOSITE)
               (COND ((SETQ NONE-OPEN (NULL (CDR OPEN-OPPOSITE))))
                     ((SETQ OPEN-Y (CAADR OPEN-OPPOSITE)
                            OPEN-LEFT (CADADR OPEN-OPPOSITE)
                            OPEN-RIGHT (CADDR (CADR OPEN-OPPOSITE))))))
           (COND (MEET-OPEN
                  ;;If we met an open edge, make the current edge the piece of
                  ;;the open edge from the start point of the scan.
                  (SETQ LEFT-X SHADED-LEFT RIGHT-X OPEN-RIGHT)
                  (COND ((> SHADED-LEFT OPEN-LEFT)
                         ;;If there's any piece of the open edge that still needs
                         ;;to be done, alter its RIGHT X component.
                         [DEBUG-SHADE
                          (SHADE-OPEN OPEN-LEFT OPEN-Y OPEN-RIGHT)
                          (HORIZONTAL-LINE OPEN-LEFT OPEN-Y (1- SHADED-LEFT))]
                         (AND (CDR OPEN-OPPOSITE)
			      (RPLACA (CDDADR OPEN-OPPOSITE) (1- SHADED-LEFT))))
                        ;;Otherwise, just remove the whole thing.
                        (T [DEBUG-SHADE 
                            (SHADE-OPEN (CADADR OPEN-OPPOSITE)
                                        (CAADR OPEN-OPPOSITE)
                                        (CADDR (CADR OPEN-OPPOSITE)))]
                           (AND (CDR OPEN-OPPOSITE)
				(RPLACD OPEN-OPPOSITE (CDDR OPEN-OPPOSITE))))))
                 (T (AND (> (SETQ LEFT-X 
                                  (FIND-LEFT-BOUNDARY SHADED-LEFT 
                                                      TRAVEL-Y 
                                                      AREA-COLOR))
                         ;;If scan for left boundary takes you past previous right
                         ;;boundary, you've hit the top or bottom boundary, stop.
                         SHADED-RIGHT)
                        (RETURN T))
                    ;;SEARCH FOR RIGHTMOST BOUNDARY OF FIGURE.  START FROM LEFT
          	    ;;BOUNDARY, OR IF PREVOUS LEFT BOUND WAS GREATER, START FROM THAT
                    ;;SINCE AREA BETWEEN THEM HAS BEEN SEARCHED BY FIND-LEFT-BOUNDARY.
                    (SETQ RIGHT-X
         		(FIND-RIGHT-BOUNDARY (COND ((> LEFT-X SHADED-LEFT) LEFT-X)
                                                   (SHADED-LEFT))
    				             TRAVEL-Y
        				     AREA-COLOR))
                    ;;DO THE ACTUAL SHADING.
	            (SHADE-HORIZONTAL-LINE LEFT-X TRAVEL-Y RIGHT-X)))
                  
          ;;Check for shading around turning corners.
          (COND ((< LEFT-X SHADED-LEFT)
                 ;;Shade LEFT U-turn.
                 (COND ((<= SHADED-LEFT TV-PICTURE-LEFT))
		       ((< (SETQ INTERIOR-X
                                 (FIND-INTERIOR-BACKWARD SHADED-LEFT 
                                                         SHADED-Y 
                                                         AREA-COLOR)) 
                           LEFT-X))
                       ;;If the next candidate for interior point is within
                       ;;the region, add a new open edge to scan the missing piece.
                       (T (OPEN-INCLUDE (LIST TRAVEL-Y LEFT-X INTERIOR-X) 
                                        OPEN-OPPOSITE)
                          ;;Since we added an edge, have to pop to keep in
                          ;;the same place.
                          (POP OPEN-OPPOSITE)))))
          ;;We need not check the s-turn case for left side, since the vertical
          ;;scan always crawls along the left side of the figure.
          (COND ((> RIGHT-X SHADED-RIGHT)
                 (COND ((>= SHADED-RIGHT TV-PICTURE-RIGHT))
		       ((> (SETQ INTERIOR-X 
                                 (FIND-INTERIOR-FORWARD SHADED-RIGHT 
                                                        SHADED-Y 
                                                        AREA-COLOR))
                           RIGHT-X))
                       (T (OPEN-INCLUDE (LIST TRAVEL-Y INTERIOR-X RIGHT-X) 
                                        OPEN-OPPOSITE)
                          (POP OPEN-OPPOSITE)))) 
                ((> SHADED-RIGHT RIGHT-X)
                 (COND ((>= RIGHT-X SHADED-RIGHT))
		       ((> (SETQ INTERIOR-X 
                                 (FIND-INTERIOR-FORWARD RIGHT-X 
                                                        TRAVEL-Y
                                                        AREA-COLOR))
                           SHADED-RIGHT))
                       ((OPEN-INCLUDE (LIST SHADED-Y INTERIOR-X SHADED-RIGHT) 
                                      OPEN-SAME)))))
          (SETQ SHADED-LEFT LEFT-X 
		SHADED-RIGHT RIGHT-X 
                SHADED-Y TRAVEL-Y
		TRAVEL-Y (+ TRAVEL-Y VERTICAL-DIRECTION))))


;;*PAGE

;;;
;;;			SHADING PATTERNS
;;;
;;PREDEFINED SHADING PATTERNS.  THE USER CAN ALSO SUPPLY NEW ONES.

(DEFINE SOLID (FROM-X FROM-Y TO-X)
	(HORIZONTAL-LINE FROM-X FROM-Y TO-X)) 


;; Shading code from BSG;QCOLOR.

(DEFVAR PATTERN-COLORS (make-array 6 ':type 'art-q))
(DEFVAR PATTERN-ON (make-pixel-array 128. 128. ':type 'art-1b))
(DEFVAR PATTERN-PIGNOSE (make-pixel-array 128. 128. ':type 'art-1b))
(DEFVAR PATTERN-DOTS (make-pixel-array 128. 128. ':type 'art-1b))
(DEFVAR PATTERN-LINES (make-pixel-array 128. 128. ':type 'art-1b))
(DEFVAR PATTERN-CIRCLES (make-pixel-array 128. 128. ':type 'art-1b))
(DEFVAR PATTERN-CHECKERS (make-pixel-array 128. 128. ':type 'art-1b))
(DEFVAR PIGNOSE-WORKARRAY (make-pixel-array 32. 8. ':type 'art-1b))

(comment
(DEFVAR PATTERN-COLORS (MAKE-ARRAY NIL 'ART-Q '(6)))
(DEFVAR PATTERN-ON (MAKE-ARRAY NIL 'ART-1B '(128. 128.)))
(DEFVAR PATTERN-PIGNOSE (MAKE-ARRAY NIL 'ART-1B '(128. 128.)))
(DEFVAR PATTERN-DOTS (MAKE-ARRAY NIL 'ART-1B '(128. 128.)))
(DEFVAR PATTERN-LINES (MAKE-ARRAY NIL 'ART-1B '(128. 128.)))
(DEFVAR PATTERN-CIRCLES (MAKE-ARRAY NIL 'ART-1B '(128. 128.)))
(DEFVAR PATTERN-CHECKERS (MAKE-ARRAY NIL 'ART-1B '(128. 128.)))
(DEFVAR PIGNOSE-WORKARRAY (MAKE-ARRAY NIL 'ART-1B '(32. 8.))))


;SET UP THE PATTERS FOR THE BLACK AND WHITE MONITOR
(DEFUN PATTERN-INIT ()
  (ASET PATTERN-ON PATTERN-COLORS 0)
  (ASET PATTERN-PIGNOSE PATTERN-COLORS 1)
  (ASET PATTERN-DOTS PATTERN-COLORS 2)
  (ASET PATTERN-LINES PATTERN-COLORS 3)
  (ASET PATTERN-CIRCLES PATTERN-COLORS 4)
  (ASET PATTERN-CHECKERS PATTERN-COLORS 5)
  (DOTIMES (Y 128.)(DOTIMES (X 128.)(as-2-reverse 1 PATTERN-ON X Y)))
  (PATTERN-FILL PATTERN-PIGNOSE '((1 1)(2 1)(3 1)(4 1)(5 1)
				  (0 2)(6 2)(0 3)(2 3)(4 3)(6 3)(0 4)(6 4)
				  (1 5)(2 5)(3 5)(4 5)(5 5)))
  (PATTERN-FILL PATTERN-DOTS '((3 2)(4 2)(2 3)(3 3)(4 3)(5 3)(2 4)(3 4)(4 4)(5 4)(3 5)
			       (4 5)))
  (PATTERN-FILL PATTERN-LINES '((3 0)(4 0)(3 1)(4 1)(3 2)(4 2)(3 3)(4 3)(3 4)(4 4)(3 5)(4 5)
				(3 6)(4 6)(3 7)(4 7)))
  (PATTERN-FILL PATTERN-CIRCLES '((3 0)(4 0)(1 1)(2 1)(5 1)(6 1)(1 2)(6 2)(0 3)(7 3)(0 4)
				  (7 4)(1 5)(6 5)(1 6)(6 6)(2 6)(5 6)(3 7)(4 7)))
  (PATTERN-FILL PATTERN-CHECKERS '((0 0)(1 0)(4 0)(5 0)(0 1)(1 1)(4 1)(5 1)(2 2)(3 2)(6 2)
				  (7 2)(2 3)(3 3)(6 3)(7 3)(0 4)(1 4)(4 4)(5 4)(0 5)(2 5)(4 5)
				  (5 5)(2 6)(3 6)(6 6)(7 6)(2 7)(3 7)(6 7)(7 7))))

(DEFUN PATTERN-FILL (ARRAY LIST)
  (DOTIMES (LX 4)
    (DOTIMES (X 8.)
      (DOTIMES (Y 8.)
	(as-2-reverse 0 PIGNOSE-WORKARRAY (+ (* 8. LX) X) Y)))
    (MAPC #'(LAMBDA (PAIR)
	      (as-2-reverse 1 PIGNOSE-WORKARRAY (+ (* 8 LX) (CAR PAIR))(CADR PAIR)))
	  LIST))
  (BITBLT TV:ALU-SETA 128. 128. PIGNOSE-WORKARRAY 0 0 ARRAY 0 0))

(DEFUN PIGNOSES (START-X START-Y STOP-X)
       (SEND TVRTLE-WINDOW ':BITBLT IOR (1+ (ABS (- STOP-X START-X))) 1.
		 PATTERN-PIGNOSE (\ START-X 128.) (\ START-Y 128.)
		 START-X START-Y))

(DEFUN LINES (START-X START-Y STOP-X)
       (SEND TVRTLE-WINDOW ':BITBLT IOR (1+ (ABS (- STOP-X START-X))) 1.
             PATTERN-LINES (\ START-X 128.) (\ START-Y 128.)
             START-X START-Y))

(DEFUN CHECKERS (START-X START-Y STOP-X)
       (SEND TVRTLE-WINDOW ':BITBLT IOR (1+ (ABS (- STOP-X START-X))) 1.
             PATTERN-CHECKERS (\ START-X 128.) (\ START-Y 128.)
             START-X START-Y))

(DEFUN CIRCLES (START-X START-Y STOP-X)
       (SEND TVRTLE-WINDOW ':BITBLT IOR (1+ (ABS (- STOP-X START-X))) 1.
             PATTERN-CIRCLES (\ START-X 128.) (\ START-Y 128.)
             START-X START-Y))

;;*PAGE


(DEFUN INVOKE-WINDOW-PATTERN (FROM-X FROM-Y TO-X) 
       ;;ACCESSES THE WINDOW ARRAY OF A USER SHADING PATTERN CORRECTLY SO AS TO
       ;;RETURN THE STATE OF THE 32 BITS OF THE TV WORD ACCESSED BY PATTERN-X AND
       ;;PATTERN-Y.  THE OTHER PARAMETERS ARE PECULIAR TO EACH WINDOW ARRAY, AND ARE
       ;;BOUND BY SHADE, ACCESSED GLOBALLY HERE.
       [BW (SEND TVRTLE-WINDOW ':BITBLT *DRAWMODE (1+ (- TO-X FROM-X)) 1.
		 PATTERN-PICTURE
		 (\ FROM-X PATTERN-PICTURE-SIZE-X)
		 (\ FROM-Y PATTERN-PICTURE-SIZE-Y)
		 FROM-X FROM-Y)]
       [COLOR (SEND TVRTLE-WINDOW ':BITBLT ANDC (1+ (- TO-X FROM-X)) 1.
		    PATTERN-SILHOUETTE
		    (\ FROM-X PATTERN-PICTURE-SIZE-X)
		    (\ FROM-Y PATTERN-PICTURE-SIZE-Y)
		    FROM-X FROM-Y)
	      (SEND TVRTLE-WINDOW ':BITBLT IOR (1+ (- TO-X FROM-X)) 1.
		    PATTERN-PICTURE
		    (\ FROM-X PATTERN-PICTURE-SIZE-X)
		    (\ FROM-Y PATTERN-PICTURE-SIZE-Y)
		    FROM-X FROM-Y)]) 










;;;; Expanding windows:

(let ((si:*all-free-interpreter-variable-references-special* T))
  (SETQ WINDOW-SIZE-X-INDEX 0.
      WINDOW-SIZE-Y-INDEX 1.
      WINDOW-HOME-X-INDEX 2.
      WINDOW-HOME-Y-INDEX 3.
      WINDOW-TOP-INDEX 4.
      WINDOW-BOTTOM-INDEX 5.
      WINDOW-LEFT-INDEX 6.
      WINDOW-RIGHT-INDEX 7.))

(DEFUN WINDOW-SIZE-X (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-SIZE-X-INDEX))
(DEFUN WINDOW-SIZE-Y (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-SIZE-Y-INDEX))
(DEFUN WINDOW-HOME-X (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-HOME-X-INDEX))
(DEFUN WINDOW-HOME-Y (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-HOME-Y-INDEX))
(DEFUN WINDOW-TOP (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-TOP-INDEX))
(DEFUN WINDOW-BOTTOM (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-BOTTOM-INDEX))
(DEFUN WINDOW-LEFT (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-LEFT-INDEX))
(DEFUN WINDOW-RIGHT (WINDOW-INFO) (ARRAYCALL FIXNUM WINDOW-INFO WINDOW-RIGHT-INDEX))

(DEFUN READ-WINDOW-POINT (WINDOW-INFO WINDOW-PICTURE POINT-X POINT-Y)
       (ar-2-reverse WINDOW-PICTURE POINT-X POINT-Y))

(DEFUN WRITE-WINDOW-POINT (WINDOW-INFO WINDOW-PICTURE POINT-X POINT-Y &OPTIONAL (VALUE 1))
       (as-2-reverse VALUE WINDOW-PICTURE POINT-X POINT-Y))

(DEFINE EXPAND (SMALL-WINDOW EXPANSION LARGE-WINDOW)
        (LET ((SMALL-INFO (FSYMEVAL (CAR (GET SMALL-WINDOW 'WINDOW))))
              (SMALL-PICTURE (FSYMEVAL (CADR (GET SMALL-WINDOW 'WINDOW))))
	      [COLOR (SMALL-PALETTE (FSYMEVAL (CADDR (GET SMALL-WINDOW 'WINDOW))))
		     (SMALL-SILHOUETTE (FSYMEVAL (CADDDR (GET SMALL-WINDOW 'WINDOW))))]
              (LARGE-INFO (MAKNAM (NCONC (EXPLODEC LARGE-WINDOW) WINDOW-INFO-TAIL)))
              (LARGE-PICTURE (MAKNAM (NCONC (EXPLODEC LARGE-WINDOW) 
                                            WINDOW-PICTURE-TAIL)))
	      [COLOR (LARGE-PALETTE (MAKNAM (NCONC (EXPLODEC LARGE-WINDOW)
						   WINDOW-PALETTE-TAIL)))
		     (LARGE-SILHOUETTE (MAKNAM (NCONC (EXPLODEC LARGE-WINDOW) 
						      WINDOW-SILHOUETTE-TAIL)))])
             (LET ((LARGE-ARRAYS (EXPAND-WINDOW SMALL-INFO SMALL-PICTURE EXPANSION)))
                  (FSET LARGE-INFO (CAR LARGE-ARRAYS))
                  (FSET LARGE-PICTURE (CADR LARGE-ARRAYS))
                  [COLOR (FSET LARGE-PALETTE (COPY-ARRAY SMALL-PALETTE))
			 (FSET LARGE-SILHOUETTE (CADDR LARGE-ARRAYS))]
                  (PUTPROP LARGE-WINDOW
			   (LIST LARGE-INFO
				 LARGE-PICTURE
				 [COLOR LARGE-PALETTE LARGE-SILHOUETTE])
			   'WINDOW)
		  (COND ((MEMQ LARGE-WINDOW *WINDOWS))
			(T (PUSH LARGE-WINDOW *WINDOWS)))
                  LARGE-WINDOW)))

(DEFUN COPY-ARRAY (ARRAY) (LEXPR-FUNCALL #'MAKE-ARRAY NIL (ARRAYDIMS ARRAY)))

;;*PAGE


(DEFUN EXPAND-WINDOW (SMALL-INFO SMALL-PICTURE EXPANSION)
       (LET ((LARGE-INFO (*ARRAY NIL 'FIXNUM WINDOW-INFO-DIMENSION)))
            (LET ((WINDOW-SIZE-X (1+
				  (- (ARRAYCALL FIXNUM SMALL-INFO WINDOW-RIGHT-INDEX)
				     (ARRAYCALL FIXNUM SMALL-INFO WINDOW-LEFT-INDEX))))
                  (WINDOW-SIZE-Y (1+
				  (- (ARRAYCALL FIXNUM SMALL-INFO WINDOW-BOTTOM-INDEX)
				     (ARRAYCALL FIXNUM SMALL-INFO WINDOW-TOP-INDEX)))))
                 (LET ((NEW-SIZE-X (1+ (* EXPANSION WINDOW-SIZE-X)))
                       (NEW-SIZE-Y (1+ (* EXPANSION WINDOW-SIZE-Y))))
                      (ASET NEW-SIZE-X LARGE-INFO WINDOW-SIZE-X-INDEX)
                      (ASET NEW-SIZE-Y LARGE-INFO WINDOW-SIZE-Y-INDEX)
            (ASET (AREF SMALL-INFO WINDOW-HOME-X-INDEX) LARGE-INFO WINDOW-HOME-X-INDEX)
            (ASET (AREF SMALL-INFO WINDOW-HOME-Y-INDEX) LARGE-INFO WINDOW-HOME-Y-INDEX)
            (ASET (- (* EXPANSION (AREF SMALL-INFO WINDOW-TOP-INDEX))
                     (LSH EXPANSION -1))
                  LARGE-INFO
                  WINDOW-TOP-INDEX)
            (ASET (+ (* EXPANSION (AREF SMALL-INFO WINDOW-BOTTOM-INDEX))
                     (COND ((ODDP EXPANSION) (LSH EXPANSION -1))
                           (T (1- (LSH EXPANSION -1)))))
                  LARGE-INFO
                  WINDOW-BOTTOM-INDEX)
            (ASET (- (* EXPANSION (AREF SMALL-INFO WINDOW-LEFT-INDEX))
                     (LSH EXPANSION -1))
                  LARGE-INFO
                  WINDOW-LEFT-INDEX)
            (ASET (+ (* EXPANSION (AREF SMALL-INFO WINDOW-RIGHT-INDEX))
                     (COND ((ODDP EXPANSION) (LSH EXPANSION -1))
                           (T (1- (LSH EXPANSION -1)))))
                  LARGE-INFO
                  WINDOW-RIGHT-INDEX)
            (LET ((LARGE-PICTURE (MAKEWINDOW-CREATE-ARRAY NEW-SIZE-X NEW-SIZE-Y))
		  [COLOR (LARGE-SILHOUETTE (MAKEWINDOW-CREATE-ARRAY NEW-SIZE-X NEW-SIZE-Y))])
		 (EXPAND-PICTURE SMALL-INFO 
				 SMALL-PICTURE
				 LARGE-INFO
				 LARGE-PICTURE
				 [COLOR LARGE-SILHOUETTE]
				 EXPANSION)
		 (LIST LARGE-INFO LARGE-PICTURE [COLOR LARGE-SILHOUETTE]))))))

(DEFUN EXPAND-PICTURE
       (SMALL-INFO SMALL-PICTURE LARGE-INFO LARGE-PICTURE [COLOR LARGE-SILHOUETTE] EXPANSION)
       (DO ((SMALL-Y 0. (1+ SMALL-Y))
            (SMALL-Y-STOP (- (WINDOW-BOTTOM SMALL-INFO) (WINDOW-TOP SMALL-INFO)))
            (SMALL-X-STOP (- (WINDOW-RIGHT SMALL-INFO) (WINDOW-LEFT SMALL-INFO)))
            (LARGE-Y 0. (+ LARGE-Y EXPANSION))
	    [COLOR (ALL-ONES (1- COLOR-MAX))])
           ((> SMALL-Y SMALL-Y-STOP) LARGE-PICTURE)
	   ;; Expand horizontally.
           (DO ((SMALL-X 0. (1+ SMALL-X))
                (LARGE-X 0. (+ LARGE-X EXPANSION))
		(WINDOW-POINT))
               ((> SMALL-X SMALL-X-STOP))
	       (SETQ WINDOW-POINT
		     (READ-WINDOW-POINT SMALL-INFO SMALL-PICTURE SMALL-X SMALL-Y))
	       (DO ((COPY-BIT 0. (1+ COPY-BIT)))
		   ((= COPY-BIT EXPANSION))
		   (WRITE-WINDOW-POINT LARGE-INFO
				       LARGE-PICTURE
				       (+ LARGE-X COPY-BIT)
				       LARGE-Y
				       WINDOW-POINT)
		   [COLOR
		    (COND ((NOT (= WINDOW-POINT *ERASERNUMBER))
			   (as-2-reverse ALL-ONES LARGE-SILHOUETTE (+ LARGE-X COPY-BIT) LARGE-Y)))]))
	   ;; Expand vertically by copying lines.
           (DO ((LARGE-COPY-Y 1. (1+ LARGE-COPY-Y))) 
               ((= LARGE-COPY-Y EXPANSION)) 
	       (DO ((TRAVEL-X 0 (1+ TRAVEL-X)))
		   ((= TRAVEL-X (WINDOW-SIZE-X LARGE-INFO)))
		   (as-2-reverse (ar-2-reverse LARGE-PICTURE TRAVEL-X LARGE-Y)
			 LARGE-PICTURE TRAVEL-X (+ LARGE-Y LARGE-COPY-Y))
		   [COLOR (as-2-reverse (ar-2-reverse LARGE-SILHOUETTE TRAVEL-X LARGE-Y)
				LARGE-SILHOUETTE TRAVEL-X (+ LARGE-Y LARGE-COPY-Y))]))))

               



;;;

(COMMENT 
;; Sketching ...

(DEFUN READ-EOF (FILE EOF-VALUE)
       (LET ((READ-RESULT (READ EOF-VALUE FILE))) 
            (COND ((NULL ^Q) EOF-VALUE) (READ-RESULT))))

(DEFINE READSKETCH (SKETCH-FILE) 
	;;SLURPS SKETCH MADE ON DM'S TABLET USING PROGRAM ON HENRY;SKETCH >.
	(CLEARSCREEN)
	(HIDETURTLE)
	(PENDOWN)
	;; (APPLY 'UREAD SKETCH-FILE)
	(DO ((SKETCH-FROM-X)
	     (SKETCH-FROM-Y)
	     (SKETCH-TO-X)
	     (SKETCH-TO-Y)
	     (^Q T)
	     (FILE (OPEN SKETCH-FILE '(IN)))
	     (END-OF-FILE -99999.0))
	    ((OR (= (SETQ SKETCH-FROM-X (READ-EOF FILE END-OF-FILE)) END-OF-FILE)
                 (= (SETQ SKETCH-FROM-Y (READ-EOF FILE END-OF-FILE)) END-OF-FILE)
                 (= (SETQ SKETCH-TO-X (READ-EOF FILE END-OF-FILE)) END-OF-FILE)
                 (= (SETQ SKETCH-TO-Y (READ-EOF FILE END-OF-FILE)) END-OF-FILE))
	     (CLOSE FILE)
	     (SETQ ^Q NIL))
	    ;;SLURP FOUR POINTS AND DRAW VECTOR.
            (COND (*WRAP (WRAP-VECTOR SKETCH-FROM-X SKETCH-FROM-Y SKETCH-TO-X SKETCH-TO-Y))
                  (*CLIP (CLIP-VECTOR SKETCH-FROM-X SKETCH-FROM-Y SKETCH-TO-X SKETCH-TO-Y))
                  ((BOUNDED-VECTOR SKETCH-FROM-X SKETCH-FROM-Y SKETCH-TO-X SKETCH-TO-Y))))
	NO-VALUE) 

)