Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!ames!amdcad!sun!pitstop!sundc!seismo!uunet!mcvax!prlb2!bernard From: bernard@prlb2.UUCP (Bernard Yves) Newsgroups: comp.windows.news Subject: NeWSillustrator (part 2 of 5) Message-ID: <527@prlb2.UUCP> Date: 27 Jan 89 13:21:09 GMT Organization: Philips Research Laboratory, Brussels Lines: 1235 append the other parts together, make a chmod a+x on the file. -------------------------------------------------------------------------- #!/usr/NeWS/bin/psh %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % NeWSillustrator version 1.0 % % Copyright : Yves Bernard, Philips Research Lab Brussels % e-mail : bernard@prlb2.uucp % 2 avenue Van Becelaere 1170 Brussels Belgium % % 1. You may freely copy and distribute copies of NeWSillustrator as you % receive it, provided that you appropriately publish on each file this % entire copyright notice % % 2. You may modify your copy or NeWSillustrator and copy and distribute % such modifications under the terms of Paragraph 1 provided that you % also include a notice stating what changes you made, and provided that % your copy does not change the mention to NeWSillustrator in the % windows labels and does not delete the original 'Info' copyright entry % of the file menu. % % 3. You are not allowed to sell or distribute for any commercial purposes % this software or any copies derived directly or indirectly from it. % % 4. For other licensing policies, contact the author at the above % address % % 6. This copyright notice is clearly derived from the Free Software % Foundation licensing policy (-:) % % This software is provided without warranty of any kind, of course. %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% % scrollable and zoomable window class definition systemdict /zapmenu known not {systemdict begin /zapmenu [ (No, not really) {} (Yes, really) {/destroy ThisWindow send} ] /new DefaultMenu send def end } if /marksize 5 def %size of mark for group box /ScrollAndZoomWindow ScrollWindow dictbegin /PictureWidth 0 def % for translating the client window /PictureHeight 0 def /LDivisions 10 def % number of scroll bad pieces/whole /PDivisions 3 def % number of scroll bad pieces/whole /ScrollH 0 def % cumulative translation factors /ScrollV 0 def % due to successive scrolling; /ZoomFactor 1 def % zooming factor; /newox 0 def /newoy 0 def /Nzoom 0 def /zoomstack 50 array def /overlaycan null def dictend classbegin /Resize { % width height => - size the backround canvas /PictureHeight exch def /PictureWidth exch def [%0 PictureWidth ClientWidth sub newox neg PictureWidth ClientWidth sub newox add %min max dup dup LDivisions div exch PDivisions div null] /setrange HScrollbar send [%0 PictureHeight ClientHeight sub newoy neg PictureHeight ClientHeight sub newoy add dup dup LDivisions div exch PDivisions div null] /setrange VScrollbar send } def /SetNotifiers { % Hnotifier Vnotifier => - VScrollbar /NotifyUser 3 -1 roll put HScrollbar /NotifyUser 3 -1 roll put } def /Scroll {ScrollProc} def /ZoomIn {/marksize marksize 2 div store /ZoomFactor ZoomFactor 2 mul def ZoomInProc} def /ZoomOut {ZoomFactor 1 ne {/marksize marksize 2 mul store /ZoomFactor ZoomFactor 2 div def ZoomOutProc} if} def /ShapeClientCanvas { ClientCanvas null ne { ScrollAndZoomAxis} if } def /CreateFrameMenu { % - => - (Create frame menu) % Note: Store menu in class to share menus, especially if retained. /FrameMenu [ (Move) {/slide ThisWindow send} (Move Constrained) {getfbclick pop pop /slideconstrained ThisWindow send} (Top) {/totop ThisWindow send} (Bottom) {/tobottom ThisWindow send} (Zap => ) zapmenu (Resize) {/reshapefromuser ThisWindow send} (Stretch Corner) {getfbclick pop pop /stretchcorner ThisWindow send} (Stretch Edge) {getfbclick pop pop /stretchwindowedge ThisWindow send} (Close) {/flipiconic ThisWindow send} (Redisplay) {/paint ThisWindow send} ] /new DefaultMenu send def } def /ScrollAxis {%the scorllbar values are always in abs. coord. /ScrollH HScrollbar /ItemValue get def /ScrollV VScrollbar /ItemValue get def BorderLeft BorderBottom translate ScrollH neg ScrollV neg translate } def /ScrollProc { ScrollAndZoomAxis /PaintClient self send } def /pushzoomstack{% - => - zoomstack Nzoom [ScrollH ScrollV ] put /Nzoom Nzoom 1 add store } def /popzoomstack{% Nzoom 0 ne {/Nzoom Nzoom 1 sub store zoomstack Nzoom get aload pop %put that in the scroll bar value /ScrollV exch store /ScrollH exch store HScrollbar /ItemValue ScrollH put VScrollbar /ItemValue ScrollV put } if } def /ZoomInAxis { %zoom in by 1, 2, 4, 8,... /newox ClientWidth 2 div ClientWidth 2 ZoomFactor exp div sub def /newoy ClientHeight 2 div ClientHeight 2 ZoomFactor exp div sub def newox neg newoy neg translate ZoomFactor ZoomFactor scale ScrollH ZoomFactor div newox ZoomFactor div add ScrollV ZoomFactor div newoy ZoomFactor div add ClientWidth ZoomFactor div ClientHeight ZoomFactor div ClientPath ClientCanvas reshapecanvas } def /ScrollAndZoomAxis { gsave FrameCanvas setcanvas ScrollAxis % modifies the transf. matrix of the client canvas: ZoomFactor 1 eq {/newox 0 store /newoy 0 store ScrollH ScrollV ClientWidth ClientHeight ClientPath ClientCanvas reshapecanvas} {ZoomInAxis} ifelse /overlaycan ClientCanvas createoverlay store grestore MakeScrollEvent sendevent } def /reshape{ pause KillDefComProcess pause /reshape super send /overlaycan ClientCanvas createoverlay store NeWSillustratorDict /Started known {MakeDefComProcess pause} if } def /ZoomInProc { pushzoomstack ScrollAndZoomAxis /PaintClient self send PictureWidth 2 mul PictureHeight 2 mul /Resize self send HScrollbar /ItemValue ScrollH newox add put VScrollbar /ItemValue ScrollV newoy add put /paintscrollbars self send } def /ZoomOutProc { popzoomstack ScrollAndZoomAxis /PaintClient self send PictureWidth 2 div PictureHeight 2 div /Resize self send HScrollbar /ItemValue ScrollH newox add put VScrollbar /ItemValue ScrollV newoy add put /paintscrollbars self send } def /destroy{ % typical to NeWSillustrator KillDefComProcess /destroy super send } def classend def /MyWindowClass DefaultWindow dictbegin dictend classbegin /reshape {KillDefComProcess pause /reshape super send pause pause NeWSillustratorDict /Started known {MakeDefComProcess} if } def /destroy{ % KillDefComProcess /destroy super send } def classend def %private dict for all definitions /NeWSillustratorDict 400 dict def NeWSillustratorDict begin %if user wants to redefine that... /LeftMouseButton /LeftMouseButton def /RightMouseButton /RightMouseButton def /MiddleMouseButton /MiddleMouseButton def /snap_to_grid{% x y => xg yg gridsize div round gridsize mul %x yg exch gridsize div round gridsize mul %yg xg exch } def /SnapToGrid? false def /animate_event null def /crosshair? false def /Cancel? {animate_event RightMouseButton eq} def /Abort? false def /Confirm? {% message => true | false ( Confirm by Left, Abort with R. or M. button) append prmessage .033333 blockinputqueue { createevent dup begin /Action [ /DownTransition /UpTransition] def /Exclusivity true def end expressinterest createevent dup /Name /MouseDragged put expressinterest unblockinputqueue { awaitevent begin Action UpTransition eq { Name end exit } if end } loop } fork waitprocess LeftMouseButton eq } def /MakeScrollEvent{ createevent dup begin /Name /WindowScrolled def end} def /ThisObj null def /RedisplayWhenScroll {} def /mygetanimated { % x0 y0 proc => x y; puts button name in % animate_event { 3 copy false SnapToGrid? mygetanimated_2 dup % dup /CurAniProc exch store waitprocess %p [x y] animate_event /WindowScrolled ne {pop exit} %p {pause pop pop /RedisplayWhenScroll load length 0 ne { {ClientCanvas} win send setcanvas RedisplayWhenScroll } if setoverlay X0 Y0 translate } ifelse } loop %x0 y0 proc p 4 -3 roll pop pop pop %p waitprocess aload pop %x y }def %x y ; animate_event /mygetanimated_2 { %x0 y0 proc LetMenu? snap? => [ x y ]; %puts button name in animate_event 20 dict begin /snap? exch store /LetMenu? exch def /proc exch def /y0 exch def /x0 exch def currentcursorlocation /y exch def /x exch def /gridoff? gridon not def %this should accelerate dragging a little.. /X2 X2 def /Y2 Y2 def /Sx2 Sx2 def /Sy2 Sy2 def /Angle2 Angle2 def /LB LeftMouseButton def /RB RightMouseButton def /MB MiddleMouseButton def /crosshair? crosshair? def .033333 blockinputqueue { %newprocessgroup createevent dup begin /Canvas {ClientCanvas} win send def /Action [ /DownTransition /UpTransition ] def /Exclusivity true def end expressinterest createevent dup begin /Name /MouseDragged def /Canvas {ClientCanvas} win send def /Exclusivity true def end expressinterest MakeScrollEvent expressinterest WaitForEvent expressinterest unblockinputqueue { snap? gridoff? and {x y snap_to_grid /y exch store /x exch store} if erasepage x0 y0 moveto x y /proc load exec crosshair stroke awaitevent dup begin %ev Name dup /WindowScrolled eq {pop /animate_event /WindowScrolled store end exit} if dup /AlphaEvent eq %ev Name {pop Action dup /Point eq exch /Stop eq or {/animate_event Action /Point eq {LB} {RB} ifelse store ClientData aload pop /y exch store /x exch store} {/animate_event Name store WaitForEvent /ClientData ClientData put} ifelse end exit} if pop Action /UpTransition eq {end exit} if LetMenu? Name RB eq and Action /DownTransition eq and {redistributeevent} if %downtransition /x XLocation store /y YLocation store /animate_event Name store end %end dict event pop %pop } loop %event erasepage /cur_event exch store snap? {x y snap_to_grid 2 array astore} { [x y] } ifelse } fork % [x y] end %end mygetanimated_2 dict } def /crosshair { crosshair? {x -1000 moveto 0 2000 rlineto -1000 y moveto 2000 0 rlineto} if } def /mygetclick { % - => x y 0 0 { (X, Y : %, %) [x y] sprintf prvalue } mygetanimated } def /getclickwithmenu{ 0 0 { (X, Y : %, %) [x y] sprintf prvalue } true false mygetanimated_2 waitprocess aload pop } def /mygetwholerect { % - => [x, y, w, h] { x0 y lineto lineto x y0 lineto closepath (dX, dY : %, %) [x y ] sprintf prvalue } getrectthing %x y [w h] aload pop 4 array astore } def /getrectdict dictbegin /XR0 0 def /YR0 0 def /proca null def dictend def /getrectthing{% proc => [x, y, w, h] ; proc = oval, rect, rrect getrectdict begin /proca exch store mygetclick % x y /Relative? true store Cancel? { pop pop /Abort? true store 0 0 [0 0]} { /YR0 exch store /XR0 exch store %origin XR0 YR0 translate 0 0 /proca load mygetanimated %w h 2 array astore XR0 YR0 3 -1 roll %x y [w h] Cancel? {/Abort? true store} if } ifelse end /Relative? false store } def %=========================================================================== % utilities %=========================================================================== /setoverlay {win begin overlaycan end setcanvas} def /prdebug false def /printdbg { prdebug {console exch [] fprintf} {pop} ifelse} def (Loading utilities \n) printdbg /drect { % x,y w, h => - : makes a path corresponding to the box 4 2 roll moveto rect } def /myrrectpath { %because NeWS rrectpath uses arcto which does not %work with dashed lines... matrix currentmatrix 6 1 roll % m r x y w h 4 2 roll translate % m r w h 10 dict begin /h exch def /w exch def /r exch def h 0 lt { 1 -1 scale /h h neg store} if w 0 lt { -1 1 scale /w w neg store} if r 0 moveto w r sub r r 270 0 arc w r sub h r sub r 0 90 arc r h r sub r 90 180 arc r r r 180 270 arc closepath end setmatrix } def %setting of the object coord. system /spos {translate rotate scale} def /b1 null def /boxpath { % [x1 y1 x2 y2] => - makes path of the box aload pop 3 index 3 index moveto %x1 y1 x2 y2 2 index sub %x1 y1 x2 (y2-y1) exch 3 index sub exch rect pop pop } def /box_in_box {% b1 b2 => bool ; true if b1 in b2; box = [x0, y0, x1, y1] gsave boxpath aload pop %x1 y1 x2 y2 pointinpath 3 1 roll pointinpath and grestore } def /box_of_box {% b1 b2 => b3 ;computes the box enclosing the 2 aload pop 5 -1 roll aload pop %4 points on the stack connect them in newpath moveto lineto lineto lineto [ pathbbox ] } def /o_dict dictbegin /x1 0 def /x2 0 def /y1 0 def /y2 0 def dictend def /overlapping_interval{ % x1 x2 y1 y2 => true if [x1 x2] inter [y1 y2] %non null o_dict begin /y2 exch store /y1 exch store /x2 exch store /x1 exch store x1 y1 y2 in_interval x2 y1 y2 in_interval or {true} {y1 x1 x2 in_interval y2 x1 x2 in_interval or} ifelse end } def /in_interval{% x y1 y2 => bool 2 copy min %x y1 y2 min 3 1 roll max %x min max 2 index gt %x min b1 3 1 roll gt and } def /overlapping_box{% b1 b2 => bool; true if box overlaps aload pop 5 -1 roll aload pop 7 index 6 index %x11 x12 5 index 4 index %x21 x22 overlapping_interval {6 index 5 index 4 index 3 index overlapping_interval} {false} ifelse mark 10 2 roll cleartomark } def /on_seg_dict 10 dict def /neareq{%x1 x2 => bool sub abs 3 lt } def /is_on_segment{% x y x0 y0 x1 y1 => bool ; true % if x y on segment x0 y0 x1 y1 on_seg_dict begin /y1 exch def /x1 exch def /y0 exch def /x0 exch def /y exch def /x exch def /dist 0 def false x0 x1 neareq %vertical {pop x x0 neareq y y0 y1 in_interval and} {y0 y1 neareq %horiz {pop y y0 neareq x x0 x1 in_interval and} { %oblique x x0 x1 in_interval {y y0 y1 in_interval {x1 x0 sub y y0 sub mul %p1x * py y1 y0 sub x x0 sub mul %p1y * px sub abs dup /dist exch store 500 lt {pop true} if } if} if } ifelse } ifelse end } def /drarrow { % size x0 y0 x1 y1 => - ; draws an arrow % at end of seg gsave [] 0 setdash %plain line dup 3 index sub %s x0 y0 x1 y1 yr 2 index 5 index sub atan %s x0 y0 x1 y1 a 3 1 roll %s x0 y0 a x1 y1 translate rotate pop pop %s dup neg dup neg %s -s s moveto 0 0 lineto %s neg dup lineto stroke grestore } def %working var. %/mtrx0 matrix def %/mtrx1 matrix def %/newarray null def %/tmparray 100 array def %/Ntmp 0 def /N 0 def /tmpstr 50 string def %/Angle2 0 def %/Sx2 1 def %/Sy2 1 def %/Sx3 1 def %/Sy3 1 def /X0 0 def /Y0 0 def %/X1 0 def %/Y1 0 def %/X2 0 def %/Y2 0 def %/Xc 0 def %/Yc 0 def /oldcanvas null def %=========================================================================== % object Table definition and management /SizeObjTable 1000 def /ObjTable SizeObjTable array def 0 1 SizeObjTable 1 sub {ObjTable exch null put} for /FreeObj 10 array def /FreeObjTop 0 def /AddFreeEntry {% free obj table entry => - FreeObjTop 9 le {FreeObj exch FreeObjTop exch put /FreeObjTop FreeObjTop 1 add store} {pop} ifelse } def /DeleteFreeEntries{ /FreeObjTop 0 store } def /GetFreeEntry{ FreeObjTop 0 gt {/FreeObjTop FreeObjTop 1 sub store FreeObj FreeObjTop get} {Nobj /Nobj Nobj 1 add store} ifelse } def /Nobj 0 def % /AddObject {% => - GetFreeEntry 2 copy exch ObjTable 3 1 roll put %obj index exch begin /tableindex exch store end Nobj SizeObjTable ge {(Object Table is full) prmessage} if } def /ForProc {} def /ForEachObj {% proc = ->; apply proc on each object in the table %which is not in a group /ForProc exch store 0 1 Nobj 1 sub {ObjTable exch get dup null ne {dup begin ingroup end {pop} {ForProc} ifelse } {pop} ifelse} for } def /RepaintAll {% repaint all objects in table; gsave /display a4rect send {/display exch send} ForEachObj grestore draw_grid } def /procfile null def /procstr 50 string def /token_in_line 0 def /c_writestring{% string => - procfile exch writestring procfile ( ) writestring token_in_line 10 gt {procfile (\n) writestring /token_in_line 0 store} {/token_in_line token_in_line 1 add store} ifelse } def /print_any{ %any => postscript code to procfile dup type /operatortype eq {dup procstr cvs dup ('mark) eq { pop ([) c_writestring } { dup (') search { % s post match pre ; a postscrip op. pop pop pop dup length 2 sub 1 exch getinterval c_writestring} {% s s ; a /name procfile (/) writestring c_writestring pop } ifelse} ifelse } {dup type /arraytype eq 1 index xcheck and %code array { ({) c_writestring procfile print_procdef (}) c_writestring } {dup type /nametype eq %a name {dup xcheck {procstr cvs c_writestring} {procfile (/) writestring procstr cvs c_writestring } ifelse} {dup type /arraytype eq %an array value {([) c_writestring {print_any} forall (]) c_writestring } {dup type /stringtype eq {procfile exch ( (%) ) exch [ exch ] fprintf} {procstr cvs c_writestring} ifelse } ifelse } ifelse } ifelse } ifelse } def /print_procdef { % proc file => - ; print the text of proc in file /procfile exch store cvlit { print_any } forall } def /print_code { % /name => - ; in PSfile /token_in_line 0 store dup NeWSillustratorDict exch known {% /name dup procstr cvs PSfile exch (/% { \n) exch [ exch ] fprintf NeWSillustratorDict exch get PSfile print_procdef PSfile (\n } def \n) writestring } {pop} ifelse } def /PSsignature (%! %%NeWSillustrator -- Y. Bernard, Philips Research\n) def % Rotation=0,Width=540,Height=384,Xoff=13,Yoff=219 /psbox null def /PSbox{%computes the bounding box of the drawing Nobj 0 gt {%get first box ObjTable 0 get /bbox get 4 array copy /psbox exch store {begin bbox end psbox box_of_box /psbox exch store} ForEachObj psbox aload pop %x1 y1 x2 y2 2 index sub exch %x1 y1 h x2 3 index sub exch %x1 y1 w h 4 2 roll %w h x1 y1 4 array astore } {[0 0 0 0 ]} ifelse } def /LatexFile? false def /PrintPS_header{ %postscript utilities %this is not standard but is used here for inclusion in Latex LatexFile? {PSfile (% ) writestring PSfile (Rotation=0,Width=%,Height=%,Xoff=%,Yoff=%\n) PSbox fprintf} if PSfile PSsignature writestring PSfile (/rect {dup 0 exch rlineto exch 0 rlineto neg 0 exch rlineto closepath } def /ovalpath { matrix currentmatrix 5 1 roll 4 2 roll translate scale .5 .5 translate 0 0 .5 0 360 arc closepath setmatrix} def\n) [] fprintf /myrrectpath print_code %dash patterns print_dasharray_ps /setdashpat print_code /drarrow print_code /spos print_code PSfile (0 setlinewidth 0 setgray /privatedict 100 dict def /mtrx1 matrix def /savemtrx matrix def privatedict begin /showpage {} def end \n) writestring } def /dasharray [ [ [] 0 ] [ [3] 0 ] [ [6] 0 ] ] def /setdashpat{% n => - dasharray exch get aload pop setdash} def /print_dasharray_ps{% PSfile (/dasharray \n) writestring dasharray print_any PSfile ( def\n) writestring } def /importfiledict null def %used when generating the postscript file %to remind what imported PS file have already been written /RepaintAll_ps {% generates postscript file PrintPS_header /importfiledict 50 dict store PSfile (gsave \n) [] fprintf {/display_ps exch send} ForEachObj PSfile (grestore showpage\n) [] fprintf } def /saveobjprelude null def /SaveAllObjects {% generates NeWS files of object def; loaded with run /saveobjprelude ( dup AddObject mark \n) store {/saveobject exch send} ForEachObj } def /loadobj{%used in loading obj files. counttomark 1 add index %obj mark var1... varn obj /loadivar exch send cleartomark dup begin ingroup not end {pop} if } def %Default display parameters /current_linecolor 0 def %black /current_linewidth 0 def %hair line /current_fill -1 def /current_linecap 0 def /current_linejoin 0 def /current_linestyle 0 def /current_arrowsize 5 def /current_startarrow? false def /current_endarrow? false def /current_radcorner 8 def /erase_flag true def /group_def_mode (by box) def % Root Class -- Defines the protocol of all other object classes (Loading Class def \n) printdbg /DrawObject Object dictbegin /X 0 def %position /Y 0 def /Sx 1 def %scaling /Sy 1 def /Angle 0 def %rotation /bbox null def %bounding box [x1,y1,x2,y2] /color -1 def %filling pattern = -1 : no filling /linewidth 0 def %line width /linecolor 0 def %line color = black /linestyle 0 def %line style = plain or dashed /linejoin 0 def /linecap 0 def /geom null def % % default geom is a rect [w,h] /tableindex -1 def /ingroup false def % true if object part of a group dictend classbegin %some working var. put as class variables /mtrx0 matrix def /mtrx1 matrix def /newarray null def /tmparray 100 array def /Ntmp 0 def /Angle2 0 def /Sx2 1 def /Sy2 1 def /Sx3 1 def /Sy3 1 def /X1 0 def /Y1 0 def /X2 0 def /Y2 0 def /Xc 0 def /Yc 0 def /new { /new super send begin /init self send currentdict end } def /init { /bbox 4 array store /getcurrentdisplayparam self send} def /delete { /erase self send ObjTable tableindex null put tableindex AddFreeEntry} def /destroy {} def /saveivar{%writes instance var. on File OSfile ( % % % % % ) [X Y Sx Sy Angle] fprintf OSfile ( [ % % % % ] \n) bbox fprintf OSfile ( % % % % % % \n) [color linewidth linecolor linestyle linejoin linecap] fprintf /save_geom self send OSfile ( % ) [ingroup] fprintf } def /loadivar {% mark objects instances var => self if ingroup else - %in the order in which they are defined /ingroup exch store %tableindex /geom exch store /linecap exch store /linejoin exch store /linestyle exch store /linecolor exch store /linewidth exch store /color exch store /bbox exch store /Angle exch store /Sy exch store /Sx exch store /Y exch store /X exch store } def /getclassname{%get the class name of the object ParentDictArray dup length 1 sub get begin ClassName end } def /saveobject{%saves object descr in OSfile OSfile (/new % send ) [/getclassname self send] fprintf OSfile saveobjprelude writestring /saveivar self send OSfile ( loadobj\n) writestring } def /save_geom{%save geom descr OSfile ( [ % % ]\n) geom fprintf} def /setradcorner {pop} def /setlinestyle{/linestyle exch store} def /setlinejoin2 {/linejoin exch store} def /setlinecap2 {/linecap exch store} def /setlinewidth2 { /linewidth exch store } def /setlinecolor { /linecolor exch store } def /setcolor { /color exch store } def /changefont {} def /changefontsize {} def /setarrowsize {} def /setarrow {} def /setdisplayparam{% /linewidth exch store /linecolor exch store /color exch store /linestyle exch store /linejoin exch store /linecap exch store } def /getcurrentdisplayparam{ current_linecap current_linejoin current_linestyle current_fill current_linecolor current_linewidth /setdisplayparam self send } def /update_control_panel{% put display param of objects in control panel linewidth linecolor color linestyle linejoin linecap putinControlPanel } def /bbox_path { %in absolute coord syst. bbox 0 get bbox 1 get moveto bbox 2 get bbox 0 get sub bbox 3 get bbox 1 get sub rect } def /make_path { % Sx Sy angle X Y => - %makes the path of the object : default is drawing a rect %of W, H geom null ne { spos % translate rotate scale newpath 0 0 moveto geom aload pop rect} if } def /make_path_ps{% - => - geom null ne { PSfile (spos newpath 0 0 moveto % % rect\n) geom fprintf} if } def /BoxSize{% gives box surface bbox aload pop %x1 y1 x2 y2 2 index sub %x1 y1 x2 (y2-y1) exch 3 index sub exch mul abs } def /is_in_box {% x y => bool ; bbox 1 get bbox 3 get in_interval %x by exch bbox 0 get bbox 2 get in_interval and } def /is_in_obj {% x y => bool ; geom null eq {pop pop false} {gsave newpath moveto X Y translate Angle rotate Sx Sy scale % {} {} {} {} pathforall %x y in object coord. sys. 1 1 0 0 0 /make_path self send pointinpath grestore} ifelse } def /dr { %low-level drawing : linewidth linecolor color linejoin linecap % linestyle => - %graphic state is preserved; gsave setdashpat setlinecap setlinejoin Sx Sy Angle X Y /make_path self send dup -1 ne {gsave setgray fill grestore} {pop} ifelse setgray setlinewidth stroke grestore } def /dr_ps {% color => - PSfile (gsave setdashpat setlinecap setlinejoin % % % % %\n) [Sx Sy Angle X Y] fprintf /make_path_ps self send -1 ne { PSfile ( gsave setgray fill grestore ) [] fprintf} {PSfile ( pop ) [] fprintf} ifelse PSfile (setgray setlinewidth stroke grestore\n) [] fprintf } def /erase { % this will also erase parts of overlapping objects linewidth 1 color -1 eq {color} {1} ifelse linejoin linecap linestyle /dr self send } def /display { %display the object linewidth linecolor color linejoin linecap linestyle /dr self send} def /display_ps {%generation of postscript PSfile ( % % % % % % ) [linewidth linecolor color linejoin linecap linestyle] fprintf color /dr_ps self send } def /make_bbox { %computes the bounding box of the object in the current %coord system mtrx0 currentmatrix pop gsave Sx Sy Angle X Y /make_path self send %path made in trans,scaled,rotated %coord. sys; get coord in normal sys; mtrx0 setmatrix %path set in mtrx0 coord syst. pathbbox bbox astore pop grestore } def /move { % x' y' sx' sy' a' => moves to new position and orientation; % recomputes bbox; Cancel? not { erase_flag {/erase self send} if /Angle exch def /Sy exch def /Sx exch def /Y exch def /X exch def /make_bbox self send /display self send} if } def /set_geom {% [p1,p2] => - ; new H and W /geom exch store } def /scale_geom { % sx sy => - geom 1 get mul geom exch 1 exch put geom 0 get mul geom exch 0 exch put } def /get_geom { % => geom } def /change_geom {%change geometry; => - %erases old shapes and redraws it; /erase self send exec %exec change proc on stack /make_bbox self send /display self send } def /make_opath{ %the outline path used in draging mode /make_path self send } def /drag { %drag outline of shape following cursor % returns dragged position of new origin X' Y' /oldcanvas currentcanvas store setoverlay /Angle2 Angle store /Sx2 Sx store /Sy2 Sy store /xoff 0 store /yoff 0 store ClickToMove? { (enter starting point of move) prmessage mygetclick /yoff exch store /xoff exch store /xoff xoff X sub store /yoff yoff Y sub store (move object now) prmessage setoverlay} if /WaitForEvent MoveEvent store 0 0 { newpath Sx2 Sy2 Angle2 x xoff sub y yoff sub gsave /make_opath self send stroke grestore (X, Y : %, % ) [x y] sprintf prvalue } mygetanimated %x y animate_event /AlphaEvent eq %gets the data {pop pop WaitForEvent /ClientData get aload pop %xr yr Y add exch %Y' xr X add exch} if /WaitForEvent PointEvent store yoff sub exch xoff sub exch oldcanvas setcanvas } def /bbox_center { % => xc, yc ; box center bbox 0 get bbox 2 get add 2 div bbox 1 get bbox 3 get add 2 div } def /drotate {%interactive rotation : put x y on stack /oldcanvas currentcanvas store setoverlay /Angle2 Angle store /Sx2 Sx store /Sy2 Sy store /X2 X store /Y2 Y store /bbox_center self send /Yc exch store /Xc exch store /WaitForEvent RotateEvent store 0 0 { newpath % get angle of vector Xc,Yc - x,y Sx2 Sy2 Angle2 y Yc sub x Xc sub atan add %sx sy angle dup [ exch ] (Angle : %) exch sprintf prvalue X2 Y2 gsave /make_opath self send stroke grestore } mygetanimated %x y oldcanvas setcanvas } def /dscale { %interactive scaling from box lower left corner /oldcanvas currentcanvas store setoverlay /Angle2 Angle store /Sx2 Sx store /Sy2 Sy store /X2 X store /Y2 Y store /Xc bbox 2 get bbox 0 get sub store /Yc bbox 3 get bbox 1 get sub store /WaitForEvent ScaleEvent store bbox 0 get bbox 1 get { newpath Sx2 x x0 sub Xc div mul Sy2 y y0 sub Yc div mul %sx sy [ 2 index 2 index ] (Sx, Sy : %, %) exch sprintf prvalue Angle2 X2 Y2 gsave /make_opath self send stroke grestore } mygetanimated %x y oldcanvas setcanvas } def /drag_and_scale {% scale the geometry definition; preserve line width!! (scale) prmessage /dscale self send % x y Cancel? not { animate_event /AlphaEvent eq %gets the data {pop pop WaitForEvent /ClientData get aload pop} %sx sy { /Y2 exch store /X2 exch store X2 bbox 0 get sub bbox 2 get bbox 0 get sub div %sx' Y2 bbox 1 get sub bbox 3 get bbox 1 get sub div %sy' } ifelse {/scale_geom self send} /change_geom self send } if /WaitForEvent PointEvent store } def /drag_and_trans { (move) prmessage /crosshair? true store /drag self send %x' y' on stack; move to that Sx Sy Angle /move self send /crosshair? false store} def /drag_and_rotate { (rotate) prmessage /drotate self send %x' x' on stack; recompute angle; /Y2 exch store /X2 exch store X Y Sx Sy Angle animate_event /AlphaEvent eq %gets the data { WaitForEvent /ClientData get} { Y2 Yc sub X2 Xc sub atan } ifelse %the angle RecordEvents? {dup /AlphaEvent /Rotate exch MakeEventToRecord AddEvent} if add /move self send /WaitForEvent PointEvent store } def /i_get_geom {%gets geom def. from user interaction ; - => X Y [geom def] (Rectangle) prmessage mygetwholerect % [x0 y0 w h] aload pop % x0 y0 w h 2 array astore % X0 Y0 [w h ] /Abort? Cancel? store } def /i_def_geom {%interactive definition of geom /oldcanvas currentcanvas store setoverlay /crosshair? true store /i_get_geom self send % X Y oldcanvas setcanvas Abort? not { 3 -2 roll geom null ne {/erase self send} if /Y exch store /X exch store /set_geom self send geom null ne { /make_bbox self send /display self send} if /crosshair? false store } {/geom null store /Abort? false store} ifelse } def /edit_geom {} def /clone_geom {%obj contains in its geom structured data which is %shared by other objects ; copies geom and bbox geom type (arraytype) eq