(FILECREATED "18-AUG-83 16:25:47" {PHYLUM}<LISPCORE>SOURCES>FPOLY.;1
 12560  

      changes to:  (FNS CONNECTPOLYS POLYGONS RUNPOLYGONS DRAWPOLY1 RANDOMPT FIXPT SHOWLINES)
		   (VARS FPOLYCOMS CDELTA CYCLEMAX LINECNT LINEDELTA LINESTEP)
		   (RECORDS NPOINT)
		   (MACROS ADDDX)

      previous date: "17-AUG-83 18:09:49" {PHYLUM}<MASINTER>FPOLY.;1)


(* Copyright (c) 1983 by Xerox Corporation)

(PRETTYCOMPRINT FPOLYCOMS)

(RPAQQ FPOLYCOMS
 ((FNS FIXPT SHOWLINES RANDOMPT CONNECTPOLYS POLYGONS RUNPOLYGONS DRAWPOLY1)
		  (GLOBALVARS LASTPOLYGONFROMS LASTPOLYGONTOS POLYWINDOW)
		  (CONSTANTS GLOBALVARS WHITEBACKGROUNDFLG BLACKSHADE POLYGONWAIT POLYGONACTIVEMENU 
			     POLYGONMINPTS POLYGONMAXPTS POLYGONCONNECTEDFLG POLYGONSTEPS)
		  (VARS CDELTA CYCLEMAX LINECNT LINEDELTA LINESTEP)
		  (RECORDS NPOINT)
		  (MACROS ADDDX)))
