%
% This file is a product of Sun Microsystems, Inc. and is provided for
% unrestricted use provided that this legend is included on all tape
% media and as a part of the software program in whole or part.	 Users
% may copy or modify this file without charge, but are not authorized to
% license or distribute it to anyone else except as part of a product
% or program developed by the user.
%
% THIS FILE IS PROVIDED AS IS WITH NO WARRANTIES OF ANY KIND INCLUDING THE
% WARRANTIES OF DESIGN, MERCHANTIBILITY AND FITNESS FOR A PARTICULAR
% PURPOSE, OR ARISING FROM A COURSE OF DEALING, USAGE OR TRADE PRACTICE.
%
% This file is provided with no support and without any obligation on the
% part of Sun Microsystems, Inc. to assist in its use, correction,
% modification or enhancement.
%
% SUN MICROSYSTEMS, INC. SHALL HAVE NO LIABILITY WITH RESPECT TO THE
% INFRINGEMENT OF COPYRIGHTS, TRADE SECRETS OR ANY PATENTS BY THIS FILE
% OR ANY PART THEREOF.
%
% In no event will Sun Microsystems, Inc. be liable for any lost revenue
% or profits or other special, indirect and consequential damages, even
% if Sun has been advised of the possibility of such damages.
%
% Sun Microsystems, Inc.
% 2550 Garcia Avenue
% Mountain View, California  94043
%
%
% @(#)rubber 23.3 90/06/19
%
% Copyright (c) 1989 by Sun Microsystems, Inc.
%

/RubberCanvas ClassCanvas dictbegin
% Instance Variables
    /x 0 def
    /y 0 def
    /x1 0 def
    /y1 0 def
    /x2 0 def
    /y2 0 def
    /x3 0 def
    /y3 0 def
    /x4 0 def
    /y4 0 def

    /newx 0 def
    /newy 0 def
    /datum 0 def
    /point 0 def

    /Mode 0 def
    /AdjustMode 0 def
    /Adjusting? false def
    /ShowControlPoints? true def
    /thresh 4 def
    /data [] def
    /Grid 1 def
dictend
classbegin
% Class Variables

    /animator null def

    /ModeMenu null def
    /GridMenu null def

    /lineproc {
	x1 thresh sub y1 thresh sub thresh 2 mul dup rectpath
	x2 thresh sub y2 thresh sub thresh 2 mul dup rectpath
	x1 y1 moveto x2 y2 lineto
    } def

    /linepoint {
	{
	    0 { /x1 newx store /y1 newy store }
	    1 { /x2 newx store /y2 newy store }
	} case
    } def

    /rectproc {
	x1 thresh sub y1 thresh sub thresh 2 mul dup rectpath
	x2 thresh sub y2 thresh sub thresh 2 mul dup rectpath
	x1 y1 moveto x1 y2 lineto x2 y2 lineto x2 y1 lineto closepath
    } def

    /rectpoint {
	{
	    0 { /x1 newx store /y1 newy store }
	    1 { /x2 newx store /y2 newy store }
	} case
    } def

    /curveproc {
	x1 thresh sub y1 thresh sub thresh 2 mul dup rectpath
	x2 thresh sub y2 thresh sub thresh 2 mul dup rectpath
	x3 thresh sub y3 thresh sub thresh 2 mul dup rectpath
	x4 thresh sub y4 thresh sub thresh 2 mul dup rectpath
	x1 y1 moveto x2 y2 x3 y3 x4 y4 curveto
    } def

    /curvepoint {
	{
	    0 { /x1 newx store /y1 newy store }
	    1 { /x2 newx store /y2 newy store }
	    2 { /x3 newx store /y3 newy store }
	    3 { /x4 newx store /y4 newy store }
	} case
	Adjusting? not {
	    /x2 x1 x4 x1 sub 3 div add store
	    /y2 y1 y4 y1 sub 3 div add store
	    /x3 x1 x4 x1 sub 3 div 2 mul add store
	    /y3 y1 y4 y1 sub 3 div 2 mul add store
	} if
    } def

    /pathprocs [
	/lineproc load
	/rectproc load
	/curveproc load
    ] def

    /pointprocs [
	/linepoint load
	/rectpoint load
	/curvepoint load
    ] def

    /line {
	moveto lineto
    } def

    /rectangle { % x1 y1 x2 y2
	3 index 3 index moveto
	3 index 1 index lineto
	1 index 1 index lineto
	pop exch lineto pop
	closepath
    } def

    /curve { % x1 y1 x2 y2 x3 y3 x4 y4
	8 -2 roll moveto curveto
    } def

    /stackprocs [
	/line load
	/rectangle load
	/curve load
    ] def

    /linedataproc {  % - => array
	[ x1 y1 x2 y2 0 ]
    } def

    /rectdataproc { % - => array
	[ x1 y1 x2 y2 1 ]
    } def

    /curvedataproc { % - => array
	[ x1 y1 x2 y2 x3 y3 x4 y4 2 ]
    } def

    /pathdataprocs [
	/linedataproc load
	/rectdataproc load
	/curvedataproc load
    ] def

    /newinit {	% - => -
	/newinit super send

	/CreateMenu self send
	0 /SetMode self send
	1 /SetGrid self send
    } def

    /minsize {
	/minsize super send
	64 max exch
	64 max exch
    } def

     /preferredsize { % - => w h
	/preferredsize super send
	256 max exch
	256 max exch
    } def

    /PaintCanvas {
	/canvas self send setcanvas
	FillColor /FillCanvas self send
	/repaintproc {
	    null () /setfooter /parent self send send
	    currentprocess /ProcessName (Repaint) put
	    clippath emptypath not {
		ShowControlPoints? {
		    data {
			dup dup length 1 sub get exch
			/getcontrolpoints self send
			pathprocs exch get exec
		    } forall
		}{
		    data {
			aload pop stackprocs exch get exec exec
		    } forall
		} ifelse
		StrokeColor setcolor 0 setlinewidth stroke
	    } if
	    /repaintproc null store
	} { newpath clipcanvas } refork
    } def

    /SetGrid {
	/Grid exch def
    } def

    /SetMode {
	/Mode exch def
	Mode {
	    0 { (Line) null /setfooter /parent self send send }
	    1 { (Rectangle) null /setfooter /parent self send send }
	    2 { (Curve) null /setfooter /parent self send send }
	} case
    } def

    /Undo {
	data length 0 ne {
	    /data [ data aload pop pop ] store
	    /paint self send
	} if
    } def

    /ToggleCPs {
	ShowControlPoints? {
	    /ShowControlPoints? false store
	    3 (Show Control Points)
	} {
	    /ShowControlPoints? true store
	    3 (Hide Control Points)
	} ifelse
	null /ToggleCPs self soften buildsend /change CanvasMenu send
	/paint self send
    } def

    /WritePS {
	data length 0 ne {
	    /fd (/tmp/rubberdemo.ps) (w) file def
	    fd (%) (%!PS-Adobe1.2\n) fprintf
	    fd (%%) (%Creator: rubberdemo\n) fprintf
	    fd (%%) (%Title: Sample PS output\n) fprintf
	    fd (%%) (%Pages: 1\n) fprintf
	    fd (%%) (%EndComments\n) fprintf
	    fd (/rect {\n) fprintf
	    fd (3 index 3 index moveto\n) fprintf
	    fd (3 index 1 index lineto\n) fprintf
	    fd (1 index 1 index lineto\n) fprintf
	    fd (pop exch lineto pop\n) fprintf
	    fd (closepath\n) fprintf
	    fd (} def\n) fprintf
	    fd (%%) (%EndProlog\n) fprintf
	    fd (\ngsave\n) fprintf
	    data {
		fd exch
		aload pop
		{
		    0 {
			4 array astore (% % moveto\n% % lineto\n)
		    }
		    1 {
			4 array astore (% % % % rect\n)
		    }
		    2 {
			8 array astore (% % moveto\n% % % % % % curveto\n)
		    }
		} case
		exch fprintf
	    } forall
	    fd (0 setgray stroke\n) fprintf
	    fd (\ngrestore\n) fprintf
	    fd (\nshowpage\n) fprintf
	    null (Wrote /tmp/rubberdemo.ps) /setfooter /parent self send send
	} if
    } def

    /CreateMenu { % - => -

	/ModeMenu [ (Lines) (Rect) (Curve) ] null {
	    /value 1 index send
	    /SetMode /sendtarget 4 -1 roll send
	} framebuffer /newdefault ClassMenu send def
	true /setpinnable ModeMenu send

	/GridMenu [ (1) (2) (4) (8) (16) (32) (64) ] null {
	    /valuething 1 index send cvi
	    /SetGrid /sendtarget 4 -1 roll send
	} framebuffer /newdefault ClassMenu send def
	true /setpinnable GridMenu send

	/CanvasMenu [
	    (Modes)	ModeMenu       null
	    (Grid)	GridMenu       null
	    (Undo)	null	       {/Undo /sendtarget 3 -1 roll send }
	    (Hide Control Points) null {/ToggleCPs /sendtarget 3 -1 roll send }
	    (Write PostScript) null    {/WritePS /sendtarget 3 -1 roll send }
	] framebuffer /newdefault ClassMenu send def
	true /setpinnable CanvasMenu send
	(Rubber) /setlabel CanvasMenu send
    } def

    /SnapToGrid { % x y => x' y'
	2 {
	    Grid div round Grid mul exch
	} repeat
    } def

    /animate { % point_proc path_proc up_proc
	/upproc exch def
	/pathproc exch def
	/pointproc exch def
	/nouse null /setcursor self send
	/animator [
	    MouseDragged {
		begin XLocation YLocation end
		Grid 1 ne { /SnapToGrid self send } if
		/newy exch store /newx exch store
		point pointproc
		pathproc
		erasepage
		stroke
	    } null null excleventmgrinterest

	    null {
		pop
		/beye null /setcursor self send
		erasepage
		upproc
		/killanimator self send
	    } /UpTransition null excleventmgrinterest
	] forkeventmgr store

	pause unblockinputqueue
    } def

    /getcontrolpoints {
	aload pop
	{
	    0 {
		/y2 exch def /x2 exch def
		/y1 exch def /x1 exch def
		/x3 -1 def /y3 -1 def
		/x4 -1 def /y4 -1 def
		/AdjustMode 0 store
	    }
	    1 {
		/y2 exch def /x2 exch def
		/y1 exch def /x1 exch def
		/x3 -1 def /y3 -1 def
		/x4 -1 def /y4 -1 def
		/AdjustMode 1 store
	    }
	    2 {
		/y4 exch def /x4 exch def
		/y3 exch def /x3 exch def
		/y2 exch def /x2 exch def
		/y1 exch def /x1 exch def
		/AdjustMode 2 store
	    }
	} case
    } def

    /close? { % x' y'
	y exch sub abs thresh le exch
	x exch sub abs thresh le and
    } def

    /AdjustHandler { % event => -
	/Adjusting? true store
	/canvas self send createoverlay setcanvas
	begin XLocation YLocation end
	/y exch def /x exch def
	/datum 0 def
	data {
	    /getcontrolpoints self send
	    x1 y1 close? {
		/point 0 store
		exit
	    } if
	    x2 y2 close? {
		/point 1 store
		exit
	    } if
	    x3 y3 close? {
		/point 2 store
		exit
	    } if
	    x4 y4 close? {
		/point 3 store
		exit
	    } if
	    /datum datum 1 add def
	} forall
	data length datum ne {
	    pointprocs AdjustMode get pathprocs AdjustMode get {
		data datum pathdataprocs AdjustMode get exec put
		/paint self send
		null () /setfooter /parent self send send
		/Adjusting? false store
	    } /animate self send
	} {
	    null (Not close enough...) /setfooter /parent self send send
	    {} {} {
		null () /setfooter /parent self send send
		/Adjusting? false store
	    } /animate self send
	} ifelse
    } def

    /PointHandler { % event => -
	/canvas self send createoverlay setcanvas
	begin XLocation YLocation end
	Grid 1 ne { /SnapToGrid self send } if
	/y1 exch store
	/x1 exch store
	Mode {
	    0 {
		/point 1 store
	    }
	    1 {
		/point 1 store
	    }
	    2 {
		/point 3 store
	    }
	} case
	pointprocs Mode get pathprocs Mode get {
	    /canvas self send setcanvas
	    pathdataprocs Mode get exec			% [ # # # # code ]
	    /data data [ 3 index ] append store
	    ShowControlPoints? {
		dup dup length 1 sub get exch
		/getcontrolpoints self send
		pathprocs exch get exec
	    }{
		aload pop stackprocs exch get exec exec
	    } ifelse

	    StrokeColor setcolor stroke
	} /animate self send
    } def

    /killanimator {
	animator null ne {
	    animator
		/animator null store
	    killprocess
	} if
    } def

    /MakeInterests {
	/MakeInterests super send

	PointButton /PointHandler BuildCanvasSend
	/DownTransition /canvas self send soften syncheventmgrinterest

	AdjustButton /AdjustHandler BuildCanvasSend
	/DownTransition /canvas self send soften syncheventmgrinterest
    } def

classend def

/RubberFrame /defaultclass ClassBaseFrame send []
classbegin

    /HelpFrameCreate { % - => instance
	/HelpFrameCreate super send
	[null OpenLookHelpClient] /setclient 2 index send pop
        /place 1 index send
	/activate 1 index send
    } def

    /helpdict { % - => dict
	2 dict dup begin
	    /Label (Rubberbanding Demo Help) def
	    /Text [
		(  This demo shows how NeWS can do highly interactive )
		(  placement and adjustment of dynamic objects such as)
		(  lines, rectangles and cubic spline curves)
		()
		(    Click the left button and drag out and object)
		(     once the object is places, click the middle button)
		(     on any control point to adjust that object)
		(    Press the right button to get the menu)
		(    A "snap" grid can be set from the menu)
		(    You can write the PostScript representation of the)
		(     objects to a file called "/tmp/rubberdemo" which is)
		(     suitable for printing or including in another document)
		(    Can can delete the last item entered using the menu)
	    ] def
	end
    } def

    /HelpProc { % object => -
	/popuphelp self send
    } def
classend def

/win [RubberCanvas] [] framebuffer /new RubberFrame send def

(Rubber) /seticonlabel win send
(Rubber) /setlabel win send

/place win send
/map win send
/activate win send

newprocessgroup
currentfile closefile
