reduce-historical/psl-1983/3-1/glisp/grtree.sl

% {DSK}GRTREE.PSL;11  4-FEB-83 16:48:01 





(GLOBAL '(GRAPHICSBOXTYPES))


% Tree Drawing Package. To test, do (DLT TX WW) where WW is a window. 





(GLISPOBJECTS


(BOXTYPE (ATOM (PROPLIST (DRAWPROGRAM ATOM)
			 (SIZEPROGRAM ATOM)))
MSG     ((DRAW BOXTYPE-DRAW OPEN T)
	 (ERASE BOXTYPE-ERASE OPEN T)
	 (SETSIZE BOXTYPE-SETSIZE OPEN T)))


(GRAPHICSBOX (LISTOBJECT (BOXTYPE BOXTYPE)
			 (START VECTOR)
			 (SIZE VECTOR)
			 (CONTENTSOFFSET VECTOR)
			 (DISPLAYCONTENTS ANYTHING)
			 (CONTENTSSIZE VECTOR))
MSG     ((DRAWIN GRAPHICSBOX-DRAWIN OPEN T)
	 (ERASEIN GRAPHICSBOX-ERASEIN OPEN T)
	 (SETSIZE ((SEND BOXTYPE SETSIZE self))))
SUPERS  (REGION))


(GRAPHICSTREE (LISTOBJECT (TOPNODE TREE)
			  (GRTREE TREEELEMENT)
			  (BOXTYPE BOXTYPE)
			  (LINESTYPE LINESTYPE)
			  (SPACING VECTOR))
MSG     ((CREATE CREATETREE SPECIALIZE T)
	 (MATCH MATCHTREE SPECIALIZE T)
	 (SELECTNODE GRAPHICSTREE-SELECTNODE OPEN T)))


(LISPGRAPHICSTREE (LISTOBJECT (TOPNODE LISPTREE)
			      (GRTREE TREEELEMENT))
PROP    ((BOXTYPE ('RECTANGLE)
		  RESULT BOXTYPE)
	 (LINESTYPE ('STRAIGHT)
		    RESULT LINESTYPE)
	 (SPACING ('(10 20))
		  RESULT VECTOR))
SUPERS  (GRAPHICSTREE))


(LISPNODEDISPLAY (LISTOBJECT (CONTENTS ANYTHING))
PROP    ((DISPLAYSIZE ((A VECTOR WITH X = (NCHARS CONTENTS)
			  *7 Y = 10))))
MSG     ((DRAW STRINGDATA-DRAW)))


(LISPTREE (EXPR ANYTHING)
PROP    ((CONTENTS ((A LISPNODEDISPLAY WITH CONTENTS =
		       (IF EXPR IS ATOMIC THEN EXPR ELSE (CAR EXPR)))))
	 (SUCCESSORS ((IF EXPR IS ATOMIC THEN NIL ELSE (CDR EXPR)))
		     RESULT
		     (LISTOF LISPTREE)))
ADJ     ((TERMINAL (EXPR IS ATOMIC))))


(TREEELEMENT (LISTOBJECT (BOX GRAPHICSBOX)
			 (ORIGINALNODE ANYTHING)
			 (SUCCESSORS (LISTOF TREEELEMENT))
			 (DISPLAYSIZE VECTOR))
PROP    ((DISPLAYWIDTH (DISPLAYSIZE:X))
	 (DISPLAYHEIGHT (DISPLAYSIZE:Y))
	 (TOTALAREA ((VIRTUAL REGION WITH START = TOTALSTART SIZE = 
			      DISPLAYSIZE)))
	 (TOTALSTART ((VIRTUAL VECTOR WITH X = BOX:START:X + (BOX:SIZE:X
				 - DISPLAYSIZE:X)
			       / 2 Y = BOX:START:Y + BOX:SIZE:Y - 
			       DISPLAYSIZE:Y))))
MSG     ((DRAWIN TREEELEMENT-DRAWIN)
	 (SELECTNODE TREEELEMENT-SELECTNODE)))

)



% GSN 14-JAN-83 12:58 
(DG BOXTYPE-DRAW (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW)
(APPLY BOXTYPE:DRAWPROGRAM (LIST BOX 'PAINT
				 W)))


% GSN 14-JAN-83 12:58 
(DG BOXTYPE-ERASE (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX W:WINDOW)
(APPLY BOXTYPE:DRAWPROGRAM (LIST BOX 'ERASE
				 W)))


% GSN 14-JAN-83 09:52 
(DG BOXTYPE-SETSIZE (BOXTYPE:BOXTYPE BOX:GRAPHICSBOX)
(BOX:CONTENTSSIZE _ (SEND BOX:DISPLAYCONTENTS DISPLAYSIZE))(APPLY
  BOXTYPE:SIZEPROGRAM
  (LIST BOX)))


% GSN  2-FEB-83 12:58 
(DG CIRCLESIZE (BOX:GRAPHICSBOX)
(PROG (DIAM)
      (DIAM _ BOX:CONTENTSSIZE:IMAGNITUDE + 10)
      (BOX:SIZE _ (A VECTOR WITH X = DIAM Y = DIAM))
      (BOX:CONTENTSOFFSET _ (A VECTOR WITH X = (DIAM - BOX:CONTENTSSIZE:X)
			       /2 Y = (DIAM - BOX:CONTENTSSIZE:Y)
			       /2))))


% GSN  2-FEB-83 11:23 
(DG CREATETREE (TR:GRAPHICSTREE)
(SEND TR MATCH TOPNODE))


% GSN  2-FEB-83 14:04 
% Draw a Lisp tree. 
(DG DLT (EXPR WW:WINDOW)
(PROG (TREE)
      (SEND WW CLEAR)
      (TREE _ (SEND (A LISPGRAPHICSTREE WITH TOPNODE = EXPR)
		    CREATE))
      (IF TREE:DISPLAYSIZE > WW:SIZE THEN (ERROR 0 "Window is too small")
	  ELSE
	  (SEND TREE DRAWIN (AN AREA WITH SIZE = TREE:DISPLAYSIZE START =
				(SEND WW CENTEROFFSET TREE:DISPLAYSIZE))
		WW))))


% GSN  2-FEB-83 12:16 
(DG DRAWGRCIRCLE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW)
(PROG (OLDDS)
      (OLDDS _ (CURRENTDISPLAYSTREAM W))
      (DSPOPERATION DSPOP)
      (DRAWCIRCLE BOX:CENTER:X BOX:CENTER:Y BOX:SIZE:X/2 NIL W)
      (CURRENTDISPLAYSTREAM OLDDS)))


% GSN  2-FEB-83 13:12 
(DG DRAWGRELLIPSE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW)
(PROG (OLDDS)
      (OLDDS _ (CURRENTDISPLAYSTREAM W))
      (DSPOPERATION DSPOP)
      (DRAWELLIPSE BOX:CENTER:X BOX:CENTER:Y BOX:SIZE:Y/2 BOX:SIZE:X/2 0 NIL 
		   NIL W)
      (CURRENTDISPLAYSTREAM OLDDS)))


% GSN 14-JAN-83 13:01 
(DG DRAWRECTANGLE (BOX:GRAPHICSBOX DSPOP:ATOM W:WINDOW)
(PROG (OLDDS)
      (OLDDS _ (CURRENTDISPLAYSTREAM W))
      (DSPOPERATION DSPOP)
      (MOVETO BOX:LEFT BOX:BOTTOM)
      (DRAWTO BOX:LEFT BOX:TOP)
      (DRAWTO BOX:RIGHT BOX:TOP)
      (DRAWTO BOX:RIGHT BOX:BOTTOM)
      (DRAWTO BOX:LEFT BOX:BOTTOM)
      (CURRENTDISPLAYSTREAM OLDDS)))


% GSN  2-FEB-83 13:12 
(DG ELLIPSESIZE (BOX:GRAPHICSBOX)
(PROG (DIAM)
      (DIAM _ BOX:CONTENTSSIZE:IMAGNITUDE + 10)
      (BOX:SIZE _ (A VECTOR WITH X = DIAM Y = BOX:CONTENTSSIZE:Y + 10))
      (BOX:CONTENTSOFFSET _ (A VECTOR WITH X = (DIAM - BOX:CONTENTSSIZE:X)
			       /2 + 1 Y = 6))))


% GSN 14-JAN-83 12:55 
(DG GRAPHICSBOX-DRAWIN (BOX:GRAPHICSBOX W:WINDOW)
(SEND BOX:BOXTYPE DRAW BOX W))


% GSN 14-JAN-83 12:55 
(DG GRAPHICSBOX-ERASEIN (BOX:GRAPHICSBOX W:WINDOW)
(SEND BOX:BOXTYPE ERASE BOX W))


% GSN  2-FEB-83 16:14 
(DG GRAPHICSTREE-SELECTNODE (GT:GRAPHICSTREE V:VECTOR)
(SEND GT:GRTREE SELECTNODE V))


% GSN  3-FEB-83 13:29 
% Build a TREEELEMENT structure to match the given tree TR. 
(DG MATCHTREE (TR:GRAPHICSTREE NODE:TREE)
(RESULT TREEELEMENT)(PROG (TE SUM MAXH)
			  (TE _
			      (A TREEELEMENT WITH ORIGINALNODE = NODE BOX =
				 (A GRAPHICSBOX WITH BOXTYPE = TR:BOXTYPE 
				    DISPLAYCONTENTS = NODE:CONTENTS)
				 SUCCESSORS = (FOR X IN NODE:SUCCESSORS 
						   COLLECT
						   (SEND TR MATCH X))))
			  (SEND TE:BOX SETSIZE)
			  (TE:DISPLAYWIDTH _
					   (IF NODE IS TERMINAL THEN 
					       TE:BOX:WIDTH + TR:SPACING:X 
					       ELSE (SUM_0)
					       (FOR X IN TE:SUCCESSORS DO 
						    SUM_+X:DISPLAYWIDTH)
					       (MAX (TE:BOX:WIDTH + 
							      TR:SPACING:X)
						    SUM)))
			  (TE:DISPLAYHEIGHT _
					    (IF NODE IS TERMINAL THEN 
						TE:BOX:HEIGHT ELSE (MAXH_0)
						(FOR X IN TE:SUCCESSORS DO
						     (MAXH_ (MAX MAXH 
							   X:DISPLAYHEIGHT)))
						(TE:BOX:HEIGHT + TR:SPACING:Y 
							       + MAXH)))
			  (RETURN TE)))


% GSN  2-FEB-83 12:02 
(DG RECTANGLESIZE (BOX:GRAPHICSBOX)
(BOX:SIZE _ BOX:CONTENTSSIZE + (A VECTOR WITH X = 10 Y = 10))(
  BOX:CONTENTSOFFSET _ (A VECTOR WITH X = 6 Y = 6)))


% GSN 14-JAN-83 14:35 
(DG STRINGDATA-DRAW (self:LISPNODEDISPLAY POS:VECTOR W:WINDOW)
(SEND W PRINTAT self:CONTENTS POS))


% GSN 14-JAN-83 14:42 
% Draw the subtree beginning with TREE inside area AREA in window W. 
(DG TREEELEMENT-DRAWIN (TREE:TREEELEMENT AREA:REGION W:WINDOW)
(PROG (NEWX NEWY SUM FSPN TB)
      (IF TREE:DISPLAYSIZE>AREA:SIZE THEN (ERROR 0 
					     "Area is too small for tree."))
      (TB:START _ (A VECTOR WITH X = (AREA:LEFT + AREA:RIGHT - TB:SIZE:X)
		     /2 Y = AREA:TOP - TB:SIZE:Y))
      (SEND TB DRAWIN W)
      (SEND TB:DISPLAYCONTENTS DRAW TB:START+TB:CONTENTSOFFSET W)
      
% Now compute positions for successors of top node. 

      (IF TREE:SUCCESSORS THEN (NEWY _ AREA:TOP - TB:SIZE:Y - 20)
	  (SUM_0)
	  (FOR S IN TREE:SUCCESSORS DO SUM_+S:DISPLAYSIZE:X)
	  
% Calculate free space for each box. 

	  (FSPN _ (AREA:SIZE:X - SUM)
		/
		(LENGTH SUCCESSORS))
	  (NEWX _ AREA:START:X + FSPN/2)
	  
% Draw each subtree. 

	  (FOR S IN TREE:SUCCESSORS DO 
% Draw arc to new subtree. 

	       (SEND W DRAWLINE TB:BOTTOMCENTER
		     (A VECTOR WITH X = NEWX+S:DISPLAYSIZE:X/2 Y = NEWY))
	       (SEND S DRAWIN
		     (AN AREA WITH START =
			 (A VECTOR WITH X = NEWX Y = AREA:START:Y)
			 SIZE =
			 (A VECTOR WITH X = S:DISPLAYSIZE:X Y = NEWY - 
			    AREA:START:Y))
		     W)
	       (NEWX_+S:DISPLAYSIZE:X+FSPN)))))


% GSN  2-FEB-83 17:37 
(DG TREEELEMENT-SELECTNODE (TE:TREEELEMENT V:VECTOR)
(PROG (RESULT LST TMP)
      (IF (SEND TE:BOX CONTAINS? V)
	  THEN
	  (RETURN TE)
	  ELSEIF
	  (SEND TE:TOTALAREA CONTAINS? V)
	  THEN
	  (LST_TE:SUCCESSORS)
	  (WHILE ~RESULT AND (TMP-_LST)
		 DO
		 (RESULT _ (SEND TMP SELECTNODE V)))
	  (RETURN RESULT))))


(GLISPGLOBALS
(GRAPHICSBOXTYPES (LISTOF BOXTYPE))

)


 (PUT 'RECTANGLE
      'DRAWPROGRAM
      'DRAWRECTANGLE)
 (PUT 'CIRCLE
      'DRAWPROGRAM
      'DRAWGRCIRCLE)
 (PUT 'ELLIPSE
      'DRAWPROGRAM
      'DRAWGRELLIPSE)
 (PUT 'RECTANGLE
      'SIZEPROGRAM
      'RECTANGLESIZE)
 (PUT 'CIRCLE
      'SIZEPROGRAM
      'CIRCLESIZE)
 (PUT 'ELLIPSE
      'SIZEPROGRAM
      'ELLIPSESIZE)
(SETQ GRAPHICSBOXTYPES '(RECTANGLE))
(SETQ TX '(/(+(- B)
	      (SQRT (-(^ B 2)                  (* 4 (* A C))
		      )))                      (* 2 A)
	    ))