(DEFINEQ

(FIXPT

  [LAMBDA (PT DX DY REG)                                     (* edited: "18-AUG-83 15:36")

    (PROG NIL
          (SETQ DX (IDIFFERENCE (IPLUS (fetch
 XCOORD of
 PT)
				       DX)
				HLINEDELTA))
          (if
 (OR (IGREATERP DX (fetch
 RIGHT of
 REG))
		  (ILESSP DX (fetch
 LEFT of
 REG)))
	      then
 (RETURN))
          (SETQ DY (IDIFFERENCE (IPLUS (fetch
 YCOORD of
 PT)
				       DY)
				HLINEDELTA))
          (if
 (OR (IGREATERP DY (fetch
 TOP of
 REG))
		  (ILESSP DY (fetch
 BOTTOM of
 REG)))
	      then
 (RETURN))
          (replace
 XCOORD of
 PT with
 DX)
          (replace
 YCOORD of
 PT with
 DY)
          (RETURN T])

(SHOWLINES

  [LAMBDA (W)                                                (* DECLARATIONS: FAST)

                                                             (* edited: "18-AUG-83 16:25")

    [COND
      ([NOT (WINDOWP (OR W (SETQ W POLYWINDOW]
	(SETQ POLYWINDOW (SETQ W (CREATEW]
    (DSPTEXTURE BLACKSHADE W)
    (DSPOPERATION (QUOTE ERASE)
		  W)
    (CLEARW W)
    (RESETLST (PROG ((LINES (to
 LINECNT collect
 NIL))
		     (DX1 (RAND 0 CDELTA))
		     (DX2 (RAND 0 CDELTA))
		     (DY1 (RAND 0 CDELTA))
		     (DY2 (RAND 0 CDELTA))
		     (REG (DSPCLIPPINGREGION NIL W))
		     (CYCLE1 0)
		     (CYCLE2 0)
		     (FROM
 (RANDOMPT
 W))
		     (TO
 (RANDOMPT
 W))
		     NEWX NEWY (HLD (QUOTIENT LINEDELTA 2))
		     (HCDELTA (QUOTIENT LINEDELTA 2))
		     (W (WINDOWPROP W (QUOTE DSP)))
		     PTS)
		    (NCONC LINES LINES)
		    (RESETSAVE NIL (LIST (FUNCTION RPLACD)
					 LINES))
		    (PROG NIL
		      DRAWLP
		          [if
 (CAR LINES)
			      then
                           (* ERASE OLD)

				   (SETQ PTS (CAR LINES))
				   (PROG (X1 X2 Y1 Y2)
				         (SETQ X1 (fetch
 (NPOINT XC) of
 (CAR PTS)))
				         (SETQ X2 (fetch
 (NPOINT XC) of
 (CADR PTS)))
				         (SETQ Y1 (fetch
 (NPOINT YC) of
 (CAR PTS)))
				         (SETQ Y2 (fetch
 (NPOINT YC) of
 (CADR PTS)))
				         (DRAWLINE X1 Y1 X2 Y2 1 (QUOTE INVERT)
						   W))
			    else
 (RPLACA LINES (SETQ PTS (LIST (create
 NPOINT)
							       (create
 NPOINT]
		          (PROG (X1 X2 Y1 Y2)
			        (SETQ X1 (fetch
 (NPOINT XC) of
 FROM))
			        (SETQ X2 (fetch
 (NPOINT XC) of
 TO))
			        (SETQ Y1 (fetch
 (NPOINT YC) of
 FROM))
			        (SETQ Y2 (fetch
 (NPOINT YC) of
 TO))
			        (DRAWLINE X1 Y1 X2 Y2 1 (QUOTE INVERT)
					  W))
		          (replace
 XC of
 (CAR PTS) with
 (fetch
 XC of
 FROM))
		          (replace
 YC of
 (CAR PTS) with
 (fetch
 YC of
 FROM))
		          (replace
 XC of
 (CADR PTS) with
 (fetch
 XC of
 TO))
		          (replace
 YC of
 (CADR PTS) with
 (fetch
 YC of
 TO))
		          (SETQ LINES (CDR LINES))
		          (PROG NIL
			        [COND
				  ((NOT (IGREATERP (SETQ CYCLE1 (SUB1 CYCLE1))
						   0))
				    (PROGN (ADDDX DX1)
					   (ADDDX DY1)
					   (SETQ CYCLE1 (RAND 2 CYCLEMAX]
			    TRYXAGAIN
			        (SETQ NEWX (IDIFFERENCE (IPLUS (fetch
 XC of
 FROM)
							       DX1)
							HLD))
			        (if
 (OR (IGREATERP NEWX (fetch
 RIGHT of
 REG))
					(ILESSP NEWX (fetch
 LEFT of
 REG)))
				    then
 (SETQ DX1 (RAND 0 LINEDELTA))
					 (GO TRYXAGAIN))
			    TRYYAGAIN
			        (SETQ NEWY (IDIFFERENCE (IPLUS (fetch
 YC of
 FROM)
							       DY1)
							HLD))
			        (if
 (OR (IGREATERP NEWY (fetch
 TOP of
 REG))
					(ILESSP NEWY (fetch
 BOTTOM of
 REG)))
				    then
 (SETQ DY1 (RAND 0 LINEDELTA))
					 (GO TRYYAGAIN))
			        (replace
 XC of
 FROM with
 NEWX)
			        (replace
 YC of
 FROM with
 NEWY))
		          (PROG NIL
			        [COND
				  ((NOT (IGREATERP (SETQ CYCLE2 (SUB1 CYCLE2))
						   0))
				    (PROGN (ADDDX DX2)
					   (ADDDX DY2))
				    (SETQ CYCLE2 (RAND 20 40]
			    TRYXAGAIN
			        (SETQ NEWX (IDIFFERENCE (IPLUS (fetch
 XC of
 TO)
							       DX2)
							HLD))
			        (if
 (OR (IGREATERP NEWX (fetch
 RIGHT of
 REG))
					(ILESSP NEWX (fetch
 LEFT of
 REG)))
				    then
 (SETQ DX2 (RAND 0 LINEDELTA))
					 (GO TRYXAGAIN))
			    TRYYAGAIN
			        (SETQ NEWY (IDIFFERENCE (IPLUS (fetch
 YC of
 TO)
							       DY2)
							HLD))
			        (if
 (OR (IGREATERP NEWY (fetch
 TOP of
 REG))
					(ILESSP NEWY (fetch
 BOTTOM of
 REG)))
				    then
 (SETQ DY2 (RAND 0 LINEDELTA))
					 (GO TRYYAGAIN))
			        (replace
 XC of
 TO with
 NEWX)
			        (replace
 YC of
 TO with
 NEWY))
		          (GO DRAWLP])

(RANDOMPT

  [LAMBDA (DS)                                               (* edited: "18-AUG-83 16:22")

    (PROG ((REG (DSPCLIPPINGREGION NIL DS)))
          (RETURN (create
 NPOINT
			  XC ←(RAND (fetch
 LEFT of
 REG)
				    (fetch
 RIGHT of
 REG))
			  YC ←(RAND (fetch
 BOTTOM of
 REG)
				    (fetch
 TOP of
 REG])

(CONNECTPOLYS

  [LAMBDA (FROMS TOS NSTEPS W)                               (* edited: "18-AUG-83 14:16")

    (PROG (DIFFS (XFROMS (COPY FROMS)))
          (CLEARW W)
          (DRAWPOLY1
 XFROMS 3 (COND
		       (WHITEBACKGROUNDFLG (QUOTE REPLACE))
		       (T (QUOTE ERASE)))
		     W)
          (DRAWPOLY1
 TOS 3 (COND
		       (WHITEBACKGROUNDFLG (QUOTE REPLACE))
		       (T (QUOTE ERASE)))
		     W)
          [SETQ DIFFS (for
 FPT in
 XFROMS as
 TPT in
 TOS
			 collect
 (DRAWBETWEEN FPT TPT 1 (COND
						(WHITEBACKGROUNDFLG (QUOTE REPLACE))
						(T (QUOTE ERASE)))
					      W)
				 (create
 POSITION
					 XCOORD ←(IDIFFERENCE (fetch
 XCOORD of
 TPT)
							      (fetch
 XCOORD of
 FPT))
					 YCOORD ←(IDIFFERENCE (fetch
 YCOORD of
 TPT)
							      (fetch
 YCOORD of
 FPT]
          (DISMISS 1500)
          (CLEARW W)
          (for
 I from
 1 to
 POLYGONSTEPS
	     do
 (DRAWPOLY1
 XFROMS 1 NIL W)
		[for
 PT in
 XFROMS as
 DIF in
 DIFFS as
 FROMPT in
 FROMS
		   do
 (replace
 XCOORD of
 PT with
 (IPLUS (fetch
 XCOORD of
 FROMPT)
							(IQUOTIENT (ITIMES (fetch
 XCOORD
									      of
 DIF)
									   I)
								   POLYGONSTEPS)))
		      (replace
 YCOORD of
 PT with
 (IPLUS (fetch
 YCOORD of
 FROMPT)
							(IQUOTIENT (ITIMES (fetch
 YCOORD
									      of
 DIF)
									   I)
								   POLYGONSTEPS]
	     finally
 (DRAWPOLY1
 XFROMS 1 T NIL W))
          (RETURN T])

(POLYGONS

  [LAMBDA (WHERE
)                                            (* edited: "18-AUG-83 14:08")

    (COND
      ((NOT (WINDOWP POLYWINDOW)
	    (SETQ POLYWINDOW (CREATEW)))
	(DSPTEXTURE BLACKSHADE POLYWINDOW)
	(DSPOPERATION (QUOTE ERASE)
		      POLYWINDOW)
	(CLEARW POLYWINDOW)))
    (RUNPOLYGONS
 POLYWINDOW])

(RUNPOLYGONS

  [LAMBDA (W)                                                (* edited: "18-AUG-83 14:12")

                                                             (* runs the current settings of polygon until a key is 

							     hit.)

    (bind
 NPOINTS
       do
 (SETQ NPOINTS (RAND POLYGONMINPTS POLYGONMAXPTS))
	  (CONNECTPOLYS
 (for
 I from
 1 to
 NPOINTS collect
 (RANDOMPT
 W))
			(for
 I from
 1 to
 NPOINTS collect
 (RANDOMPT
 W))
			POLYGONSTEPS W)
	  (DISMISS POLYGONWAIT])

(DRAWPOLY1

  [LAMBDA (PTLIST WIDTH OPERATION W)                         (* edited: "18-AUG-83 14:14")

                                                             (* draws a closed polygon of the points given If 

							     OPERATION is not given, use the one from the default 

							     DS.)

    [COND
      (PTLIST (bind
 (PTS ← PTLIST) while
 (CDDR PTS)
		 do
 (DRAWBETWEEN (CAR PTS)
				 (CADR PTS)
				 WIDTH OPERATION W)
		    (pop
 PTS)
		 finally
 (DRAWBETWEEN (CAR PTS)
				      (CAR PTLIST)
				      WIDTH OPERATION W]
    (BLOCK])
)
(DECLARE: DOEVAL@COMPILE DONTCOPY

(ADDTOVAR GLOBALVARS LASTPOLYGONFROMS LASTPOLYGONTOS POLYWINDOW)
)
(DECLARE: EVAL@COMPILE 

(RPAQQ GLOBALVARS
 (POLYGONSTEPS POLYGONWAIT POLYGONMINPTS POLYGONMAXPTS WHITEBACKGROUNDFLG 
				POLYGONCONNECTEDFLG LASTPOLYGONTOS LASTPOLYGONFROMS POINTSINPUT 
				SAVEDPOLYGONS SHOWMOVEMENTFLG POLYGONSFLASHWAIT RANDSTATE \TOL 
				LAFITE.FILE.TO.MONITOR.HARRAY LAFITE.FILE.TO.WINDOW.HARRAY \TEXTOFD 
				\TEXTFDEV SCROLLBARWIDTH SCROLLWAITTIME WAITBEFORESCROLLTIME 
				WAITBETWEENSCROLLTIME WAITINGCURSOR TOPW WINDOWUSERFORMS 
				ENDOFWINDOWUSERFORMS PROMPTWINDOW KNOWNWINDOWS GRAYSHADE WHITECOLOR 
				BLACKCOLOR SCREENHEIGHT SCREENWIDTH ScreenBitMap CursorBitMap 
				WHOLESCREEN LASTMOUSEX LASTMOUSEY LASTMOUSEBUTTONS LASTMOUSETIME 
				LASTKEYBOARD))

(RPAQQ WHITEBACKGROUNDFLG
 NIL)

(RPAQQ BLACKSHADE
 65535)

(RPAQQ POLYGONWAIT
 5000)

(RPAQQ POLYGONACTIVEMENU
 ((("AUTO-MODE" (RUNPOLYGONS (QUOTE {DISPLAYSTREAM}#5,36430))
					NIL)
			   ("Do One" (DOPOLYGON (QUOTE {DISPLAYSTREAM}#5,36430))
				     NIL)
			   ("Pause Time" (READPOLYNUMBER (QUOTE WAIT))
					 (SETQ POLYGONWAIT 5000))
			   ("Number Of Steps" (READPOLYNUMBER (QUOTE STEPS))
					      (SETQ POLYGONSTEPS 35))
			   ("Max Points" (READPOLYNUMBER (QUOTE MAX))
					 (SETQ POLYGONMAXPTS 9))
			   ("Min Points" (READPOLYNUMBER (QUOTE MIN))
					 (SETQ POLYGONMINPTS 3))
			   ("Movement" (COND (SHOWMOVEMENTFLG (SETQ SHOWMOVEMENTFLG NIL)
							      "Movement")
					     ((SETQ SHOWMOVEMENTFLG T)
					      "Don't Movement"))
				       (SETQ SHOWMOVEMENTFLG NIL))
			   ["REDRAW" (DRAWPOLYS LASTPOLYGONFROMS LASTPOLYGONTOS POLYGONSTEPS 
						POLYGONCONNECTEDFLG (QUOTE {DISPLAYSTREAM}#5,36430))
				     (PROGN [SETQ LASTPOLYGONFROMS (QUOTE ((210 . 637)
									   (471 . 493)
									   (72 . 319)
									   (470 . 146)
									   (225 . 46]
					    (SETQ LASTPOLYGONTOS (QUOTE ((431 . 635)
									 (96 . 491)
									 (419 . 370)
									 (125 . 172)
									 (527 . 61]
			   ("Not Connected" (COND (POLYGONCONNECTEDFLG (SETQ POLYGONCONNECTEDFLG NIL)
								       "Connected")
						  (T (SETQ POLYGONCONNECTEDFLG T)
						     "Not Connected"))
					    (SETQ POLYGONCONNECTEDFLG T))
			   ("FROM pts" (READPOLYGONPTS (QUOTE FROM)
						       {DISPLAYSTREAM}#5,36430)
				       NIL)
			   ("TO pts" (READPOLYGONPTS (QUOTE TO)
						     {DISPLAYSTREAM}#5,36430)
				     NIL)
			   ("White back" (CHANGE/POLYGONS/BACKGROUND {DISPLAYSTREAM}#5,36430)
					 (PROGN (SETQ WHITEBACKGROUNDFLG NIL)
						(DSPTEXTURE BLACKSHADE WINDOW)
						(DSPOPERATION (QUOTE ERASE)
							      WINDOW)))
			   ("Save Figure" (SAVECURRENTPOLYGONS)
					  NIL)
			   ("Retrieve Figure" (RETRIEVEPOLYGONS)
					      NIL)
			   ("Hardcopy" (HARDCOPYW {DISPLAYSTREAM}#5,36430)
				       NIL)
			   ("Stop" (QUOTE STOP)
				   NIL))
			  {MENU}#5,35154))

(RPAQQ POLYGONMINPTS
 3)

(RPAQQ POLYGONMAXPTS
 9)

(RPAQQ POLYGONCONNECTEDFLG
 T)

(RPAQQ POLYGONSTEPS
 32)

(CONSTANTS GLOBALVARS WHITEBACKGROUNDFLG BLACKSHADE POLYGONWAIT POLYGONACTIVEMENU POLYGONMINPTS 
	   POLYGONMAXPTS POLYGONCONNECTEDFLG POLYGONSTEPS)
)

(RPAQQ CDELTA
 6)

(RPAQQ CYCLEMAX
 10)

(RPAQQ LINECNT
 100)

(RPAQQ LINEDELTA
 20)

(RPAQQ LINESTEP
 20)
[DECLARE: EVAL@COMPILE 

(DATATYPE NPOINT
 ((XC BITS 16)
		  (YC BITS 16)))
]
[/DECLAREDATATYPE (QUOTE NPOINT)
		  (QUOTE ((BITS 16)
			  (BITS 16]
(DECLARE: EVAL@COMPILE 

(PUTPROPS ADDDX MACRO
 ((VAR)
		       (SETQ VAR (RAND 0 LINEDELTA))))
)
(PUTPROPS FPOLY COPYRIGHT ("Xerox Corporation" 1983))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (839 8957 (FIXPT 849 . 1570) (SHOWLINES 1572 . 5598) (RANDOMPT 5600 . 5952) (
CONNECTPOLYS 5954 . 7494) (POLYGONS 7496 . 7827) (RUNPOLYGONS 7829 . 8372) (DRAWPOLY1 8374 . 8955))))
)
STOP