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 4 of 5) Message-ID: <529@prlb2.UUCP> Date: 27 Jan 89 13:25:02 GMT Organization: Philips Research Laboratory, Brussels Lines: 1230 %--------------------------------------------------------------------- } forall exch pop } def %utilities /add_extension{% filename (.extension) => filename.extension exch %ext filename ( ) search %ext post match pre true { 4 -1 roll %post match pre ext 4 2 roll %pre ext post match pop pop append } { %ext pre exch append } ifelse } def /extract_fname{% /.../.../.../toto.xxx => toto.xxx { (/) search { % post match pre pop pop} {exit} ifelse } loop } def /make_wrappedfname{%filename => PWD/fname.wps (PWD) getenv (/) append exch extract_fname append (.wps) add_extension } def /achar 1 string def /linestring2 256 string def /make_procname{ % filename => - %from a filename make a postscript name %by repacing all / by a _ /N 0 store 0 1 linestring2 length 1 sub {linestring2 exch 32 put} for { achar 0 3 -1 roll put achar dup (/) eq {pop (_)} if %char or _ linestring2 N 3 -1 roll putinterval /N N 1 add store } forall linestring2 ( ) search pop %post match pre 3 1 roll pop pop cvn } def /linestring 256 string def /TmpFile null def /PS2file null def /errorstring 30 string def /copytofile{% filename file => bool ; true if error exch %file filename { (r) file /TmpFile exch store % file { dup % file file TmpFile linestring readline % file file subst bool {writestring % file dup (\n) writestring % file } {pop exit} ifelse } loop TmpFile closefile } stopped dup {get_errorstr} if } def /get_errorstr{%gets current errorname and puts it in errorstring $error begin errorname end errorstring cvs pop } def /fileerrorpr{% operation filename => - %print last file error message exch (file error : ) errorstring append exch append exch append prerror } def /FileExist? {% filename => true | false { (r) file} stopped {false} {closefile true} ifelse } def /PostScript DrawObject dictbegin /drawproc nullproc def %the drawing code; any legal ps? /filename 100 string def %the imported file /privatedict2 null def /procname null def /savemtrx null def /RedisplayIfScroll {} def dictend classbegin /new { /new super send begin currentdict end } def /init{ /init super send % /geom 4 array store /privatedict2 50 dict store %a private dict for drawproc def and store /savemtrx matrix store } def /clone_geom{ /clone_geom super send privatedict2 50 dict copy /privatedict2 exch store } def /display{%drawing param are set; it is the responsability %of the drawing proc to reset them to its own values savemtrx currentmatrix pop gsave Sx Sy Angle X Y spos geom 0 get neg geom 1 get neg translate linewidth setlinewidth linecolor setgray linecap setlinecap linejoin setlinejoin linestyle setdashpat mark privatedict2 begin drawproc end cleartomark grestore savemtrx setmatrix } def /display_ps {%for each imported file a procedure / is %defined and called procname null eq {/procname filename make_procname store} if importfiledict procname known not {% the procedure is not yet defined in the ps file %procname procname self /drawproc get length 300 lt { PSfile (\n/%{\n) [ procname ] fprintf filename PSfile copytofile pop %procname PSfile (\n} def\n) writestring importfiledict procname 1 put %procname } if %if the proc is too long %do not create a proc, but write %the imported file each time it is needed } if PSfile (savemtrx currentmatrix pop gsave % % % % % spos % % translate\n) [Sx Sy Angle X Y geom 0 get neg geom 1 get neg] fprintf PSfile (% % % % % setdashpat setlinejoin setlinecap setgray setlinewidth\n) [linewidth linecolor linecap linejoin linestyle] fprintf self /drawproc get length 300 lt {PSfile (mark privatedict begin % end cleartomark grestore savemtrx setmatrix\n) [procname] fprintf } {PSfile (mark privatedict begin\n) writestring filename PSfile copytofile pop PSfile (end cleartomark grestore savemtrx setmatrix\n) writestring } ifelse } def /scale_geom{ Sy mul /Sy exch store Sx mul /Sx exch store } def /make_opath{%draws the local bbox spos % geom 0 get geom 1 get moveto 0 0 moveto geom 2 get geom 0 get sub geom 3 get geom 1 get sub rect } def /make_path{ /make_opath self send} def %will be used in is_in_obj; /erase{%erases the local bounding box gsave 1 setgray Sx Sy Angle X Y make_opath fill grestore } def /make_bbox{%computes the global bbox gsave mtrx0 currentmatrix pop Sx Sy Angle X Y /make_opath self send mtrx0 setmatrix pathbbox bbox astore pop grestore } def /load_drawproc{ % - => bool; true if ok; %if not already made, makes the wrapped file and loads it %the wrapped file is created in the user Home directory %with the same name as the user file and *.wps as extension /procname filename make_procname store alreadyimporteddict procname known %the dict entry contains the Postscript object %for which the corresponding drawproc has been defined {/drawproc alreadyimporteddict procname get aload pop pop def true } {%the PS file is not yet loaded /PS2file filename make_wrappedfname (w) file store PS2file (/drawproc{ \n) writestring filename PS2file copytofile %copies filename to the %end of PS2file {%error in copying file false PS2file closefile } {%close it and load it to define /drawproc PS2file (\n} def \n) writestring PS2file closefile (loading wrapped file ) filename make_wrappedfname append prmessage filename make_wrappedfname LoadFile dup {alreadyimporteddict procname [/drawproc load filename ] put} if } ifelse } ifelse } def /i_get_geom{ %reads the imported filename * and loads it %makes a 'wrapped' file *.wps %where the ps code is embedded : /drawproc{ } def %then loads it with LoadFile (Import PostScript) prmessage /filename get_ps_filename dup length string copy store filename extract_fname length 0 gt { (making wrapped file ) filename make_wrappedfname append prmessage /load_drawproc self send %true if ok; { (enter the bounding box : ) prmessage currentcanvas %the overlay canvas oldcanvas setcanvas %the win canvas /X0 0 store /Y0 0 store /RedisplayIfScroll {gsave 0 0 translate savemtrx currentmatrix pop gsave mark privatedict2 begin drawproc end cleartomark grestore savemtrx setmatrix grestore } store /ThisObj self store /RedisplayWhenScroll { {RedisplayIfScroll} ThisObj send } store {RedisplayIfScroll} stopped {(error in executing PS file ) filename append prerror setcanvas 0 0 null } { setcanvas %reset the overlay mygetwholerect %[x y w h] aload pop %x1 y1 w h 2 index add %x1 y1 w y2 exch 3 index add %x1 y1 y2 x2 exch 3 index 3 index %x1 y1 x2 y2 x1 y1 6 2 roll 4 array astore %x1 y1 box (PS file imported: ) filename append prmessage } ifelse } {( in loading ) filename fileerrorpr 0 0 null } ifelse } {( in loading ) filename fileerrorpr 0 0 null } ifelse /RedisplayWhenScroll {} store }def /save_geom{ OSfile ( [ % % % % ] \n) geom fprintf} def /saveivar{ /saveivar super send OSfile ( \() writestring OSfile filename writestring OSfile (\) \n) writestring } def /loadivar{ /filename exch store mark /load_drawproc self send {} %ok {(error in importing) filename append prerror)} ifelse cleartomark /loadivar super send } def classend def %building of an A4 size rectangle /a4rect /new DrawObject send def { /X 100 35 div 3 mul def /Y 100 35 div 3 mul def /geom [100 35 div 197 mul 100 35 div 282 mul] def /linecolor .85 def /linewidth 2 def /ingroup true def %so that it is not selectable by user; } a4rect send %============================================================================= %drawing area window definition %=========================================================================== %/win framebuffer /new ScrollAndZoomWindow send def (main interaction routines\n) printdbg /previous_selection null def /current_selection null def /old_selection null def /push_selection{% obj /previous_selection current_selection store /current_selection exch store } def /pop_selection{% /current_selection previous_selection store /previous_selection null store } def /ClosedPath? false def /create_object {%class => obj {ClientCanvas} win send setcanvas /new exch send push_selection % /current_selection exch store ClosedPath? {current_selection begin /Closed true store end /ClosedPath? false store} if /i_def_geom current_selection send current_selection begin geom end null ne {current_selection AddObject} {pop_selection} ifelse } def /foundlist 100 array def /Nfound 0 def /MaxBoxSize 0 def /find_object_on_pt {%x y => obj | null %only objects which are not in a group can be found /Y0 exch store /X0 exch store /Xc null store /Yc null store /Nfound 0 store ObjTable 0 Nobj getinterval { /Xc exch store Xc null ne {Xc begin ingroup end not {X0 Y0 /is_in_obj Xc send { foundlist Nfound Xc put /Nfound Nfound 1 add store } if} if} if} forall Nfound 0 eq { null} { /MaxBoxSize 10000000 store foundlist 0 Nfound getinterval { /Xc exch store /BoxSize Xc send dup MaxBoxSize le {/Yc Xc store /MaxBoxSize exch store MaxBoxSize 0 eq {exit} if} {pop} ifelse } forall Yc } ifelse } def /find_objects_in_box {% [x1 y1 x2 y2] => o1 o2.... on n /b1 exch store /N 0 def ObjTable 0 Nobj getinterval { /Xc exch store Xc null ne {Xc begin ingroup end not {Xc begin bbox end b1 box_in_box {Xc /N N 1 add store} if} if} if} forall N } def /select_object { {ClientCanvas} win send setcanvas gsave /oldcanvas currentcanvas store (select object by clicking on it : ) prmessage setoverlay getclickwithmenu oldcanvas setcanvas find_object_on_pt grestore dup null ne {dup /erase exch send push_selection pause /display current_selection send current_selection begin [tableindex] end (% is selected) exch prmessage /getclassname current_selection send /Group ne {/update_control_panel current_selection send} if } {pop (no object selected) prmessage} ifelse } def /i1 0 def /i2 0 def /swap_obj{ % o1 o2 => - ; swaps the 2 obj in ObjTable; dup begin /i2 tableindex store end exch dup begin /i1 tableindex store end %o2 o1 dup begin /tableindex i2 store end ObjTable exch i2 exch put dup begin /tableindex i1 store end ObjTable exch i1 exch put (% and % swapped) [i1 i2] prmessage } def /find_overlapping_obj{ % fromindex step toindex obj => first_over_obj %obj in X1, overlap in Xc /X1 exch store /Xc null store {ObjTable exch get dup /X2 exch store null ne {X2 begin ingroup end not {X1 begin bbox end X2 begin bbox end overlapping_box {/Xc X2 store exit} if } if } if } for Xc } def /move_down{ % obj => obj2 ; invert position of obj in ObjTable with % the next object behind it overlapping it dup begin tableindex end 1 sub -1 0 4 -1 roll find_overlapping_obj dup null ne {X1 Xc swap_obj} if } def /move_up{ % obj => obj2 ; invert position of obj in ObjTable with % the next object over it overlapping it obj2 dup begin tableindex end 1 add 1 Nobj 1 sub 4 -1 roll find_overlapping_obj dup null ne {X1 Xc swap_obj} if } def /apply_on_sel {% proc => - ; apply proc on selection if non null current_selection null ne {{ClientCanvas} win send setcanvas exec } {pop (no object selected !) prmessage} ifelse } def /fapply_on_sel{% /message -> apply it on current selection current_selection dup null ne %/message obj {{ClientCanvas} win send setcanvas send } {pop pop (no object selected !) prmessage} ifelse } def /notifyselection true def /setdpar {% value /paramfunct => - ; %apply change of param on selection if non null 2 copy %arg1 arg2 arg1 arg2 current_selection null ne notifyselection and {{ClientCanvas} win send setcanvas {self send} /change_geom current_selection send pop pop } {pop pop } ifelse } def /fontmenu [ FontDirectory { % include all fonts except /Cursor pop dup /Cursor ne { 25 string cvs dup length 3 le { pop } if } { pop } ifelse } forall ] [{/FontName currentkey store FontName /changefont setdpar} ] /new DefaultMenu send def /pointsizemenu [( 6 ) (8) (10) (12) (14) (16) (18) (24) (30) (32) (64)] [{/pointsize currentkey cvi store pointsize /changefontsize setdpar} ] /new DefaultMenu send def /filemenu [ (save PS file) {generate_ps} (------) {} (save Objects file) {generate_os} (load Objects file) {load_osfile} (------) {} (save Tools file) {SaveTools} (load Tools file) {LoadToolFile} (------) {} (Windows Pos.) {WindowPositions} (Info) {CopyrightNotice prmessage {ClientCanvas} win send setcanvas} ] /new DefaultMenu send def /CopyrightNotice (NeWSillustrator 1.0.p, jan 89, Yves Bernard, Philips Research Lab, Brussels) def /align_op{%align_proc => - current_selection null ne {{ClientCanvas} win send setcanvas /getclassname current_selection send /Group eq {/change_geom current_selection send} if } {pop (no group object selected !) prmessage} ifelse } def /clipped_obj null def /clipping_obj null def /make_clip{%the current selection contains the clipping object %the previous selection should contain the object to clip current_selection null eq previous_selection null eq or {(error : no objects for making clip) prerror} { /clipped_obj previous_selection store /getclassname current_selection send dup /Group ne %class b 1 index /TextObject ne and %class b 1 index /PostScript ne and %class b exch pop { /clipping_obj current_selection store /erase clipped_obj send /new ClippingGroup send push_selection [clipping_obj clipped_obj] /set_geom current_selection send /make_bbox current_selection send /display current_selection send current_selection AddObject } { (error : the clipping obj can not be a group, a text or an importPS) prerror } ifelse } ifelse } def /psfilename null def /get_ps_filename{ items /psfilename get /ItemValue get} def /notifypsfname{ /psfilename ItemValue store} def /ConfirmWriteFile? {% filename FileExist? {(Overwrite Existing File ?? ) Confirm?} {true} ifelse } def /PSfile null def /generate_ps { {ClientCanvas} win send setcanvas get_ps_filename PSFileCycle not { get_ps_filename ConfirmWriteFile? { {get_ps_filename (w) file /PSfile exch store (writing PS file...) prmessage RepaintAll_ps PSfile closefile} stopped {get_errorstr ( in writing ) get_ps_filename fileerrorpr} {(PS file is written: ) get_ps_filename append prmessage} ifelse } {(writing aborted...) prmessage} ifelse } {(can not write PS file: cycle,same name as an imported PS file ) get_ps_filename append prerror } ifelse } def /osfilename null def /get_os_filename{ items /osfilename get /ItemValue get} def /notifyosfname{ /osfilename ItemValue store} def /saveproc null def /GenericSave{% proc => -; to file OSfile /saveproc exch store get_os_filename ConfirmWriteFile? { { /OSfile get_os_filename (w) file store /procfile OSfile store saveproc OSfile (\n) writestring OSfile closefile } stopped {get_errorstr ( in writing ) get_os_filename fileerrorpr} {(file is written) prmessage} ifelse } if } def /OSfile null def /generate_os { {ClientCanvas} win send setcanvas {(writing object files...) prmessage SaveImportedFiles SaveAllObjects} GenericSave } def /load_osfile{ {ClientCanvas} win send setcanvas (loading...) prmessage get_os_filename LoadFile {(Object file loaded: ) get_os_filename append prmessage /PaintClient win send } {get_errorstr ( in loading ) get_os_filename fileerrorpr} ifelse } def %============================================================================ %control panel window definition %============================================================================ (Control Panel definition\n) printdbg systemdict /Item known not { (NeWS/liteitem.ps) run } if %systemdict /Item known not { (NeWS/liteitem.ps) LoadFile pop } if /notify? true def /notify { notify? {(Notify: Value=%) [ItemValue] /printf messages send} if } def /FillColor .75 def /prmessage { % sting => - print messages in Control Panel gsave /printf messages send grestore } def /prerror { % sting => - print messages in Control Panel gsave /printf errormessage send grestore } def /prvalue { % string => - print in Control Panel gsave /printf valuemessage send grestore } def /recstr 30 string def /notifylq {ItemValue 10 div setlinequality} def /ParValue 0 def /notifylw {ItemValue /setlinewidth2 setdpar} def /notifylc {ItemValue 100 div /setlinecolor setdpar} def /notifyfc {ItemValue 0 lt {-1} {ItemValue 100 div} ifelse /setcolor setdpar} def /notifygroupdefmode {/group_def_mode ItemValue 0 eq (by box) (by enumeration) ifelse store } def /notifylcap{ItemValue /setlinecap2 setdpar} def /notifyljoin{ItemValue /setlinejoin2 setdpar} def /notifylstyle{ItemValue /setlinestyle setdpar} def /notifyarrowsize{ItemValue cvr /setarrowsize setdpar} def /arrowstartend? { % - => startarrow endarrow ParValue 0 eq {false false} if ParValue 1 eq {true false} if ParValue 2 eq {false true} if ParValue 3 eq {true true} if } def /Pend false def /Pstart false def /notifylarrow{/ParValue ItemValue store arrowstartend? /Pend exch store /Pstart exch store [Pstart Pend] /setarrow setdpar} def /notifyradcorner {ItemValue cvr dup 0 eq {pop 8} if /setradcorner setdpar} def /textstring (enter string) def /notifytext{/textstring ItemValue store} def /gridon false def /gridsize 100 def /notifygridsize {/gridsize ItemValue cvr dup 0 eq {pop 100} if store} def /notifysnap {/SnapToGrid? ItemValue 1 eq store } def /updateCPitem{% newvalue /name items exch get %newvalue it dup 2 index /ItemValue exch put %v it exch pop /paint exch send } def /ClickToMove? false def /xoff 0 def /yoff 0 def /notifyclicktomove{/ClickToMove? ItemValue 1 eq store} def /notifygridon {/gridon ItemValue 1 eq store gridon {{ClientCanvas} win send setcanvas draw_grid} {/PaintClient win send} ifelse } def /get_textstring{%gets the ItemValue of the text liteitem items /textstring get /ItemValue get dup /textstring exch store } def /notifyalphadata {} def /draw_grid{% draws the grid gridon gridsize 0 gt and {gsave 0 setgray [2 5] 0 setdash 0 gridsize 1000 {dup 0 moveto 1000 lineto stroke} for 0 gridsize 1000 {dup 0 exch moveto 1000 exch lineto stroke} for grestore} if } def /putinControlPanel{%linewidth linecolor color linestyle linejoin linecap /notifyselection false store /oldcanvas currentcanvas store {ClientCanvas} controlpanel send setcanvas items begin linecap /ItemValue 3 -1 roll put /paint linecap send linejoin /ItemValue 3 -1 roll put /paint linejoin send linestyle /ItemValue 3 -1 roll put /paint linestyle send dup -1 ne {100 mul} if fillcolor /ItemValue 3 -1 roll put /paint fillcolor send 100 mul linecolor /ItemValue 3 -1 roll put /paint linecolor send linewidth /ItemValue 3 -1 roll put /paint linewidth send end oldcanvas setcanvas pause /notifyselection true store } def /setcurrentdisplayparam{%set control parameters as default items begin linecap /ItemValue get /current_linecap exch store linejoin /ItemValue get /current_linejoin exch store linestyle /ItemValue get /current_linestyle exch store fillcolor /ItemValue get dup 0 lt {pop -1} {100 div} ifelse /current_fill exch store linecolor /ItemValue get 100 div /current_linecolor exch store linewidth /ItemValue get /current_linewidth exch store arrowsize /ItemValue get cvr /current_arrowsize exch store linearrow /ItemValue get /ParValue exch store arrowstartend? /current_arrowend? exch store /current_arrowstart? exch store end } def %Items creation /createitems { /items 30 dict dup begin /messages /panel_text () /Right {} can 700 0 /new MessageItem send dup begin /ItemFrame 1 def /ItemBorder 4 def end 20 20 /move 3 index send def /value /panel_text () /Right {} can 700 0 /new MessageItem send dup begin /ItemFrame 1 def /ItemBorder 4 def end 20 0 /move 3 index send def /errormessage /panel_text () /Right {} can 700 0 /new MessageItem send dup begin /ItemFrame 1 def /ItemBorder 4 def end 20 -20 /move 3 index send def /textstring (Text String:) (Text string) /Right /notifytext can 500 0 /new TextItem send 20 290 /move 3 index send def /osfilename (Objects file name:) (PWD) getenv (/) append /Right /notifyosfname can 500 0 /new TextItem send 20 260 /move 3 index send def /psfilename (PS file name:) (PWD) getenv (/) append /Right /notifypsfname can 500 0 /new TextItem send 20 230 /move 3 index send def /gridsize (Grid Size:) (100) /Right /notifygridsize can 220 0 /new TextItem send 20 200 /move 3 index send def /gridbutton (Grid on:) [/panel_check_off /panel_check_on] /Right /notifygridon can 0 0 /new CycleItem send dup /LabelY -4 put 250 200 /move 3 index send def /SnapToGrid? (Snap To Grid:) [/panel_check_off /panel_check_on] /Right /notifysnap can 0 0 /new CycleItem send dup /LabelY -4 put 355 200 /move 3 index send def /linequality (line quality:) [0 10 10] /Right /notifylq can 220 20 /new SliderItem send 20 170 /move 3 index send def /linecap (line cap:) [(butt) (round) (square) ] /Right /notifylcap can 0 0 /new CycleItem send 250 140 /move 3 index send def /linejoin (line join:) [(miter) (round) (belevel) ] /Right /notifyljoin can 0 0 /new CycleItem send 355 170 /move 3 index send def /linestyle (line style:) [(plain) (dash1) (dash2) ] /Right /notifylstyle can 0 0 /new CycleItem send 250 170 /move 3 index send def /linearrow (line arrow:) [(no) (at start) (at end) (at start and end) ] /Right /notifylarrow can 0 0 /new CycleItem send 355 140 /move 3 index send def /linewidth (line width:) [0 10 0] /Right /notifylw can 220 20 /new SliderItem send dup /ItemFrame 1 put 20 140 /move 3 index send def /linecolor (line color:) [0 100 0] /Right /notifylc can 220 20 /new SliderItem send dup /ItemFrame 1 put 20 110 /move 3 index send def /fillcolor (fill color:) [-1 100 -1] /Right /notifyfc can 220 20 /new SliderItem send dup /ItemFrame 1 put 20 80 /move 3 index send def /groupdef (Group Defined by :) [ ( box) ( enumeration) ] /Right /notifygroupdefmode can 220 0 /new CycleItem send 20 50 /move 3 index send def /radcorner (Rounded Corner Radius:) (8) /Right /notifyradcorner can 220 0 /new TextItem send 250 50 /move 3 index send def /arrowsize (Arrow Size :) (5) /Right /notifyarrowsize can 165 0 /new TextItem send 250 110 /move 3 index send def /ClickToMove? (Click To Move:) [/panel_check_off /panel_check_on] /Right /notifyclicktomove can 0 0 /new CycleItem send dup /LabelY -4 put 250 80 /move 3 index send def /alphadata (Data :) (arguments) /Right /notifyalphadata can 220 0 /new TextItem send 20 -50 /move 3 index send def /doitbutton (SendIt!) /SendAlphaEvent can 100 0 /new ButtonItem send dup /ItemBorderColor .5 .5 .5 rgbcolor put 130 -90 /move 3 index send def end def /messages items /messages get def /valuemessage items /value get def /errormessage items /errormessage get def } def /slideitem { % items fillcolor item => - gsave dup 4 1 roll % item items fillcolor item /moveinteractive exch send % item /bbox exch send % x y w h (Item: x=%, y=%, w=%, h=% Canvas: w=%, h=%) [ 6 2 roll win begin FrameWidth FrameHeight end ] /printf messages send grestore } def /MakeControlPanel { % Create and size a window. The size is chosen to accommodate the % items we are creating. Right before we map the window, we ask the % user to reshape the window. This is atypical, but gets the items % positioned the way we want them. /controlpanel framebuffer /new MyWindowClass send def { /PaintClient {FillColor fillcanvas items paintitems} def /FrameLabel (NeWSillustrator - Control Panel) def /IconLabel (Control Panel) def /IconImage /galaxy def /ClientMenu [ (set as Default) {setcurrentdisplayparam} (White Background) {/FillColor 1 store /paintclient controlpanel send} (Light Background) {/FillColor .75 store /paintclient controlpanel send} (Medium Background) {/FillColor .50 store /paintclient controlpanel send} (Dark Background) {/FillColor .25 store /paintclient controlpanel send} (Black Background) {/FillColor 0 store /paintclient controlpanel send} ] /new DefaultMenu send def } controlpanel send 30 30 700 350 /reshape controlpanel send /can controlpanel /ClientCanvas get def % Create all the items. createitems % Create event manager to slide around the items. /slidemgr [ items { % key item exch pop dup /ItemCanvas get % item can MiddleMouseButton [items FillColor % item can name [ dict color 6 -1 roll /slideitem cvx] cvx % can name proc DownTransition % can name proc action 4 -1 roll eventmgrinterest % interest } forall ] forkeventmgr def ControlPanelPosition null eq {/reshapefromuser controlpanel send } {ControlPanelPosition aload pop /reshape controlpanel send} ifelse /map controlpanel send /itemmgr items forkitems def } def 1 setlinequality /make_bbox a4rect send %------------------------------------------------------------------------- % Iconic command window or Tool Palette %------------------------------------------------------------------------- (CommandObj Class\n) printdbg /CommandObj Group %a command is a group ; the geom of the group is the icon of the command dictbegin /name null def /ident 0 def %use to identify command in macro /param null def /execproc nullproc def /undoproc {} def /repeatproc {} def /CanBeDefault? false def /kind /Standard def dictend classbegin /new { /new super send begin /CanBeDefault? false def currentdict end } def /display { gsave Sx Sy Angle X Y spos geom {/display exch send} forall grestore } def /execcommand {% /hilite self send pause {ClientCanvas} win send setcanvas execproc RepeatCommand self ne {/LastCommand self store /LastCommand? true store} if /deshilite self send } def /saveivar{% /saveivar super send OSfile (/%) [name] fprintf } def /loadivar{% /name exch def name null ne { CommandDict name self put} if %tool built from macro are not put in the commanddict /loadivar super send } def /saveobject{ OSfile (/new CommandObj send dup AddCommand mark\n) writestring /saveivar self send OSfile ( loadobj\n) writestring OSfile ({\n) writestring OSfile (/kind /% def\n) [kind] fprintf OSfile (/execproc \n) writestring /execproc load print_any OSfile ( def\n) writestring OSfile (/undoproc \n) writestring /undoproc load print_any OSfile ( def\n) writestring OSfile (/repeatproc \n) writestring /repeatproc load print_any OSfile ( def\n) writestring OSfile (/CanBeDefault? % def\n) [CanBeDefault?] fprintf OSfile (} topcom send\n) writestring } def /undo{ undoproc } def /borderpath{% bbox 0 get bbox 1 get moveto -7 -7 rmoveto bbox 2 get bbox 0 get sub 14 add %w bbox 3 get bbox 1 get sub 14 add rect } def /hilite{% when a command is selected, it is highlighted % by drawing a thick rect around it {ClientCanvas} CommandWindow send setcanvas gsave 0 setgray 4 setlinewidth /borderpath self send stroke grestore } def /deshilite{ {ClientCanvas} CommandWindow send setcanvas gsave 1 setgray 4 setlinewidth /borderpath self send stroke grestore } def classend def %/DefaultCommand select_command def /LastCommand null def /LastCommand? false def /CommandDict 100 dict def /CommandTable 100 array def /Ncommand 0 def /AddCommand {% => - dup CommandTable exch Ncommand exch put %obj begin /ident Ncommand store end /Ncommand Ncommand 1 add store } def (MakeNeWCommand\n) printdbg /NewComDict dictbegin /toolerror {(error: the valid expressions are: (1) (macroname) CallMacro (2) {PScode}) prerror } def /thenewcom null def /itscode null def /theGroup null def dictend def /MakeNewCommand{%makes a command from the current_selection if %it is a group; %ask the place in the tool palette and the code %for its exec proc NewComDict begin current_selection null ne { /getclassname current_selection send /Group eq { /itscode null store current_selection GroupToCommand /thenewcom exch store %ask the code (ok with this code: ) ConfirmText? {%parse it mark get_textstring {token {exch} {exit} ifelse} loop %codearray or (macroname) CallMacro { %case loop %mark {} or mark (name) /CallMacro counttomark 2 gt {toolerror exit} if dup type /nametype eq %macroname CallMacro {(macro call) prmessage dup /CallMacro eq %macroname CallMacro {exec /itscode exch store /itscode load 10 string cvs prvalue thenewcom begin /kind /MacroTool def end} {pop toolerror} ifelse exit} if %codearray dup type /arraytype eq 1 index xcheck and %mark {} {(code array) prmessage /itscode exch store itscode 10 string cvs prvalue exit } if %mark xxx pop } loop %mark -- itscode cleartomark /itscode load null ne {%save it and give position /itscode load thenewcom begin /execproc exch store end PlaceCommand theGroup begin ObjTable tableindex null put end /erase theGroup send (The tool is added) prmessage } {(tool creation aborted) prmessage /Ncommand Ncommand 1 sub store } ifelse } if %Confirm } {(command icons are made from group!!) prerror} ifelse } {(no selected object) prerror} ifelse end } def /PlaceCommand{% thenewcom => - place it on Tool Palette (place the icon in the tool palette -- click with any button) prmessage {ClientCanvas} CommandWindow send createoverlay setcanvas thenewcom begin bbox aload pop end %x1 y1 x2 y2 2 index sub %x1 y1 x2 h exch 3 index sub %x1 y1 h w /X2 exch store /Y2 exch store 0 0 {x y moveto X2 Y2 rect} getanimated waitprocess aload pop %x y thenewcom begin /Y exch store /X exch store end {ClientCanvas} CommandWindow send setcanvas /make_bbox thenewcom send /display thenewcom send {ClientCanvas} win send setcanvas } def /GroupToCommand {%group => command /theGroup exch store /new CommandObj send dup AddCommand /thenewcom exch store theGroup begin bbox X Y Angle geom Ngr end thenewcom begin /Ngr exch store /geom exch store /Angle exch store /Y exch store /X exch store /bbox exch store end thenewcom } def /SaveTools{% save new added tools in a file /saveobjprelude ( mark\n) store {(writing tool file...) prmessage CommandTable FirstUserCommand dup Ncommand exch sub getinterval {/saveobject exch send} forall } GenericSave } def /LoadToolFile{% (Loading tool file ) get_os_filename append ( ??) append Confirm? {get_os_filename LoadFile {(tool file loaded) prmessage pause {ClientCanvas} CommandWindow send setcanvas /PaintClient CommandWindow send } {(in loading) get_os_filename fileerrorpr} ifelse } if } def /DefComProcess null store /MakeDefComProcess{% DefComProcess null eq {/DefComProcess { newprocessgroup {/execcommand DefaultCommand send pause} loop } fork store pause } if } def /KillDefComProcess{ DefComProcess null ne { pause DefComProcess killprocessgroup pause /DefComProcess null store pause} if } def (Command Window\n) printdbg